Personal tools

The Monadic Way/Part II

From HaskellWiki

< The Monadic Way(Difference between revisions)
Jump to: navigation, search
m (Updated references to the Jeff Newbern's tutorial.)
(Next?)
 
(4 intermediate revisions by 2 users not shown)
Line 1: Line 1:
'''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''
 
''Note: this is just the skeleton of this part, with code but very little text''
   
Line 463: Line 461:
   
 
printAll :: [String] -> IO ()
 
printAll :: [String] -> IO ()
printAll [] = return ()
+
printAll = mapM_ putStrLn
printAll (a:xs) = do putStrLn a
 
printAll xs
 
   
 
eval :: Term -> IO ()
 
eval :: Term -> IO ()
Line 470: Line 468:
 
Done (State a b c )
 
Done (State a b c )
 
-> do printAll $ reverse a
 
-> do printAll $ reverse a
putStrLn $ show $ unpackDone $
+
print $ unpackDone $
 
evalStateT (evalT exp) emptyState
 
evalStateT (evalT exp) emptyState
 
case b of
 
case b of
Line 547: Line 545:
 
We need a parser to get a string from input and turn into something of type Term!
 
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!!
+
Let's see if we'll time for it... First we must complete the text above!!
   
 
==Suggested readings==
 
==Suggested readings==

Latest revision as of 14:50, 14 August 2011

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

Contents

[edit] 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 ++ " - "


[edit] 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).

[edit] 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!.

[edit] 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

[edit] 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

[edit] 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>


[edit] 3 The final cut

[edit] 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 = mapM_ putStrLn
 
eval :: Term -> IO ()
eval exp = case execStateT (evalT exp) emptyState of
             Fail e -> putStrLn e
             Done (State a b c )
                 -> do printAll $ reverse a
                       print $ 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> 
-}

[edit] 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... First we must complete the text above!!

[edit] 5 Suggested readings

Cale Gibbard, Monads as Containers

Jeff Newbern, All About Monads

IO Inside

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


[edit] 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