haskell-notebooks/freemonad.ipynb

1464 lines
40 KiB
Plaintext

{
"cells": [
{
"cell_type": "code",
"execution_count": 3,
"metadata": {},
"outputs": [
{
"data": {
"text/html": [
"<style>/* Styles used for the Hoogle display in the pager */\n",
".hoogle-doc {\n",
"display: block;\n",
"padding-bottom: 1.3em;\n",
"padding-left: 0.4em;\n",
"}\n",
".hoogle-code {\n",
"display: block;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"}\n",
".hoogle-text {\n",
"display: block;\n",
"}\n",
".hoogle-name {\n",
"color: green;\n",
"font-weight: bold;\n",
"}\n",
".hoogle-head {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-sub {\n",
"display: block;\n",
"margin-left: 0.4em;\n",
"}\n",
".hoogle-package {\n",
"font-weight: bold;\n",
"font-style: italic;\n",
"}\n",
".hoogle-module {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-class {\n",
"font-weight: bold;\n",
"}\n",
".get-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"display: block;\n",
"white-space: pre-wrap;\n",
"}\n",
".show-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"margin-left: 1em;\n",
"}\n",
".mono {\n",
"font-family: monospace;\n",
"display: block;\n",
"}\n",
".err-msg {\n",
"color: red;\n",
"font-style: italic;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"display: block;\n",
"}\n",
"#unshowable {\n",
"color: red;\n",
"font-weight: bold;\n",
"}\n",
".err-msg.in.collapse {\n",
"padding-top: 0.7em;\n",
"}\n",
".highlight-code {\n",
"white-space: pre;\n",
"font-family: monospace;\n",
"}\n",
".suggestion-warning { \n",
"font-weight: bold;\n",
"color: rgb(200, 130, 0);\n",
"}\n",
".suggestion-error { \n",
"font-weight: bold;\n",
"color: red;\n",
"}\n",
".suggestion-name {\n",
"font-weight: bold;\n",
"}\n",
"</style><span class='get-type'>(Output 'A' Done) :: forall b next. Toy Char (Toy b next)</span>"
],
"text/plain": [
"(Output 'A' Done) :: forall b next. Toy Char (Toy b next)"
]
},
"metadata": {},
"output_type": "display_data"
},
{
"data": {
"text/html": [
"<style>/* Styles used for the Hoogle display in the pager */\n",
".hoogle-doc {\n",
"display: block;\n",
"padding-bottom: 1.3em;\n",
"padding-left: 0.4em;\n",
"}\n",
".hoogle-code {\n",
"display: block;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"}\n",
".hoogle-text {\n",
"display: block;\n",
"}\n",
".hoogle-name {\n",
"color: green;\n",
"font-weight: bold;\n",
"}\n",
".hoogle-head {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-sub {\n",
"display: block;\n",
"margin-left: 0.4em;\n",
"}\n",
".hoogle-package {\n",
"font-weight: bold;\n",
"font-style: italic;\n",
"}\n",
".hoogle-module {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-class {\n",
"font-weight: bold;\n",
"}\n",
".get-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"display: block;\n",
"white-space: pre-wrap;\n",
"}\n",
".show-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"margin-left: 1em;\n",
"}\n",
".mono {\n",
"font-family: monospace;\n",
"display: block;\n",
"}\n",
".err-msg {\n",
"color: red;\n",
"font-style: italic;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"display: block;\n",
"}\n",
"#unshowable {\n",
"color: red;\n",
"font-weight: bold;\n",
"}\n",
".err-msg.in.collapse {\n",
"padding-top: 0.7em;\n",
"}\n",
".highlight-code {\n",
"white-space: pre;\n",
"font-family: monospace;\n",
"}\n",
".suggestion-warning { \n",
"font-weight: bold;\n",
"color: rgb(200, 130, 0);\n",
"}\n",
".suggestion-error { \n",
"font-weight: bold;\n",
"color: red;\n",
"}\n",
".suggestion-name {\n",
"font-weight: bold;\n",
"}\n",
"</style><span class='get-type'>(Bell (Output 'A' Done)) :: forall b1 b2 next. Toy b1 (Toy Char (Toy b2 next))</span>"
],
"text/plain": [
"(Bell (Output 'A' Done)) :: forall b1 b2 next. Toy b1 (Toy Char (Toy b2 next))"
]
},
"metadata": {},
"output_type": "display_data"
}
],
"source": [
"-- http://www.haskellforall.com/2012/06/you-could-have-invented-free-monads.html\n",
"\n",
"{-| \n",
"data Toy b\n",
" = Output b (Toy b)\n",
" | Bell (Toy b)\n",
" | Done\n",
"-}\n",
"\n",
"data Toy b next =\n",
" Output b next\n",
" | Bell next\n",
" | Done\n",
" \n",
"-- A simple program\n",
"-- output 'A'\n",
"-- done\n",
":t (Output 'A' Done)\n",
"\n",
"-- bell\n",
"-- output 'A'\n",
"-- done\n",
":t (Bell (Output 'A' Done))"
]
},
{
"cell_type": "code",
"execution_count": 9,
"metadata": {},
"outputs": [
{
"data": {
"text/html": [
"<style>/* Styles used for the Hoogle display in the pager */\n",
".hoogle-doc {\n",
"display: block;\n",
"padding-bottom: 1.3em;\n",
"padding-left: 0.4em;\n",
"}\n",
".hoogle-code {\n",
"display: block;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"}\n",
".hoogle-text {\n",
"display: block;\n",
"}\n",
".hoogle-name {\n",
"color: green;\n",
"font-weight: bold;\n",
"}\n",
".hoogle-head {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-sub {\n",
"display: block;\n",
"margin-left: 0.4em;\n",
"}\n",
".hoogle-package {\n",
"font-weight: bold;\n",
"font-style: italic;\n",
"}\n",
".hoogle-module {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-class {\n",
"font-weight: bold;\n",
"}\n",
".get-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"display: block;\n",
"white-space: pre-wrap;\n",
"}\n",
".show-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"margin-left: 1em;\n",
"}\n",
".mono {\n",
"font-family: monospace;\n",
"display: block;\n",
"}\n",
".err-msg {\n",
"color: red;\n",
"font-style: italic;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"display: block;\n",
"}\n",
"#unshowable {\n",
"color: red;\n",
"font-weight: bold;\n",
"}\n",
".err-msg.in.collapse {\n",
"padding-top: 0.7em;\n",
"}\n",
".highlight-code {\n",
"white-space: pre;\n",
"font-family: monospace;\n",
"}\n",
".suggestion-warning { \n",
"font-weight: bold;\n",
"color: rgb(200, 130, 0);\n",
"}\n",
".suggestion-error { \n",
"font-weight: bold;\n",
"color: red;\n",
"}\n",
".suggestion-name {\n",
"font-weight: bold;\n",
"}\n",
"</style><span class='get-type'>(Fix (Output 'A' (Fix Done))) :: Fix (Toy Char)</span>"
],
"text/plain": [
"(Fix (Output 'A' (Fix Done))) :: Fix (Toy Char)"
]
},
"metadata": {},
"output_type": "display_data"
},
{
"data": {
"text/html": [
"<style>/* Styles used for the Hoogle display in the pager */\n",
".hoogle-doc {\n",
"display: block;\n",
"padding-bottom: 1.3em;\n",
"padding-left: 0.4em;\n",
"}\n",
".hoogle-code {\n",
"display: block;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"}\n",
".hoogle-text {\n",
"display: block;\n",
"}\n",
".hoogle-name {\n",
"color: green;\n",
"font-weight: bold;\n",
"}\n",
".hoogle-head {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-sub {\n",
"display: block;\n",
"margin-left: 0.4em;\n",
"}\n",
".hoogle-package {\n",
"font-weight: bold;\n",
"font-style: italic;\n",
"}\n",
".hoogle-module {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-class {\n",
"font-weight: bold;\n",
"}\n",
".get-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"display: block;\n",
"white-space: pre-wrap;\n",
"}\n",
".show-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"margin-left: 1em;\n",
"}\n",
".mono {\n",
"font-family: monospace;\n",
"display: block;\n",
"}\n",
".err-msg {\n",
"color: red;\n",
"font-style: italic;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"display: block;\n",
"}\n",
"#unshowable {\n",
"color: red;\n",
"font-weight: bold;\n",
"}\n",
".err-msg.in.collapse {\n",
"padding-top: 0.7em;\n",
"}\n",
".highlight-code {\n",
"white-space: pre;\n",
"font-family: monospace;\n",
"}\n",
".suggestion-warning { \n",
"font-weight: bold;\n",
"color: rgb(200, 130, 0);\n",
"}\n",
".suggestion-error { \n",
"font-weight: bold;\n",
"color: red;\n",
"}\n",
".suggestion-name {\n",
"font-weight: bold;\n",
"}\n",
"</style><span class='get-type'>(Fix (Bell (Fix (Output 'A' (Fix Done))))) :: Fix (Toy Char)</span>"
],
"text/plain": [
"(Fix (Bell (Fix (Output 'A' (Fix Done))))) :: Fix (Toy Char)"
]
},
"metadata": {},
"output_type": "display_data"
}
],
"source": [
"data Fix f = Fix (f (Fix f))\n",
"\n",
":t (Fix (Output 'A' (Fix Done)))\n",
"\n",
":t (Fix (Bell (Fix (Output 'A' (Fix Done)))))\n",
"\n",
"-- cosine x = x\n",
"-- x = 0.7...\n",
"\n",
"-- f x = x"
]
},
{
"cell_type": "code",
"execution_count": 10,
"metadata": {},
"outputs": [
{
"data": {
"text/plain": [
"120"
]
},
"metadata": {},
"output_type": "display_data"
},
{
"data": {
"text/plain": [
"120"
]
},
"metadata": {},
"output_type": "display_data"
},
{
"data": {
"text/html": [
"<style>/* Styles used for the Hoogle display in the pager */\n",
".hoogle-doc {\n",
"display: block;\n",
"padding-bottom: 1.3em;\n",
"padding-left: 0.4em;\n",
"}\n",
".hoogle-code {\n",
"display: block;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"}\n",
".hoogle-text {\n",
"display: block;\n",
"}\n",
".hoogle-name {\n",
"color: green;\n",
"font-weight: bold;\n",
"}\n",
".hoogle-head {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-sub {\n",
"display: block;\n",
"margin-left: 0.4em;\n",
"}\n",
".hoogle-package {\n",
"font-weight: bold;\n",
"font-style: italic;\n",
"}\n",
".hoogle-module {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-class {\n",
"font-weight: bold;\n",
"}\n",
".get-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"display: block;\n",
"white-space: pre-wrap;\n",
"}\n",
".show-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"margin-left: 1em;\n",
"}\n",
".mono {\n",
"font-family: monospace;\n",
"display: block;\n",
"}\n",
".err-msg {\n",
"color: red;\n",
"font-style: italic;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"display: block;\n",
"}\n",
"#unshowable {\n",
"color: red;\n",
"font-weight: bold;\n",
"}\n",
".err-msg.in.collapse {\n",
"padding-top: 0.7em;\n",
"}\n",
".highlight-code {\n",
"white-space: pre;\n",
"font-family: monospace;\n",
"}\n",
".suggestion-warning { \n",
"font-weight: bold;\n",
"color: rgb(200, 130, 0);\n",
"}\n",
".suggestion-error { \n",
"font-weight: bold;\n",
"color: red;\n",
"}\n",
".suggestion-name {\n",
"font-weight: bold;\n",
"}\n",
"</style><span class='get-type'>fact' :: forall p. (Eq p, Num p) => (p -> p) -> p -> p</span>"
],
"text/plain": [
"fact' :: forall p. (Eq p, Num p) => (p -> p) -> p -> p"
]
},
"metadata": {},
"output_type": "display_data"
},
{
"data": {
"text/plain": [
"120"
]
},
"metadata": {},
"output_type": "display_data"
}
],
"source": [
"{-# LANGUAGE FlexibleContexts #-}\n",
"\n",
"-- https://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Monad-Fix.html\n",
"import Control.Monad.Fix\n",
"\n",
"-- fix :: (a -> a) -> a\n",
"-- fix f = let {x = f x} in x\n",
"\n",
"let fac n = if n <= 1 then 1 else n * fac (n-1) in fac 5\n",
"\n",
"fix (\\rec n -> if n <= 1 then 1 else n * rec (n-1)) 5\n",
"\n",
"-- fix fact' 5\n",
"fact' rec n = if n == 0 then 1 else n * rec (n-1)\n",
"\n",
":t fact'\n",
"\n",
"-- f = fact' f\n",
"-- = \\n -> if n == 0 then 1 else n * f (n-1)\n",
"\n",
"{-|\n",
" fix fact'\n",
"= fact' (fix fact')\n",
"= (\\rec n -> if n == 0 then 1 else n * rec (n-1)) (fix fact')\n",
"= \\n -> if n == 0 then 1 else n * fix fact' (n-1)\n",
"= \\n -> if n == 0 then 1 else n * fact' (fix fact') (n-1)\n",
"= \\n -> if n == 0 then 1\n",
" else n * (\\rec n' -> if n' == 0 then 1 else n' * rec (n'-1)) (fix fact') (n-1)\n",
"= \\n -> if n == 0 then 1\n",
" else n * (if n-1 == 0 then 1 else (n-1) * fix fact' (n-2))\n",
"= \\n -> if n == 0 then 1\n",
" else n * (if n-1 == 0 then 1\n",
" else (n-1) * (if n-2 == 0 then 1\n",
" else (n-2) * fix fact' (n-3)))\n",
"= ...\n",
"-}\n",
"\n",
"fix fact' 5"
]
},
{
"cell_type": "code",
"execution_count": 5,
"metadata": {},
"outputs": [
{
"data": {
"text/html": [
"<style>/* Styles used for the Hoogle display in the pager */\n",
".hoogle-doc {\n",
"display: block;\n",
"padding-bottom: 1.3em;\n",
"padding-left: 0.4em;\n",
"}\n",
".hoogle-code {\n",
"display: block;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"}\n",
".hoogle-text {\n",
"display: block;\n",
"}\n",
".hoogle-name {\n",
"color: green;\n",
"font-weight: bold;\n",
"}\n",
".hoogle-head {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-sub {\n",
"display: block;\n",
"margin-left: 0.4em;\n",
"}\n",
".hoogle-package {\n",
"font-weight: bold;\n",
"font-style: italic;\n",
"}\n",
".hoogle-module {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-class {\n",
"font-weight: bold;\n",
"}\n",
".get-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"display: block;\n",
"white-space: pre-wrap;\n",
"}\n",
".show-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"margin-left: 1em;\n",
"}\n",
".mono {\n",
"font-family: monospace;\n",
"display: block;\n",
"}\n",
".err-msg {\n",
"color: red;\n",
"font-style: italic;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"display: block;\n",
"}\n",
"#unshowable {\n",
"color: red;\n",
"font-weight: bold;\n",
"}\n",
".err-msg.in.collapse {\n",
"padding-top: 0.7em;\n",
"}\n",
".highlight-code {\n",
"white-space: pre;\n",
"font-family: monospace;\n",
"}\n",
".suggestion-warning { \n",
"font-weight: bold;\n",
"color: rgb(200, 130, 0);\n",
"}\n",
".suggestion-error { \n",
"font-weight: bold;\n",
"color: red;\n",
"}\n",
".suggestion-name {\n",
"font-weight: bold;\n",
"}\n",
"</style><div class=\"suggestion-name\" style=\"clear:both;\">Use section</div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Found:</div><div class=\"highlight-code\" id=\"haskell\">(flip catch f)</div></div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Why Not:</div><div class=\"highlight-code\" id=\"haskell\">(`catch` f)</div></div>"
],
"text/plain": [
"Line 4: Use section\n",
"Found:\n",
"(flip catch f)\n",
"Why not:\n",
"(`catch` f)"
]
},
"metadata": {},
"output_type": "display_data"
}
],
"source": [
"data FixE f e = Fix (f (FixE f e)) | Throw e\n",
"\n",
"-- data Free f r = Free (f (Free f r)) | Pure r\n",
"\n",
"catch :: (Functor f) => FixE f e1 -> (e1 -> FixE f e2) -> FixE f e2\n",
"catch (Fix x) f = Fix (fmap (flip catch f) x)\n",
"catch (Throw e) f = f e\n",
"\n",
"instance Functor (Toy b) where\n",
" fmap f (Output x next) = Output x (f next)\n",
" fmap f (Bell next) = Bell (f next)\n",
" fmap f Done = Done\n",
" \n",
"data IncompleteException = IncompleteException\n",
"\n",
"-- output 'A'\n",
"-- throw IncompleteException\n",
"-- output 'B'\n",
"subroutine = Fix (Output 'A' (Throw IncompleteException)) :: FixE (Toy Char) IncompleteException\n",
"\n",
"-- try {subroutine}\n",
"-- catch (IncompleteException) {\n",
"-- bell\n",
"-- done\n",
"-- }\n",
"program = subroutine `catch` (\\_ -> Fix (Bell (Fix Done))) :: FixE (Toy Char) e"
]
},
{
"cell_type": "code",
"execution_count": 6,
"metadata": {},
"outputs": [
{
"data": {
"text/html": [
"<style>/* Styles used for the Hoogle display in the pager */\n",
".hoogle-doc {\n",
"display: block;\n",
"padding-bottom: 1.3em;\n",
"padding-left: 0.4em;\n",
"}\n",
".hoogle-code {\n",
"display: block;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"}\n",
".hoogle-text {\n",
"display: block;\n",
"}\n",
".hoogle-name {\n",
"color: green;\n",
"font-weight: bold;\n",
"}\n",
".hoogle-head {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-sub {\n",
"display: block;\n",
"margin-left: 0.4em;\n",
"}\n",
".hoogle-package {\n",
"font-weight: bold;\n",
"font-style: italic;\n",
"}\n",
".hoogle-module {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-class {\n",
"font-weight: bold;\n",
"}\n",
".get-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"display: block;\n",
"white-space: pre-wrap;\n",
"}\n",
".show-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"margin-left: 1em;\n",
"}\n",
".mono {\n",
"font-family: monospace;\n",
"display: block;\n",
"}\n",
".err-msg {\n",
"color: red;\n",
"font-style: italic;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"display: block;\n",
"}\n",
"#unshowable {\n",
"color: red;\n",
"font-weight: bold;\n",
"}\n",
".err-msg.in.collapse {\n",
"padding-top: 0.7em;\n",
"}\n",
".highlight-code {\n",
"white-space: pre;\n",
"font-family: monospace;\n",
"}\n",
".suggestion-warning { \n",
"font-weight: bold;\n",
"color: rgb(200, 130, 0);\n",
"}\n",
".suggestion-error { \n",
"font-weight: bold;\n",
"color: red;\n",
"}\n",
".suggestion-name {\n",
"font-weight: bold;\n",
"}\n",
"</style><span class='get-type'>output :: forall b (m :: * -> *). MonadFree (Toy b) m => b -> m ()</span>"
],
"text/plain": [
"output :: forall b (m :: * -> *). MonadFree (Toy b) m => b -> m ()"
]
},
"metadata": {},
"output_type": "display_data"
},
{
"data": {
"text/html": [
"<style>/* Styles used for the Hoogle display in the pager */\n",
".hoogle-doc {\n",
"display: block;\n",
"padding-bottom: 1.3em;\n",
"padding-left: 0.4em;\n",
"}\n",
".hoogle-code {\n",
"display: block;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"}\n",
".hoogle-text {\n",
"display: block;\n",
"}\n",
".hoogle-name {\n",
"color: green;\n",
"font-weight: bold;\n",
"}\n",
".hoogle-head {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-sub {\n",
"display: block;\n",
"margin-left: 0.4em;\n",
"}\n",
".hoogle-package {\n",
"font-weight: bold;\n",
"font-style: italic;\n",
"}\n",
".hoogle-module {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-class {\n",
"font-weight: bold;\n",
"}\n",
".get-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"display: block;\n",
"white-space: pre-wrap;\n",
"}\n",
".show-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"margin-left: 1em;\n",
"}\n",
".mono {\n",
"font-family: monospace;\n",
"display: block;\n",
"}\n",
".err-msg {\n",
"color: red;\n",
"font-style: italic;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"display: block;\n",
"}\n",
"#unshowable {\n",
"color: red;\n",
"font-weight: bold;\n",
"}\n",
".err-msg.in.collapse {\n",
"padding-top: 0.7em;\n",
"}\n",
".highlight-code {\n",
"white-space: pre;\n",
"font-family: monospace;\n",
"}\n",
".suggestion-warning { \n",
"font-weight: bold;\n",
"color: rgb(200, 130, 0);\n",
"}\n",
".suggestion-error { \n",
"font-weight: bold;\n",
"color: red;\n",
"}\n",
".suggestion-name {\n",
"font-weight: bold;\n",
"}\n",
"</style><span class='get-type'>bell :: forall b (m :: * -> *). MonadFree (Toy b) m => m ()</span>"
],
"text/plain": [
"bell :: forall b (m :: * -> *). MonadFree (Toy b) m => m ()"
]
},
"metadata": {},
"output_type": "display_data"
},
{
"data": {
"text/html": [
"<style>/* Styles used for the Hoogle display in the pager */\n",
".hoogle-doc {\n",
"display: block;\n",
"padding-bottom: 1.3em;\n",
"padding-left: 0.4em;\n",
"}\n",
".hoogle-code {\n",
"display: block;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"}\n",
".hoogle-text {\n",
"display: block;\n",
"}\n",
".hoogle-name {\n",
"color: green;\n",
"font-weight: bold;\n",
"}\n",
".hoogle-head {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-sub {\n",
"display: block;\n",
"margin-left: 0.4em;\n",
"}\n",
".hoogle-package {\n",
"font-weight: bold;\n",
"font-style: italic;\n",
"}\n",
".hoogle-module {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-class {\n",
"font-weight: bold;\n",
"}\n",
".get-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"display: block;\n",
"white-space: pre-wrap;\n",
"}\n",
".show-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"margin-left: 1em;\n",
"}\n",
".mono {\n",
"font-family: monospace;\n",
"display: block;\n",
"}\n",
".err-msg {\n",
"color: red;\n",
"font-style: italic;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"display: block;\n",
"}\n",
"#unshowable {\n",
"color: red;\n",
"font-weight: bold;\n",
"}\n",
".err-msg.in.collapse {\n",
"padding-top: 0.7em;\n",
"}\n",
".highlight-code {\n",
"white-space: pre;\n",
"font-family: monospace;\n",
"}\n",
".suggestion-warning { \n",
"font-weight: bold;\n",
"color: rgb(200, 130, 0);\n",
"}\n",
".suggestion-error { \n",
"font-weight: bold;\n",
"color: red;\n",
"}\n",
".suggestion-name {\n",
"font-weight: bold;\n",
"}\n",
"</style><span class='get-type'>done :: forall b (m :: * -> *) a. MonadFree (Toy b) m => m a</span>"
],
"text/plain": [
"done :: forall b (m :: * -> *) a. MonadFree (Toy b) m => m a"
]
},
"metadata": {},
"output_type": "display_data"
}
],
"source": [
"import Control.Monad.Free\n",
"\n",
"{-|\n",
"data Free f r = Free (f (Free f r)) | Pure r\n",
"\n",
"instance (Functor f) => Monad (Free f) where\n",
" return = Pure\n",
" (Free x) >>= f = Free (fmap (>>= f) x)\n",
" (Pure r) >>= f = f r\n",
"-}\n",
"\n",
"{-|\n",
"(>>=) :: forall a b. m a -> (a -> m b) -> m b\n",
"catch :: (Functor f) => FixE f e1 -> (e1 -> FixE f e2) -> FixE f e2\n",
"\n",
"FixE f --- m\n",
"e1 --- a\n",
"e2 --- b\n",
"\n",
"catch -- >>=\n",
"Throw -- Pure\n",
"-}\n",
"\n",
"{-|\n",
"output :: a -> Free (Toy a) ()\n",
"output x = Free (Output x (Pure ()))\n",
"\n",
"bell :: Free (Toy a) ()\n",
"bell = Free (Bell (Pure ()))\n",
"\n",
"done :: Free (Toy a) r\n",
"done = Free Done\n",
"\n",
"liftF :: (Functor f) => f r -> Free f r\n",
"liftF command = Free (fmap Pure command)\n",
"-}\n",
"\n",
"-- There is some Functor f => Free f is a monad\n",
"\n",
"-- Toy b is a Functor, Free (Toy b) is a monad\n",
"\n",
"output x = liftF (Output x ())\n",
"bell = liftF (Bell ())\n",
"done = liftF Done\n",
"\n",
":t output\n",
":t bell\n",
":t done\n",
"\n",
"subroutine :: Free (Toy Char) ()\n",
"subroutine = output 'A'\n",
"\n",
"program :: Free (Toy Char) r\n",
"program = do\n",
" bell\n",
" subroutine\n",
" bell\n",
" done"
]
},
{
"cell_type": "code",
"execution_count": 7,
"metadata": {},
"outputs": [
{
"data": {
"text/plain": [
"bell\n",
"output 'A'\n",
"bell\n",
"done"
]
},
"metadata": {},
"output_type": "display_data"
}
],
"source": [
"showProgram :: (Show a, Show r) => Free (Toy a) r -> String\n",
"showProgram (Free (Output a x)) =\n",
" \"output \" ++ show a ++ \"\\n\" ++ showProgram x\n",
"showProgram (Free (Bell x)) =\n",
" \"bell\\n\" ++ showProgram x\n",
"showProgram (Free Done) =\n",
" \"done\\n\"\n",
"showProgram (Pure r) =\n",
" \"return \" ++ show r ++ \"\\n\"\n",
" \n",
"putStr (showProgram program)"
]
},
{
"cell_type": "code",
"execution_count": 25,
"metadata": {},
"outputs": [
{
"data": {
"text/html": [
"<style>/* Styles used for the Hoogle display in the pager */\n",
".hoogle-doc {\n",
"display: block;\n",
"padding-bottom: 1.3em;\n",
"padding-left: 0.4em;\n",
"}\n",
".hoogle-code {\n",
"display: block;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"}\n",
".hoogle-text {\n",
"display: block;\n",
"}\n",
".hoogle-name {\n",
"color: green;\n",
"font-weight: bold;\n",
"}\n",
".hoogle-head {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-sub {\n",
"display: block;\n",
"margin-left: 0.4em;\n",
"}\n",
".hoogle-package {\n",
"font-weight: bold;\n",
"font-style: italic;\n",
"}\n",
".hoogle-module {\n",
"font-weight: bold;\n",
"}\n",
".hoogle-class {\n",
"font-weight: bold;\n",
"}\n",
".get-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"display: block;\n",
"white-space: pre-wrap;\n",
"}\n",
".show-type {\n",
"color: green;\n",
"font-weight: bold;\n",
"font-family: monospace;\n",
"margin-left: 1em;\n",
"}\n",
".mono {\n",
"font-family: monospace;\n",
"display: block;\n",
"}\n",
".err-msg {\n",
"color: red;\n",
"font-style: italic;\n",
"font-family: monospace;\n",
"white-space: pre;\n",
"display: block;\n",
"}\n",
"#unshowable {\n",
"color: red;\n",
"font-weight: bold;\n",
"}\n",
".err-msg.in.collapse {\n",
"padding-top: 0.7em;\n",
"}\n",
".highlight-code {\n",
"white-space: pre;\n",
"font-family: monospace;\n",
"}\n",
".suggestion-warning { \n",
"font-weight: bold;\n",
"color: rgb(200, 130, 0);\n",
"}\n",
".suggestion-error { \n",
"font-weight: bold;\n",
"color: red;\n",
"}\n",
".suggestion-name {\n",
"font-weight: bold;\n",
"}\n",
"</style><div class=\"suggestion-name\" style=\"clear:both;\">Monad law, left identity</div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Found:</div><div class=\"highlight-code\" id=\"haskell\">return 'A' >>= output</div></div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Why Not:</div><div class=\"highlight-code\" id=\"haskell\">output 'A'</div></div><div class=\"suggestion-name\" style=\"clear:both;\">Monad law, right identity</div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Found:</div><div class=\"highlight-code\" id=\"haskell\">output 'A' >>= return</div></div><div class=\"suggestion-row\" style=\"float: left;\"><div class=\"suggestion-warning\">Why Not:</div><div class=\"highlight-code\" id=\"haskell\">output 'A'</div></div>"
],
"text/plain": [
"Line 6: Monad law, left identity\n",
"Found:\n",
"return 'A' >>= output\n",
"Why not:\n",
"output 'A'Line 8: Monad law, right identity\n",
"Found:\n",
"output 'A' >>= return\n",
"Why not:\n",
"output 'A'"
]
},
"metadata": {},
"output_type": "display_data"
},
{
"data": {
"text/plain": [
"output 'A'\n",
"return ()"
]
},
"metadata": {},
"output_type": "display_data"
},
{
"data": {
"text/plain": [
"output 'A'\n",
"return ()"
]
},
"metadata": {},
"output_type": "display_data"
},
{
"data": {
"text/plain": [
"output 'A'\n",
"return ()"
]
},
"metadata": {},
"output_type": "display_data"
},
{
"data": {
"text/plain": [
"output 'A'\n",
"done"
]
},
"metadata": {},
"output_type": "display_data"
},
{
"data": {
"text/plain": [
"output 'A'\n",
"done"
]
},
"metadata": {},
"output_type": "display_data"
}
],
"source": [
"pretty :: (Show a, Show r) => Free (Toy a) r -> IO ()\n",
"pretty = putStr . showProgram\n",
"\n",
"pretty (output 'A')\n",
"\n",
"pretty (return 'A' >>= output)\n",
"\n",
"pretty (output 'A' >>= return)\n",
"\n",
"pretty ((output 'A' >> done) >> output 'C')\n",
"\n",
"pretty (output 'A' >> (done >> output 'C'))"
]
},
{
"cell_type": "code",
"execution_count": 43,
"metadata": {},
"outputs": [],
"source": [
"-- data Free f r = Free (f (Free f r)) | Pure r\n",
"\n",
"data List a = Cons a (List a ) | Nil\n",
"\n",
"type List' a = Free ((,) a) ()\n",
"\n",
"{-|\n",
"List' a\n",
"= Free ((,) a) ()\n",
"= Free (a, List' a)) | Pure ()\n",
"= Free a (List' a) | Pure ()\n",
"-}"
]
},
{
"cell_type": "code",
"execution_count": 9,
"metadata": {},
"outputs": [],
"source": [
"{-|\n",
"\n",
"data Request =\n",
" Look Direction\n",
" | ReadLine\n",
" | Fire Direction\n",
" | WriteLine String\n",
" \n",
"data Response =\n",
" Image Picture -- Response for Look\n",
" | ChatLine String -- Response for Read\n",
" | Succeeded Bool -- Response for Write\n",
" \n",
"data Interaction next =\n",
" Look Direction (Image -> next)\n",
" | Fire Direction next\n",
" | ReadLine (String -> next)\n",
" | WriteLine String (Bool -> next)\n",
" \n",
"instance Functor Interaction where\n",
" fmap f (Look dir g) = Look dir (f . g)\n",
" fmap f (Fire dir x) = Fire dir (f x)\n",
" fmap f (ReadLine g) = ReadLine (f . g)\n",
" fmap f (WriteLine s g) = WriteLine s (f . g)\n",
" \n",
"interpret :: Program r -> Game r\n",
"interpret prog = case prog of\n",
" Free (Look dir g) -> do\n",
" img <- collectImage dir\n",
" interpret (g img)\n",
" Free (Fire dir next) -> do\n",
" sendBullet dir\n",
" interpret next\n",
" Free (ReadLine g) -> do\n",
" str <- getChatLine\n",
" interpret (g str)\n",
" Free (WriteLine s g) ->\n",
" putChatLine s\n",
" interpret (g True)\n",
" Pure r -> return r\n",
"-}"
]
},
{
"cell_type": "code",
"execution_count": 45,
"metadata": {},
"outputs": [],
"source": [
"-- Taken from some gist on the internet\n",
"import Control.Monad.Free\n",
"import Control.Monad.Trans\n",
"import System.Directory\n",
"\n",
"-- | Define our Free Monad DSL\n",
"data FileF r =\n",
" Write String String r\n",
" | Delete String r\n",
" | Copy String String r\n",
" | Move String String r\n",
" | Read (String -> r)\n",
" | Log String r\n",
" deriving (Functor)\n",
"\n",
"-- | Smart constructors\n",
"write :: String -> String -> Free FileF ()\n",
"write path txt = liftF $ Write path txt ()\n",
"\n",
"delete :: String -> Free FileF ()\n",
"delete path = liftF $ Delete path ()\n",
"\n",
"copy :: String -> String -> Free FileF ()\n",
"copy from to = liftF $ Copy from to ()\n",
"\n",
"move :: String -> String -> Free FileF ()\n",
"move from to = liftF $ Move from to ()\n",
"\n",
"readLine :: Free FileF String\n",
"readLine = liftF $ Read id\n",
"\n",
"logMsg :: String -> Free FileF ()\n",
"logMsg msg = liftF $ Log msg ()\n",
"\n",
"-- | We can transform our data structure before execution\n",
"optimizeMove :: Free FileF a -> Free FileF a\n",
"optimizeMove (Pure a) = Pure a\n",
"optimizeMove (Free (Copy from to (Free (Delete f r)))) | f == from = Free $ Move from to (optimizeMove r)\n",
"optimizeMove (Free f) = Free (fmap optimizeMove f)\n",
"\n",
"\n",
"-- | Log each action we take\n",
"addLogging :: Free FileF a -> Free FileF a\n",
"addLogging (Pure a) = Pure a\n",
"addLogging (Free f@(Write path txt _)) = Free (Log (\"Writing \" ++ txt ++ \" to \" ++ path) (Free $ fmap addLogging f))\n",
"addLogging (Free f@(Delete path _)) = Free (Log (\"Deleting \" ++ path) (Free $ fmap addLogging f))\n",
"addLogging (Free f@(Copy from to _)) = Free (Log (\"Copying \" ++ from ++ \" to \" ++ to) (Free $ fmap addLogging f))\n",
"addLogging (Free f@(Move from to _)) = Free (Log (\"Moving \" ++ from ++ \" to \" ++ to) (Free $ fmap addLogging f))\n",
"addLogging (Free (Read f)) = Free (Read (\\txt -> Free (Log (\"Read \" ++ txt ++ \" from console\") (addLogging (f txt)))))\n",
"addLogging (Free f) = Free (fmap addLogging f)\n",
"\n",
"\n",
"-- | We can run our FileF as IO\n",
"interpToIO :: Free FileF () -> IO ()\n",
"interpToIO (Pure ()) = return ()\n",
"interpToIO (Free (Write path txt r)) = writeFile path txt >> interpToIO r\n",
"interpToIO (Free (Delete path r)) = removeFile path >> interpToIO r\n",
"interpToIO (Free (Copy from to r)) = copyFile from to >> interpToIO r\n",
"interpToIO (Free (Move from to r)) = renameFile from to >> interpToIO r\n",
"interpToIO (Free (Read f)) = getLine >>= interpToIO . f\n",
"interpToIO (Free (Log msg r)) = putStrLn msg >> interpToIO r\n",
"\n",
"-- | Here's a program\n",
"operations :: Free FileF ()\n",
"operations = do\n",
" write \"helloworld.txt\" \"Hello, World!\"\n",
" logMsg \"Enter new filename\"\n",
" newFilename <- readLine\n",
" if newFilename == \"quit\"\n",
" then logMsg \"See ya later\"\n",
" else copy \"helloworld.txt\" newFilename >> delete \"helloworld.txt\"\n",
"\n",
"\n",
"-- Note how we can now perform arbitrary optimizations over our calculations\n",
"-- We can compose our optimizations in any order to get the effects we want;\n",
"-- Note how (optimizeMove . addLogging) is different from (addLogging . optimizeMove)\n",
"loggedOptimized :: IO ()\n",
"loggedOptimized = interpToIO . optimizeMove . addLogging $ operations\n",
"-- > λ> loggedOptimized\n",
"-- > Writing Hello, World! to helloworld.txt\n",
"-- > Enter new filename\n",
"-- > NEW\n",
"-- > Read NEW from console\n",
"-- > Copying helloworld.txt to NEW\n",
"-- > Deleting helloworld.txt\n",
"\n",
"optimizedLogged :: IO ()\n",
"optimizedLogged = interpToIO . addLogging . optimizeMove $ operations\n",
"-- > λ> optimizedLogged\n",
"-- > Writing Hello, World! to helloworld.txt\n",
"-- > Enter new filename\n",
"-- > NEW\n",
"-- > Read NEW from console\n",
"-- > Moving helloworld.txt to NEW"
]
}
],
"metadata": {
"kernelspec": {
"display_name": "Haskell",
"language": "haskell",
"name": "haskell"
},
"language_info": {
"codemirror_mode": "ihaskell",
"file_extension": ".hs",
"name": "haskell",
"pygments_lexer": "Haskell",
"version": "8.6.5"
}
},
"nbformat": 4,
"nbformat_minor": 4
}