ExtensibleEffects.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}

module ExtensibleEffects
  ( interpret
  , program
  ) where

{-
 - This example solves the challenge with the "extensible effects" framework
 - originally proposed in [1] and elaborated in [2].
 -
 - [1] Oleg Kiselyov, Amr Sabry, and Cameron Swords. 2013. Extensible effects:
 -     an alternative to monad transformers. In Proceedings of the 2013 ACM
 -     SIGPLAN symposium on Haskell (Haskell '13). ACM, New York, NY, USA,
 -     59-70. DOI=https://doi.org/10.1145/2503778.2503791
 -
 - [2] Oleg Kiselyov and Hiromi Ishii. 2015. Freer monads, more extensible
 -     effects. In Proceedings of the 2015 ACM SIGPLAN Symposium on Haskell
 -     (Haskell '15). ACM, New York, NY, USA, 94-105.
 -     DOI=https://doi.org/10.1145/2804302.2804319
 -}
import Control.Eff (Eff, Member, run)
import Control.Eff.Extend (handle_relay_s, send)
import Control.Eff.State.Lazy (State, get, put, runState)
import Control.Eff.Writer.Lazy (Writer, runMonoidWriter, tell)
import Control.Monad (replicateM_)
import Data.Typeable (Typeable)
import System.Random (mkStdGen, randomR)

-- A custom effect
data Random a where
  GetRandom :: Random Integer
  deriving (Typeable)

-- The operations
getRandom :: Member Random r => Eff r Integer
getRandom = send GetRandom

getAccumulator :: Member (State Integer) r => Eff r Integer
getAccumulator = get

setAccumulator :: Member (State Integer) r => Integer -> Eff r ()
setAccumulator = put

logOutput :: Member (Writer String) r => String -> Eff r ()
logOutput = tell

-- The program
program ::
     (Member Random r, Member (State Integer) r, Member (Writer String) r)
  => Eff r ()
program =
  replicateM_ 10 $ do
    i <- getAccumulator
    logOutput (show i ++ "\n")
    r <- getRandom
    setAccumulator (r + i)

-- A custom effect handler
runRandom :: Eff (Random ': r) a -> Eff r a
runRandom =
  handle_relay_s
    (mkStdGen 0)
    (const pure)
    (\s1 GetRandom k ->
       let (r, s2) = randomR (0, 9) s1
        in k s2 r)

-- An interpreter
interpret ::
     (forall r. ( Member Random r
                , Member (State Integer) r
                , Member (Writer String) r
                ) =>
                  Eff r a)
  -> (a, String)
interpret c =
  let ((x, o), _) =
        run . runState (0 :: Integer) . runMonoidWriter . runRandom $ c
   in (x, o)