RevState.hs

{-# 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 = revState $ \s -> (s, s)

------------------------------------------------------------------------------
-- | Sends a new state into the past.
revPut :: forall s r
        . Member (RevState s) r
       => Sem r s
revPut = revState $ \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 f = revState $ \s -> (f 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 =
   (`runRevStateT` s)
  . 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 =
   (`runLazyRevStateT` s)
  . runLazyRevStateInC

newtype RevStateT s m a = RevStateT { runRevStateT :: s -> m (s, a) }
  deriving (Functor)

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

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

newtype LazyRevStateT s m a = LazyRevStateT { runLazyRevStateT :: s -> m (s, a) }
  deriving (Functor)

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

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

runRevStateInC :: Member Fixpoint r
               => Sem (RevState s ': r) a
               -> RevStateT s (Sem r) a
runRevStateInC = usingSem $ \u -> RevStateT $ \s ->
  case decomp u of
    Right (Weaving (RevState f) st _ ex _) ->
      return $ (ex . (<$ st)) <$> f s
    Left g ->
      liftSem $
        weave
          (s, ())
          (uncurry runRevState)
          (Just . snd)
          g

runLazyRevStateInC :: Member Fixpoint r
                   => Sem (RevState s ': r) a
                   -> LazyRevStateT s (Sem r) a
runLazyRevStateInC = usingSem $ \u -> LazyRevStateT $ \s ->
  case decomp u of
    Right (Weaving (RevState f) st _ ex _) ->
      return $ (ex . (<$ st)) <$> f s
    Left g ->
      liftSem $
        weave
          (s, ())
          (uncurry runLazyRevState)
          (Just . snd)
          g