{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
----------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Representable.State
-- Copyright   :  (c) Edward Kmett & Sjoerd Visscher 2011
-- License     :  BSD3
--
-- Maintainer  :  ekmett@gmail.com
-- Stability   :  experimental
--
-- A generalized State monad, parameterized by a Representable functor.
-- The representation of that functor serves as the state.
----------------------------------------------------------------------
module Control.Monad.Representable.State
   ( State
   , runState
   , evalState
   , execState
   , mapState
   , StateT(..)
   , stateT
   , runStateT
   , evalStateT
   , execStateT
   , mapStateT
   , liftCallCC
   , liftCallCC'
   , MonadState(..)
   ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Monad
import Data.Functor.Bind
import Data.Functor.Bind.Trans
import Control.Monad.State.Class
import Control.Monad.Cont.Class (MonadCont(..))
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class
import Control.Monad.Free.Class
import Control.Monad.Trans.Class
import Data.Functor.Identity
import Data.Functor.Rep

-- ---------------------------------------------------------------------------
-- | A memoized state monad parameterized by a representable functor @g@, where
-- the representatation of @g@, @Rep g@ is the state to carry.
--
-- The 'return' function leaves the state unchanged, while @>>=@ uses
-- the final state of the first computation as the initial state of
-- the second.
type State g = StateT g Identity


-- | Unwrap a state monad computation as a function.
-- (The inverse of 'state'.)
runState :: Representable g
         => State g a   -- ^ state-passing computation to execute
         -> Rep g       -- ^ initial state
         -> (a, Rep g)  -- ^ return value and final state
runState :: State g a -> Rep g -> (a, Rep g)
runState State g a
m = Identity (a, Rep g) -> (a, Rep g)
forall a. Identity a -> a
runIdentity (Identity (a, Rep g) -> (a, Rep g))
-> (Rep g -> Identity (a, Rep g)) -> Rep g -> (a, Rep g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State g a -> Rep g -> Identity (a, Rep g)
forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
StateT g m a -> Rep g -> m (a, Rep g)
runStateT State g a
m

-- | Evaluate a state computation with the given initial state
-- and return the final value, discarding the final state.
--
-- * @'evalState' m s = 'fst' ('runState' m s)@
evalState :: Representable g
          => State g a  -- ^state-passing computation to execute
          -> Rep g      -- ^initial value
          -> a          -- ^return value of the state computation
evalState :: State g a -> Rep g -> a
evalState State g a
m Rep g
s = (a, Rep g) -> a
forall a b. (a, b) -> a
fst (State g a -> Rep g -> (a, Rep g)
forall (g :: * -> *) a.
Representable g =>
State g a -> Rep g -> (a, Rep g)
runState State g a
m Rep g
s)

-- | Evaluate a state computation with the given initial state
-- and return the final state, discarding the final value.
--
-- * @'execState' m s = 'snd' ('runState' m s)@
execState :: Representable g
          => State g a  -- ^state-passing computation to execute
          -> Rep g      -- ^initial value
          -> Rep g      -- ^final state
execState :: State g a -> Rep g -> Rep g
execState State g a
m Rep g
s = (a, Rep g) -> Rep g
forall a b. (a, b) -> b
snd (State g a -> Rep g -> (a, Rep g)
forall (g :: * -> *) a.
Representable g =>
State g a -> Rep g -> (a, Rep g)
runState State g a
m Rep g
s)

-- | Map both the return value and final state of a computation using
-- the given function.
--
-- * @'runState' ('mapState' f m) = f . 'runState' m@
mapState :: Functor g => ((a, Rep g) -> (b, Rep g)) -> State g a -> State g b
mapState :: ((a, Rep g) -> (b, Rep g)) -> State g a -> State g b
mapState (a, Rep g) -> (b, Rep g)
f = (Identity (a, Rep g) -> Identity (b, Rep g))
-> State g a -> State g b
forall (g :: * -> *) (m :: * -> *) a (n :: * -> *) b.
Functor g =>
(m (a, Rep g) -> n (b, Rep g)) -> StateT g m a -> StateT g n b
mapStateT ((b, Rep g) -> Identity (b, Rep g)
forall a. a -> Identity a
Identity ((b, Rep g) -> Identity (b, Rep g))
-> (Identity (a, Rep g) -> (b, Rep g))
-> Identity (a, Rep g)
-> Identity (b, Rep g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Rep g) -> (b, Rep g)
f ((a, Rep g) -> (b, Rep g))
-> (Identity (a, Rep g) -> (a, Rep g))
-> Identity (a, Rep g)
-> (b, Rep g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (a, Rep g) -> (a, Rep g)
forall a. Identity a -> a
runIdentity)

-- ---------------------------------------------------------------------------
-- | A state transformer monad parameterized by:
--
--   * @g@ - A representable functor used to memoize results for a state @Rep g@
--
--   * @m@ - The inner monad.
--
-- The 'return' function leaves the state unchanged, while @>>=@ uses
-- the final state of the first computation as the initial state of
-- the second.
newtype StateT g m a = StateT { StateT g m a -> g (m (a, Rep g))
getStateT :: g (m (a, Rep g)) }

stateT :: Representable g => (Rep g -> m (a, Rep g)) -> StateT g m a
stateT :: (Rep g -> m (a, Rep g)) -> StateT g m a
stateT = g (m (a, Rep g)) -> StateT g m a
forall (g :: * -> *) (m :: * -> *) a.
g (m (a, Rep g)) -> StateT g m a
StateT (g (m (a, Rep g)) -> StateT g m a)
-> ((Rep g -> m (a, Rep g)) -> g (m (a, Rep g)))
-> (Rep g -> m (a, Rep g))
-> StateT g m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rep g -> m (a, Rep g)) -> g (m (a, Rep g))
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate

runStateT :: Representable g => StateT g m a -> Rep g -> m (a, Rep g)
runStateT :: StateT g m a -> Rep g -> m (a, Rep g)
runStateT (StateT g (m (a, Rep g))
m) = g (m (a, Rep g)) -> Rep g -> m (a, Rep g)
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index g (m (a, Rep g))
m

mapStateT :: Functor g => (m (a, Rep g) -> n (b, Rep g)) -> StateT g m a -> StateT g n b
mapStateT :: (m (a, Rep g) -> n (b, Rep g)) -> StateT g m a -> StateT g n b
mapStateT m (a, Rep g) -> n (b, Rep g)
f (StateT g (m (a, Rep g))
m) = g (n (b, Rep g)) -> StateT g n b
forall (g :: * -> *) (m :: * -> *) a.
g (m (a, Rep g)) -> StateT g m a
StateT ((m (a, Rep g) -> n (b, Rep g))
-> g (m (a, Rep g)) -> g (n (b, Rep g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m (a, Rep g) -> n (b, Rep g)
f g (m (a, Rep g))
m)

-- | Evaluate a state computation with the given initial state
-- and return the final value, discarding the final state.
--
-- * @'evalStateT' m s = 'liftM' 'fst' ('runStateT' m s)@
evalStateT :: (Representable g, Monad m) => StateT g m a -> Rep g -> m a
evalStateT :: StateT g m a -> Rep g -> m a
evalStateT StateT g m a
m Rep g
s = do
    (a
a, Rep g
_) <- StateT g m a -> Rep g -> m (a, Rep g)
forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
StateT g m a -> Rep g -> m (a, Rep g)
runStateT StateT g m a
m Rep g
s
    a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Evaluate a state computation with the given initial state
-- and return the final state, discarding the final value.
--
-- * @'execStateT' m s = 'liftM' 'snd' ('runStateT' m s)@
execStateT :: (Representable g, Monad m) => StateT g m a -> Rep g -> m (Rep g)
execStateT :: StateT g m a -> Rep g -> m (Rep g)
execStateT StateT g m a
m Rep g
s = do
    (a
_, Rep g
s') <- StateT g m a -> Rep g -> m (a, Rep g)
forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
StateT g m a -> Rep g -> m (a, Rep g)
runStateT StateT g m a
m Rep g
s
    Rep g -> m (Rep g)
forall (m :: * -> *) a. Monad m => a -> m a
return Rep g
s'

instance (Functor g, Functor m) => Functor (StateT g m) where
  fmap :: (a -> b) -> StateT g m a -> StateT g m b
fmap a -> b
f = g (m (b, Rep g)) -> StateT g m b
forall (g :: * -> *) (m :: * -> *) a.
g (m (a, Rep g)) -> StateT g m a
StateT (g (m (b, Rep g)) -> StateT g m b)
-> (StateT g m a -> g (m (b, Rep g)))
-> StateT g m a
-> StateT g m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m (a, Rep g) -> m (b, Rep g))
-> g (m (a, Rep g)) -> g (m (b, Rep g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, Rep g) -> (b, Rep g)) -> m (a, Rep g) -> m (b, Rep g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ ~(a
a, Rep g
s) -> (a -> b
f a
a, Rep g
s))) (g (m (a, Rep g)) -> g (m (b, Rep g)))
-> (StateT g m a -> g (m (a, Rep g)))
-> StateT g m a
-> g (m (b, Rep g))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT g m a -> g (m (a, Rep g))
forall (g :: * -> *) (m :: * -> *) a.
StateT g m a -> g (m (a, Rep g))
getStateT

instance (Representable g, Bind m) => Apply (StateT g m) where
  StateT g m (a -> b)
mf <.> :: StateT g m (a -> b) -> StateT g m a -> StateT g m b
<.> StateT g m a
ma = StateT g m (a -> b)
mf StateT g m (a -> b) -> ((a -> b) -> StateT g m b) -> StateT g m b
forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
>>- \a -> b
f -> (a -> b) -> StateT g m a -> StateT g m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f StateT g m a
ma

instance (Representable g, Functor m, Monad m) => Applicative (StateT g m) where
  pure :: a -> StateT g m a
pure = g (m (a, Rep g)) -> StateT g m a
forall (g :: * -> *) (m :: * -> *) a.
g (m (a, Rep g)) -> StateT g m a
StateT (g (m (a, Rep g)) -> StateT g m a)
-> (a -> g (m (a, Rep g))) -> a -> StateT g m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Rep g) -> m (a, Rep g)) -> a -> g (m (a, Rep g))
forall (u :: * -> *) a b.
Representable u =>
((a, Rep u) -> b) -> a -> u b
leftAdjunctRep (a, Rep g) -> m (a, Rep g)
forall (m :: * -> *) a. Monad m => a -> m a
return
  StateT g m (a -> b)
mf <*> :: StateT g m (a -> b) -> StateT g m a -> StateT g m b
<*> StateT g m a
ma = StateT g m (a -> b)
mf StateT g m (a -> b) -> ((a -> b) -> StateT g m b) -> StateT g m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a -> b
f -> (a -> b) -> StateT g m a -> StateT g m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f StateT g m a
ma

instance (Representable g, Bind m) => Bind (StateT g m) where
  StateT g (m (a, Rep g))
m >>- :: StateT g m a -> (a -> StateT g m b) -> StateT g m b
>>- a -> StateT g m b
f = g (m (b, Rep g)) -> StateT g m b
forall (g :: * -> *) (m :: * -> *) a.
g (m (a, Rep g)) -> StateT g m a
StateT (g (m (b, Rep g)) -> StateT g m b)
-> g (m (b, Rep g)) -> StateT g m b
forall a b. (a -> b) -> a -> b
$ (m (a, Rep g) -> m (b, Rep g))
-> g (m (a, Rep g)) -> g (m (b, Rep g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (m (a, Rep g) -> ((a, Rep g) -> m (b, Rep g)) -> m (b, Rep g)
forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
>>- (a -> Rep g -> m (b, Rep g))
-> (a, Rep ((->) (Rep g))) -> m (b, Rep g)
forall (u :: * -> *) a b.
Representable u =>
(a -> u b) -> (a, Rep u) -> b
rightAdjunctRep (StateT g m b -> Rep g -> m (b, Rep g)
forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
StateT g m a -> Rep g -> m (a, Rep g)
runStateT (StateT g m b -> Rep g -> m (b, Rep g))
-> (a -> StateT g m b) -> a -> Rep g -> m (b, Rep g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> StateT g m b
f)) g (m (a, Rep g))
m

instance (Representable g, Monad m) => Monad (StateT g m) where
#if __GLASGOW_HASKELL__ < 710
  return = StateT . leftAdjunctRep return
#endif
  StateT g (m (a, Rep g))
m >>= :: StateT g m a -> (a -> StateT g m b) -> StateT g m b
>>= a -> StateT g m b
f = g (m (b, Rep g)) -> StateT g m b
forall (g :: * -> *) (m :: * -> *) a.
g (m (a, Rep g)) -> StateT g m a
StateT (g (m (b, Rep g)) -> StateT g m b)
-> g (m (b, Rep g)) -> StateT g m b
forall a b. (a -> b) -> a -> b
$ (m (a, Rep g) -> m (b, Rep g))
-> g (m (a, Rep g)) -> g (m (b, Rep g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (m (a, Rep g) -> ((a, Rep g) -> m (b, Rep g)) -> m (b, Rep g)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> Rep g -> m (b, Rep g))
-> (a, Rep ((->) (Rep g))) -> m (b, Rep g)
forall (u :: * -> *) a b.
Representable u =>
(a -> u b) -> (a, Rep u) -> b
rightAdjunctRep (StateT g m b -> Rep g -> m (b, Rep g)
forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
StateT g m a -> Rep g -> m (a, Rep g)
runStateT (StateT g m b -> Rep g -> m (b, Rep g))
-> (a -> StateT g m b) -> a -> Rep g -> m (b, Rep g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> StateT g m b
f)) g (m (a, Rep g))
m

instance Representable f => BindTrans (StateT f) where
  liftB :: b a -> StateT f b a
liftB b a
m = (Rep f -> b (a, Rep f)) -> StateT f b a
forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
(Rep g -> m (a, Rep g)) -> StateT g m a
stateT ((Rep f -> b (a, Rep f)) -> StateT f b a)
-> (Rep f -> b (a, Rep f)) -> StateT f b a
forall a b. (a -> b) -> a -> b
$ \Rep f
s -> (a -> (a, Rep f)) -> b a -> b (a, Rep f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
a -> (a
a, Rep f
s)) b a
m

instance Representable f => MonadTrans (StateT f) where
  lift :: m a -> StateT f m a
lift m a
m = (Rep f -> m (a, Rep f)) -> StateT f m a
forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
(Rep g -> m (a, Rep g)) -> StateT g m a
stateT ((Rep f -> m (a, Rep f)) -> StateT f m a)
-> (Rep f -> m (a, Rep f)) -> StateT f m a
forall a b. (a -> b) -> a -> b
$ \Rep f
s -> (a -> (a, Rep f)) -> m a -> m (a, Rep f)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\a
a -> (a
a, Rep f
s)) m a
m

instance (Representable g, Monad m, Rep g ~ s) => MonadState s (StateT g m) where
  get :: StateT g m s
get = (Rep g -> m (s, Rep g)) -> StateT g m s
forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
(Rep g -> m (a, Rep g)) -> StateT g m a
stateT ((Rep g -> m (s, Rep g)) -> StateT g m s)
-> (Rep g -> m (s, Rep g)) -> StateT g m s
forall a b. (a -> b) -> a -> b
$ \Rep g
s -> (s, s) -> m (s, s)
forall (m :: * -> *) a. Monad m => a -> m a
return (s
Rep g
s, s
Rep g
s)
  put :: s -> StateT g m ()
put s
s = g (m ((), Rep g)) -> StateT g m ()
forall (g :: * -> *) (m :: * -> *) a.
g (m (a, Rep g)) -> StateT g m a
StateT (g (m ((), Rep g)) -> StateT g m ())
-> g (m ((), Rep g)) -> StateT g m ()
forall a b. (a -> b) -> a -> b
$ m ((), s) -> g (m ((), s))
forall (f :: * -> *) a. Representable f => a -> f a
pureRep (m ((), s) -> g (m ((), s))) -> m ((), s) -> g (m ((), s))
forall a b. (a -> b) -> a -> b
$ ((), s) -> m ((), s)
forall (m :: * -> *) a. Monad m => a -> m a
return ((),s
s)
#if MIN_VERSION_transformers(0,3,0)
  state :: (s -> (a, s)) -> StateT g m a
state s -> (a, s)
f = (Rep g -> m (a, Rep g)) -> StateT g m a
forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
(Rep g -> m (a, Rep g)) -> StateT g m a
stateT ((a, s) -> m (a, s)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, s) -> m (a, s)) -> (s -> (a, s)) -> s -> m (a, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> (a, s)
f)
#endif

instance (Representable g, MonadReader e m) => MonadReader e (StateT g m) where
  ask :: StateT g m e
ask = m e -> StateT g m e
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m e
forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: (e -> e) -> StateT g m a -> StateT g m a
local = (m (a, Rep g) -> m (a, Rep g)) -> StateT g m a -> StateT g m a
forall (g :: * -> *) (m :: * -> *) a (n :: * -> *) b.
Functor g =>
(m (a, Rep g) -> n (b, Rep g)) -> StateT g m a -> StateT g n b
mapStateT ((m (a, Rep g) -> m (a, Rep g)) -> StateT g m a -> StateT g m a)
-> ((e -> e) -> m (a, Rep g) -> m (a, Rep g))
-> (e -> e)
-> StateT g m a
-> StateT g m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> e) -> m (a, Rep g) -> m (a, Rep g)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local

instance (Representable g, MonadWriter w m) => MonadWriter w (StateT g m) where
  tell :: w -> StateT g m ()
tell = m () -> StateT g m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT g m ()) -> (w -> m ()) -> w -> StateT g m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
  listen :: StateT g m a -> StateT g m (a, w)
listen = (m (a, Rep g) -> m ((a, w), Rep g))
-> StateT g m a -> StateT g m (a, w)
forall (g :: * -> *) (m :: * -> *) a (n :: * -> *) b.
Functor g =>
(m (a, Rep g) -> n (b, Rep g)) -> StateT g m a -> StateT g n b
mapStateT ((m (a, Rep g) -> m ((a, w), Rep g))
 -> StateT g m a -> StateT g m (a, w))
-> (m (a, Rep g) -> m ((a, w), Rep g))
-> StateT g m a
-> StateT g m (a, w)
forall a b. (a -> b) -> a -> b
$ \m (a, Rep g)
ma -> do
     ((a
a,Rep g
s'), w
w) <- m (a, Rep g) -> m ((a, Rep g), w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen m (a, Rep g)
ma
     ((a, w), Rep g) -> m ((a, w), Rep g)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
a,w
w), Rep g
s')
  pass :: StateT g m (a, w -> w) -> StateT g m a
pass = (m ((a, w -> w), Rep g) -> m (a, Rep g))
-> StateT g m (a, w -> w) -> StateT g m a
forall (g :: * -> *) (m :: * -> *) a (n :: * -> *) b.
Functor g =>
(m (a, Rep g) -> n (b, Rep g)) -> StateT g m a -> StateT g n b
mapStateT ((m ((a, w -> w), Rep g) -> m (a, Rep g))
 -> StateT g m (a, w -> w) -> StateT g m a)
-> (m ((a, w -> w), Rep g) -> m (a, Rep g))
-> StateT g m (a, w -> w)
-> StateT g m a
forall a b. (a -> b) -> a -> b
$ \m ((a, w -> w), Rep g)
ma -> m ((a, Rep g), w -> w) -> m (a, Rep g)
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (m ((a, Rep g), w -> w) -> m (a, Rep g))
-> m ((a, Rep g), w -> w) -> m (a, Rep g)
forall a b. (a -> b) -> a -> b
$ do
    ((a
a, w -> w
f), Rep g
s') <- m ((a, w -> w), Rep g)
ma
    ((a, Rep g), w -> w) -> m ((a, Rep g), w -> w)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
a, Rep g
s'), w -> w
f)

instance (Representable g, MonadCont m) => MonadCont (StateT g m) where
    callCC :: ((a -> StateT g m b) -> StateT g m a) -> StateT g m a
callCC = ((((a, Rep g) -> m (b, Rep g)) -> m (a, Rep g)) -> m (a, Rep g))
-> ((a -> StateT g m b) -> StateT g m a) -> StateT g m a
forall (g :: * -> *) a (m :: * -> *) b.
Representable g =>
((((a, Rep g) -> m (b, Rep g)) -> m (a, Rep g)) -> m (a, Rep g))
-> ((a -> StateT g m b) -> StateT g m a) -> StateT g m a
liftCallCC' (((a, Rep g) -> m (b, Rep g)) -> m (a, Rep g)) -> m (a, Rep g)
forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC

instance (Functor f, Representable g, MonadFree f m) => MonadFree f (StateT g m) where
    wrap :: f (StateT g m a) -> StateT g m a
wrap f (StateT g m a)
as = (Rep g -> m (a, Rep g)) -> StateT g m a
forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
(Rep g -> m (a, Rep g)) -> StateT g m a
stateT ((Rep g -> m (a, Rep g)) -> StateT g m a)
-> (Rep g -> m (a, Rep g)) -> StateT g m a
forall a b. (a -> b) -> a -> b
$ \Rep g
s -> f (m (a, Rep g)) -> m (a, Rep g)
forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap ((StateT g m a -> m (a, Rep g))
-> f (StateT g m a) -> f (m (a, Rep g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (StateT g m a -> Rep g -> m (a, Rep g)
forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
StateT g m a -> Rep g -> m (a, Rep g)
`runStateT` Rep g
s) f (StateT g m a)
as)

leftAdjunctRep :: Representable u => ((a, Rep u) -> b) -> a -> u b
leftAdjunctRep :: ((a, Rep u) -> b) -> a -> u b
leftAdjunctRep (a, Rep u) -> b
f a
a = (Rep u -> b) -> u b
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate (\Rep u
s -> (a, Rep u) -> b
f (a
a,Rep u
s))

rightAdjunctRep :: Representable u => (a -> u b) -> (a, Rep u) -> b
rightAdjunctRep :: (a -> u b) -> (a, Rep u) -> b
rightAdjunctRep a -> u b
f ~(a
a, Rep u
k) = a -> u b
f a
a u b -> Rep u -> b
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` Rep u
k

-- | Uniform lifting of a @callCC@ operation to the new monad.
-- This version rolls back to the original state on entering the
-- continuation.
liftCallCC :: Representable g => ((((a,Rep g) -> m (b,Rep g)) -> m (a,Rep g)) -> m (a,Rep g)) ->
    ((a -> StateT g m b) -> StateT g m a) -> StateT g m a
liftCallCC :: ((((a, Rep g) -> m (b, Rep g)) -> m (a, Rep g)) -> m (a, Rep g))
-> ((a -> StateT g m b) -> StateT g m a) -> StateT g m a
liftCallCC (((a, Rep g) -> m (b, Rep g)) -> m (a, Rep g)) -> m (a, Rep g)
callCC' (a -> StateT g m b) -> StateT g m a
f = (Rep g -> m (a, Rep g)) -> StateT g m a
forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
(Rep g -> m (a, Rep g)) -> StateT g m a
stateT ((Rep g -> m (a, Rep g)) -> StateT g m a)
-> (Rep g -> m (a, Rep g)) -> StateT g m a
forall a b. (a -> b) -> a -> b
$ \Rep g
s ->
    (((a, Rep g) -> m (b, Rep g)) -> m (a, Rep g)) -> m (a, Rep g)
callCC' ((((a, Rep g) -> m (b, Rep g)) -> m (a, Rep g)) -> m (a, Rep g))
-> (((a, Rep g) -> m (b, Rep g)) -> m (a, Rep g)) -> m (a, Rep g)
forall a b. (a -> b) -> a -> b
$ \(a, Rep g) -> m (b, Rep g)
c ->
    StateT g m a -> Rep g -> m (a, Rep g)
forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
StateT g m a -> Rep g -> m (a, Rep g)
runStateT ((a -> StateT g m b) -> StateT g m a
f (\a
a -> g (m (b, Rep g)) -> StateT g m b
forall (g :: * -> *) (m :: * -> *) a.
g (m (a, Rep g)) -> StateT g m a
StateT (g (m (b, Rep g)) -> StateT g m b)
-> g (m (b, Rep g)) -> StateT g m b
forall a b. (a -> b) -> a -> b
$ m (b, Rep g) -> g (m (b, Rep g))
forall (f :: * -> *) a. Representable f => a -> f a
pureRep (m (b, Rep g) -> g (m (b, Rep g)))
-> m (b, Rep g) -> g (m (b, Rep g))
forall a b. (a -> b) -> a -> b
$ (a, Rep g) -> m (b, Rep g)
c (a
a, Rep g
s))) Rep g
s

-- | In-situ lifting of a @callCC@ operation to the new monad.
-- This version uses the current state on entering the continuation.
-- It does not satisfy the laws of a monad transformer.
liftCallCC' :: Representable g => ((((a,Rep g) -> m (b,Rep g)) -> m (a,Rep g)) -> m (a,Rep g)) ->
    ((a -> StateT g m b) -> StateT g m a) -> StateT g m a
liftCallCC' :: ((((a, Rep g) -> m (b, Rep g)) -> m (a, Rep g)) -> m (a, Rep g))
-> ((a -> StateT g m b) -> StateT g m a) -> StateT g m a
liftCallCC' (((a, Rep g) -> m (b, Rep g)) -> m (a, Rep g)) -> m (a, Rep g)
callCC' (a -> StateT g m b) -> StateT g m a
f = (Rep g -> m (a, Rep g)) -> StateT g m a
forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
(Rep g -> m (a, Rep g)) -> StateT g m a
stateT ((Rep g -> m (a, Rep g)) -> StateT g m a)
-> (Rep g -> m (a, Rep g)) -> StateT g m a
forall a b. (a -> b) -> a -> b
$ \Rep g
s ->
    (((a, Rep g) -> m (b, Rep g)) -> m (a, Rep g)) -> m (a, Rep g)
callCC' ((((a, Rep g) -> m (b, Rep g)) -> m (a, Rep g)) -> m (a, Rep g))
-> (((a, Rep g) -> m (b, Rep g)) -> m (a, Rep g)) -> m (a, Rep g)
forall a b. (a -> b) -> a -> b
$ \(a, Rep g) -> m (b, Rep g)
c ->
    StateT g m a -> Rep g -> m (a, Rep g)
forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
StateT g m a -> Rep g -> m (a, Rep g)
runStateT ((a -> StateT g m b) -> StateT g m a
f (\a
a -> (Rep g -> m (b, Rep g)) -> StateT g m b
forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
(Rep g -> m (a, Rep g)) -> StateT g m a
stateT ((Rep g -> m (b, Rep g)) -> StateT g m b)
-> (Rep g -> m (b, Rep g)) -> StateT g m b
forall a b. (a -> b) -> a -> b
$ \Rep g
s' -> (a, Rep g) -> m (b, Rep g)
c (a
a, Rep g
s'))) Rep g
s