module Control.Effect.Writer.Strict
  ( module Control.Effect.Writer
  , runWriter
  , evalWriter
  , execWriter
  ) where

import Control.Category ((>>>))
import Control.Effect.Base
import Control.Effect.State.Strict
import Control.Effect.Writer
import Data.Function

-- | Handles a @'Writer'@ effect, strictly accumulating the monoidal state.
--
-- Note that the state will be accumulated via __left-associated__ uses of '<>'.
-- This is necessary to be strict, but it can be catastrophically slow on
-- certain monoids, most notably @[]@. To avoid pathological performance, use a
-- data structure that supports efficient appends, such as @Data.Sequence.Seq@,
-- or use 'Data.Semigroup.Dual' to flip the argument order of '<>' (but beware
-- that this will cause the elements to be accumulated in reverse order).
runWriter :: Monoid w => Eff (Writer w ': effs) a -> Eff effs (w, a)
runWriter :: Eff (Writer w : effs) a -> Eff effs (w, a)
runWriter (Eff (Writer w : effs) a
m0 :: Eff (Writer w ': effs) a) = Eff (Writer w : effs) a -> Eff (Writer w : State w : effs) a
forall (effs1 :: [(* -> *) -> * -> *])
       (effs2 :: [(* -> *) -> * -> *]) a.
Lift effs1 effs2 =>
Eff effs1 a -> Eff effs2 a
lift Eff (Writer w : effs) a
m0
  Eff (Writer w : State w : effs) a
-> (Eff (Writer w : State w : effs) a -> Eff (State w : effs) a)
-> Eff (State w : effs) a
forall a b. a -> (a -> b) -> b
& (a -> Eff (State w : effs) a)
-> (forall (effs' :: [(* -> *) -> * -> *]) b.
    (Writer w :< effs') =>
    Writer w (Eff effs') b
    -> Handle (Writer w) (State w : effs) a a effs' b)
-> Eff (Writer w : State w : effs) a
-> Eff (State w : effs) a
forall (eff :: (* -> *) -> * -> *) a r
       (effs :: [(* -> *) -> * -> *]).
(a -> Eff effs r)
-> (forall (effs' :: [(* -> *) -> * -> *]) b.
    (eff :< effs') =>
    eff (Eff effs') b -> Handle eff effs a r effs' b)
-> Eff (eff : effs) a
-> Eff effs r
handle a -> Eff (State w : effs) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure \case
      Tell w -> Eff (Writer w : State w : effs) ()
-> Handle (Writer w) (State w : effs) a a effs' ()
forall (eff :: (* -> *) -> * -> *) (effs :: [(* -> *) -> * -> *]) a
       i r (effs' :: [(* -> *) -> * -> *]).
Eff (eff : effs) a -> Handle eff effs i r effs' a
liftH (Eff (Writer w : State w : effs) ()
 -> Handle (Writer w) (State w : effs) a a effs' ())
-> Eff (Writer w : State w : effs) ()
-> Handle (Writer w) (State w : effs) a a effs' ()
forall a b. (a -> b) -> a -> b
$ w -> Eff (Writer w : State w : effs) ()
forall (effs' :: [(* -> *) -> * -> *]).
(State w :< effs') =>
w -> Eff effs' ()
tellS w
w
      Listen m -> Eff effs (w, a)
-> Handle (Writer w) (State w : effs) a a effs (w, a)
forall (effs' :: [(* -> *) -> * -> *]) a
       (eff :: (* -> *) -> * -> *) (effs :: [(* -> *) -> * -> *]) i r.
Eff effs' a -> Handle eff effs i r effs' a
locally (Eff effs (w, a)
 -> Handle (Writer w) (State w : effs) a a effs (w, a))
-> Eff effs (w, a)
-> Handle (Writer w) (State w : effs) a a effs (w, a)
forall a b. (a -> b) -> a -> b
$ Eff (Writer w : effs) a -> Eff effs (w, a)
forall (effs' :: [(* -> *) -> * -> *]) b.
(Writer w :< effs') =>
Eff (Writer w : effs') b -> Eff effs' (w, b)
runListen Eff (Writer w : effs) a
m
      Censor f m -> Eff effs b -> Handle (Writer w) (State w : effs) a a effs b
forall (effs' :: [(* -> *) -> * -> *]) a
       (eff :: (* -> *) -> * -> *) (effs :: [(* -> *) -> * -> *]) i r.
Eff effs' a -> Handle eff effs i r effs' a
locally (Eff effs b -> Handle (Writer w) (State w : effs) a a effs b)
-> Eff effs b -> Handle (Writer w) (State w : effs) a a effs b
forall a b. (a -> b) -> a -> b
$ (w -> w) -> Eff (Writer w : effs) b -> Eff effs b
forall (effs' :: [(* -> *) -> * -> *]) b.
(Writer w :< effs') =>
(w -> w) -> Eff (Writer w : effs') b -> Eff effs' b
runCensor w -> w
f Eff (Writer w : effs) b
m
  Eff (State w : effs) a
-> (Eff (State w : effs) a -> Eff effs (w, a)) -> Eff effs (w, a)
forall a b. a -> (a -> b) -> b
& w -> Eff (State w : effs) a -> Eff effs (w, a)
forall s (effs :: [(* -> *) -> * -> *]) a.
s -> Eff (State s : effs) a -> Eff effs (s, a)
runState w
forall a. Monoid a => a
mempty
  where
    tellS :: State w :< effs' => w -> Eff effs' ()
    tellS :: w -> Eff effs' ()
tellS w
w = Eff effs' w
forall s (effs :: [(* -> *) -> * -> *]).
(State s :< effs) =>
Eff effs s
get Eff effs' w -> (w -> Eff effs' ()) -> Eff effs' ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \w
ws -> w -> Eff effs' ()
forall s (effs :: [(* -> *) -> * -> *]).
(State s :< effs) =>
s -> Eff effs ()
put (w -> Eff effs' ()) -> w -> Eff effs' ()
forall a b. (a -> b) -> a -> b
$! (w
ws w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
w)

    runListen :: Writer w :< effs' => Eff (Writer w ': effs') b -> Eff effs' (w, b)
    runListen :: Eff (Writer w : effs') b -> Eff effs' (w, b)
runListen = Eff (Writer w : effs') b -> Eff (Writer w : State w : effs') b
forall (effs1 :: [(* -> *) -> * -> *])
       (effs2 :: [(* -> *) -> * -> *]) a.
Lift effs1 effs2 =>
Eff effs1 a -> Eff effs2 a
lift
      (Eff (Writer w : effs') b -> Eff (Writer w : State w : effs') b)
-> (Eff (Writer w : State w : effs') b -> Eff effs' (w, b))
-> Eff (Writer w : effs') b
-> Eff effs' (w, b)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (b -> Eff (State w : effs') b)
-> (forall (effs' :: [(* -> *) -> * -> *]) b.
    (Writer w :< effs') =>
    Writer w (Eff effs') b
    -> Handle (Writer w) (State w : effs') b b effs' b)
-> Eff (Writer w : State w : effs') b
-> Eff (State w : effs') b
forall (eff :: (* -> *) -> * -> *) a r
       (effs :: [(* -> *) -> * -> *]).
(a -> Eff effs r)
-> (forall (effs' :: [(* -> *) -> * -> *]) b.
    (eff :< effs') =>
    eff (Eff effs') b -> Handle eff effs a r effs' b)
-> Eff (eff : effs) a
-> Eff effs r
handle b -> Eff (State w : effs') b
forall (f :: * -> *) a. Applicative f => a -> f a
pure \case
            Tell w -> Eff (Writer w : State w : effs') ()
-> Handle (Writer w) (State w : effs') b b effs' ()
forall (eff :: (* -> *) -> * -> *) (effs :: [(* -> *) -> * -> *]) a
       i r (effs' :: [(* -> *) -> * -> *]).
Eff (eff : effs) a -> Handle eff effs i r effs' a
liftH do
              w -> Eff (Writer w : State w : effs') ()
forall (effs' :: [(* -> *) -> * -> *]).
(State w :< effs') =>
w -> Eff effs' ()
tellS w
w
              Eff (State w : effs') () -> Eff (Writer w : State w : effs') ()
forall (eff :: (* -> *) -> * -> *) (effs :: [(* -> *) -> * -> *])
       a.
Eff effs a -> Eff (eff : effs) a
lift1 (Eff (State w : effs') () -> Eff (Writer w : State w : effs') ())
-> Eff (State w : effs') () -> Eff (Writer w : State w : effs') ()
forall a b. (a -> b) -> a -> b
$ w -> Eff (State w : effs') ()
forall w (effs :: [(* -> *) -> * -> *]).
(Writer w :< effs) =>
w -> Eff effs ()
tell w
w
            Listen m -> Eff effs (w, a)
-> Handle (Writer w) (State w : effs') b b effs (w, a)
forall (effs' :: [(* -> *) -> * -> *]) a
       (eff :: (* -> *) -> * -> *) (effs :: [(* -> *) -> * -> *]) i r.
Eff effs' a -> Handle eff effs i r effs' a
locally (Eff effs (w, a)
 -> Handle (Writer w) (State w : effs') b b effs (w, a))
-> Eff effs (w, a)
-> Handle (Writer w) (State w : effs') b b effs (w, a)
forall a b. (a -> b) -> a -> b
$ Eff (Writer w : effs) a -> Eff effs (w, a)
forall (effs' :: [(* -> *) -> * -> *]) b.
(Writer w :< effs') =>
Eff (Writer w : effs') b -> Eff effs' (w, b)
runListen Eff (Writer w : effs) a
m
            Censor f m -> Eff effs b -> Handle (Writer w) (State w : effs') b b effs b
forall (effs' :: [(* -> *) -> * -> *]) a
       (eff :: (* -> *) -> * -> *) (effs :: [(* -> *) -> * -> *]) i r.
Eff effs' a -> Handle eff effs i r effs' a
locally (Eff effs b -> Handle (Writer w) (State w : effs') b b effs b)
-> Eff effs b -> Handle (Writer w) (State w : effs') b b effs b
forall a b. (a -> b) -> a -> b
$ (w -> w) -> Eff (Writer w : effs) b -> Eff effs b
forall (effs' :: [(* -> *) -> * -> *]) b.
(Writer w :< effs') =>
(w -> w) -> Eff (Writer w : effs') b -> Eff effs' b
runCensor w -> w
f Eff (Writer w : effs) b
m
      (Eff (Writer w : State w : effs') b -> Eff (State w : effs') b)
-> (Eff (State w : effs') b -> Eff effs' (w, b))
-> Eff (Writer w : State w : effs') b
-> Eff effs' (w, b)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> w -> Eff (State w : effs') b -> Eff effs' (w, b)
forall s (effs :: [(* -> *) -> * -> *]) a.
s -> Eff (State s : effs) a -> Eff effs (s, a)
runState w
forall a. Monoid a => a
mempty

    runCensor :: Writer w :< effs' => (w -> w) -> Eff (Writer w ': effs') b -> Eff effs' b
    runCensor :: (w -> w) -> Eff (Writer w : effs') b -> Eff effs' b
runCensor w -> w
f = (b -> Eff effs' b)
-> (forall (effs' :: [(* -> *) -> * -> *]) b.
    (Writer w :< effs') =>
    Writer w (Eff effs') b -> Handle (Writer w) effs' b b effs' b)
-> Eff (Writer w : effs') b
-> Eff effs' b
forall (eff :: (* -> *) -> * -> *) a r
       (effs :: [(* -> *) -> * -> *]).
(a -> Eff effs r)
-> (forall (effs' :: [(* -> *) -> * -> *]) b.
    (eff :< effs') =>
    eff (Eff effs') b -> Handle eff effs a r effs' b)
-> Eff (eff : effs) a
-> Eff effs r
handle b -> Eff effs' b
forall (f :: * -> *) a. Applicative f => a -> f a
pure \case
      Tell w -> Eff (Writer w : effs') () -> Handle (Writer w) effs' b b effs' ()
forall (eff :: (* -> *) -> * -> *) (effs :: [(* -> *) -> * -> *]) a
       i r (effs' :: [(* -> *) -> * -> *]).
Eff (eff : effs) a -> Handle eff effs i r effs' a
liftH (Eff (Writer w : effs') () -> Handle (Writer w) effs' b b effs' ())
-> Eff (Writer w : effs') ()
-> Handle (Writer w) effs' b b effs' ()
forall a b. (a -> b) -> a -> b
$ Eff effs' () -> Eff (Writer w : effs') ()
forall (eff :: (* -> *) -> * -> *) (effs :: [(* -> *) -> * -> *])
       a.
Eff effs a -> Eff (eff : effs) a
lift1 (w -> Eff effs' ()
forall w (effs :: [(* -> *) -> * -> *]).
(Writer w :< effs) =>
w -> Eff effs ()
tell (w -> Eff effs' ()) -> w -> Eff effs' ()
forall a b. (a -> b) -> a -> b
$! w -> w
f w
w)
      Listen m -> Eff effs (w, a) -> Handle (Writer w) effs' b b effs (w, a)
forall (effs' :: [(* -> *) -> * -> *]) a
       (eff :: (* -> *) -> * -> *) (effs :: [(* -> *) -> * -> *]) i r.
Eff effs' a -> Handle eff effs i r effs' a
locally (Eff effs (w, a) -> Handle (Writer w) effs' b b effs (w, a))
-> Eff effs (w, a) -> Handle (Writer w) effs' b b effs (w, a)
forall a b. (a -> b) -> a -> b
$ Eff (Writer w : effs) a -> Eff effs (w, a)
forall (effs' :: [(* -> *) -> * -> *]) b.
(Writer w :< effs') =>
Eff (Writer w : effs') b -> Eff effs' (w, b)
runListen Eff (Writer w : effs) a
m
      Censor g m -> Eff effs b -> Handle (Writer w) effs' b b effs b
forall (effs' :: [(* -> *) -> * -> *]) a
       (eff :: (* -> *) -> * -> *) (effs :: [(* -> *) -> * -> *]) i r.
Eff effs' a -> Handle eff effs i r effs' a
locally (Eff effs b -> Handle (Writer w) effs' b b effs b)
-> Eff effs b -> Handle (Writer w) effs' b b effs b
forall a b. (a -> b) -> a -> b
$ (w -> w) -> Eff (Writer w : effs) b -> Eff effs b
forall (effs' :: [(* -> *) -> * -> *]) b.
(Writer w :< effs') =>
(w -> w) -> Eff (Writer w : effs') b -> Eff effs' b
runCensor w -> w
g Eff (Writer w : effs) b
m

evalWriter :: Monoid w => Eff (Writer w ': effs) a -> Eff effs a
evalWriter :: Eff (Writer w : effs) a -> Eff effs a
evalWriter = ((w, a) -> a) -> Eff effs (w, a) -> Eff effs a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (w, a) -> a
forall a b. (a, b) -> b
snd (Eff effs (w, a) -> Eff effs a)
-> (Eff (Writer w : effs) a -> Eff effs (w, a))
-> Eff (Writer w : effs) a
-> Eff effs a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff (Writer w : effs) a -> Eff effs (w, a)
forall w (effs :: [(* -> *) -> * -> *]) a.
Monoid w =>
Eff (Writer w : effs) a -> Eff effs (w, a)
runWriter

execWriter :: Monoid w => Eff (Writer w ': effs) a -> Eff effs w
execWriter :: Eff (Writer w : effs) a -> Eff effs w
execWriter = ((w, a) -> w) -> Eff effs (w, a) -> Eff effs w
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (w, a) -> w
forall a b. (a, b) -> a
fst (Eff effs (w, a) -> Eff effs w)
-> (Eff (Writer w : effs) a -> Eff effs (w, a))
-> Eff (Writer w : effs) a
-> Eff effs w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff (Writer w : effs) a -> Eff effs (w, a)
forall w (effs :: [(* -> *) -> * -> *]) a.
Monoid w =>
Eff (Writer w : effs) a -> Eff effs (w, a)
runWriter