The Monadic Way/Part II
Jump to navigation
Jump to search
Note: this is just the skeleton of this part, with code but very little text
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 ++ " - "
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:
> 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!.
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
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
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>
The final cut
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>
-}
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, Monads as Containers
Jeff Newbern, All About Monads
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 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!