{-# LANGUAGE TemplateHaskell #-}

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

import Polysemy qualified as P
import Polysemy.State qualified 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 :: forall o (r :: EffectRow) a.
Monoid o =>
Sem (LocalWriter o : r) a -> Sem r (o, a)
runLocalWriter =
  o -> Sem (State o : r) a -> Sem r (o, a)
forall s (r :: EffectRow) 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 :: EffectRow) 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 :: Effect) (e2 :: Effect) (r :: EffectRow) a.
(forall (rInitial :: EffectRow) 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
o -> do
            (o -> o)
-> Sem
     (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r)) ()
forall s (r :: EffectRow).
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 x))
-> Sem
     (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r)) (f x)
forall a b.
Sem (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r)) a
-> (a
    -> Sem
         (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r)) b)
-> Sem
     (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ()
-> Sem
     (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r)) (f x)
()
-> Sem
     (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r)) (f ())
forall (f :: * -> *) a (e :: Effect) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
P.pureT
          Llisten Sem rInitial a
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 :: Effect) (f :: * -> *)
       (r :: EffectRow).
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 :: Effect) (r :: EffectRow) 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 :: EffectRow) a.
Monoid o =>
Sem (LocalWriter o : r) a -> Sem r (o, a)
runLocalWriter Sem (LocalWriter o : State o : r) (f a)
mm
            f x
-> Sem
     (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r)) (f x)
forall a.
a
-> Sem
     (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f x
 -> Sem
      (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r)) (f x))
-> f x
-> Sem
     (WithTactics (LocalWriter o) f (Sem rInitial) (State o : r)) (f x)
forall a b. (a -> b) -> a -> b
$ (a -> x) -> f a -> f x
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (o
o,) f a
fa
      )