--
-- CBV interpreter with error messages 
--
module InterpErr where

data Term = Var String 
          | Con Int
          | Add Term Term
          | Lam String Term
          | App Term Term
  deriving Show

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

instance Show Value where
    show Wrong = "<wrong>"
    show (Num  n) = show n
    show (Fun _) = "<function>"


data Err a = Err String | Succ a
instance Show a => Show (Err a) where
    show (Err s) = "Error: "++s
    show (Succ v) = "Success: "++(show v)

unit v = Succ v
bad s = Err s
bind x f = case x of
    Succ v -> f v
    Err s -> bad s


type M a = Err a

type Env = [(String, Value)]

getVar :: Env -> String -> M Value
getVar ((x,v):xs) y = if x == y then unit v else getVar xs y
getVar [] y = bad $ "unbound variable "++y

add :: Value -> Value -> M Value
add (Num m) (Num n) = unit $ Num $ m + n
add m n = bad $ "expected numbers, found "++(show m)++" and "++(show n)

apply :: Value -> Value -> M Value
apply (Fun v1) v2 = v1 v2
apply f _ = bad $ "expected function, found "++(show f)

interp :: Term -> Env -> M Value
interp (Var x) env = getVar env x
interp (Con n) _ = unit $ Num n
interp (Add e1 e2) env = 
    bind (interp e1 env) (\v1 ->
    bind (interp e2 env) (\v2 ->
    add v1 v2))
interp (Lam x e) env = unit $ Fun $ \v -> interp e ((x,v):env)
interp (App e1 e2) env = 
    bind (interp e1 env) (\v1 ->
    bind (interp e2 env) (\v2 ->
    apply v1 v2))

test e = interp e []

i = Lam "x" $ Var "x"
k = Lam "x" $ Lam "y" $ Var "x"
s = Lam "f" $ Lam "g" $ Lam "x" $ App (App (Var "f") (Var "x")) (App (Var "g") (Var "x"))
omega = App (Lam "x" $ App (Var "x") (Var "x")) (Lam "x" $ App (Var "x") (Var "x"))