1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
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"
|