Wadler's interpreter for Either monad

interp_errors.hs

module Main where

import Lib

main :: IO ()
main = putStrLn "Monad Interpreter v0.2" 
       >> putStrLn "-------------------------------------"
       >> putStrLn "Input test term:"
       >> getLine >>= putStrLn . test . (read :: String -> Term)
       >> return ()


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

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 -> Computation Value)


type Environment = [(Name, Value)]


interp :: Term -> Environment -> Computation Value
interp (Var x) e   = 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 -> Computation Value
lookup' x []         = errorComp ("Unbound variable: " ++ x)
lookup' x ((y, v):e) = if x == y then (Success v) else (lookup' x e)


add :: Value -> Value -> Computation Value
add (Num i) (Num j) = return $ Num (i + j)
add  a b            = errorComp ("Should be numbers: " ++ showval a ++ ", " ++ showval b) 


apply :: Value -> Value -> Computation Value
apply (Fun f) a = f a
apply f _       = errorComp ("Should be function: " ++ showval f)


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


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

-- ------------------ Computation details -------------------------------

data Computation a = Success a | Error String

instance Functor Computation where
  fmap f (Success a) = Success (f a)
  fmap f (Error e)   = Error e

instance Applicative Computation where
  pure a = Success a
  (Success f) <*> (Success a) = Success (f a)
  _ <*> (Error e)             = (Error e)
  (Error f) <*> (Success a)   = (Error f)

instance Monad Computation where
  return = pure
  (Success a) >>= f = f a
  (Error e)   >>= f = Error e

errorComp :: String -> Computation a
errorComp = Error

showComp :: Computation Value -> String
showComp (Success a) = "Success: " ++ showval a
showComp (Error e)   = "Error: " ++ e

$ stack exec interp-exe -- 
Monad Interpreter v0.2
-------------------------------------
Input test term:
(App (Con 1) (Con 2))
Error: Should be function: 1