{-# LANGUAGE RecursiveDo, TemplateHaskell #-}
module Polysemy.RevState
 ( -- * Effect
   RevState (..)

   -- * Actions
 , revState
 , revGet
 , revPut
 , revModify

   -- * Interpretations
 , runRevState
 , runLazyRevState
 ) where

import Control.Monad.Fix

import Polysemy
import Polysemy.Fixpoint
import Polysemy.Internal
import Polysemy.Internal.Union

------------------------------------------------------------------------------
-- | A 'Polysemy.State.State' effect for threading state /backwards/ instead
-- of forwards through a computation.
newtype RevState s m a where
  RevState :: (s -> (s, a)) -> RevState s m a

makeSem_ ''RevState


------------------------------------------------------------------------------
-- | Gets the state as sent from the next call to 'revState'
-- \/ 'revPut' \/ 'revModify', use it, and send a new state into the past.
revState :: forall s a r
          . Member (RevState s) r
         => (s -> (s, a))
         -> Sem r a

------------------------------------------------------------------------------
-- | Gets the state as sent from the next call to 'revState' \/ 'revPut'
-- \/ 'revModify'.
revGet :: forall s r
        . Member (RevState s) r
       => Sem r s
revGet :: Sem r s
revGet = (s -> (s, s)) -> Sem r s
forall s a (r :: EffectRow).
Member (RevState s) r =>
(s -> (s, a)) -> Sem r a
revState ((s -> (s, s)) -> Sem r s) -> (s -> (s, s)) -> Sem r s
forall a b. (a -> b) -> a -> b
$ \s
s -> (s
s, s
s)

------------------------------------------------------------------------------
-- | Sends a new state into the past.
revPut :: forall s r
        . Member (RevState s) r
       => s
       -> Sem r ()
revPut :: s -> Sem r ()
revPut s
s = (s -> (s, ())) -> Sem r ()
forall s a (r :: EffectRow).
Member (RevState s) r =>
(s -> (s, a)) -> Sem r a
revState ((s -> (s, ())) -> Sem r ()) -> (s -> (s, ())) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \s
_ -> (s
s, ())

------------------------------------------------------------------------------
-- | Gets the state as sent from the next call to 'revState'
-- \/ 'revModify' \/ 'revPut', modify it, and return it into the past.
revModify :: forall s r
           . Member (RevState s) r
          => (s -> s)
          -> Sem r ()
revModify :: (s -> s) -> Sem r ()
revModify s -> s
f = (s -> (s, ())) -> Sem r ()
forall s a (r :: EffectRow).
Member (RevState s) r =>
(s -> (s, a)) -> Sem r a
revState ((s -> (s, ())) -> Sem r ()) -> (s -> (s, ())) -> Sem r ()
forall a b. (a -> b) -> a -> b
$ \s
s -> (s -> s
f s
s, ())


------------------------------------------------------------------------------
-- | Run a 'RevState' effect with local state that is propagated /backwards/
-- through the computation, from last action to first.
runRevState :: Member Fixpoint r
            => s
            -> Sem (RevState s ': r) a
            -> Sem r (s, a)
runRevState :: s -> Sem (RevState s : r) a -> Sem r (s, a)
runRevState s
s =
   (RevStateT s (Sem r) a -> s -> Sem r (s, a)
forall s (m :: * -> *) a. RevStateT s m a -> s -> m (s, a)
`runRevStateT` s
s)
  (RevStateT s (Sem r) a -> Sem r (s, a))
-> (Sem (RevState s : r) a -> RevStateT s (Sem r) a)
-> Sem (RevState s : r) a
-> Sem r (s, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (RevState s : r) a -> RevStateT s (Sem r) a
forall (r :: EffectRow) s a.
Member Fixpoint r =>
Sem (RevState s : r) a -> RevStateT s (Sem r) a
runRevStateInC

------------------------------------------------------------------------------
-- | Run a 'RevState' effect with local state that is lazily propagated
-- /backwards/ through the computation, from last action to first.
runLazyRevState :: Member Fixpoint r
                => s
                -> Sem (RevState s ': r) a
                -> Sem r (s, a)
runLazyRevState :: s -> Sem (RevState s : r) a -> Sem r (s, a)
runLazyRevState s
s =
   (LazyRevStateT s (Sem r) a -> s -> Sem r (s, a)
forall s (m :: * -> *) a. LazyRevStateT s m a -> s -> m (s, a)
`runLazyRevStateT` s
s)
  (LazyRevStateT s (Sem r) a -> Sem r (s, a))
-> (Sem (RevState s : r) a -> LazyRevStateT s (Sem r) a)
-> Sem (RevState s : r) a
-> Sem r (s, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (RevState s : r) a -> LazyRevStateT s (Sem r) a
forall (r :: EffectRow) s a.
Member Fixpoint r =>
Sem (RevState s : r) a -> LazyRevStateT s (Sem r) a
runLazyRevStateInC

newtype RevStateT s m a = RevStateT { RevStateT s m a -> s -> m (s, a)
runRevStateT :: s -> m (s, a) }
  deriving (a -> RevStateT s m b -> RevStateT s m a
(a -> b) -> RevStateT s m a -> RevStateT s m b
(forall a b. (a -> b) -> RevStateT s m a -> RevStateT s m b)
-> (forall a b. a -> RevStateT s m b -> RevStateT s m a)
-> Functor (RevStateT s m)
forall a b. a -> RevStateT s m b -> RevStateT s m a
forall a b. (a -> b) -> RevStateT s m a -> RevStateT s m b
forall s (m :: * -> *) a b.
Functor m =>
a -> RevStateT s m b -> RevStateT s m a
forall s (m :: * -> *) a b.
Functor m =>
(a -> b) -> RevStateT s m a -> RevStateT s m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> RevStateT s m b -> RevStateT s m a
$c<$ :: forall s (m :: * -> *) a b.
Functor m =>
a -> RevStateT s m b -> RevStateT s m a
fmap :: (a -> b) -> RevStateT s m a -> RevStateT s m b
$cfmap :: forall s (m :: * -> *) a b.
Functor m =>
(a -> b) -> RevStateT s m a -> RevStateT s m b
Functor)

instance MonadFix m => Applicative (RevStateT s m) where
  pure :: a -> RevStateT s m a
pure a
a = (s -> m (s, a)) -> RevStateT s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> RevStateT s m a
RevStateT ((s -> m (s, a)) -> RevStateT s m a)
-> (s -> m (s, a)) -> RevStateT s m a
forall a b. (a -> b) -> a -> b
$ \s
s -> (s, a) -> m (s, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s
s, a
a)
  RevStateT s m (a -> b)
ff <*> :: RevStateT s m (a -> b) -> RevStateT s m a -> RevStateT s m b
<*> RevStateT s m a
fa = (s -> m (s, b)) -> RevStateT s m b
forall s (m :: * -> *) a. (s -> m (s, a)) -> RevStateT s m a
RevStateT ((s -> m (s, b)) -> RevStateT s m b)
-> (s -> m (s, b)) -> RevStateT s m b
forall a b. (a -> b) -> a -> b
$ \s
s -> do
    rec
      (s
s'', a -> b
f) <- RevStateT s m (a -> b) -> s -> m (s, a -> b)
forall s (m :: * -> *) a. RevStateT s m a -> s -> m (s, a)
runRevStateT RevStateT s m (a -> b)
ff s
s'
      (s
s',  a
a) <- RevStateT s m a -> s -> m (s, a)
forall s (m :: * -> *) a. RevStateT s m a -> s -> m (s, a)
runRevStateT RevStateT s m a
fa s
s
    (s, b) -> m (s, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (s
s'', a -> b
f a
a)
  RevStateT s m a
fa *> :: RevStateT s m a -> RevStateT s m b -> RevStateT s m b
*> RevStateT s m b
fb = RevStateT s m a
fa RevStateT s m a -> (a -> RevStateT s m b) -> RevStateT s m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
_ -> RevStateT s m b
fb

instance MonadFix m => Monad (RevStateT s m) where
  RevStateT s m a
m >>= :: RevStateT s m a -> (a -> RevStateT s m b) -> RevStateT s m b
>>= a -> RevStateT s m b
f = (s -> m (s, b)) -> RevStateT s m b
forall s (m :: * -> *) a. (s -> m (s, a)) -> RevStateT s m a
RevStateT ((s -> m (s, b)) -> RevStateT s m b)
-> (s -> m (s, b)) -> RevStateT s m b
forall a b. (a -> b) -> a -> b
$ \s
s -> do
    rec
      (s
s'', a
a) <- RevStateT s m a -> s -> m (s, a)
forall s (m :: * -> *) a. RevStateT s m a -> s -> m (s, a)
runRevStateT RevStateT s m a
m s
s'
      (s
s',  b
b) <- RevStateT s m b -> s -> m (s, b)
forall s (m :: * -> *) a. RevStateT s m a -> s -> m (s, a)
runRevStateT (a -> RevStateT s m b
f a
a) s
s
    (s, b) -> m (s, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (s
s'', b
b)

newtype LazyRevStateT s m a = LazyRevStateT { LazyRevStateT s m a -> s -> m (s, a)
runLazyRevStateT :: s -> m (s, a) }
  deriving (a -> LazyRevStateT s m b -> LazyRevStateT s m a
(a -> b) -> LazyRevStateT s m a -> LazyRevStateT s m b
(forall a b.
 (a -> b) -> LazyRevStateT s m a -> LazyRevStateT s m b)
-> (forall a b. a -> LazyRevStateT s m b -> LazyRevStateT s m a)
-> Functor (LazyRevStateT s m)
forall a b. a -> LazyRevStateT s m b -> LazyRevStateT s m a
forall a b. (a -> b) -> LazyRevStateT s m a -> LazyRevStateT s m b
forall s (m :: * -> *) a b.
Functor m =>
a -> LazyRevStateT s m b -> LazyRevStateT s m a
forall s (m :: * -> *) a b.
Functor m =>
(a -> b) -> LazyRevStateT s m a -> LazyRevStateT s m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> LazyRevStateT s m b -> LazyRevStateT s m a
$c<$ :: forall s (m :: * -> *) a b.
Functor m =>
a -> LazyRevStateT s m b -> LazyRevStateT s m a
fmap :: (a -> b) -> LazyRevStateT s m a -> LazyRevStateT s m b
$cfmap :: forall s (m :: * -> *) a b.
Functor m =>
(a -> b) -> LazyRevStateT s m a -> LazyRevStateT s m b
Functor)

instance MonadFix m => Applicative (LazyRevStateT s m) where
  pure :: a -> LazyRevStateT s m a
pure a
a = (s -> m (s, a)) -> LazyRevStateT s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> LazyRevStateT s m a
LazyRevStateT ((s -> m (s, a)) -> LazyRevStateT s m a)
-> (s -> m (s, a)) -> LazyRevStateT s m a
forall a b. (a -> b) -> a -> b
$ \s
s -> (s, a) -> m (s, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s
s, a
a)
  LazyRevStateT s m (a -> b)
ff <*> :: LazyRevStateT s m (a -> b)
-> LazyRevStateT s m a -> LazyRevStateT s m b
<*> LazyRevStateT s m a
fa = (s -> m (s, b)) -> LazyRevStateT s m b
forall s (m :: * -> *) a. (s -> m (s, a)) -> LazyRevStateT s m a
LazyRevStateT ((s -> m (s, b)) -> LazyRevStateT s m b)
-> (s -> m (s, b)) -> LazyRevStateT s m b
forall a b. (a -> b) -> a -> b
$ \s
s -> do
    rec
      ~(s
s'', a -> b
f) <- LazyRevStateT s m (a -> b) -> s -> m (s, a -> b)
forall s (m :: * -> *) a. LazyRevStateT s m a -> s -> m (s, a)
runLazyRevStateT LazyRevStateT s m (a -> b)
ff s
s'
      ~(s
s',  a
a) <- LazyRevStateT s m a -> s -> m (s, a)
forall s (m :: * -> *) a. LazyRevStateT s m a -> s -> m (s, a)
runLazyRevStateT LazyRevStateT s m a
fa s
s
    (s, b) -> m (s, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (s
s'', a -> b
f a
a)
  LazyRevStateT s m a
fa *> :: LazyRevStateT s m a -> LazyRevStateT s m b -> LazyRevStateT s m b
*> LazyRevStateT s m b
fb = LazyRevStateT s m a
fa LazyRevStateT s m a
-> (a -> LazyRevStateT s m b) -> LazyRevStateT s m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
_ -> LazyRevStateT s m b
fb

instance MonadFix m => Monad (LazyRevStateT s m) where
  LazyRevStateT s m a
m >>= :: LazyRevStateT s m a
-> (a -> LazyRevStateT s m b) -> LazyRevStateT s m b
>>= a -> LazyRevStateT s m b
f = (s -> m (s, b)) -> LazyRevStateT s m b
forall s (m :: * -> *) a. (s -> m (s, a)) -> LazyRevStateT s m a
LazyRevStateT ((s -> m (s, b)) -> LazyRevStateT s m b)
-> (s -> m (s, b)) -> LazyRevStateT s m b
forall a b. (a -> b) -> a -> b
$ \s
s -> do
    rec
      ~(s
s'', a
a) <- LazyRevStateT s m a -> s -> m (s, a)
forall s (m :: * -> *) a. LazyRevStateT s m a -> s -> m (s, a)
runLazyRevStateT LazyRevStateT s m a
m s
s'
      ~(s
s',  b
b) <- LazyRevStateT s m b -> s -> m (s, b)
forall s (m :: * -> *) a. LazyRevStateT s m a -> s -> m (s, a)
runLazyRevStateT (a -> LazyRevStateT s m b
f a
a) s
s
    (s, b) -> m (s, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (s
s'', b
b)

runRevStateInC :: Member Fixpoint r
               => Sem (RevState s ': r) a
               -> RevStateT s (Sem r) a
runRevStateInC :: Sem (RevState s : r) a -> RevStateT s (Sem r) a
runRevStateInC = (forall x.
 Union (RevState s : r) (Sem (RevState s : r)) x
 -> RevStateT s (Sem r) x)
-> Sem (RevState s : r) a -> RevStateT s (Sem r) a
forall (m :: * -> *) (r :: EffectRow) a.
Monad m =>
(forall x. Union r (Sem r) x -> m x) -> Sem r a -> m a
usingSem ((forall x.
  Union (RevState s : r) (Sem (RevState s : r)) x
  -> RevStateT s (Sem r) x)
 -> Sem (RevState s : r) a -> RevStateT s (Sem r) a)
-> (forall x.
    Union (RevState s : r) (Sem (RevState s : r)) x
    -> RevStateT s (Sem r) x)
-> Sem (RevState s : r) a
-> RevStateT s (Sem r) a
forall a b. (a -> b) -> a -> b
$ \Union (RevState s : r) (Sem (RevState s : r)) x
u -> (s -> Sem r (s, x)) -> RevStateT s (Sem r) x
forall s (m :: * -> *) a. (s -> m (s, a)) -> RevStateT s m a
RevStateT ((s -> Sem r (s, x)) -> RevStateT s (Sem r) x)
-> (s -> Sem r (s, x)) -> RevStateT s (Sem r) x
forall a b. (a -> b) -> a -> b
$ \s
s ->
  case Union (RevState s : r) (Sem (RevState s : r)) x
-> Either
     (Union r (Sem (RevState s : r)) x)
     (Weaving (RevState s) (Sem (RevState s : r)) x)
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union (RevState s : r) (Sem (RevState s : r)) x
u of
    Right (Weaving (RevState f) f ()
st forall x. f (Sem rInitial x) -> Sem (RevState s : r) (f x)
_ f a -> x
ex forall x. f x -> Maybe x
_) ->
      (s, x) -> Sem r (s, x)
forall (m :: * -> *) a. Monad m => a -> m a
return ((s, x) -> Sem r (s, x)) -> (s, x) -> Sem r (s, x)
forall a b. (a -> b) -> a -> b
$ (f a -> x
ex (f a -> x) -> (a -> f a) -> a -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f () -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
st)) (a -> x) -> (s, a) -> (s, x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s -> (s, a)
f s
s
    Left Union r (Sem (RevState s : r)) x
g ->
      Union r (Sem r) (s, x) -> Sem r (s, x)
forall (r :: EffectRow) a. Union r (Sem r) a -> Sem r a
liftSem (Union r (Sem r) (s, x) -> Sem r (s, x))
-> Union r (Sem r) (s, x) -> Sem r (s, x)
forall a b. (a -> b) -> a -> b
$
        (s, ())
-> (forall x. (s, Sem (RevState s : r) x) -> Sem r (s, x))
-> (forall x. (s, x) -> Maybe x)
-> Union r (Sem (RevState s : r)) x
-> Union r (Sem r) (s, x)
forall (s :: * -> *) (n :: * -> *) (m :: * -> *) (r :: EffectRow)
       a.
(Functor s, Functor n) =>
s ()
-> (forall x. s (m x) -> n (s x))
-> (forall x. s x -> Maybe x)
-> Union r m a
-> Union r n (s a)
weave
          (s
s, ())
          ((s -> Sem (RevState s : r) x -> Sem r (s, x))
-> (s, Sem (RevState s : r) x) -> Sem r (s, x)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry s -> Sem (RevState s : r) x -> Sem r (s, x)
forall (r :: EffectRow) s a.
Member Fixpoint r =>
s -> Sem (RevState s : r) a -> Sem r (s, a)
runRevState)
          (x -> Maybe x
forall a. a -> Maybe a
Just (x -> Maybe x) -> ((s, x) -> x) -> (s, x) -> Maybe x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s, x) -> x
forall a b. (a, b) -> b
snd)
          Union r (Sem (RevState s : r)) x
g

runLazyRevStateInC :: Member Fixpoint r
                   => Sem (RevState s ': r) a
                   -> LazyRevStateT s (Sem r) a
runLazyRevStateInC :: Sem (RevState s : r) a -> LazyRevStateT s (Sem r) a
runLazyRevStateInC = (forall x.
 Union (RevState s : r) (Sem (RevState s : r)) x
 -> LazyRevStateT s (Sem r) x)
-> Sem (RevState s : r) a -> LazyRevStateT s (Sem r) a
forall (m :: * -> *) (r :: EffectRow) a.
Monad m =>
(forall x. Union r (Sem r) x -> m x) -> Sem r a -> m a
usingSem ((forall x.
  Union (RevState s : r) (Sem (RevState s : r)) x
  -> LazyRevStateT s (Sem r) x)
 -> Sem (RevState s : r) a -> LazyRevStateT s (Sem r) a)
-> (forall x.
    Union (RevState s : r) (Sem (RevState s : r)) x
    -> LazyRevStateT s (Sem r) x)
-> Sem (RevState s : r) a
-> LazyRevStateT s (Sem r) a
forall a b. (a -> b) -> a -> b
$ \Union (RevState s : r) (Sem (RevState s : r)) x
u -> (s -> Sem r (s, x)) -> LazyRevStateT s (Sem r) x
forall s (m :: * -> *) a. (s -> m (s, a)) -> LazyRevStateT s m a
LazyRevStateT ((s -> Sem r (s, x)) -> LazyRevStateT s (Sem r) x)
-> (s -> Sem r (s, x)) -> LazyRevStateT s (Sem r) x
forall a b. (a -> b) -> a -> b
$ \s
s ->
  case Union (RevState s : r) (Sem (RevState s : r)) x
-> Either
     (Union r (Sem (RevState s : r)) x)
     (Weaving (RevState s) (Sem (RevState s : r)) x)
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union (RevState s : r) (Sem (RevState s : r)) x
u of
    Right (Weaving (RevState f) f ()
st forall x. f (Sem rInitial x) -> Sem (RevState s : r) (f x)
_ f a -> x
ex forall x. f x -> Maybe x
_) ->
      (s, x) -> Sem r (s, x)
forall (m :: * -> *) a. Monad m => a -> m a
return ((s, x) -> Sem r (s, x)) -> (s, x) -> Sem r (s, x)
forall a b. (a -> b) -> a -> b
$ (f a -> x
ex (f a -> x) -> (a -> f a) -> a -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f () -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
st)) (a -> x) -> (s, a) -> (s, x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s -> (s, a)
f s
s
    Left Union r (Sem (RevState s : r)) x
g ->
      Union r (Sem r) (s, x) -> Sem r (s, x)
forall (r :: EffectRow) a. Union r (Sem r) a -> Sem r a
liftSem (Union r (Sem r) (s, x) -> Sem r (s, x))
-> Union r (Sem r) (s, x) -> Sem r (s, x)
forall a b. (a -> b) -> a -> b
$
        (s, ())
-> (forall x. (s, Sem (RevState s : r) x) -> Sem r (s, x))
-> (forall x. (s, x) -> Maybe x)
-> Union r (Sem (RevState s : r)) x
-> Union r (Sem r) (s, x)
forall (s :: * -> *) (n :: * -> *) (m :: * -> *) (r :: EffectRow)
       a.
(Functor s, Functor n) =>
s ()
-> (forall x. s (m x) -> n (s x))
-> (forall x. s x -> Maybe x)
-> Union r m a
-> Union r n (s a)
weave
          (s
s, ())
          ((s -> Sem (RevState s : r) x -> Sem r (s, x))
-> (s, Sem (RevState s : r) x) -> Sem r (s, x)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry s -> Sem (RevState s : r) x -> Sem r (s, x)
forall (r :: EffectRow) s a.
Member Fixpoint r =>
s -> Sem (RevState s : r) a -> Sem r (s, a)
runLazyRevState)
          (x -> Maybe x
forall a. a -> Maybe a
Just (x -> Maybe x) -> ((s, x) -> x) -> (s, x) -> Maybe x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s, x) -> x
forall a b. (a, b) -> b
snd)
          Union r (Sem (RevState s : r)) x
g