# The Monadic Way/Part II

### From HaskellWiki

(splitting the tutorial in two parts (file was too long for a wiki)) |
DonStewart (Talk | contribs) m (category) |

## Revision as of 00:54, 8 October 2006

**Note: this is the second part of The Monadic Way**

*Note: this is just the skeleton of this part, with code but very little text*

## Contents |

## 1 Summary of the Previous Part

> module TheMonadicWay where > data Term = Con Int > | Add Term Term > deriving (Show) > type Exception = String > type O = String > type Output = String > formatLine :: Term -> Int -> Output > formatLine t a = "eval (" ++ show t ++ ") <= " ++ show a ++ " - "

## 2 Taking Complexity Out of a Monad: Monadic Transformers

We have seen how the complexity of (>>=) was growing by adding operations to be done.

We will do the opposite: we will implement a state transformer (I copied StateT).

We will embed our monad in the StateT monad and we will start moving state and output from the inner monad (our one) to the outer monad (StateT).

### 2.1 The StateT Monad: a Monad Container

Let me introduce StateT with some useful functions:

> newtype StateT s m a = StateT {runStateT :: s -> m (a,s) } --StateT (s -> m (a,s)) > instance Monad m => Monad (StateT s m) where > return a = StateT (\s -> return (a,s)) > StateT m1 >>= k = StateT (\s -> do ~(a,s1) <- m1 s > let StateT m2 = k a > m2 s1) > -- | Execute a stateful computation, as a result we get > -- the result of the computation, and the final state. > runState :: s -> StateT s m a -> m (a,s) > runState s (StateT m) = m s > -- | Execute a stateful computation, ignoring the final state. > evalState :: Functor m => s -> StateT s m a -> m a > evalState s m = fmap fst (runState s m) > -- | Execute a stateful computation, just for the side effect. > execState :: Functor m => s -> StateT s m a -> m s > execState s m = fmap snd (runState s m) > lift :: (Monad m) => m a -> StateT s m a > lift m = StateT (\s -> do x <- m > return (x,s))

StateT is pleased to meet you!.

### 2.2 StateT as a counter, and monadic evaluator with output and exceptions

And now out monad, with state out from it:

> data MTa a = FailTa Exception > | DoneTa {unpackDoneTa :: (a,O) } > deriving (Show) > instance Monad MTa where > return a = DoneTa (a, "") > m >>= f = case m of > FailTa e -> FailTa e > DoneTa (a, x) -> case (f a) of > FailTa e1 -> FailTa e1 > DoneTa (b, y) -> DoneTa (b, x ++ y) > instance Functor MTa where > fmap _ (FailTa e) = FailTa e > fmap f (DoneTa (r,o)) = DoneTa ((f r),o) > raiseTa_SIOE :: O -> StateT Int MTa a > raiseTa_SIOE e = lift (FailTa e) > printTa_SIOE :: O -> StateT Int MTa () > printTa_SIOE x = lift (DoneTa ((), x)) > incTaState :: StateT Int MTa () > incTaState = StateT (\s -> return ((), s + 1)) > evalTa_SIOE :: Term -> StateT Int MTa Int > evalTa_SIOE (Con a) = do incTaState > printTa_SIOE (formatLine (Con a) a) > return a > evalTa_SIOE (Add t u) = do a <- evalTa_SIOE t > b <- evalTa_SIOE u > incTaState > let out = formatLine (Add t u) (a + b) > printTa_SIOE out > if (a+b) == 42 > then raiseTa_SIOE $ > out ++ "The Ultimate Answer Has Been Computed!! Now I'm tired!" > else return (a + b) > runEvalTa :: Term -> String > runEvalTa exp = case runStateT (evalTa_SIOE exp) 0 of > FailTa e -> e > DoneTa (~(r,s),o)-> "Result = " ++ show r ++ > "; Iteration = " ++ show s ++ > "; Output = " ++ o > runEvalTa1 :: Term -> String > runEvalTa1 exp = case runState 0 (evalTa_SIOE exp) of > FailTa e -> e > DoneTa ((r,s),o) -> "Result = " ++ show r ++ > "; Iteration = " ++ show s ++ > "; Output = " ++ o > runEvalTa2 :: Term -> String > runEvalTa2 exp = case evalState 0 (evalTa_SIOE exp) of > FailTa e -> e > DoneTa (r,o) -> "Result = " ++ show r ++ "; Output = " ++ o > runEvalTa3 :: Term -> String > runEvalTa3 exp = case execState 0 (evalTa_SIOE exp) of > FailTa e -> e > DoneTa (s,o) -> "Iterations = " ++ show s ++ "; Output = " ++ o

