module Cont where

data Term = Var String 
          | String :\ Term
          | Term :$: Term
          | Con Int
          | Term :+: Term
          | TT 
          | FF
          | Not Term
          | Term :==: Term
          | If Term Term Term
          | Skip
          | CallCC String Term
  deriving Show

infixr 2 :\
infixl 5 :$:
infixl 7 :+:

data Value = Err String
           | Fun (Value -> K Value)
           | Num Int 
           | Bl Bool
           | Unit

instance Eq Value where
    Num x == Num y = x == y
    Bl x == Bl y = x == y
    Unit == Unit = True
    _ == _ = False

instance Show Value where
    show (Err err) = "Error: "++err
    show (Fun _) = "<function>"
    show (Num n) = show n
    show (Bl x) = show x
    show Unit = "()"


type Env = [(String, Value)]

type K v = (v -> Answer) -> Answer

type Answer = Value

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

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

add :: Value -> Value -> K Value
add (Num m) (Num n) k = k $ Num $ m + n
add m n k = k $ Err $ "expected numbers, found "++(show m)++" and "++(show n)

not' :: Value -> K Value
not' (Bl v) k = k $ Bl $ not v
not' x k =  k $ Err $ "expected bool, found "++(show x)

if' :: Value -> K Value -> K Value -> K Value
if' (Bl v) x y k = if v then x k else y k
if' v _ _ k = k $ Err $ "expected bool, found "++(show v)

callcc :: ((v -> K w) -> K v) -> K v
callcc f k = f (\a _ -> k a) k

interp :: Term -> Env -> K Value
interp (Var x) env k = getVar env x k
interp (x :\ e) env k = k $ Fun $ \v -> interp e ((x,v):env)
interp (e1 :$: e2) env k =
    interp e1 env $ \v1 ->
    interp e2 env $ \v2 ->
    apply v1 v2 k

interp (Con n) _ k = k $ Num n
interp (e1 :+: e2) env k =
    interp e1 env $ \v1 ->
    interp e2 env $ \v2 ->
    add v1 v2 k

interp TT _ k = k $ Bl True
interp FF _ k = k $ Bl False
interp (Not e) env k = interp e env $ \v -> not' v k
interp (e1 :==: e2) env k = 
    interp e1 env $ \v1 ->
    interp e2 env $ \v2 ->
    k $ Bl $ v1 == v2
interp (If e1 e2 e3) env k =
    interp e1 env $ \v1 -> 
    if' v1 (interp e2 env) (interp e3 env) k

interp Skip env k = k Unit

interp (CallCC x e) env k = callcc (\v -> interp e ((x,Fun v):env)) k 

test e = interp e [] id

i = "x" :\ Var "x"
k = "x" :\ "y" :\ Var "x"
s = "f" :\ "g" :\ "x" :\ (Var "f") :$: (Var "x") :$: ((Var "g") :$: (Var "x"))
omega = ("x" :\ (Var "x") :$: (Var "x")) :$: ("x" :\ (Var "x") :$: (Var "x"))

e1 = Con 1 :+: CallCC "k" (Con 2 :+: (Var "k" :$: Con 3))
e2 = Con 1 :+: CallCC "k" (Con 2 :+: (Var "k" :$: (Var "k" :$: Con 3)))
e3 = Con 1 :+: CallCC "k" (Con 2 :+: Con 3)

e4 = CallCC "k" $ "x" :\ (Var "k") :$: ("y" :\ Var "x" :+: Var "y")

handle e e' = CallCC "k" (e :$: ("_" :\ Var "k" :$: e'))
raise e = e :$: Skip

e5 = "x" :\ handle ("ex" :\ If (Var "x" :==: Con 10) (raise (Var "ex")) (Var "x" :+: Con 2))
                   (Con (-1))