Examples from "Effect handlers in Scope" implemented with the EvEff package.

Scope.hs

{-# LANGUAGE RankNTypes, TypeOperators, FlexibleContexts, UndecidableInstances, TypeApplications, LambdaCase, ScopedTypeVariables, BlockArguments, DeriveFunctor, KindSignatures, ExistentialQuantification, FlexibleContexts #-}
{-# OPTIONS_GHC -Wall -Wno-orphans #-}
module Control.Ev.Scope where

import           Control.Applicative
import           Control.Ev.Eff
import           Control.Monad
import           Data.Foldable
import           Data.Functor                   ( (<&>) )
import           Debug.Trace
import Prelude hiding (log)

--------------------------------------------------------------------------------
-- Backtracking Computation
--------------------------------------------------------------------------------

data Nondet e ans = Nondet
  { _fail   :: forall a . Op () a e ans
  , _select :: forall a. Op [a] a e ans
  }

select :: Nondet :? e => [a] -> Eff e a
select = perform _select

instance Nondet :? e => Alternative (Eff e) where
  empty = perform _fail ()
  x1 <|> x2 = asum' [x1, x2]

asum' :: Nondet :? e => [Eff e a] -> Eff e a
asum' = join . select

knapsack :: Nondet :? e => Int -> [Int] -> Eff e [Int]
knapsack w vs
  | w < 0 = empty
  | w == 0 = pure []
  | w > 0 = do
    v   <- select vs
    vs' <- knapsack (w - v) vs
    pure (v : vs')
  | otherwise = error "impossible"

-- This short circuits
nondetMaybe :: Eff (Nondet :* e) ans -> Eff e (Maybe ans)
nondetMaybe = handlerRet
  Just
  Nondet
    { _fail   = except \_ -> pure Nothing
    , _select = operation \xs k -> foldr
                  (\i rest -> maybe rest (pure . Just) =<< k i)
                  (pure Nothing)
                  xs
    }

nondet :: Alternative f => Eff (Nondet :* e) ans -> Eff e (f ans)
nondet = handlerRet
  pure
  Nondet
    { _fail = except \_ -> pure empty
    , _select = operation \xs k -> asum <$> traverse k xs
    }

-- $> runEff $ nondet @[] $ knapsack 3 [3,2,1]

--------------------------------------------------------------------------------
-- Composing Semantics
--------------------------------------------------------------------------------

-- The State effect

data State s e ans = State
  { _get :: Op () s e ans
  , _put :: Op s () e ans
  }

get :: State s :? e => Eff e s
get = perform _get ()

put :: State s :? e => s -> Eff e ()
put = perform _put

modify :: State s :? e => (s -> s) -> Eff e ()
modify f = put . f =<< get

(>>=$) :: Monad m => m (a -> m b) -> a -> m b
m >>=$ x = m >>= ($ x)

infixr 9 $<=<

($<=<) :: Monad m => a -> (c -> m (a -> m b)) -> (c -> m b)
x $<=< m = ($ x) <=< m

state :: s -> Eff (State s :* e) ans -> Eff e (s, ans)
state x = x $<=< handlerRet
  (\ans s -> pure (s, ans))
  State { _get = operation (\_ k -> pure (\s -> k s >>=$ s))
        , _put = operation (\s k -> pure (\_ -> k () >>=$ s))
        }

-- Combining State and Nondeterminism

runLocal :: s -> Eff (State s :* Nondet :* e) ans -> Eff e [(s, ans)]
runLocal s = nondet . state s

runGlobal :: s -> Eff (Nondet :* State s :* e) ans -> Eff e (s, [ans])
runGlobal s = state s . nondet

incr :: State Int :? e => Eff e ()
incr = modify @Int (+ 1)

choices :: (Nondet :? e, State Int :? e) => Eff (Nondet :* e) a -> Eff e a
choices = handler Nondet { _fail   = function (const empty)
                         , _select = function (\xs -> incr *> select xs)
                         }

-- We get different numbers here because our select operation can make more than
-- a single binary decision each time.

-- $> runEff . runGlobal 0 . choices $ knapsack 3 [3,2,1] :: (Int,[[Int]])

-- $> runEff . runLocal  0 . choices $ knapsack 3 [3,2,1] :: [(Int,[Int])]

--------------------------------------------------------------------------------
-- Cut and Call
--------------------------------------------------------------------------------

newtype Cut e ans = Cut
  { _cutfail :: forall a. Op () a e ans }

cutfail :: Cut :? e => Eff e a
cutfail = perform _cutfail ()

call
  :: forall e ans . Nondet :? e => Eff (Nondet :* Cut :* e) ans -> Eff e ans
call =
  handler Cut { _cutfail = function (const empty) } . empty $<=< handlerRet
    (\ans q -> pure ans <|> q)
    Nondet
      { _fail   = operation \_ _ -> pure id
      , _select = operation \xs k ->
                    pure \q -> foldr (\x rest -> k x >>=$ rest) q xs
      }

cut :: (Nondet :? e, Cut :? e) => Eff e ()
cut = skip <|> cutfail

skip :: Eff e ()
skip = pure ()

once :: Nondet :? e => Eff (Nondet :* Cut :* e) b -> Eff e b
once p = call (p <* cut)

-- $> (runEff . nondet @[] . once) (knapsack 3 [3, 2, 1])

--------------------------------------------------------------------------------
-- Grammars
--------------------------------------------------------------------------------

newtype Symbol e ans = Symbol
  { _symbol :: Op (String, Char -> Bool) Char e ans }

symbol :: Symbol :? e => String -> (Char -> Bool) -> Eff e Char
symbol = curry (perform _symbol)

char :: Symbol :? e => Char -> Eff e Char
char c = symbol [c] (== c)

digit :: Symbol :? e => Eff e Char
digit = symbol "digit" (`elem` ['0' .. '9'])

parse :: Nondet :? e => String -> Eff (Symbol :* e) a -> Eff e a
parse str = ($ str) <=< handlerRet
  (\ans xs -> if null xs then pure ans else empty)
  Symbol
    { _symbol = operation \(_, p) k -> pure \case
      (x : xs) | p x -> k x >>=$ xs
      _              ->  empty
    }

expr :: (Nondet :? e, Symbol :? e) => Eff e Int
expr = (+) <$> term <* char '+' <*> expr <|> term

term :: (Nondet :? e, Symbol :? e) => Eff e Int
term = factor >>= \i -> (i *) <$ char '*' <*> factor <|> pure i

factor :: (Nondet :? e, Symbol :? e) => Eff e Int
factor = read <$> some digit <|> char '(' *> expr <* char ')'

-- $> (runEff . nondet @[] . parse "2+8*5") expr

expr2 :: (Nondet :? e, Symbol :? e) => Eff e Int
expr2 = term >>= \i -> call $ (i +) <$ char '+' <* cut <*> expr <|> pure i

-- $> (runEff . nondet @[] . parse "1") expr2

--------------------------------------------------------------------------------
-- Scoped Syntax
--------------------------------------------------------------------------------

data Call e ans = Call
  { _bcall       :: Op () () e ans
  , _ecall       :: Op () () e ans
  , _cutfailcall :: forall a. Op () a e ans
  }

data CallResult a = CallResult a (Maybe Int) deriving Functor

instance Show (CallResult a) where
  show (CallResult _ x) = "CallResult <a> " ++ show x
  
pureCallResult :: a -> CallResult a
pureCallResult x = CallResult x Nothing

callResult :: Nondet :? e => CallResult (Eff e a) -> Eff e a
callResult (CallResult x Nothing) = x
callResult _ = error "Mismatched call"

-- Don't look at this terrible type, just look at the buildable instances below.
type BuildHandler h
  = forall e ans. (  forall a b
     . (forall e' ans' . h e' ans' -> Op a b e' ans')
    -> Op a b e ans
    )
  -> h e ans

class Buildable (h :: * -> * -> *) where
  build :: BuildHandler h

instance Buildable Nondet where
  build f = Nondet { _fail = f _fail, _select = f _select }

instance Buildable Call where
  build f =
    Call { _cutfailcall = f _cutfailcall, _bcall = f _bcall, _ecall = f _ecall }

-- Sometimes you really want to interpret two independently defined effects as
-- one combined effect. For example when you run into unscoped resumption errors
-- if you use two separate handlers. Here we define 'ComposeHandler' and
-- 'handlers' that allows you to circumvent that error while still keeping the
-- two handlers separate.

data ComposeHandler h1 h2 e ans = ComposeHandler
  { _composeHandler1 :: h1 e ans
  , _composeHandler2 :: h2 e ans
  }

-- The 'handlerHideUnder' function is not in the standard EvEff package. I
-- defined it like this:
--
-- {-# INLINE handlerHideUnder #-}
-- handlerHideUnder :: forall h1 h2 h3 e ans . h1 (h3 :* e) ans -> Eff (h1 :* h2 :* e) ans -> Eff (h2 :* h3 :* e) ans
-- handlerHideUnder h1 action
--   = Eff @(h2 :* h3 :* e) f
--     where
--       f (CCons m2 h2 g2 (CCons m3 h3 g3 ctx')) =
--         prompt (\m1 -> under @(h1 :* h2 :* e)
--           (CCons m1 h1 (CTCompose test CTTail) (CCons m2 h2 (CTCompose g2 test) ctx'))
--           action)
--         where 
--           test :: ContextT e (h3 :* e)
--           test = CTCons m3 h3 g3

handlers
  :: forall h1 h2 e ans
   . (Buildable h1, Buildable h2)
  => ComposeHandler h1 h2 e ans
  -> Eff (h1 :* h2 :* e) ans
  -> Eff e ans
handlers hs =
  handler hs
    . handler
        (build \f ->
          function $ perform @(ComposeHandler h1 h2) $ f . _composeHandler2
        )
    . handlerHideUnder
        (build \f ->
          function $ perform @(ComposeHandler h1 h2) $ f . _composeHandler1
        )

cutcall
  :: forall e ans . Nondet :? e => Eff (Call :* Nondet :* e) ans -> Eff e ans
cutcall = callResult <=< handlers
  (ComposeHandler
    (Call
      { _cutfailcall = except \_ -> pure (CallResult empty (Just 0))
      , _bcall       = operation \_ k -> k () <&> \case
                         CallResult x (Just 0) -> CallResult x Nothing
                         CallResult x (Just i) -> CallResult x (Just (i - 1))
                         x                     -> x
      , _ecall       = operation \_ k -> k () <&> \case
                         CallResult x (Just i) -> CallResult x (Just (i + 1))
                         x                     -> x
      })
    (Nondet
      { _fail    = except \_ -> pure (CallResult empty Nothing)
      , _select  = operation \xs k -> foldr
                         (\i rest -> k i >>= \case
                           x@(CallResult _ (Just _)) -> pure x
                           CallResult a Nothing ->
                             fmap (fmap (a <|>)) rest)
                         (pure (CallResult empty Nothing))
                         xs
      }))
  . fmap (pureCallResult . pure)

call' :: Call :? e => Eff e a -> Eff e a
call' p = begin *> p <* end where
  begin = perform _bcall ()
  end   = perform _ecall ()

cut' :: (Nondet :? e, Call :? e) => Eff e ()
cut' = pure () <|> perform _cutfailcall ()

parse3 :: (Nondet :? e, Call :? e) => String -> Eff (Symbol :* e) a -> Eff e a
parse3 str = ($ str) <=< handlerRet
  (\ans xs -> if null xs then pure ans else empty)
  Symbol
    { _symbol = operation \(name, p) k -> pure \case
      (x : xs) | p x -> trace ("okay " ++ name ++ ": " ++ show x) (k x >>=$ xs)
      _              -> trace ("fail " ++ name) empty
    }

expr3 :: (Nondet :? e, Call :? e, Symbol :? e) => Eff e Int
expr3 = do
  i <- term3
  call' $ (i +) <$ char '+' <* cut' <*> expr3 <|> pure i

term3 :: (Nondet :? e, Call :? e, Symbol :? e) => Eff e Int
term3 = do
  i <- factor3
  call' $ (i *) <$ char '*' <* cut' <*> term3 <|> pure i

factor3 :: (Nondet :? e, Call :? e, Symbol :? e) => Eff e Int
factor3 =
  call'
    $   read <$> ((:) <$> digit <* cut' <*> many digit)
    <|> char '(' *>  expr3 <*  char ')'

-- $> (runEff . nondet @[] . cutcall . parse "1") expr3

--------------------------------------------------------------------------------
-- Exceptions
--------------------------------------------------------------------------------

newtype Exc x e ans = Exc
  { _throw :: forall a. Op x a e ans
  }

throw :: Exc x :? e => x -> Eff e a
throw = perform _throw 

runExc :: Eff (Exc x :* e) ans -> Eff e (Either x ans)
runExc = handlerRet Right Exc { _throw = except $ pure . Left }

catch :: Exc x :? e => Eff (Exc x :* e) ans -> (x -> Eff e ans) -> Eff e ans
catch act hdl = runExc act >>= either hdl pure

tripleDecr :: (State Int :? e, Exc () :? e) => Eff e ()
tripleDecr = decr *> catch (decr *> decr) pure

decr :: (State Int :? e, Exc () :? e) => Eff e ()
decr = do
  x <- get @Int
  if x > 0 then put (x - 1) else throw ()

data Catch x e ans = Catch
  { _bcatch :: Op () (Maybe x) e ans
  , _ecatch :: Op () () e ans
  , _throwcatch :: forall a. Op x a e ans
  }

throw' :: Catch x :? e => x -> Eff e a
throw' = perform _throwcatch

instance Buildable (Catch x) where
  build f = Catch (f _bcatch) (f _ecatch) (f _throwcatch)

catch' :: forall x e ans. Catch x :? e => Eff e ans -> (x -> Eff e ans) -> Eff e ans
catch' act hdl = do
  x <- perform _bcatch ()
  case x of
    Just y -> hdl y
    Nothing -> act <* perform @(Catch x) _ecatch ()

data CatchResult x a = CatchReturn a | CatchThrow x Int deriving Functor

catchResult :: CatchResult x a -> Either x a
catchResult (CatchReturn x) = Right x
catchResult (CatchThrow x 0) = Left x
catchResult (CatchThrow _ _) = error "Mismatched catch block"

runCatch :: Eff (Catch x :* e) ans -> Eff e (Either x ans)
runCatch = fmap catchResult . handlerRet CatchReturn
  Catch
    { _bcatch = operation \_ k -> k Nothing >>= \case
      CatchReturn x -> pure (CatchReturn x)
      CatchThrow x 0 -> k (Just x)
      CatchThrow x n -> pure (CatchThrow x (n - 1))
    , _ecatch = operation \_ k -> k () <&> \case
      CatchThrow x n -> CatchThrow x (n + 1)
      x -> x
    , _throwcatch = except \x -> pure (CatchThrow x 0)
    }

tripleDecr' :: (Catch () :? e, State Int :? e) => Eff e ()
tripleDecr' = decr' *> catch' (decr' *> decr') pure

decr' :: (Catch () :? e, State Int :? e) => Eff e ()
decr' = do
  x <- get @Int
  if x > 0 then put (x - 1) else throw' ()

-- $> (runEff . runCatch . state (2 :: Int)) tripleDecr'

-- $> (runEff . state (2 :: Int) . runCatch) tripleDecr'

--------------------------------------------------------------------------------
-- Multi-threading
--------------------------------------------------------------------------------

data Thread e ans = Thread
  { _yield :: Op () () e ans
  , _fork :: Op () ThreadType e ans
  , _efork :: Op () () e ans
  }

data ThreadType = MainThread | DaemonThread

yield :: Thread :? e => Eff e ()
yield = perform _yield ()

fork :: forall e a. Thread :? e => Eff e a -> Eff e ()
fork daemon = perform _fork () >>= \case
  DaemonThread -> daemon *> perform _efork ()
  MainThread -> pure ()

data Daemon e = forall x. Daemon (Eff e (SThread e x))

data SThread e r
  = SYield (Eff e (SThread e r))
  | SFork (Daemon e) (Eff e (SThread e r))
  | SActive r

schedule :: Eff (Thread :* e) ans -> Eff e ans
schedule = main [] <=< handlerRet SActive
  Thread
    { _yield = operation \_ k -> pure (SYield (k ()))
    , _fork = operation \_ k -> pure (SFork (Daemon (k DaemonThread)) (k MainThread))
    , _efork = except \_ -> pure (SActive (error "efork in main thread"))
    }
  where
    main ds = \case
      SActive x -> pure x
      SYield p -> daemons ds [] p
      SFork d p -> daemons (d:ds) [] p
    daemons [] ds' p = main (reverse ds') =<< p
    daemons (Daemon q : ds) ds' p = q >>= \case
      SActive _ -> daemons ds ds' p
      SYield q' -> daemons ds (Daemon q' : ds') p
      SFork d' q' -> daemons (d' : ds) (Daemon q' : ds') p

-- threading in action

newtype Out e ans = Out
  { _out :: Op String () e ans
  }

out :: Out :? e => String -> Eff e ()
out = perform _out

io :: forall a . Eff (Out :* ()) a -> IO a
io = runEff . handlerRet pure
  Out { _out = operation \str k -> (putStrLn str *>) <$> k () }

prog :: (Thread :? e, State Int :? e, Out :? e) => Eff e ()
prog = do
  logIncr "main"
  fork (logIncr "daemon" *> logIncr "daemon")
  logIncr "main"

log :: (State Int :? e, Out :? e) => String -> Eff e ()
log x = do
  n <- get @Int
  out (x ++ ": " ++ show n)

logIncr :: (State Int :? e, Out :? e) => String -> Eff e ()
logIncr x = log x >> incr

-- $> (io . state (0 :: Int) . schedule) prog

-- $> (io . schedule . state (0 :: Int)) prog