### 2.3 StateT to keep output and counter, and monadic evaluator with (only) exceptions

Now we take output away from the inner monad and place it in the outer one (StateT):

> data MTb a = FailTb Exception > | DoneTb {unpackDoneTb :: a } > deriving (Show) > type StateIO = (O,Int) > instance Monad MTb where > return a = DoneTb a > m >>= f = case m of > FailTb e -> FailTb e > DoneTb a -> f a > instance Functor MTb where > fmap _ (FailTb e) = FailTb e > fmap f (DoneTb b) = DoneTb (f b) > raiseTb_SIOE :: O -> StateT StateIO MTb a > raiseTb_SIOE e = lift (FailTb e) > printTb_SIOE :: O -> StateT StateIO MTb () > printTb_SIOE x = StateT (\(o,s) -> return ((), (o ++ x,s))) > incTbStateIO :: StateT StateIO MTb () > incTbStateIO = StateT (\(o,s) -> return ((), (o,s + 1))) > evalTb_SIOE :: Term -> StateT StateIO MTb Int > evalTb_SIOE (Con a) = do incTbStateIO > printTb_SIOE (formatLine (Con a) a) > return a > evalTb_SIOE (Add t u) = do a <- evalTb_SIOE t > b <- evalTb_SIOE u > incTbStateIO > let out = formatLine (Add t u) (a + b) > printTb_SIOE out > if (a+b) == 42 > then raiseTb_SIOE $ > out ++ "The Ultimate Answer Has Been Computed!! Now I'm tired!" > else return (a + b)

We take away complexity from >>= and put it in the function we need to use to manipulate content in our StateT monad.

These are some wrapper to the evaluator to get the result and the side-effects produced by evaluation:

> runEvalTb :: Term -> String > runEvalTb exp = case runStateT (evalTb_SIOE exp) ("",0) of > FailTb e -> e > DoneTb (r,~(o,s)) -> "Result = " ++ show r ++ > "; Iteration = " ++ show s ++ > "; Output = " ++ o > runEvalTb1 :: Term -> String > runEvalTb1 exp = case runState ("",0) (evalTb_SIOE exp) of > FailTb e -> e > DoneTb (r,~(o,s)) -> "Result = " ++ show r ++ > "; Iteration = " ++ show s ++ > "; Output = " ++ o > runEvalTb2 :: Term -> String > runEvalTb2 exp = case evalState ("",0) (evalTb_SIOE exp) of > FailTb e -> e > DoneTb r -> "Result = " ++ show r > runEvalTb3 :: Term -> String > runEvalTb3 exp = case execState ("",0) (evalTb_SIOE exp) of > FailTb e -> e > DoneTb (o,s) -> "Iterations = " ++ show s ++ > " - Output = " ++ o

### 2.4 StateT to keep output, counter and debug. The monadic evaluator is only for failable computations

And now we will keep in the inner monad only the result of the evaluation.

> data MT a = FailT Exc > | DoneT {unpackDoneT :: a } > deriving (Show) > type Exc = String > type IOstack = [Output] > newtype StateTIO = StateTIO {unPackStateTIO :: (IOstack,Exc,Int)} > deriving(Show) > instance Monad MT where > return a = DoneT a > m >>= f = case m of > FailT e -> FailT e > DoneT a -> f a > instance Functor MT where > fmap _ (FailT a) = FailT a > fmap f (DoneT a) = DoneT (f a)

Simple isn't it?

The complexity is now below:

