import qualified Table import EnvSimple import Parser import Repl type Symbol = String data Value = VNum Integer | VCtor Symbol Int [Value] | VRec (Table.T Symbol Value) | VFun Symbol Environment Expr data Expr = EId Symbol | ENum Integer | EPlus Expr Expr | ETimes Expr Expr | EFun Symbol Expr | EApp Expr Expr | ELet Symbol Expr Expr | ERecord [(Symbol, Expr)] | EMember Expr Symbol | ETypeVar [(Symbol, Int)] Expr | ECase Expr [(Pattern, Expr)] deriving Eq data Pattern = ElsePat | VarPat Symbol | CtorPat Symbol [Symbol] | NumPat Integer deriving Eq type Environment = Env Value eval :: Environment -> Expr -> Value eval env (ENum n) = VNum n eval env (EFun arg body) = VFun arg env body eval env (EId id) = lookup_variable env id eval env (EPlus e1 e2) = case (eval env e1, eval env e2) of (VNum x1, VNum x2) -> VNum (x1 + x2) _ -> error "addition of non-numbers" eval env (ETimes e1 e2) = case (eval env e1, eval env e2) of (VNum x1, VNum x2) -> VNum (x1 * x2) _ -> error "multiplication of non-numbers" eval env (EApp f a) = let val = eval env a in case eval env f of VFun p e b -> eval (bind_variable e p val) b VCtor ctor 0 args -> error "constructor applied to too many arguments" VCtor ctor ar args -> VCtor ctor (ar-1) (args ++ [val]) _ -> error "application of non-function" eval env (ERecord fields) = VRec (Table.map (\f e -> eval env e) (Table.of_list fields)) eval env (EMember e f) = case eval env e of VRec fields -> Table.lookup fields f _ -> error "not a record" eval env (ELet x e b) = eval (bind_variable env x (eval env e)) b eval env (ETypeVar ctors e) = eval new_env e where new_env = foldl (\env (c,ar) -> bind_variable env c (VCtor c ar [])) env ctors eval env (ECase e pats) = iter pats where val = eval env e iter [] = error "no matching pattern in case expression" iter ((ElsePat, e):ps) = eval env e iter ((VarPat x, e):ps) = case maybe_lookup_variable env x of -- check whether x is a constructor or a variable Nothing -> eval (bind_variable env x val) e Just (VCtor c 0 []) -> case val of VCtor d 0 [] | c == d -> eval env e _ -> iter ps iter ((NumPat n, e):ps) = case val of VNum k | n == k -> eval env e _ -> iter ps iter ((CtorPat c xs,e):ps) = case val of VCtor d 0 args | c == d && length xs == length args -> eval (foldl (\env (x,a) -> bind_variable env x a) env (zip xs args)) e _ -> iter ps desugar :: PExpr -> Expr desugar (PId id) = EId id desugar (PNum n) = ENum n desugar (PPlus e1 e2) = EPlus (desugar e1) (desugar e2) desugar (PTimes e1 e2) = ETimes (desugar e1) (desugar e2) desugar (PMinus e1 e2) = EPlus (desugar e1) (ETimes (ENum (-1)) (desugar e2)) desugar (PEqual e1 e2) = ECase (desugar (PMinus e1 e2)) [ (NumPat 0, EId "%True"), (ElsePat, EId "%False") ] desugar (PFun [] b) = EFun "()" (desugar b) desugar (PFun [(p,_)] b) = EFun p (desugar b) desugar (PFun ((p,_):args) b) = EFun p (desugar (PFun args b)) desugar (PApp f []) = EApp (desugar f) (EId "()") desugar (PApp f [a]) = EApp (desugar f) (desugar a) desugar (PApp f args) = foldl (\f a -> EApp f a ) (desugar f) (map desugar args) desugar (PRecord fields) = ERecord (map (\(f,e) -> (f, desugar e)) fields) desugar (PMember e f) = EMember (desugar e) f desugar (PDecl (PLet x _ e) b) = ELet x (desugar e) (desugar b) desugar (PDecl (PLetFun f args _ b) e) = ELet f (desugar (PFun args b)) (desugar e) desugar (PDecl (PTypeVar _ _ ctors) e) = ETypeVar (map (\(c,args) -> (c, length args)) ctors) (desugar e) desugar (PDecl (PTypeRec _ _ _) e) = desugar e desugar (PDecl (PTypeDef _ _ _) e) = desugar e desugar (PIf c t e) = ECase (desugar c) [ (VarPat "%True", desugar t), (ElsePat, desugar e) ] desugar (PCase e pats) = ECase (desugar e) (map (\(p,e) -> (desugar_pat p, desugar e)) pats) desugar (PListLit es t) = foldr (\x y -> EApp (EApp (EId "%Cons") (desugar x)) y) (case t of Nothing -> EId "%Nil" Just e -> desugar e) es desugar _ = error "unsupported syntactic construct\n" desugar_pat :: PPattern -> Pattern desugar_pat PElsePat = ElsePat desugar_pat (PVarPat x) = VarPat x desugar_pat (PCtorPat c xs) = CtorPat c xs desugar_pat (PNumPat n) = NumPat n show_list :: Show a => String -> String -> (a -> String) -> [a] -> String show_list l r sh [] = "" show_list l r sh xs = l ++ foldl1 (\ x y -> x ++ ", " ++ y) (map sh xs) ++ r instance Show Value where show (VNum n) = show n show (VCtor c _ args) = c ++ show_list "(" ")" show args show (VRec fields) = show_list "[" "]" (\(f,v) -> f ++ " = " ++ show v) (Table.to_list fields) show (VFun a _ b) = "fun (" ++ a ++ ") { " ++ show b ++ " }" instance Show Expr where show (EId x) = x show (ENum n) = show n show (EPlus e1 e2) = "(" ++ show e1 ++ " + " ++ show e2 ++ ")" show (ETimes e1 e2) = "(" ++ show e1 ++ " * " ++ show e2 ++ ")" show (EFun a b) = "fun (" ++ a ++ ") { " ++ show b ++ " }" show (EApp f a) = show fn ++ show_list "(" ")" show args where (fn, args) = collect_args f [a] collect_args (EApp g b) args = collect_args g (b:args) collect_args g args = (g, args) show (ERecord fields) = show_list "[" "]" (\(f,e) -> f ++ " = " ++ show e) fields show (EMember e f) = show e ++ "." ++ f show (ELet x b e) = "let " ++ x ++ " = " ++ show b ++ "; " ++ show e show (ECase e pats) = foldl (++) ("case " ++ show e) (map (\(p,e) -> " | " ++ show p ++ " => " ++ show e) pats) show (ETypeVar ctors e) = foldl (++) "type ?? =" (map (\(c,ar) -> " | " ++ c ++ show_list "(" ")" id (replicate ar "_")) ctors) ++ "; " ++ show e instance Show Pattern where show ElsePat = "else" show (VarPat x) = x show (NumPat n) = show n show (CtorPat c xs) = c ++ show_list "(" ")" id xs builtin_ctors = foldl (\env (ctor, val) -> bind_variable env ctor val) empty_env [("()", VCtor "()" 0 []), ("True", VCtor "True" 0 []), ("False", VCtor "False" 0 []), ("Pair", VCtor "Pair" 2 []), ("Nil", VCtor "Nil" 0 []), ("Cons", VCtor "Cons" 2 []), ("%True", VCtor "True" 0 []), ("%False", VCtor "False" 0 []), ("%Nil", VCtor "Nil" 0 []), ("%Cons", VCtor "Cons" 2 [])] run str = ("", show (eval builtin_ctors (desugar (parse str)))) main :: IO () main = repl run Nothing