View source for The Monadic Way/Part II

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

==Summary of the previous part==

<div id="BasicEval">
<haskell>

> 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 ++ " - "                                                       


</haskell>


==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).

===The StateT monad: A monad container=== 
Let me introduce StateT with some useful functions:

<haskell>

> 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))

</haskell>

StateT is pleased to meet you!.

===StateT as a counter, and monadic evaluator with output and exceptions===
And now out monad, with state out from it:

<haskell>

> 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 

</haskell>

===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):

<haskell>


> 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)

</haskell>

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:

<haskell>

> 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

</haskell>

===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.

<haskell>

> 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)

</haskell>

Simple isn't it?

The complexity is now below:

<haskell>

> 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)

</haskell>

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

Some helper functions:

<haskell>

> 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

</haskell>

Some tests:
<pre>
  *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>
</pre>


==The final cut==

===StateT for output, counter, debug, using the standard library===

<haskell>
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> 
-}
</haskell>

== 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!!

==Suggested readings==

Cale Gibbard, [http://haskell.org/haskellwiki/Monads_as_Containers Monads as Containers]

Jeff Newbern, [http://haskell.org/all_about_monads/html/contmonad.html All About Monads]

[http://haskell.org/haskellwiki/IO_inside IO Inside]

[http://sigfpe.blogspot.com/2006/08/you-could-have-invented-monads-and.html You Could Have Invented Monads! (And Maybe You Already Have.) by  sigfpe]


==Acknowledgments==

Thanks to Neil Mitchell, Daniel Fisher, Bulat Ziganzhin, Brian Hulley
and Udo Stenzel for the invaluable help they gave, in the
[http://www.haskell.org/mailman/listinfo/haskell-cafe 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!

- [[User:AndreaRossato|Andrea Rossato]]

[[Category:Tutorials]]
[[Category:Monad]]