> stopExecT_SIOE :: Output -> StateT StateTIO MT Int > stopExecT_SIOE exc = StateT (\s -> do x <- FailT exc > return (x, s)) > catchT_SIOE exc = StateT (\(StateTIO (o,e,s)) -> > return ((), StateTIO (o ,"Exception at Iteration " ++ > show s ++ ": " ++ exc ++ " - " ++ e,s))) > printT_SIOE :: Output -> StateT StateTIO MT () > printT_SIOE x = StateT (\(StateTIO (o,e,s)) -> return ((), StateTIO (x:o,e,s))) > incTstateIO :: StateT StateTIO MT () > incTstateIO = StateT (\(StateTIO (o,e,s)) -> return ((),StateTIO (o,e,s + 1))) > evalT_SIOE :: Term -> StateT StateTIO MT Int > evalT_SIOE (Con a) = do incTstateIO > printT_SIOE (formatLine (Con a) a) > return a > evalT_SIOE (Add t u) = do a <- evalT_SIOE t > b <- evalT_SIOE u > incTstateIO > let out = formatLine (Add t u) (a + b) > printT_SIOE out > case (a+b) of > 42 -> do catchT_SIOE "The Ultimate Answer Has Been Computed!! Now I'm tired!" > return (a+b) > 11 -> stopExecT_SIOE "11.... I do not like this number!" > otherwise -> return (a + b)

But now we have exceptions to stop execution and debugging output.

Some helper functions:

> runEvalT :: Term -> String > runEvalT exp = case runStateT (evalT_SIOE exp) (StateTIO ([],"",0)) of > FailT e -> e > DoneT (r,StateTIO (o,e,s)) -> "Result = " ++ show r ++ "; Iteration = " ++ show s ++ > "; Output = " ++ show o ++ " - Exceptions = " ++ e > runEvalT1 :: Term -> String > runEvalT1 exp = case runState (StateTIO ([],"",0)) (evalT_SIOE exp) of > FailT e -> e > DoneT (r,StateTIO(o,e,s)) -> "Result = " ++ show r ++ "; Iteration = " ++ show s > ++ "; Output = " ++ show o ++ " - Exceptions = " ++ e > runEvalT2 :: Term -> String > runEvalT2 exp = case evalState (StateTIO ([],"",0)) (evalT_SIOE exp) of > FailT e -> e > DoneT r -> "Result = " ++ show r > runEvalT3 :: Term -> String > runEvalT3 exp = case execState (StateTIO ([],"",0)) (evalT_SIOE exp) of > FailT e -> e > DoneT (StateTIO (o,e,s)) -> "Iterations = " ++ show s ++ > " - Output = " ++ show o ++ " - Exceptions = " ++ e > showOut :: [String] -> IO () > showOut [] = return () > showOut (a:xs) = do print a > showOut xs > runMyEval :: Term -> IO () > runMyEval exp = let StateTIO (a,b,c) = unpackDoneT $ execState (StateTIO ([],"",0)) (evalT_SIOE exp) in > showOut $ reverse a

Some tests:

