{-# LANGUAGE TemplateHaskell #-}

-- | A Writer monad that supports local writing, reverse reader I guess?
module Calamity.Internal.LocalWriter
    ( LocalWriter(..)
    , ltell
    , llisten
    , runLocalWriter ) where

import qualified Polysemy       as P
import qualified Polysemy.State as P

data LocalWriter o m a where
  Ltell :: o -> LocalWriter o m ()
  Llisten :: m a -> LocalWriter o m (o, a)

P.makeSem ''LocalWriter

runLocalWriter :: Monoid o => P.Sem (LocalWriter o ': r) a -> P.Sem r (o, a)
runLocalWriter :: Sem (LocalWriter o : r) a -> Sem r (o, a)
runLocalWriter = o -> Sem (State o : r) a -> Sem r (o, a)
forall s (r :: [(* -> *) -> * -> *]) a.
s -> Sem (State s : r) a -> Sem r (s, a)
P.runState o
forall a. Monoid a => a
mempty (Sem (State o : r) a -> Sem r (o, a))
-> (Sem (LocalWriter o : r) a -> Sem (State o : r) a)
-> Sem (LocalWriter o : r) a
-> Sem r (o, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (m :: * -> *) x.
 LocalWriter o m x -> Tactical (LocalWriter o) m (State o : r) x)
-> Sem (LocalWriter o : r) a -> Sem (State o : r) a
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
(forall (m :: * -> *) x. e1 m x -> Tactical e1 m (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
P.reinterpretH
  (\case
     Ltell o   -> do
       (o -> o)
-> Sem (Tactics f m (LocalWriter o : State o : r) : State o : r) ()
forall s (r :: [(* -> *) -> * -> *]).
Member (State s) r =>
(s -> s) -> Sem r ()
P.modify' (o -> o -> o
forall a. Semigroup a => a -> a -> a
<> o
o) Sem (Tactics f m (LocalWriter o : State o : r) : State o : r) ()
-> (()
    -> Sem
         (Tactics f m (LocalWriter o : State o : r) : State o : r) (f ()))
-> Sem
     (Tactics f m (LocalWriter o : State o : r) : State o : r) (f ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ()
-> Sem
     (Tactics f m (LocalWriter o : State o : r) : State o : r) (f ())
forall a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]).
a -> Tactical e m r a
P.pureT
     Llisten m -> do
       Sem (LocalWriter o : State o : r) (f a)
mm <- m a
-> Sem
     (Tactics f m (LocalWriter o : State o : r) : State o : r)
     (Sem (LocalWriter o : State o : r) (f a))
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (f :: * -> *)
       (r :: [(* -> *) -> * -> *]).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
P.runT m a
m
       (o :: o
o, fa :: f a
fa) <- Sem (State o : r) (o, f a)
-> Sem
     (Tactics f m (LocalWriter o : State o : r) : State o : r) (o, f a)
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
P.raise (Sem (State o : r) (o, f a)
 -> Sem
      (Tactics f m (LocalWriter o : State o : r) : State o : r) (o, f a))
-> Sem (State o : r) (o, f a)
-> Sem
     (Tactics f m (LocalWriter o : State o : r) : State o : r) (o, f a)
forall a b. (a -> b) -> a -> b
$ Sem (LocalWriter o : State o : r) (f a)
-> Sem (State o : r) (o, f a)
forall o (r :: [(* -> *) -> * -> *]) a.
Monoid o =>
Sem (LocalWriter o : r) a -> Sem r (o, a)
runLocalWriter Sem (LocalWriter o : State o : r) (f a)
mm
       f (o, a)
-> Sem
     (Tactics f m (LocalWriter o : State o : r) : State o : r) (f x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f (o, a)
 -> Sem
      (Tactics f m (LocalWriter o : State o : r) : State o : r) (f x))
-> f (o, a)
-> Sem
     (Tactics f m (LocalWriter o : State o : r) : State o : r) (f x)
forall a b. (a -> b) -> a -> b
$ (a -> (o, a)) -> f a -> f (o, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (o
o, ) f a
fa)