> import CPS ( CPS(..), unit, (&=), (&), abort ) > import IOSupport ( newLine, putLine ) > import PrettyBased on the article Monads for functional programming by Philip Wadler. But instead of defining several special monads each variant of the evaluator is based on the CPS monad.
> data Term = Con Integer -- constant > | Div Term Term -- dividePretty printing an arithmetic term.
> instance Pretty Term where > ppPrec d (Con n) = ppShow n > ppPrec d (Div t u)= ppParen (d<=7) > (block 2 [ppPrec 8 t, ppStr " /", brk 1, > ppPrec 8 u])Examples.
> exa = Div (Div (Con 1972) (Con 2)) (Con 23) > err = Div (Con 1) (Con 0) > big = big 10 > where big 0 = Con 1 > big (n+1) = let t = big n in Div t t
> eval1 :: Term -> CPS Integer res > eval1 (Con n) = unit n > eval1 (Div t u) = eval1 t &= \a -> > eval1 u &= \b -> > unit (a `div` b)
> run1 :: CPS val val -> val > run1 m = m id
> eval2 :: Term -> ST2 Integer res > eval2 z@(Con n) = trace (Yields z n) & > unit n > eval2 z@(Div t u) = eval2 t &= \a -> > eval2 u &= \b -> > let c = a `div` b in > trace (Yields z c) & > unit c
> data Yields = Yields Term Integer > > instance Pretty Yields where > ppPrec d (Yields t k) = block 2 [pp t, ppStr " ->", brk 1, pp k]A state transformer extending the basic CPS Monad.
> type ST2 val res = CPS val (State2 -> res) > type State2 = [Yields] -> [Yields] > type Result2 val = (val, [Yields]) > > trace :: Yields -> ST2 () res > trace t = \c s -> c () (s . (:) t) > > run2 :: ST2 val (Result2 val) -> Result2 val > run2 m = m (\v s -> (v, s [])) id
> eval3 :: Term -> ST3 Integer res > eval3 z@(Con n) = trace (Yields z n) & > tick & > unit n > eval3 z@(Div t u) = eval3 t &= \a -> > eval3 u &= \b -> > let c = a `div` b in > trace (Yields z c) & > tick & > unit cAnother state transformer extending the state transformer above.
> type ST3 val res = ST2 val (State3 -> res) > type State3 = Integer > type Result3 val = (val, [Yields], Integer) > > tick :: ST3 () res > tick = \c s n -> c () s (n+1) > > run3 :: ST3 val (Result3 val) -> Result3 val > run3 m = m (\v s n -> (v, s [], n)) id 0
> eval4 :: Term -> ST4 Integer > eval4 z@(Con n) = trace (Yields z n) & > tick & > unit n > eval4 z@(Div t u) = eval4 t &= \a -> > eval4 u &= \b -> > if b == 0 then > raise4 "division by 0" > else > let c = a `div` b in > trace (Yields z c) & > tick & > unit c
> type ST4 val = ST3 val (Result4 val) > type Result4 val = Either (String, [Yields], Integer) -- error > (val, [Yields], Integer) -- OK > > raise4 :: String -> ST4 Integer > raise4 e = abort (\s n -> Left (e, s [], n)) > > run4 :: ST4 val -> Result4 val > run4 m = m (\v s n -> Right (v, s [], n)) id 0
> eval5 :: Term -> ST5 Integer res > eval5 z@(Con n) = io (display 79 (Yields z n)) & > tick & > unit n > eval5 z@(Div t u) = eval5 t &= \a -> > eval5 u &= \b -> > if b == 0 then > raise5 "division by 0" > else > let c = a `div` b in > io (display 79 (Yields z c)) & > tick & > unit c
> type ST5 val res = ST3 val (IO (Result4 res)) > > io :: IO val -> ST5 val res > io m = \c s n -> m >>= \v -> c v s n > > raise5 :: String -> ST5 Integer res > raise5 e = abort (\s n -> return (Left (e, s [], n))) > > run5 :: ST5 val val -> IO (Result4 val) > run5 m = m (\v s n -> return (Right (v, s [], n))) id 0
> main = putLine "Mark 1:" >>
> let v1 = run1 (eval1 exa) in
> putLine ("Result = " ++ show v1) >>
> newLine >>
>
> putLine "Mark 2:" >>
> let (v2, trace) = run2 (eval2 exa) in
> displays 79 trace >>
> putLine ("Result = " ++ show v2) >>
> newLine >>
>
> putLine "Mark 3:" >>
> let (v3, trace, ticks) = run3 (eval3 exa) in
> displays 79 trace >>
> putLine ("Result = " ++ show v3) >>
> putLine ("Time = " ++ show ticks) >>
> newLine >>
>
> putLine "Mark 4:" >>
> (case run4 (eval4 err) of
> Left (e, trace, ticks) ->
> displays 79 trace >>
> putLine ("** error: " ++ e)
> Right (v4, trace, ticks) ->
> displays 79 trace >>
> putLine ("Result = " ++ show v4) >>
> putLine ("Time = " ++ show ticks))>>
> newLine >>
>
> putLine "Mark 5:" >>
> run5 (eval5 err) >>=
> either
> (\ (err, trace, ticks) ->
> putLine ("** error: " ++ err))
> (\ (v5, trace, ticks) ->
> putLine ("Result = " ++ show v5) >>
> putLine ("Time = " ++ show ticks))