More Extensible Effects
This package is an implementation of "Freer Monads, More Extensible Effects".
Much of the implementation is a repackaging and cleaning up of the reference materials provided here:
Overview
Examples
VerboseAddition.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}
module Control.Monad.Eff.Examples.VerboseAddition where
import Control.Monad.Eff
import Control.Monad.Eff.Lift
import Prelude hiding (log)
-- | The Log Effect
data Log v where
Log :: String -> Log ()
log :: Member Log r => String -> Eff r ()
log = send . Log
-- | The Log Interpreter, Pure
runLogger :: Eff (Log ': r) a -> Eff r (a, [String])
runLogger = handleRelay (\x -> return (x, []))
(\(Log s) k -> k () >>= \(x, ss) -> return (x, s:ss))
-- | The Log Interpreter, Impure
runIOLogger :: MemberU2 Lift (Lift IO) r => Eff (Log ': r) a -> Eff r a
runIOLogger = handleRelay return
(\(Log s) k -> lift (putStrLn s) >>= k)
-- | The program we want to be able to write
verboseAddition :: Member Log r => Eff r Int
verboseAddition = do
log "I'm starting with 1..."
x <- return 1
log "and I'm adding 2..."
y <- return 2
let r = x + y
log $ "Looks like the result is " ++ show r
return r
Now we can run the program in pure or impure way:
λ> run (runLogger verboseAddition)
(3,["I'm starting with 1...","and I'm adding 2...","Looks like the result is 3"])
λ> runLift (runIOLogger verboseAddition)
I'm starting with 1...
and I'm adding 2...
Looks like the result is 3
3
Teletype.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Control.Monad.Eff.Examples.Teletype where
import Control.Monad.Eff
import Control.Monad.Eff.Lift
import System.Exit (exitSuccess)
data Teletype x where
GetLine :: Teletype String
PutStrLn :: String -> Teletype ()
ExitSuccess :: Teletype ()
putStrLn' :: Member Teletype r => String -> Eff r ()
putStrLn' = send . PutStrLn
getLine' :: Member Teletype r => Eff r String
getLine' = send GetLine
exitSuccess' :: Member Teletype r => Eff r ()
exitSuccess' = send ExitSuccess
runTeletype :: [String] -> Eff (Teletype ': r) a -> Eff r [String]
runTeletype ss = handleRelayS ss ret handle
where
ret :: [String] -> a -> Eff r [String]
ret _ a = return []
handle :: HandlerS [String] Teletype r [String]
handle (s:stdin) GetLine k = k stdin s
handle _ GetLine k = error "Insufficient input"
handle stdin (PutStrLn s) k = do
stdout <- k stdin ()
return (s:stdout)
handle _ ExitSuccess k = return []
runIOTeletype :: forall r a. MemberU2 Lift (Lift IO) r => Eff (Teletype ': r) a -> Eff r a
runIOTeletype = handleRelay ret handle
where
ret :: a -> Eff r a
ret = return
handle :: Handler Teletype r a
handle GetLine k = lift getLine >>= k
handle (PutStrLn s) k = lift (putStrLn s) >>= k
handle ExitSuccess k = lift exitSuccess >>= k
example :: Member Teletype r => Eff r ()
example = do
str <- getLine'
putStrLn' ("put: " ++ str)
str <- getLine'
putStrLn' ("put: " ++ str)
exitSuccess'
putStrLn' "should not appear"
Run it purely:
λ> run $ runTeletype ["hello", "world", "and more"] example
["put: hello","put: world"]
λ> run $ runTeletype ["hello"] example
*** Exception: Insufficient input
CallStack (from HasCallStack):
error, called at /work/src/Control/Monad/Eff/Examples/Teletype.hs:35:39 in main:Control.Monad.Eff.Examples.Teletype
Run it in IO:
λ> runLift $ runIOTeletype example
hello
put: hello
world
put: world
*** Exception: ExitSuccess