#if MTL
#endif
module Control.Effect.Writer (
EffectWriter, Writer, runWriter,
tell, listen, listens, pass, censor
) where
import Control.Monad.Effect
import Control.Applicative ((<$>))
import Control.Arrow (second)
import Data.Monoid (Monoid (..))
#ifdef MTL
import qualified Control.Monad.Writer.Class as W
instance EffectWriter e es => W.MonadWriter e (Effect es) where
tell = tell
listen = listen
pass = pass
#endif
data Writer w a = Writer w a
deriving Functor
type EffectWriter w es = (Monoid w, Member (Writer w) es, w ~ WriterType es)
type family WriterType es where
WriterType (Writer w ': es) = w
WriterType (t ': es) = WriterType es
tell :: EffectWriter w es => w -> Effect es ()
tell x = send (Writer x ())
listen :: EffectWriter w es => Effect es a -> Effect es (a, w)
listen effect = do
value@(_, output) <- run effect
tell output
return value
where
run =
handle point
$ intercept bind
$ defaultRelay
listens :: EffectWriter w es => (w -> b) -> Effect es a -> Effect es (a, b)
listens f = fmap (second f) . listen
pass :: EffectWriter w es => Effect es (a, w -> w) -> Effect es a
pass effect = do
((x, f), l) <- listen effect
tell (f l)
return x
censor :: EffectWriter w es => (w -> w) -> Effect es a -> Effect es a
censor f effect = pass $ do
a <- effect
return (a, f)
runWriter :: Monoid w => Effect (Writer w ': es) a -> Effect es (a, w)
runWriter =
handle point
$ eliminate bind
$ defaultRelay
point :: Monoid w => a -> Effect es (a, w)
point x = return (x, mempty)
bind :: Monoid w => Writer w (Effect es (b, w)) -> Effect es (b, w)
bind (Writer l k) = second (mappend l) <$> k