my ex eff

myeff.hs

{-# LANGUAGE GADTs               #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE TypeOperators       #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase          #-}
module Main where

import Control.Monad.Freer
import Control.Monad.RWS

--------------------------------------------------------------------------------
                          -- Effect Model --
--------------------------------------------------------------------------------
data PutStrLn s where
  PutStrLn :: String -> PutStrLn ()

data GetLine s where
  GetLine :: GetLine String

putStrLn' :: Member PutStrLn r => String -> Eff r ()
putStrLn' = send . PutStrLn

getLine'  :: Member GetLine r => Eff r String
getLine' = send GetLine
--------------------------------------------------------------------------------
                     -- Effectful Interpreter --
--------------------------------------------------------------------------------
runPutStrLn :: Member IO r => Eff (PutStrLn ': r) w -> Eff r w
runPutStrLn = runIt $ \(PutStrLn msg) -> putStrLn msg
  where runIt :: Member IO r => (forall a. PutStrLn a -> IO a)
              -> Eff (PutStrLn ': r) w -> Eff r w
        runIt = runNat
  
runGetLine :: Member IO r => Eff (GetLine ': r) w -> Eff r w
runGetLine = runIt $ \GetLine -> getLine
  where runIt :: Member IO r => (forall a. GetLine a -> IO a)
              -> Eff (GetLine ': r) w -> Eff r w
        runIt = runNat

runEverything :: Eff '[GetLine, PutStrLn, IO] a -> IO a
runEverything = runM . runPutStrLn . runGetLine

runEverythingKindaBackwards :: Eff '[PutStrLn, GetLine, IO] a -> IO a
runEverythingKindaBackwards = runM . runGetLine . runPutStrLn
--------------------------------------------------------------------------------
                        -- Pure Interpreter --
--------------------------------------------------------------------------------
type PureStack = RWS () [String] [String]

putStrLnWriter :: Member PureStack r => Eff (PutStrLn ': r) w -> Eff r w
putStrLnWriter = runIt (\(PutStrLn msg) -> tell [msg]) 
  where runIt :: Member PureStack r
              => (forall a. PutStrLn a -> PureStack a) -> Eff (PutStrLn ': r) w
              -> Eff r w
        runIt = runNat

getLineReader :: Member PureStack r => Eff (GetLine ': r) w -> Eff r w
getLineReader = runIt $ \GetLine -> get >>= \case
  []         -> error "No more input"
  input:rest -> do
    put rest
    return input
  where runIt :: Member PureStack r => (forall a. GetLine a -> PureStack a)
              -> Eff (GetLine ': r) w -> Eff r w
        runIt = runNat 

runPureStack :: Eff '[PutStrLn, GetLine, PureStack] a -> [String] -> (a, [String], [String])
runPureStack eff = runRWS (runM $ getLineReader $ putStrLnWriter eff) () 

myEff :: (Member PutStrLn r, Member GetLine r) => Eff r ()
myEff = do
  putStrLn' "This is the first printed line"
  putStrLn' "This is the second printed line"
  -- Here we get a line from the interpreter which will come either as a canned
  -- string (in the case of the pure interpreter), or as the result of getLine
  -- (in the case of actual IO)
  ln <- getLine'
  putStrLn' $ ln ++ "some extra stuff"

main :: IO ()
main = do
  runEverything myEff
  runEverythingKindaBackwards myEff
  let input = ["line 1","line 2","line 3"] 
      ((), unread, written) = runPureStack myEff input 
  putStrLn $ "written PutStrLn's: " ++ show written
  putStrLn $ "unread  GetStrLn's: " ++ show unread

{- output
This is the first printed line
This is the second printed line
aoeu
aoeusome extra stuff
This is the first printed line
This is the second printed line
snth
snthsome extra stuff
written PutStrLn's: ["This is the first printed line","This is the second printed line","line 1some extra stuff"]
unread  GetStrLn's: ["line 2","line 3"]
-}

runNat makes writing the interpreter super easy!