--
-- CBV interpreter with output.
--
module InterpOutput where

data Term = Var String 
          | Con Int
          | Add Term Term
          | Lam String Term
          | App Term Term
          | Out 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 Output a = Output (String, a)
instance Show a => Show (Output a) where
    show (Output (o,a)) = "Output: "++o++"\nValue: "++(show a)

unit v = Output ("", v)
bad s = Output (s, Wrong)
bind (Output (o1,v1)) f = 
    let Output (o2, v2) = f v1 
    in Output (o1++o2, v2)

out v = Output ((show v)++"; ", v)


type M a = Output 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
interp (Out e) env = 
    bind (interp e env) out

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"))