module Eval where
import Data.Map (empty, (!))
import CPSScheme
import Common
type Closure = (Lambda, BEnv)
type Contour = Integer
type BEnv = Label :⇀ Contour
type VEnv = Var :× Contour :⇀ D
data D = DI Const
| DC Closure
| DP Prim
| Stop
deriving (Show)
type Ans = Const
evalCPS :: Prog -> Ans
evalCPS lam = evalF f [Stop] ve 0
where ve = empty
β = empty
f = evalV (L lam) β ve
evalV :: Val -> BEnv -> VEnv -> D
evalV (C _ int) β ve = DI int
evalV (P prim) β ve = DP prim
evalV (R _ var) β ve = ve ! (var, β ! binder var)
evalV (L lam) β ve = DC (lam, β)
evalF :: D -> [D] -> VEnv -> Contour -> Ans
evalF (DC (Lambda lab vs c, β)) as ve b
| length as /= length vs = error $ "Wrong number of arguments to lambda expression " ++ show lab
| otherwise = evalC c β' ve' b
where β' = β `upd` [lab ↦ b]
ve' = ve `upd` zipWith (\v a -> (v,b) ↦ a) vs as
evalF (DP (Plus c)) [DI a1, DI a2, cont] ve b = evalF cont [DI (a1 + a2)] ve b'
where b' = succ b
evalF (DP (If ct cf)) [DI v, contt, contf] ve b
| v /= 0 = evalF contt [] ve b'
| v == 0 = evalF contf [] ve b'
where b' = succ b
evalF Stop [DI int] _ _ = int
evalF Stop _ _ _ = error $ "Stop called with wrong number or types of arguments"
evalF (DP prim) _ _ _ = error $ "Primop " ++ show prim ++ " called with wrong arguments"
evalF (DI int) _ _ _ = error $ "Cannot treat a constant value as a function"
evalC :: Call -> BEnv -> VEnv -> Contour -> Ans
evalC (App lab f vs) β ve b = evalF f' as ve b'
where f' = evalV f β ve
as = map (\v -> evalV v β ve) vs
b' = succ b
evalC (Let lab ls c') β ve b = evalC c' β' ve' b'
where b' = succ b
β' = β `upd` [lab ↦ b']
ve' = ve `upd` [(v,b') ↦ evalV (L l) β' ve | (v,l) <- ls]