fine-grained IO effects using extensible-effects and freer

extensible-effects.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators         #-}

module GetlinePutline where

--------------------------------------------------------------------------------
import           Control.Eff
import           Control.Eff.Lift
import           Data.Typeable
import           Prelude          hiding (log)
--------------------------------------------------------------------------------

--------------------------------------------------------------------------------

data Getline v = Getline (String -> v)
  deriving (Typeable, Functor)

getline :: Member Getline r => Eff r String
getline = send (inj (Getline id))

runGetline :: (SetMember Lift (Lift IO) r) => Eff (Getline :> r) w -> Eff r w
runGetline = freeMap return (\u -> handleRelay u runGetline (\(Getline k) -> lift getLine >>= runGetline . k))

--------------------------------------------------------------------------------

data Putline v = Putline String (() -> v)
  deriving (Typeable, Functor)

putline :: Member Putline r => String -> Eff r ()
putline s = send (inj (Putline s id))

runPutline :: (SetMember Lift (Lift IO) r) => Eff (Putline :> r) w -> Eff r w
runPutline = freeMap return (\u -> handleRelay u runPutline (\(Putline s k) -> lift (putStrLn s) >>= runPutline . k))

--------------------------------------------------------------------------------

-- Similar to Putline, but we provide a logger when running

data Logger

defaultLogger :: Logger
defaultLogger = undefined

logToHandle :: Logger -> String -> IO ()
logToHandle _ s = putStrLn ("logging: " ++ show s)

-- Log using a logger
data Log v = Log String (() -> v)
  deriving (Typeable, Functor)

log :: Member Log r => String -> Eff r ()
log s = send (inj (Log s id))

runLog :: SetMember Lift (Lift IO) r => Logger -> Eff (Log :> r) w -> Eff r w
runLog logger = freeMap return (\u -> handleRelay u (runLog logger) (\(Log s k) -> lift (logToHandle logger s) >>= runLog logger . k))

--------------------------------------------------------------------------------

-- Database read

data User = User { username :: String }
  deriving (Show)

data ReadDb v
  = GetUsers ([User] -> v)
  | GetUserByUsername String (Maybe User -> v)
  deriving (Typeable, Functor)

getUsers :: Member ReadDb r => Eff r [User]
getUsers = send (inj (GetUsers id))

getUserByUsername :: Member ReadDb r => String -> Eff r (Maybe User)
getUserByUsername uname = send (inj (GetUserByUsername uname id))

data SqlBackend = SqlBackend

getUsers_db :: SqlBackend -> IO [User]
getUsers_db _ = return [User "user1"]

getUserByUsername_db :: SqlBackend -> String -> IO (Maybe User)
getUserByUsername_db _ uname = return (Just (User uname))

runReadDb :: SetMember Lift (Lift IO) r => SqlBackend -> Eff (ReadDb :> r) w -> Eff r w
runReadDb db = freeMap return (\u -> handleRelay u (runReadDb db) (\case GetUsers k -> lift (getUsers_db db) >>= runReadDb db . k
                                                                         GetUserByUsername s k -> lift (getUserByUsername_db db s) >>= runReadDb db . k))

--------------------------------------------------------------------------------

myEff :: (Member Log r, Member Putline r, Member Getline r, Member ReadDb r) => Eff r ()
myEff = do
  ln <- getline
  putline ln
  putline "done"
  log "logging stuff"
  putline "reading db"
  users <- getUsers
  log (show users)

main :: IO ()
main = runLift $ runLog defaultLogger $ runPutline $ runGetline $ runReadDb SqlBackend myEff

freer.hs

-- originally posted to https://gitlab.com/queertypes/freer/issues/7
-- modified to remove IO from myEff

{-# OPTIONS_GHC -Wall #-}

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators         #-}

module GetlinePutline where

--------------------------------------------------------------------------------
import           Control.Monad.Freer
import           Control.Monad.Freer.Internal
import           Prelude                      hiding (log)
--------------------------------------------------------------------------------

doIO :: Member IO r => IO a -> Eff r a
doIO = send

--------------------------------------------------------------------------------

data Getline a where
  Getline :: Getline String

getline :: Member Getline r => Eff r String
getline = send Getline

runGetline :: Member IO r => Eff (Getline ': r) w -> Eff r w
runGetline (Val x) = return x
runGetline (E u q) = case decomp u of
  Right Getline -> doIO getLine >>= runGetline . qApp q
  Left u1       -> E u1 (tsingleton (runGetline . qApp q))

--------------------------------------------------------------------------------

data Putline a where
  Putline :: String -> Putline ()

runPutline :: Member IO r => Eff (Putline ': r) w -> Eff r w
runPutline (Val x) = return x
runPutline (E u q) = case decomp u of
  Right (Putline s) -> doIO (putStrLn s) >> runPutline (qApp q ())
  Left u1           -> E u1 (tsingleton (runPutline . qApp q))

putline :: Member Putline r => String -> Eff r ()
putline = send . Putline

--------------------------------------------------------------------------------

-- Similar to Putline, but we provide a logger when running

data Logger

defaultLogger :: Logger
defaultLogger = undefined

logToHandle :: Logger -> String -> IO ()
logToHandle _ s = putStrLn ("logging: " ++ show s)

-- Log using a logger
data Log a where
  Log :: String -> Log ()

log :: Member Log r => String -> Eff r ()
log = send . Log

runLog :: Member IO r => Logger -> Eff (Log ': r) w -> Eff r w
runLog _      (Val x) = return x
runLog logger (E u q) = case decomp u of
  Right (Log s) -> doIO (logToHandle logger s) >> runLog logger (qApp q ())
  Left u1       -> E u1 (tsingleton (runLog logger . qApp q))

--------------------------------------------------------------------------------

-- Database read

data User = User { username :: String }
  deriving (Show)

data ReadDb a where
  GetUsers          :: ReadDb [User]
  GetUserByUsername :: String -> ReadDb (Maybe User)

getUsers :: Member ReadDb r => Eff r [User]
getUsers = send GetUsers

getUserByUsername :: Member ReadDb r => String -> Eff r (Maybe User)
getUserByUsername = send . GetUserByUsername

data SqlBackend = SqlBackend

getUsers_db :: SqlBackend -> IO [User]
getUsers_db _ = return [User "user1"]

getUserByUsername_db :: SqlBackend -> String -> IO (Maybe User)
getUserByUsername_db _ uname = return (Just (User uname))

runReadDb :: Member IO r => SqlBackend -> Eff (ReadDb ': r) w -> Eff r w
runReadDb _  (Val x) = return x
runReadDb db (E u q) = case decomp u of
  Right GetUsers -> doIO (getUsers_db db) >>= runReadDb db . qApp q
  Right (GetUserByUsername uname) -> doIO (getUserByUsername_db db uname) >>= runReadDb db . qApp q
  Left u1 -> E u1 (tsingleton (runReadDb db . qApp q))

--------------------------------------------------------------------------------

myEff :: (Member Log r, Member Putline r, Member Getline r, Member ReadDb r) => Eff r ()
myEff = do
  ln <- getline
  putline ln
  putline "done"
  log "logging stuff"
  putline "reading db"
  users <- getUsers
  log (show users)

main :: IO ()
main = runM $ runLog defaultLogger $ runPutline $ runGetline $ runReadDb SqlBackend myEff