From bdc72de514f63440a634d011faedfbeef770ed1f Mon Sep 17 00:00:00 2001
From: Marcin Chrzanowski <marcin.j.chrzanowski@gmail.com>
Date: Sun, 13 May 2018 19:51:07 +0200
Subject: Initial commit

---
 Eval.hs | 144 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 144 insertions(+)
 create mode 100644 Eval.hs

(limited to 'Eval.hs')

diff --git a/Eval.hs b/Eval.hs
new file mode 100644
index 0000000..c4f6cf7
--- /dev/null
+++ b/Eval.hs
@@ -0,0 +1,144 @@
+module Eval where
+
+import Abs
+import Prelude hiding (lookup)
+import Parser.AbsSchmim
+import Control.Monad.Reader
+import Data.Map.Lazy
+import Typecheck
+
+type Interpreter a = ReaderT Env (Either String) a
+
+eval :: Exp -> Interpreter Val
+eval (EAdd e1 e2) = do
+    (VNum v1) <- eval e1
+    (VNum v2) <- eval e2
+    return (VNum $ v1 + v2)
+eval (EMul e1 e2) = do
+    (VNum v1) <- eval e1
+    (VNum v2) <- eval e2
+    return (VNum $ v1 * v2)
+eval (ESub e1 e2) = do
+    (VNum v1) <- eval e1
+    (VNum v2) <- eval e2
+    return (VNum $ v1 - v2)
+eval (EDiv e1 e2) = do
+    (VNum v1) <- eval e1
+    (VNum v2) <- eval e2
+    if v2 == 0
+    then lift $ Left "division by 0"
+    else return (VNum $ v1 `div` v2)
+eval (EVar x) = do
+    (Just v) <- asks $ lookup x
+    return v
+eval (ENum n) = return (VNum n)
+eval (EAbs x t e) = do
+    env <- ask
+    return $ VAbs x t env e
+eval (EApp e1 []) = do
+    eval e1
+eval (EApp e1 [e2]) = do
+    (VAbs x t env e) <- eval e1
+    v <- eval e2
+    local (\_ -> insert x v env) $ eval e
+eval (EApp e1 (e2:es)) = do
+    eval (EApp (EApp e1 [e2]) es)
+eval ETr = return VTr
+eval EFl = return VFl
+eval (EEq e1 e2) = do
+    (VNum v1) <- eval e1
+    (VNum v2) <- eval e2
+    return $ if v1 == v2 then VTr else VFl
+eval (ELeq e1 e2) = do
+    (VNum v1) <- eval e1
+    (VNum v2) <- eval e2
+    return $ if v1 <= v2 then VTr else VFl
+eval (EGeq e1 e2) = do
+    (VNum v1) <- eval e1
+    (VNum v2) <- eval e2
+    return $ if v1 >= v2 then VTr else VFl
+eval (ELess e1 e2) = do
+    (VNum v1) <- eval e1
+    (VNum v2) <- eval e2
+    return $ if v1 < v2 then VTr else VFl
+eval (EGrt e1 e2) = do
+    (VNum v1) <- eval e1
+    (VNum v2) <- eval e2
+    return $ if v1 > v2 then VTr else VFl
+eval (EAnd e1 e2) = do
+    v1 <- eval e1
+    v2 <- eval e2
+    return $ case (v1, v2) of
+                (VTr, VTr) -> VTr
+                _ -> VFl
+eval (EOr e1 e2) = do
+    v1 <- eval e1
+    v2 <- eval e2
+    return $ case (v1, v2) of
+                (VFl, VFl) -> VFl
+                _ -> VTr
+eval (EIfte e1 e2 e3) = do
+    v1 <- eval e1
+    let e = case v1 of
+                VTr -> e2
+                VFl -> e3
+    eval e
+eval (EVrnt l e t) = do
+    v <- eval e
+    return $ VVrnt l v t
+eval (ETpl es) = do
+    vs <- forM es eval
+    return $ VTpl vs
+eval (EProj e i) = do
+    (VTpl vs) <- eval e
+    return $ vs !! (fromIntegral (i - 1))
+eval (EMtch e ms) = do
+    (VVrnt l v t) <- eval e
+    let (Matching _ x e') = lookupLabel l ms
+    local (insert x v) $ eval e'
+    where
+        lookupLabel l (m@(Matching l' x e):ms)
+            | l == l' = m
+            | otherwise = lookupLabel l ms
+eval (ENil t) = return $ VNil t
+eval (ECons e1 e2) = do
+    v1 <- eval e1
+    v2 <- eval e2
+    return (VCons v1 v2)
+eval (EHead e) = do
+    v <- eval e
+    case v of
+        (VNil _) -> lift $ Left "head of empty list"
+        (VCons v _) -> return v
+eval (ETail e) = do
+    v <- eval e
+    case v of
+        (VNil _) -> lift $ Left "tail of empty list"
+        (VCons _ v) -> return v
+eval (EIsnil e) = do
+    v <- eval e
+    return $ case v of
+                (VNil _) -> VTr
+                _ -> VFl
+eval (EFix (EAbs x t e)) = do
+    env <- ask
+    let env' = insert x (forcedEval (EFix (EAbs x t e)) env') env
+    local (\_ -> env') $ eval e
+    where
+    forcedEval e env = case runReaderT (eval e) env of
+        Right v -> v
+eval (ELet x ps e1 e2) = do
+    eval (EApp (EAbs x t e2) [e1'])
+    where
+        (e1', t) = Prelude.foldr (\(Param x t') (e, t) -> ((EAbs x t' e), TFun t' t)) (e1, placeholderType) ps
+eval (ELetrec x _ ps e1 e2) = do
+    eval (EApp (EAbs x t e2) [(EFix (EAbs x t e1'))])
+    where
+        (e1', t) = Prelude.foldr (\(Param x t') (e, t) -> ((EAbs x t' e), TFun t' t)) (e1, placeholderType) ps
+
+placeholderType = TInt
+
+interp :: Exp -> Either String Val
+interp e = case runReaderT (typeof e) empty of
+    (Just t) -> runReaderT (eval e) empty
+    Nothing -> Left "badly typed expression"
-- 
cgit v1.2.3