1463 lines
40 KiB
Text
1463 lines
40 KiB
Text
{
|
|
"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
|
|
}
|