Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
Free play 2
{-# LANGUAGE DeriveFunctor#-}
-- Simple example of using Free with a single algebra/API.
module Free1 where
import Control.Monad.Free
data SimpleFileF a
= LoadFile FilePath (String -> a)
| SaveFile FilePath String a
deriving(Functor)
type SimpleFileAPI = Free SimpleFileF
loadFile :: FilePath -> SimpleFileAPI String
loadFile fp = liftF $ LoadFile fp id
saveFile :: FilePath -> String -> SimpleFileAPI ()
saveFile fp d = liftF $ SaveFile fp d ()
runSimpleFile :: SimpleFileAPI a -> IO a
runSimpleFile = foldFree f
where
f (LoadFile fp f') = f' <$> readFile fp
f (SaveFile fp d r) = writeFile fp d >> return r
withSimpleFile :: (String -> String) -> FilePath -> SimpleFileAPI ()
withSimpleFile f fp = do
d <- loadFile fp
let result = f d
saveFile (fp ++ "_new") result
-- to run:
-- runSimpleFile $ withSimpleFile <transFunc> "filename"
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveFunctor #-}
-- An example of using Free with two algebras/APIs, where one is used as a
-- decorator of the other.
module Free2 where
import Control.Monad.Free
data SimpleFileF a
= LoadFile FilePath (String -> a)
| SaveFile FilePath String a
deriving(Functor)
type SimpleFileAPI = Free SimpleFileF
loadFile :: FilePath -> SimpleFileAPI String
loadFile fp = liftF $ LoadFile fp id
saveFile :: FilePath -> String -> SimpleFileAPI ()
saveFile fp d = liftF $ SaveFile fp d ()
stepSimpleFile :: SimpleFileF a -> IO a
stepSimpleFile (LoadFile fp f') = f' <$> readFile fp
stepSimpleFile (SaveFile fp d r) = writeFile fp d >> return r
withSimpleFile :: (String -> String) -> FilePath -> SimpleFileAPI ()
withSimpleFile f fp = do
d <- loadFile fp
let result = f d
saveFile (fp ++ "_new") result
data LogF a = Log String a
deriving(Functor)
type LogAPI = Free LogF
stepLog :: LogF a -> IO a
stepLog (Log s r) = putStrLn s >> return r
logSimpleFileT :: SimpleFileF a -> LogAPI ()
logSimpleFileT (LoadFile fp _) = liftF $ Log ("** load file " ++ fp) ()
logSimpleFileT (SaveFile fp _ _) = liftF $ Log ("** save file " ++ fp) ()
data S a1 a2 t = A1 (a1 t) | A2 (a2 t)
deriving(Functor)
type SumAPI = Free (S LogF SimpleFileF)
runSum :: Monad m => (forall a. LogF a -> m a) -> (forall a. SimpleFileF a -> m a) -> SumAPI b -> m b
runSum f1 f2 = foldFree f
where
f (A1 op) = f1 op
f (A2 op) = f2 op
logSimpleFile :: SimpleFileAPI a -> SumAPI a
logSimpleFile = foldFree f
where
f op = hoistFree A1 (logSimpleFileT op) *> hoistFree A2 (liftF op)
-- runSum stepLog stepSimpleFile (logSimpleFile (withSimpleFile <f> <file>))
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveFunctor #-}
-- An example of using Free with three algebras/APIs, two independent algebras
-- and the third one is used for decorating the other two.
module Free3 where
import Control.Monad.Free
import Data.Char
data SimpleFileF a
= LoadFile FilePath (String -> a)
| SaveFile FilePath String a
deriving(Functor)
loadFile :: FilePath -> SumAPI String
loadFile fp = liftF $ A2 $ LoadFile fp id
saveFile :: FilePath -> String -> SumAPI ()
saveFile fp d = liftF $ A2 $ SaveFile fp d ()
stepSimpleFile :: SimpleFileF a -> IO a
stepSimpleFile (LoadFile fp f') = f' <$> readFile fp
stepSimpleFile (SaveFile fp d r) = writeFile fp d >> return r
data StdIoF a = PutStrLn String a
deriving(Functor)
stdioPut :: String -> SumAPI ()
stdioPut s = liftF $ A3 $ PutStrLn s ()
stepStdIo :: StdIoF b -> IO b
stepStdIo (PutStrLn s a) = putStrLn s >> return a
data LogF a = Log String a
deriving(Functor)
type LogAPI = Free LogF
stepLog :: LogF a -> IO a
stepLog (Log s r) = putStrLn s >> return r
logSimpleFileT :: SimpleFileF a -> LogAPI ()
logSimpleFileT (LoadFile fp _) = liftF $ Log ("** load file " ++ fp) ()
logSimpleFileT (SaveFile fp _ _) = liftF $ Log ("** save file " ++ fp) ()
logStdIoT :: StdIoF a -> LogAPI ()
logStdIoT (PutStrLn s _) = liftF $ Log ("** on stdio " ++ s) ()
data S a1 a2 a3 t = A1 (a1 t) | A2 (a2 t) | A3 (a3 t)
deriving(Functor)
type SumAPI = Free (S LogF SimpleFileF StdIoF)
runSum :: Monad m => (forall a. LogF a -> m a)
-> (forall a. SimpleFileF a -> m a)
-> (forall a. StdIoF a -> m a)
-> SumAPI b -> m b
runSum f1 f2 f3 = foldFree f
where
f (A1 op) = f1 op
f (A2 op) = f2 op
f (A3 op) = f3 op
logT :: SumAPI a -> SumAPI a
logT = foldFree f
where
f (A2 op) = hoistFree A1 (logSimpleFileT op) *> hoistFree A2 (liftF op)
f (A3 op) = hoistFree A1 (logStdIoT op) *> hoistFree A3 (liftF op)
f a@(A1 _) = liftF a
withSimpleFile :: (String -> String) -> FilePath -> SumAPI ()
withSimpleFile f fp = do
d <- loadFile fp
let result = f d
saveFile (fp ++ "_new") result
prog :: FilePath -> SumAPI ()
prog fn = do
stdioPut "About to start"
withSimpleFile (map toUpper) fn
stdioPut "Done!"
-- runSum undefined stepSimpleFile stepStdIo (prog <fn>)
-- runSum stepLog stepSimpleFile stepStdIo (logT $ prog <fn>)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment