Wadler's interpreter for Identity monad

interp_identity.hs

module Main where

import Lib

main :: IO ()
main = putStrLn "Monad Interpreter v0.1" 
    --    >> putStrLn ("Demo term: \"" ++ (show term0) ++ "\"")
    --    >> putStrLn ("Result: " ++ (test term0))
       >> putStrLn "-------------------------------------"
       >> putStrLn "Input test term:"
       >> getLine >>= putStrLn . test . (read :: String -> Term)
       >> return ()


type Name = String


data Term = Var Name
          | Con Int
          | Add Term Term
          | Lam Name Term
          | App Term Term
          deriving (Show, Read)


data Value = Wrong
           | Num Int
           | Fun (Value -> M Value)


type Environment = [(Name, Value)]


term0 = (App (Lam "x" (Add (Var "x") (Var "x"))) (Add (Con 10) (Con 11)))


showval :: Value -> String
showval Wrong   = "<wrong>"
showval (Num i) = show i
showval (Fun f) = "<function>"


interp :: Term -> Environment -> M Value
interp (Var x) e   = return $ lookup' x e
interp (Con i) _   = return (Num i)

interp (Add u v) e = interp u e >>= (\a -> 
                     interp v e >>= \b -> 
                     add a b)

interp (Lam x u) e = return (Fun (\a -> interp u ((x,a):e)))

interp (App t u) e = interp t e >>= \f -> 
                     interp u e >>= \a ->
                     apply f a


lookup' :: Name -> Environment -> Value
lookup' x []         = Wrong
lookup' x ((y, v):e) = if x == y then v else (lookup' x e)


add :: Value -> Value -> M Value
add (Num i) (Num j) = return $ Num (i + j)
add  _ _            = return Wrong


apply :: Value -> Value -> M Value
apply (Fun f) a = f a
apply _ _       = return Wrong


test :: Term -> String
test t = showM (interp t [])


newtype M a = M a

instance Functor M where
  fmap f (M a) = M (f a)

instance Applicative M where
  pure a = M a
  (M f) <*> a = fmap f a

instance Monad M where
  return = pure
  (M a) >>= f = f a

showM :: M Value -> String
showM (M a) = showval a

$ stack exec interp-exe -- 
Monad Interpreter v0.1
-------------------------------------
Input test term:
(App (Lam "x" (Add (Var "x") (Var "x"))) (Add (Con 10) (Con 11)))
42