Free play 2

Free1.hs

{-# 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"

Free2.hs

{-# 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>))

Free3.hs

{-# 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>)