*TheMonadicWay> runEvalT (Add (Con 18) (Add (Con 12) (Add (Con 10) (Con 2)))) "Result = 42; Iteration = 7; Output = [\"eval (Add (Con 18) (Add (Con 12) (Add (Con 10) (Con 2)))) <= 42 - \", \"eval (Add (Con 12) (Add (Con 10) (Con 2))) <= 24 - \", \"eval (Add (Con 10) (Con 2)) <= 12 - \", \"eval (Con 2) <= 2 - \", \"eval (Con 10) <= 10 - \", \"eval (Con 12) <= 12 - \", \"eval (Con 18) <= 18 - \"] - Exceptions = Exception at Iteration 7: The Ultimate Answer Has Been Computed!! Now I'm tired! - " *TheMonadicWay> runEvalT2 (Add (Con 18) (Add (Con 12) (Add (Con 10) (Con 2)))) "Result = 42" *TheMonadicWay> runEvalT3 (Add (Con 18) (Add (Con 12) (Add (Con 10) (Con 2)))) "Iterations = 7 - Output = [\"eval (Add (Con 18) (Add (Con 12) (Add (Con 10) (Con 2)))) <= 42 - \", \"eval (Add (Con 12) (Add (Con 10) (Con 2))) <= 24 - \", \"eval (Add (Con 10) (Con 2)) <= 12 - \", \"eval (Con 2) <= 2 - \", \"eval (Con 10) <= 10 - \", \"eval (Con 12) <= 12 - \", \"eval (Con 18) <= 18 - \"] - Exceptions = Exception at Iteration 7: The Ultimate Answer Has Been Computed!! Now I'm tired! - " *TheMonadicWay> runEvalT3 (Add (Con 1) (Add (Con 7) (Add (Con 1) (Con 2)))) "Iterations = 7 - Output = [\"eval (Add (Con 1) (Add (Con 5) (Add (Con 1) (Con 2)))) <= 9 - \", \"eval (Add (Con 5) (Add (Con 1) (Con 2))) <= 8 - \", \"eval (Add (Con 1) (Con 2)) <= 3 - \", \"eval (Con 2) <= 2 - \", \"eval (Con 1) <= 1 - \", \"eval (Con 5) <= 5 - \", \"eval (Con 1) <= 1 - \"] - Exceptions = " *TheMonadicWay> runEvalT3 (Add (Con 1) (Add (Con 7) (Add (Con 1) (Con 2)))) "11.... I do not like this number!" *TheMonadicWay> runMyEval (Add (Add (Add (Add (Con 10) (Con 2)) (Add (Con 12) (Con 3))) (Con 3)) (Con 10)) "eval (Con 10) <= 10 - " "eval (Con 2) <= 2 - " "eval (Add (Con 10) (Con 2)) <= 12 - " "eval (Con 12) <= 12 - " "eval (Con 3) <= 3 - " "eval (Add (Con 12) (Con 3)) <= 15 - " "eval (Add (Add (Con 10) (Con 2)) (Add (Con 12) (Con 3))) <= 27 - " "eval (Con 3) <= 3 - " "eval (Add (Add (Add (Con 10) (Con 2)) (Add (Con 12) (Con 3))) (Con 3)) <= 30 - " "eval (Con 10) <= 10 - " "eval (Add (Add (Add (Add (Con 10) (Con 2)) (Add (Con 12) (Con 3))) (Con 3)) (Con 10)) <= 40 - " *TheMonadicWay>

## 3 The Final Cut

### 3.1 StateT for output, counter, debug, using the Standard Library

