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