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:

• Eff1.hs
• OpenUnion5.hs
• FTCQueue1.hs

Overview

• Control
  • Monad
    • Eff
      • Examples
        • Teletype
        • VerboseAddition
      • Exception
      • Internal
      • Lift
      • NdetEff
      • Reader
      • State
      • StateRW
      • Writer
• Data
  • FTCQueue
  • OpenUnion

Examples

Log Effect (24 Days of Hackage: extensible-effects)

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 (Purify code using free monads)

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