Exerise P-7: Logging Monad

This extends the evaluation of a syntax tree with logging of operations.

\begin{code}
import Parsing
import Prelude hiding (log)
import Control.Monad
import Control.Monad.State
\end{code}

Abstract type of expressions.
\begin{code}
data Op             =   Plus | Times
                        deriving (Eq,Show)

data Expr           =   Const Int
                    |   Op Op  Expr Expr
                        deriving (Eq,Show)

class (Monad m) => Logger m where
 logger :: String -> m String
\end{code}

Parser for expressions.
\begin{code}
-- Version 1: Monad as a state transformer (function type)
newtype Log a = L (String -> (a, String))

instance Monad Log where
  return = returnLog
  (>>=)  = bindLog

returnLog s  = L (\ str -> (s, str))
-- here, bind only does the sequencing
bindLog (L f) g = L (\ str -> let (x,str') = f str
                                  (y,str'') = let (L g') = (g x) in g' str'
                              in (y, str'') )

runLog :: Log a -> String -> (a, String)
runLog (L f) s = f s

-- here, log does the append, modifying the state
log                 :: String -> Log String
log s               = L (\ str -> (s, str++s))

instance Logger Log where
 logger = log

-- Version 2: as above but using predefined Control.Monad.State
type Log1 a = State String a
               
log1 :: String -> Log1 String
log1 x = do
          s <- get
	  put (s++x)
          return x

runLog1 f = (evalState f "", execState f "")

-- instance Logger Log1 where
--  logger = log1

-- Version 2: Monad as a record type
newtype Log2 a = Log2 { runLog2 :: (a, String) }

returnLog2 s   = Log2 { runLog2 = (s, "") }
-- here, bind combines the buffers
bindLog2 f g   = let (x,str') = runLog2 f
                     (y,str'') = runLog2 (g x)
                 in  Log2 { runLog2 = (y, str'++str'') }

instance Monad Log2 where
  return = returnLog2
  (>>=)  = bindLog2

-- here, log only adds a string to the buffer
log2                 :: String -> Log2 String
log2 s               = Log2 { runLog2 = (s, s) }

instance Logger Log2 where
 logger = log2

-----------------------------------------------------------------------------
-- Parser
expr                :: Parser Expr
expr                =  do t <- term
                          do symbol "+"               
                             e <- expr
                             return (Op Plus t e)
                           +++ return t

term                :: Parser Expr
term                =  do f <- factor
                          do symbol "*"
                             t <- term
                             return (Op Times f t)
                           +++ return f

factor              :: Parser Expr
factor              =  do symbol "("
                          e <- expr
                          symbol ")"
                          return e
                        +++ do n <- natural
                               return (Const n)

parseExpr           :: String -> Expr
parseExpr xs        =  case (parse expr xs) of
                          [(n,[])]  -> n
                          [(_,out)] -> error ("unused input " ++ out)
                          []        -> error "invalid input"

\end{code}
\begin{code}
perform             ::  Op -> Int -> Int -> Int
perform Plus  x y   =   x + y
perform Times x y   =   x * y

-- eval                ::  (Logger m) => (String -> m String) -> Expr -> m Int
eval                ::  (Logger m) => Expr -> m Int
eval  (Const i)     =   return i
eval  (Op op e1 e2) =   do   x  <-  eval e1
                             when (op == Times) $ do { logger "*" ; return () }
                             y  <-  eval e2
                             let r  = perform op x y
                             return r
\end{code}

\begin{code}
calcWithLog    ::  String -> (Int, String)
calcWithLog s  =   runLog (eval (parseExpr s)) ""

-- calcWithLog1    ::  String -> (Int, String)
-- calcWithLog1 s  =   runLog1 (eval (parseExpr s)) ""

calcWithLog2    ::  String -> (Int, String)
calcWithLog2 s  =   runLog2 (eval (parseExpr s))

calc    ::  String -> Int
calc s  =   fst (runLog (eval (parseExpr s)) "")
\end{code}