{-# 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 (rInitial :: [(* -> *) -> * -> *]) x.
 LocalWriter o (Sem rInitial) x
 -> Tactical (LocalWriter o) (Sem rInitial) (State o : r) x)
-> Sem (LocalWriter o : r) a -> Sem (State o : r) a
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e1 (Sem rInitial) x -> Tactical e1 (Sem rInitial) (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
P.reinterpretH
  (\case
     Ltell o   -> do
       (o -> o)
-> Sem
     (WithTactics (LocalWriter o) f (Sem rInitial) (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 (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r)) ()
-> (()
    -> Sem
         (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r))
         (f ()))
-> Sem
     (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r)) (f ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ()
-> Sem
     (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r)) (f ())
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
P.pureT
     Llisten m -> do
       Sem (LocalWriter o : State o : r) (f a)
mm <- Sem rInitial a
-> Sem
     (WithTactics (LocalWriter o) f (Sem rInitial) (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 Sem rInitial a
m
       (o
o, f a
fa) <- Sem (State o : r) (o, f a)
-> Sem
     (WithTactics (LocalWriter o) f (Sem rInitial) (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
      (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r))
      (o, f a))
-> Sem (State o : r) (o, f a)
-> Sem
     (WithTactics (LocalWriter o) f (Sem rInitial) (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
     (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r))
     (f (o, a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f (o, a)
 -> Sem
      (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r))
      (f (o, a)))
-> f (o, a)
-> Sem
     (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r))
     (f (o, a))
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)