diff --git a/freemonad.ipynb b/freemonad.ipynb
new file mode 100644
index 0000000..78a3d99
--- /dev/null
+++ b/freemonad.ipynb
@@ -0,0 +1,1294 @@
+{
+ "cells": [
+ {
+ "cell_type": "code",
+ "execution_count": 4,
+ "metadata": {},
+ "outputs": [
+ {
+ "data": {
+ "text/html": [
+ "(Output 'A' Done) :: forall b next. Toy Char (Toy b next)"
+ ],
+ "text/plain": [
+ "(Output 'A' Done) :: forall b next. Toy Char (Toy b next)"
+ ]
+ },
+ "metadata": {},
+ "output_type": "display_data"
+ },
+ {
+ "data": {
+ "text/html": [
+ "(Bell (Output 'A' Done)) :: forall b1 b2 next. Toy b1 (Toy Char (Toy b2 next))"
+ ],
+ "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": [
+ "(Fix (Output 'A' (Fix Done))) :: Fix (Toy Char)"
+ ],
+ "text/plain": [
+ "(Fix (Output 'A' (Fix Done))) :: Fix (Toy Char)"
+ ]
+ },
+ "metadata": {},
+ "output_type": "display_data"
+ },
+ {
+ "data": {
+ "text/html": [
+ "(Fix (Bell (Fix (Output 'A' (Fix Done))))) :: Fix (Toy Char)"
+ ],
+ "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)))))"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 13,
+ "metadata": {},
+ "outputs": [
+ {
+ "data": {
+ "text/plain": [
+ "120"
+ ]
+ },
+ "metadata": {},
+ "output_type": "display_data"
+ },
+ {
+ "data": {
+ "text/plain": [
+ "120"
+ ]
+ },
+ "metadata": {},
+ "output_type": "display_data"
+ }
+ ],
+ "source": [
+ "-- https://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Monad-Fix.html\n",
+ "import Control.Monad.Fix\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",
+ "-- fact' rec n = if n == 0 then 1 else n * rec (n-1)\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",
+ "-}"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 15,
+ "metadata": {},
+ "outputs": [
+ {
+ "data": {
+ "text/html": [
+ "
Use section
"
+ ],
+ "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",
+ "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",
+ "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": 23,
+ "metadata": {},
+ "outputs": [
+ {
+ "data": {
+ "text/html": [
+ "output :: forall b. b -> Free (Toy b) ()"
+ ],
+ "text/plain": [
+ "output :: forall b. b -> Free (Toy b) ()"
+ ]
+ },
+ "metadata": {},
+ "output_type": "display_data"
+ },
+ {
+ "data": {
+ "text/html": [
+ "bell :: forall b. Free (Toy b) ()"
+ ],
+ "text/plain": [
+ "bell :: forall b. Free (Toy b) ()"
+ ]
+ },
+ "metadata": {},
+ "output_type": "display_data"
+ },
+ {
+ "data": {
+ "text/html": [
+ "done :: forall b r. Free (Toy b) r"
+ ],
+ "text/plain": [
+ "done :: forall b r. Free (Toy b) r"
+ ]
+ },
+ "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",
+ "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",
+ "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",
+ " subroutine\n",
+ " bell\n",
+ " done"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": 24,
+ "metadata": {},
+ "outputs": [
+ {
+ "data": {
+ "text/plain": [
+ "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": [
+ "Monad law, left identity
Found:
return 'A' >>= output
Monad law, right identity
Found:
output 'A' >>= return
"
+ ],
+ "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": 27,
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "import Control.Exception\n",
+ "\n",
+ "ringBell :: IO ()\n",
+ "ringBell = undefined\n",
+ "\n",
+ "interpret :: (Show b) => Free (Toy b) r -> IO ()\n",
+ "interpret (Free (Output b x)) = print b >> interpret x\n",
+ "interpret (Free (Bell x)) = ringBell >> interpret x\n",
+ "interpret (Free Done ) = return ()\n",
+ "interpret (Pure r) = throwIO (userError \"Improper termination\")"
+ ]
+ },
+ {
+ "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": 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
+}