{-# LANGUAGE GADTs #-} -- Code for the article about Free and Freer state monads module FreeState where import Control.Applicative -- ------------------------------------------------------------------------ -- Standard State Monad newtype State s a = State{unState :: s -> (a,s)} instance Functor (State s) where fmap f (State m) = State \$ \s -> let (v,s') = m s in (f v,s') instance Applicative (State s) where pure x = State \$ \s -> (x,s) State f <*> State x = State \$ \s -> let (vf,s1) = f s (vx,s2) = x s1 in (vf vx, s2) instance Monad (State s) where return x = State \$ \s -> (x,s) State m >>= k = State \$ \s -> let (v,s') = m s in unState (k v) s' -- Monad operations get :: State s s get = State \$ \s -> (s,s) put :: s -> State s () put s = State \$ \_ -> ((),s) -- The intrepreter runState :: State s a -> s -> (a,s) runState = unState ts1 :: State Int Int ts1 = do put 10 x <- get return x ts1r = ((10,10) ==) \$ runState ts1 0 ts2 :: State Int Int ts2 = do put 10 x <- get put 20 y <- get return (x+y) ts2r = ((30,20) ==) \$ runState ts2 0 -- ------------------------------------------------------------------------ -- Free monad data Free f a where Pure :: a -> Free f a Impure :: f (Free f a) -> Free f a -- These instances are defined once and for all, for any Functor f instance Functor f => Functor (Free f) where fmap f (Pure x) = Pure \$ f x fmap f (Impure m) = Impure \$ fmap (fmap f) m instance Functor f => Applicative (Free f) where pure = Pure Pure f <*> m = fmap f m Impure f <*> m = Impure \$ fmap (<*> m) f instance Functor f => Monad (Free f) where return = Pure Pure a >>= k = k a Impure m >>= k = Impure (fmap (>>= k) m) -- State as a free monad type FState s = Free (State s) runFState :: FState s a -> s -> (a,s) runFState (Pure x) s = (x,s) runFState (Impure m) s = let (m',s') = unState m s in runFState m' s' -- By the very construction, and meaning of the Free monad, we can -- convert (technically, embed) the functor |f| into |Free f|. eta :: Functor f => f a -> Free f a eta = Impure . fmap Pure -- In particular, we convert the primitive operations of State getF :: FState s s getF = eta get putF :: s -> FState s () putF = eta . put -- Tests tsF1 :: FState Int Int tsF1 = do putF 10 x <- getF return x tsF1r = ((10,10) ==) \$ runFState tsF1 0 tsF2 :: FState Int Int tsF2 = do putF 10 x <- getF putF 20 y <- getF return (x+y) tsF2r = ((30,20) ==) \$ runFState tsF2 0 -- ------------------------------------------------------------------------ -- Freer monad data Lan g a where Lan :: g x -> (x -> a) -> Lan g a instance Functor (Lan g) where fmap f (Lan gx h) = Lan gx (f . h) lan :: g a -> Lan g a lan ga = Lan ga id -- The following Freer monad is not (yet) extensible and not very optimal -- Either. It is used for the sake of explanation. -- Please see the Haskell Symposium 2015 paper for the extensible and -- optimal version. data FFree g a where FPure :: a -> FFree g a FImpure :: g x -> (x -> FFree g a) -> FFree g a -- These instances are defined once and for all, for any f -- (which does not have any constraints at all) instance Functor (FFree g) where fmap f (FPure x) = FPure (f x) fmap f (FImpure u q) = FImpure u (fmap f . q) instance Applicative (FFree g) where pure = FPure FPure f <*> x = fmap f x FImpure u q <*> x = FImpure u ((<*> x) . q) instance Monad (FFree g) where return = FPure FPure x >>= k = k x FImpure u k' >>= k = FImpure u (k' >>> k) -- Kleisli composition (>>>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) f >>> g = (>>= g) . f -- By the very construction, and meaning of the Free monad, we can -- convert (technically, embed) the |f| into |FFree g|. -- Unlike Free f, |f| is not required to be a functor. -- Therefore, there is no longer fmap. -- This is the sign of improved efficiency etaF :: g a -> FFree g a etaF fa = FImpure fa FPure -- State as a freer monad type FFState s = FFree (State s) -- Compare with runFState! Actually, it looks pretty much like bind -- in the original State s monad. runFFState :: FFState s a -> s -> (a,s) runFFState (FPure x) s = (x,s) runFFState (FImpure m q) s = let (x,s') = unState m s in runFFState (q x) s' -- They are really easily defined in terms of get, put getFF :: FFState s s getFF = etaF get putFF :: s -> FFState s () putFF = etaF . put -- Tests tsFF1 :: FFState Int Int tsFF1 = do putFF 10 x <- getFF return x tsFF1r = ((10,10) ==) \$ runFFState tsFF1 0 tsFF2 :: FFState Int Int tsFF2 = do putFF 10 x <- getFF putFF 20 y <- getFF return (x+y) tsFF2r = ((30,20) ==) \$ runFFState tsFF2 0 -- ------------------------------------------------------------------------ -- Definitional interpreter for the state effect data StateEff s x where Get :: StateEff s s Put :: s -> StateEff s () type EffState s = FFree (StateEff s) getEff:: EffState s s getEff = etaF Get putEff:: s -> EffState s () putEff = etaF . Put unEffState :: StateEff s a -> (s -> (a,s)) unEffState Get s = (s,s) unEffState (Put s) _ = ((),s) -- The definitional interpreter. Compare with runFFState; the code -- is essentially the same, only with unEff instead of unState runEffState :: EffState s a -> s -> (a,s) runEffState (FPure x) s = (x,s) runEffState (FImpure m q) s = let (x,s') = unEffState m s in runEffState (q x) s' -- Tests tsEff1 :: EffState Int Int tsEff1 = do putEff 10 x <- getEff return x tsEff1r = ((10,10) ==) \$ runEffState tsEff1 0 tsEff2 :: EffState Int Int tsEff2 = do putEff 10 x <- getEff putEff 20 y <- getEff return (x+y) tsEff2r = ((30,20) ==) \$ runEffState tsEff2 0