From 91050d615a5defecec62c5b0b6c4f34daee2b8eb Mon Sep 17 00:00:00 2001 From: Sanchayan Maity Date: Sat, 1 Aug 2020 19:18:09 +0530 Subject: [PATCH] Add a notebook on free monad Signed-off-by: Sanchayan Maity --- freemonad.ipynb | 1294 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1294 insertions(+) create mode 100644 freemonad.ipynb 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
Found:
(flip catch f)
Why Not:
(`catch` f)
" + ], + "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
Why Not:
output 'A'
Monad law, right identity
Found:
output 'A' >>= return
Why Not:
output 'A'
" + ], + "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 +}