{ "cells": [ { "cell_type": "code", "execution_count": 3, "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)))))\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": [ "fact' :: forall p. (Eq p, Num p) => (p -> p) -> p -> p" ], "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": [ "
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", "-- 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": [ "output :: forall b (m :: * -> *). MonadFree (Toy b) m => b -> m ()" ], "text/plain": [ "output :: forall b (m :: * -> *). MonadFree (Toy b) m => b -> m ()" ] }, "metadata": {}, "output_type": "display_data" }, { "data": { "text/html": [ "bell :: forall b (m :: * -> *). MonadFree (Toy b) m => m ()" ], "text/plain": [ "bell :: forall b (m :: * -> *). MonadFree (Toy b) m => m ()" ] }, "metadata": {}, "output_type": "display_data" }, { "data": { "text/html": [ "done :: forall b (m :: * -> *) a. MonadFree (Toy b) m => m a" ], "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": [ "
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": 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 }