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

{- | Writer effect.
-}

module Effects.Writer (
    Writer(..)
  , tell
  , tellM
  , handleWriter
  , handleWriterM) where

import Prog ( discharge, Member(inj), Prog(..) )
import Model ( Model(..) )

-- | Writer effect for writing to a strean @w@
data Writer w a where
  -- | Write to a stream @w@
  Tell :: w             -- ^ value to write
       -> Writer w ()

-- | Wrapper for @Tell@
tell :: Member (Writer w) es => w -> Prog es ()
tell :: forall w (es :: [* -> *]). Member (Writer w) es => w -> Prog es ()
tell w
w = EffectSum es () -> (() -> Prog es ()) -> Prog es ()
forall (es :: [* -> *]) x a.
EffectSum es x -> (x -> Prog es a) -> Prog es a
Op (Writer w () -> EffectSum es ()
forall (e :: * -> *) (es :: [* -> *]) x.
Member e es =>
e x -> EffectSum es x
inj (Writer w () -> EffectSum es ()) -> Writer w () -> EffectSum es ()
forall a b. (a -> b) -> a -> b
$ w -> Writer w ()
forall w. w -> Writer w ()
Tell w
w) () -> Prog es ()
forall a (es :: [* -> *]). a -> Prog es a
Val

-- | Wrapper for @Tell@ inside @Model@
tellM :: Member (Writer w) es => w -> Model env es ()
tellM :: forall w (es :: [* -> *]) (env :: [Assign Symbol (*)]).
Member (Writer w) es =>
w -> Model env es ()
tellM w
w = ((Member Dist es, Member (ObsReader env) es) => Prog es ())
-> Model env es ()
forall (env :: [Assign Symbol (*)]) (es :: [* -> *]) a.
((Member Dist es, Member (ObsReader env) es) => Prog es a)
-> Model env es a
Model (((Member Dist es, Member (ObsReader env) es) => Prog es ())
 -> Model env es ())
-> ((Member Dist es, Member (ObsReader env) es) => Prog es ())
-> Model env es ()
forall a b. (a -> b) -> a -> b
$ w -> Prog es ()
forall w (es :: [* -> *]). Member (Writer w) es => w -> Prog es ()
tell w
w

-- | Handle the @Writer@ effect for a stream @w@
handleWriter :: forall w es a. Monoid w
  => Prog (Writer w ': es) a
  -- | (output, final stream)
  -> Prog es (a, w)
handleWriter :: forall w (es :: [* -> *]) a.
Monoid w =>
Prog (Writer w : es) a -> Prog es (a, w)
handleWriter = w -> Prog (Writer w : es) a -> Prog es (a, w)
loop w
forall a. Monoid a => a
mempty where
  loop ::  w -> Prog (Writer w ': es) a -> Prog es (a, w)
  loop :: w -> Prog (Writer w : es) a -> Prog es (a, w)
loop w
w (Val a
x) = (a, w) -> Prog es (a, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, w
w)
  loop w
w (Op EffectSum (Writer w : es) x
u x -> Prog (Writer w : es) a
k) = case EffectSum (Writer w : es) x -> Either (EffectSum es x) (Writer w x)
forall (e :: * -> *) (es :: [* -> *]) x.
EffectSum (e : es) x -> Either (EffectSum es x) (e x)
discharge EffectSum (Writer w : es) x
u of
    Right (Tell w
w') -> w -> Prog (Writer w : es) a -> Prog es (a, w)
loop (w
w w -> w -> w
forall a. Monoid a => a -> a -> a
`mappend` w
w') (x -> Prog (Writer w : es) a
k ())
    Left EffectSum es x
u'         -> EffectSum es x -> (x -> Prog es (a, w)) -> Prog es (a, w)
forall (es :: [* -> *]) x a.
EffectSum es x -> (x -> Prog es a) -> Prog es a
Op EffectSum es x
u' (w -> Prog (Writer w : es) a -> Prog es (a, w)
loop w
w (Prog (Writer w : es) a -> Prog es (a, w))
-> (x -> Prog (Writer w : es) a) -> x -> Prog es (a, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> Prog (Writer w : es) a
k)

-- | Handle the @Writer@ effect inside a @Model@
handleWriterM :: Monoid w
  => Model env (Writer w : es) a
  -- | (output, final stream)
  -> Model env es (a, w)
handleWriterM :: forall w (env :: [Assign Symbol (*)]) (es :: [* -> *]) a.
Monoid w =>
Model env (Writer w : es) a -> Model env es (a, w)
handleWriterM Model env (Writer w : es) a
m = ((Member Dist es, Member (ObsReader env) es) => Prog es (a, w))
-> Model env es (a, w)
forall (env :: [Assign Symbol (*)]) (es :: [* -> *]) a.
((Member Dist es, Member (ObsReader env) es) => Prog es a)
-> Model env es a
Model (((Member Dist es, Member (ObsReader env) es) => Prog es (a, w))
 -> Model env es (a, w))
-> ((Member Dist es, Member (ObsReader env) es) => Prog es (a, w))
-> Model env es (a, w)
forall a b. (a -> b) -> a -> b
$ Prog (Writer w : es) a -> Prog es (a, w)
forall w (es :: [* -> *]) a.
Monoid w =>
Prog (Writer w : es) a -> Prog es (a, w)
handleWriter (Prog (Writer w : es) a -> Prog es (a, w))
-> Prog (Writer w : es) a -> Prog es (a, w)
forall a b. (a -> b) -> a -> b
$ Model env (Writer w : es) a
-> (Member Dist (Writer w : es),
    Member (ObsReader env) (Writer w : es)) =>
   Prog (Writer w : es) a
forall (env :: [Assign Symbol (*)]) (es :: [* -> *]) a.
Model env es a
-> (Member Dist es, Member (ObsReader env) es) => Prog es a
runModel Model env (Writer w : es) a
m