{-# 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  :  [email protected]
-- 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 :: forall (g :: * -> *) a.
Representable g =>
State g a -> Rep g -> (a, Rep g)
runState State g a
m = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (g :: * -> *) a. Representable g => State g a -> Rep g -> a
evalState State g a
m Rep g
s = forall a b. (a, b) -> a
fst (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 :: forall (g :: * -> *) a.
Representable g =>
State g a -> Rep g -> Rep g
execState State g a
m Rep g
s = forall a b. (a, b) -> b
snd (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 :: forall (g :: * -> *) a b.
Functor g =>
((a, Rep g) -> (b, Rep g)) -> State g a -> State g b
mapState (a, Rep g) -> (b, Rep g)
f = 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 (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Rep g) -> (b, Rep g)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 { forall (g :: * -> *) (m :: * -> *) a.
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 :: forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
(Rep g -> m (a, Rep g)) -> StateT g m a
stateT = forall (g :: * -> *) (m :: * -> *) a.
g (m (a, Rep g)) -> StateT g m a
StateT forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
StateT g m a -> Rep g -> m (a, Rep g)
runStateT (StateT g (m (a, Rep g))
m) = 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 :: 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) -> n (b, Rep g)
f (StateT g (m (a, Rep g))
m) = forall (g :: * -> *) (m :: * -> *) a.
g (m (a, Rep g)) -> StateT g m a
StateT (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 :: forall (g :: * -> *) (m :: * -> *) a.
(Representable g, Monad m) =>
StateT g m a -> Rep g -> m a
evalStateT StateT g m a
m Rep g
s = do
    (a
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
    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 :: forall (g :: * -> *) (m :: * -> *) a.
(Representable g, Monad m) =>
StateT g m a -> Rep g -> m (Rep g)
execStateT StateT g m a
m Rep g
s = do
    (a
_, Rep g
s') <- 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
    forall (m :: * -> *) a. Monad m => a -> m a
return Rep g
s'

instance (Functor g, Functor m) => Functor (StateT g m) where
  fmap :: forall a b. (a -> b) -> StateT g m a -> StateT g m b
fmap a -> b
f = forall (g :: * -> *) (m :: * -> *) a.
g (m (a, Rep g)) -> StateT g m a
StateT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <.> :: forall a b. StateT g m (a -> b) -> StateT g m a -> StateT g m b
<.> StateT g m a
ma = StateT g m (a -> b)
mf forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
>>- \a -> b
f -> 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 :: forall a. a -> StateT g m a
pure = forall (g :: * -> *) (m :: * -> *) a.
g (m (a, Rep g)) -> StateT g m a
StateT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (u :: * -> *) a b.
Representable u =>
((a, Rep u) -> b) -> a -> u b
leftAdjunctRep forall (m :: * -> *) a. Monad m => a -> m a
return
  StateT g m (a -> b)
mf <*> :: forall a b. StateT g m (a -> b) -> StateT g m a -> StateT g m b
<*> StateT g m a
ma = StateT g m (a -> b)
mf forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a -> b
f -> 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 >>- :: forall a b. StateT g m a -> (a -> StateT g m b) -> StateT g m b
>>- a -> StateT g m b
f = forall (g :: * -> *) (m :: * -> *) a.
g (m (a, Rep g)) -> StateT g m a
StateT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
>>- forall (u :: * -> *) a b.
Representable u =>
(a -> u b) -> (a, Rep u) -> b
rightAdjunctRep (forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
StateT g m a -> Rep g -> m (a, Rep g)
runStateT 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 >>= :: forall a b. StateT g m a -> (a -> StateT g m b) -> StateT g m b
>>= a -> StateT g m b
f = forall (g :: * -> *) (m :: * -> *) a.
g (m (a, Rep g)) -> StateT g m a
StateT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (u :: * -> *) a b.
Representable u =>
(a -> u b) -> (a, Rep u) -> b
rightAdjunctRep (forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
StateT g m a -> Rep g -> m (a, Rep g)
runStateT 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 :: forall (b :: * -> *) a. Bind b => b a -> StateT f b a
liftB b a
m = forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
(Rep g -> m (a, Rep g)) -> StateT g m a
stateT forall a b. (a -> b) -> a -> b
$ \Rep f
s -> 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 :: forall (m :: * -> *) a. Monad m => m a -> StateT f m a
lift m a
m = forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
(Rep g -> m (a, Rep g)) -> StateT g m a
stateT forall a b. (a -> b) -> a -> b
$ \Rep f
s -> 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 = forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
(Rep g -> m (a, Rep g)) -> StateT g m a
stateT forall a b. (a -> b) -> a -> b
$ \Rep g
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (Rep g
s, Rep g
s)
  put :: s -> StateT g m ()
put s
s = forall (g :: * -> *) (m :: * -> *) a.
g (m (a, Rep g)) -> StateT g m a
StateT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Representable f => a -> f a
pureRep forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ((),s
s)
#if MIN_VERSION_transformers(0,3,0)
  state :: forall a. (s -> (a, s)) -> StateT g m a
state s -> (a, s)
f = forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
(Rep g -> m (a, Rep g)) -> StateT g m a
stateT (forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: forall a. (e -> e) -> StateT g m a -> StateT g m a
local = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
  listen :: forall a. StateT g m a -> StateT g m (a, w)
listen = 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 forall a b. (a -> b) -> a -> b
$ \m (a, Rep g)
ma -> do
     ((a
a,Rep g
s'), w
w) <- forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen m (a, Rep g)
ma
     forall (m :: * -> *) a. Monad m => a -> m a
return ((a
a,w
w), Rep g
s')
  pass :: forall a. StateT g m (a, w -> w) -> StateT g m a
pass = 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 forall a b. (a -> b) -> a -> b
$ \m ((a, w -> w), Rep g)
ma -> forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass forall a b. (a -> b) -> a -> b
$ do
    ((a
a, w -> w
f), Rep g
s') <- m ((a, w -> w), Rep g)
ma
    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 :: forall a b. ((a -> StateT g m b) -> StateT g m a) -> StateT g m a
callCC = 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' 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 :: forall a. f (StateT g m a) -> StateT g m a
wrap f (StateT g m a)
as = forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
(Rep g -> m (a, Rep g)) -> StateT g m a
stateT forall a b. (a -> b) -> a -> b
$ \Rep g
s -> forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 :: forall (u :: * -> *) a b.
Representable u =>
((a, Rep u) -> b) -> a -> u b
leftAdjunctRep (a, Rep u) -> b
f a
a = 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 :: forall (u :: * -> *) a b.
Representable u =>
(a -> u b) -> (a, Rep u) -> b
rightAdjunctRep a -> u b
f ~(a
a, Rep u
k) = a -> u b
f a
a 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 :: 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)
callCC' (a -> StateT g m b) -> StateT g m a
f = forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
(Rep g -> m (a, Rep g)) -> StateT g m a
stateT 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' forall a b. (a -> b) -> a -> b
$ \(a, Rep g) -> m (b, Rep g)
c ->
    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 -> forall (g :: * -> *) (m :: * -> *) a.
g (m (a, Rep g)) -> StateT g m a
StateT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Representable f => a -> f a
pureRep 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' :: 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)
callCC' (a -> StateT g m b) -> StateT g m a
f = forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
(Rep g -> m (a, Rep g)) -> StateT g m a
stateT 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' forall a b. (a -> b) -> a -> b
$ \(a, Rep g) -> m (b, Rep g)
c ->
    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 -> forall (g :: * -> *) (m :: * -> *) a.
Representable g =>
(Rep g -> m (a, Rep g)) -> StateT g m a
stateT 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