module MyStateT where import Control.Monad.State hiding (State) data Term = Con Int | Add Term Term deriving (Show) type IOStack = [Output] type Output = String type Debug = [String] data EvalST = State {getIOS :: IOStack, getDebug :: Debug, getCount:: Int} deriving(Show) type Exception = String data MT a = Fail Exception | Done {unpackDone :: a } deriving (Show) type Eval s a = StateT s MT a instance Monad MT where return a = Done a m >>= f = case m of Fail e -> Fail e Done a -> f a instance Functor MT where fmap _ (Fail a) = Fail a fmap f (Done a) = Done (f a) emptyState = State [] [] 0 stopExecT exc = lift $ Fail exc catchT e = do st <- get let s = getCount st let es = getDebug st let o = getIOS st let exc = "Debug msg at Iteration " ++ show s ++ ": " ++ e put $ State o (exc:es) s printT :: Output -> Eval EvalST () printT o = do st <- get let s = getCount st let e = getDebug st let os = getIOS st let out = show s ++ " - " ++ o put $ State (out:os) e s incTcounter :: Eval EvalST () incTcounter = do st <- get let s = getCount st let e = getDebug st let o = getIOS st put $ State o e (s+1) evalT :: Term -> Eval EvalST Int evalT (Con a) = do incTcounter printT (formatLine (Con a) a) return a evalT (Add t u) = do a <- evalT t b <- evalT u incTcounter let out = formatLine (Add t u) (a + b) printT out case (a+b) of 42 -> do catchT "The Ultimate Answer Has Been Computed!! Now I'm tired!" return (a+b) 11 -> stopExecT "11.... I do not like this number!" otherwise -> return (a + b) formatLine :: Term -> Int -> Output formatLine t a = "eval (" ++ show t ++ ") <= " ++ show a printAll :: [String] -> IO () printAll [] = return () printAll (a:xs) = do putStrLn a printAll xs eval :: Term -> IO () eval exp = case execStateT (evalT exp) emptyState of Fail e -> putStrLn e Done (State a b c ) -> do printAll $ reverse a putStrLn $ show $ unpackDone $ evalStateT (evalT exp) emptyState case b of [] -> putStrLn $ "Iterations: " ++ show c _ -> do printAll $ reverse b putStrLn $ "Iterations: " ++ show c ---- testing functions ---- runEvalT :: Term -> String runEvalT exp = case runStateT (evalT exp) emptyState of Fail e -> e Done (r,State o e s) -> "Result = " ++ show r ++ "; Iteration = " ++ show s ++ "; Output = " ++ show o ++ " - Exceptions = " ++ show e getEvalResult :: Term -> String getEvalResult exp = case evalStateT (evalT exp) emptyState of Fail e -> e Done r -> "Result = " ++ show r getSideEffects :: Term -> String getSideEffects exp = case execStateT (evalT exp) emptyState of Fail e -> e Done (State o e s) -> "Iterations = " ++ show s ++ " - Output = " ++ show o ++ " - Exceptions = " ++ show e {- Some runs: *MyStateT> eval (Add (Add (Add (Add (Con 40) (Con 2)) (Add (Con 12) (Con 30))) (Con 3)) (Con 10)) 1 - eval (Con 40) <= 40 2 - eval (Con 2) <= 2 3 - eval (Add (Con 40) (Con 2)) <= 42 4 - eval (Con 12) <= 12 5 - eval (Con 30) <= 30 6 - eval (Add (Con 12) (Con 30)) <= 42 7 - eval (Add (Add (Con 40) (Con 2)) (Add (Con 12) (Con 30))) <= 84 8 - eval (Con 3) <= 3 9 - eval (Add (Add (Add (Con 40) (Con 2)) (Add (Con 12) (Con 30))) (Con 3)) <= 87 10 - eval (Con 10) <= 10 11 - eval (Add (Add (Add (Add (Con 40) (Con 2)) (Add (Con 12) (Con 30))) (Con 3)) (Con 10)) <= 97 97 Debug msg at Iteration 3: The Ultimate Answer Has Been Computed!! Now I'm tired! Debug msg at Iteration 6: The Ultimate Answer Has Been Computed!! Now I'm tired! Iterations: 11 *MyStateT> *MyStateT> eval (Add (Add (Add (Add (Con 10) (Con 2)) (Add (Con 12) (Con 3))) (Add (Con 5) (Con 2))) (Con 2)) 1 - eval (Con 10) <= 10 2 - eval (Con 2) <= 2 3 - eval (Add (Con 10) (Con 2)) <= 12 4 - eval (Con 12) <= 12 5 - eval (Con 3) <= 3 6 - eval (Add (Con 12) (Con 3)) <= 15 7 - eval (Add (Add (Con 10) (Con 2)) (Add (Con 12) (Con 3))) <= 27 8 - eval (Con 5) <= 5 9 - eval (Con 2) <= 2 10 - eval (Add (Con 5) (Con 2)) <= 7 11 - eval (Add (Add (Add (Con 10) (Con 2)) (Add (Con 12) (Con 3))) (Add (Con 5) (Con 2))) <= 34 12 - eval (Con 2) <= 2 13 - eval (Add (Add (Add (Add (Con 10) (Con 2)) (Add (Con 12) (Con 3))) (Add (Con 5) (Con 2))) (Con 2)) <= 36 36 Iterations: 13 *MyStateT> *MyStateT> eval (Add (Con 5) (Con 6)) 11.... I do not like this number! *MyStateT> -}

## 4 Next?

We need a parser to get a string from input and turn into something of type Term!

Let's see if we'll time for it... Fist we must complete the text above!!

## 5 Suggested Readings

Cale Gibbard, Monads as Containers

Jeff Newbern, All About Monads

You Could Have Invented Monads! (And Maybe You Already Have.) by sigfpe

## 6 Acknowledgments

Thanks to Neil Mitchell, Daniel Fisher, Bulat Ziganzhin, Brian Hulley and Udo Stenzel for the invaluable help they gave, in the haskell-cafe mailing list, in understanding this topic.

I couldn't do it without their help.

Obviously errors are totally mine. But this is a wiki so, please, correct them!

- Andrea Rossato