1{-# LANGUAGE CPP #-}
2{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeSynonymInstances #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE UndecidableInstances #-}
8----------------------------------------------------------------------
9-- |
10-- Module      :  Control.Monad.Representable.State
11-- Copyright   :  (c) Edward Kmett & Sjoerd Visscher 2011
12-- License     :  BSD3
13--
14-- Maintainer  :  ekmett@gmail.com
15-- Stability   :  experimental
16--
17-- A generalized State monad, parameterized by a Representable functor.
18-- The representation of that functor serves as the state.
19----------------------------------------------------------------------
20module Control.Monad.Representable.State
21   ( State
22   , runState
23   , evalState
24   , execState
25   , mapState
26   , StateT(..)
27   , stateT
28   , runStateT
29   , evalStateT
30   , execStateT
31   , mapStateT
32   , liftCallCC
33   , liftCallCC'
34   , MonadState(..)
35   ) where
36
37#if __GLASGOW_HASKELL__ < 710
38import Control.Applicative
39#endif
40import Control.Monad
41import Data.Functor.Bind
42import Data.Functor.Bind.Trans
43import Control.Monad.State.Class
44import Control.Monad.Cont.Class
45import Control.Monad.Reader.Class
46import Control.Monad.Writer.Class
47import Control.Monad.Free.Class
48import Control.Monad.Trans.Class
49import Data.Functor.Identity
50import Data.Functor.Rep
51
52-- ---------------------------------------------------------------------------
53-- | A memoized state monad parameterized by a representable functor @g@, where
54-- the representatation of @g@, @Rep g@ is the state to carry.
55--
56-- The 'return' function leaves the state unchanged, while @>>=@ uses
57-- the final state of the first computation as the initial state of
58-- the second.
59type State g = StateT g Identity
60
61
62-- | Unwrap a state monad computation as a function.
63-- (The inverse of 'state'.)
64runState :: Representable g
65         => State g a   -- ^ state-passing computation to execute
66         -> Rep g       -- ^ initial state
67         -> (a, Rep g)  -- ^ return value and final state
68runState m = runIdentity . runStateT m
69
70-- | Evaluate a state computation with the given initial state
71-- and return the final value, discarding the final state.
72--
73-- * @'evalState' m s = 'fst' ('runState' m s)@
74evalState :: Representable g
75          => State g a  -- ^state-passing computation to execute
76          -> Rep g      -- ^initial value
77          -> a          -- ^return value of the state computation
78evalState m s = fst (runState m s)
79
80-- | Evaluate a state computation with the given initial state
81-- and return the final state, discarding the final value.
82--
83-- * @'execState' m s = 'snd' ('runState' m s)@
84execState :: Representable g
85          => State g a  -- ^state-passing computation to execute
86          -> Rep g      -- ^initial value
87          -> Rep g      -- ^final state
88execState m s = snd (runState m s)
89
90-- | Map both the return value and final state of a computation using
91-- the given function.
92--
93-- * @'runState' ('mapState' f m) = f . 'runState' m@
94mapState :: Functor g => ((a, Rep g) -> (b, Rep g)) -> State g a -> State g b
95mapState f = mapStateT (Identity . f . runIdentity)
96
97-- ---------------------------------------------------------------------------
98-- | A state transformer monad parameterized by:
99--
100--   * @g@ - A representable functor used to memoize results for a state @Rep g@
101--
102--   * @m@ - The inner monad.
103--
104-- The 'return' function leaves the state unchanged, while @>>=@ uses
105-- the final state of the first computation as the initial state of
106-- the second.
107newtype StateT g m a = StateT { getStateT :: g (m (a, Rep g)) }
108
109stateT :: Representable g => (Rep g -> m (a, Rep g)) -> StateT g m a
110stateT = StateT . tabulate
111
112runStateT :: Representable g => StateT g m a -> Rep g -> m (a, Rep g)
113runStateT (StateT m) = index m
114
115mapStateT :: Functor g => (m (a, Rep g) -> n (b, Rep g)) -> StateT g m a -> StateT g n b
116mapStateT f (StateT m) = StateT (fmap f m)
117
118-- | Evaluate a state computation with the given initial state
119-- and return the final value, discarding the final state.
120--
121-- * @'evalStateT' m s = 'liftM' 'fst' ('runStateT' m s)@
122evalStateT :: (Representable g, Monad m) => StateT g m a -> Rep g -> m a
123evalStateT m s = do
124    (a, _) <- runStateT m s
125    return a
126
127-- | Evaluate a state computation with the given initial state
128-- and return the final state, discarding the final value.
129--
130-- * @'execStateT' m s = 'liftM' 'snd' ('runStateT' m s)@
131execStateT :: (Representable g, Monad m) => StateT g m a -> Rep g -> m (Rep g)
132execStateT m s = do
133    (_, s') <- runStateT m s
134    return s'
135
136instance (Functor g, Functor m) => Functor (StateT g m) where
137  fmap f = StateT . fmap (fmap (\ ~(a, s) -> (f a, s))) . getStateT
138
139instance (Representable g, Bind m) => Apply (StateT g m) where
140  mf <.> ma = mf >>- \f -> fmap f ma
141
142instance (Representable g, Functor m, Monad m) => Applicative (StateT g m) where
143  pure = StateT . leftAdjunctRep return
144  mf <*> ma = mf >>= \f -> fmap f ma
145
146instance (Representable g, Bind m) => Bind (StateT g m) where
147  StateT m >>- f = StateT $ fmap (>>- rightAdjunctRep (runStateT . f)) m
148
149instance (Representable g, Monad m) => Monad (StateT g m) where
150#if __GLASGOW_HASKELL__ < 710
151  return = StateT . leftAdjunctRep return
152#endif
153  StateT m >>= f = StateT $ fmap (>>= rightAdjunctRep (runStateT . f)) m
154
155instance Representable f => BindTrans (StateT f) where
156  liftB m = stateT $ \s -> fmap (\a -> (a, s)) m
157
158instance Representable f => MonadTrans (StateT f) where
159  lift m = stateT $ \s -> liftM (\a -> (a, s)) m
160
161instance (Representable g, Monad m, Rep g ~ s) => MonadState s (StateT g m) where
162  get = stateT $ \s -> return (s, s)
163  put s = StateT $ pureRep $ return ((),s)
164#if MIN_VERSION_transformers(0,3,0)
165  state f = stateT (return . f)
166#endif
167
168instance (Representable g, MonadReader e m) => MonadReader e (StateT g m) where
169  ask = lift ask
170  local = mapStateT . local
171
172instance (Representable g, MonadWriter w m) => MonadWriter w (StateT g m) where
173  tell = lift . tell
174  listen = mapStateT $ \ma -> do
175     ((a,s'), w) <- listen ma
176     return ((a,w), s')
177  pass = mapStateT $ \ma -> pass $ do
178    ((a, f), s') <- ma
179    return ((a, s'), f)
180
181instance (Representable g, MonadCont m) => MonadCont (StateT g m) where
182    callCC = liftCallCC' callCC
183
184instance (Functor f, Representable g, MonadFree f m) => MonadFree f (StateT g m) where
185    wrap as = stateT $ \s -> wrap (fmap (`runStateT` s) as)
186
187leftAdjunctRep :: Representable u => ((a, Rep u) -> b) -> a -> u b
188leftAdjunctRep f a = tabulate (\s -> f (a,s))
189
190rightAdjunctRep :: Representable u => (a -> u b) -> (a, Rep u) -> b
191rightAdjunctRep f ~(a, k) = f a `index` k
192
193-- | Uniform lifting of a @callCC@ operation to the new monad.
194-- This version rolls back to the original state on entering the
195-- continuation.
196liftCallCC :: Representable g => ((((a,Rep g) -> m (b,Rep g)) -> m (a,Rep g)) -> m (a,Rep g)) ->
197    ((a -> StateT g m b) -> StateT g m a) -> StateT g m a
198liftCallCC callCC' f = stateT $ \s ->
199    callCC' $ \c ->
200    runStateT (f (\a -> StateT $ pureRep $ c (a, s))) s
201
202-- | In-situ lifting of a @callCC@ operation to the new monad.
203-- This version uses the current state on entering the continuation.
204-- It does not satisfy the laws of a monad transformer.
205liftCallCC' :: Representable g => ((((a,Rep g) -> m (b,Rep g)) -> m (a,Rep g)) -> m (a,Rep g)) ->
206    ((a -> StateT g m b) -> StateT g m a) -> StateT g m a
207liftCallCC' callCC' f = stateT $ \s ->
208    callCC' $ \c ->
209    runStateT (f (\a -> stateT $ \s' -> c (a, s'))) s
210
211