Kapitel 6: Programmiertechniken

hugs MEval
ghc -c MEval.lhs

> module MEval
> where

< return                        :: a -> M a
< (>>=)                         :: M a -> (a -> M b) -> M b

< (>>)                          :: M a -> M b -> M b
< m >> n                        =  m >>= \_ -> n

< class  Monad m  where
<     (>>=)                     :: m a -> (a -> m b) -> m b
<     (>>)                      :: m a -> m b -> m b
<     return                    :: a -> m a
<     fail                      :: String -> m a
< 
<     m >> k                    =  m >>= \_ -> k
<     fail s                    =  error s


Gesetze.

< return a >>= k		=  k a
< m >>= return			=  m
< m >>= (\a -> k a >>= h)	=  (m >>= k) >>= h

Auswerter.

> data Term                     =  Con Integer
>                               |  Bin Term Op Term
>                                  deriving (Eq, Show)

> data Op                       =  Add | Sub | Mul | Div
>                                  deriving (Eq, Show)

> aterm				:: Term
> aterm				=  Bin (Bin (Con 11) Add (Con 23)) Mul (Con 47)

> sys				:: Op -> (Integer -> Integer -> Integer)
> sys Add                       =  (+)
> sys Sub                       =  (-)
> sys Mul                       =  (*)
> sys Div                       =  div

Der Ausgangspunkt.

> eval                          :: Term -> Id Integer
> eval (Con n)                  =  return n
> eval (Bin t op u)             =  eval t                       >>= \ v ->
>                                  eval u                       >>= \ w ->
>                                  return (sys op v w)

eval aterm

Identitätsmonade.

> newtype Id a                  =  Id a
>				   deriving (Show)

> instance Monad Id where
>     return a                  =  Id a
>     Id a >>= f		=  f a

Erweiterung 1: Fehlerbehandlung.

> eval1                         :: Term -> Exception Integer
> eval1 (Con n)                 =  return n
> eval1 (Bin t op u)            =  eval1 t                       >>= \ v ->
>                                  eval1 u                       >>= \ w ->
>                                  if (op == Div && w == 0) then
>                                     raise "div by zero"
>                                  else
>                                     return (sys op v w)

eval1 aterm

Fehlermonade.

> data Exception a              =  Raise String | Return a
>				   deriving (Show)

> instance Monad Exception where
>     return a                  =  Return a
>     m >>= f                   =  case m of Raise  s -> Raise s
>                                            Return v -> f v

> raise				=  Raise

> eval'                         :: Term -> Exception Integer
> eval' (Con n)                 =  return n
> eval' (Bin t op u)            =  do { v <- eval' t;
>                                       w <- eval' u;
>                                       if (op == Div && w == 0) then
>                                          raise "div by zero"
>                                       else
>                                          return (sys op v w) }

Erweiterung 2: Zähler.

> eval2                         :: Term -> Count Integer
> eval2 (Con n)                 =  return n
> eval2 (Bin t op u)            =  eval2 t                       >>= \ v ->
>                                  eval2 u                       >>= \ w ->
>                                  incr                         >>
>                                  return (sys op v w)
>

apply (eval2 aterm) 0

Zustandsmonade.

> newtype Count a               =  Count (Int -> (a, Int))
> apply (Count f) i             =  f i

> instance Monad Count where
>     return a                  =  Count (\ i -> (a, i))
>     m >>= f                   =  Count (\ i -> let (a, j) = apply m i
>                                                in  apply (f a) j)

> incr                          :: Count ()
> incr                          =  Count (\ i -> ((), i + 1))

Erweiterung 3: Protokoll der durchgeführten Operationen.

> eval3                         :: Term -> Trace Integer
> eval3 e@(Con n)               =  output (trace e n)           >>
>                                  return n
> eval3 e@(Bin t op u)          =  eval3 t                       >>= \v ->
>                                  eval3 u                       >>= \w ->
>                                  let r = sys op v w           in
>                                  output (trace e r)           >>
>                                  return r

pair (eval3 aterm)

> trace t n                     =  "eval (" ++ show t ++ ") = "
>                               ++ show n ++ "\n"

"`Schreibermonade"'.

> newtype Trace a               =  Trace (a, String)
> pair (Trace p)                =  p

> instance Monad Trace where
>     return a                  =  Trace (a, "")
>     m >>= f                   =  let (a, x) = pair m
>                                      (b, y) = pair (f a)
>                                  in  Trace (b, x ++ y)

> output                        :: String -> Trace ()
> output s                      =  Trace ((), s)