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
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
|
module Transfer.Interpreter where
import Transfer.Core.Abs
import Transfer.Core.Print
import Control.Monad
import Data.List
import Data.Maybe
import Debug.Trace
data Value = VStr String
| VInt Integer
| VDbl Double
| VType
| VRec [(CIdent,Value)]
| VClos Env Exp
| VCons CIdent [Value]
| VPrim (Value -> Value)
| VMeta Integer
deriving (Show)
instance Show (a -> b) where
show _ = "<<function>>"
--
-- * Environment
--
newtype Env = Env [(CIdent,Value)]
deriving Show
mkEnv :: [(CIdent,Value)] -> Env
mkEnv = Env
addToEnv :: [(CIdent,Value)] -> Env -> Env
addToEnv bs (Env e) = Env (bs ++ e)
lookupEnv :: Env -> CIdent -> Value
lookupEnv (Env e) id =
case lookup id e of
Just x -> x
Nothing -> error $ "Variable " ++ printTree id ++ " not in environment."
++ " Environment contains: " ++ show (map (printTree . fst) e)
prEnv :: Env -> String
prEnv (Env e) = unlines [ printTree id ++ ": " ++ printValue v | (id,v) <- e ]
seqEnv :: Env -> Env
seqEnv (Env e) = Env $! deepSeqList [ fst p `seq` p | p <- e ]
-- | The built-in types and functions.
builtin :: Env
builtin =
mkEnv [(CIdent "Integer",VType),
(CIdent "Double",VType),
(CIdent "String",VType),
mkIntUn "neg" negate toInt,
mkIntBin "add" (+) toInt,
mkIntBin "sub" (-) toInt,
mkIntBin "mul" (*) toInt,
mkIntBin "div" div toInt,
mkIntBin "mod" mod toInt,
mkIntBin "eq" (==) toBool,
mkIntBin "cmp" compare toOrd,
mkIntUn "show" show toStr,
mkDblUn "neg" negate toDbl,
mkDblBin "add" (+) toDbl,
mkDblBin "sub" (-) toDbl,
mkDblBin "mul" (*) toDbl,
mkDblBin "div" (/) toDbl,
mkDblBin "mod" (\_ _ -> 0.0) toDbl,
mkDblBin "eq" (==) toBool,
mkDblBin "cmp" compare toOrd,
mkDblUn "show" show toStr,
mkStrBin "add" (++) toStr,
mkStrBin "eq" (==) toBool,
mkStrBin "cmp" compare toOrd,
mkStrUn "show" show toStr
]
where
toInt i = VInt i
toDbl i = VDbl i
toBool b = VCons (CIdent (show b)) []
toOrd o = VCons (CIdent (show o)) []
toStr s = VStr s
mkUn t a x f g = let c = CIdent ("prim_" ++ x ++ "_" ++ t)
in (c, VPrim (\n -> a f g n))
mkBin t a x f g = let c = CIdent ("prim_" ++ x ++ "_" ++ t)
in (c, VPrim (\n -> VPrim (\m -> a f g n m )))
mkIntUn = mkUn "Integer" $ \ f g x ->
case x of
VInt n -> g (f n)
_ -> error $ printValue x ++ " is not an integer"
mkIntBin = mkBin "Integer" $ \ f g x y ->
case (x,y) of
(VInt n,VInt m) -> g (f n m)
_ -> error $ printValue x ++ " and " ++ printValue y
++ " are not both integers"
mkDblUn = mkUn "Double" $ \ f g x ->
case x of
VDbl n -> g (f n)
_ -> error $ printValue x ++ " is not a double"
mkDblBin = mkBin "Double" $ \ f g x y ->
case (x,y) of
(VDbl n,VDbl m) -> g (f n m)
_ -> error $ printValue x ++ " and " ++ printValue y
++ " are not both doubles"
mkStrUn = mkUn "String" $ \ f g x ->
case x of
VStr n -> g (f n)
_ -> error $ printValue x ++ " is not a string"
mkStrBin = mkBin "String" $ \ f g x y ->
case (x,y) of
(VStr n,VStr m) -> g (f n m)
_ -> error $ printValue x ++ " and " ++ printValue y
++ " are not both strings"
addModuleEnv :: Env -> Module -> Env
addModuleEnv env (Module ds) =
let bs = [ (c,VCons c []) | DataDecl _ _ cs <- ds, ConsDecl c _ <- cs ]
++ [ (t,VCons t []) | DataDecl t _ _ <- ds ]
++ [ (x,eval env' e) | ValueDecl x e <- ds]
env' = addToEnv bs env
in env'
--
-- * Evaluation.
--
eval :: Env -> Exp -> Value
eval env x = case x of
ELet defs exp2 ->
let env' = [ (id, v) | LetDef id e <- defs,
let v = eval env' e]
`addToEnv` env
in eval (seqEnv env') exp2
ECase exp cases ->
let v = eval env exp
r = case firstMatch env v cases of
Nothing -> error $ "No pattern matched " ++ printValue v
Just (e,env') -> eval env' e
in v `seq` r
EAbs _ _ -> VClos env x
EPi _ _ _ -> VClos env x
EApp exp1 exp2 ->
let v1 = eval env exp1
v2 = eval env exp2
in case v1 of
VClos env' (EAbs id e) -> eval (bind id v2 `addToEnv` env') e
VPrim f -> f $! v2
VCons c vs -> (VCons $! c) $! ((++) $! vs) $! [v2]
_ -> error $ "Bad application (" ++ printValue v1
++ ") (" ++ printValue v2 ++ ")"
EProj exp id -> let v = eval env exp
in case v of
VRec fs -> recLookup id fs
_ -> error $ printValue v ++ " is not a record, "
++ "cannot get field " ++ printTree id
ERecType fts -> VRec $! deepSeqList $! [v `seq` (f,v) | FieldType f e <- fts,
let v = eval env e]
ERec fvs -> VRec $! deepSeqList $! [v `seq` (f,v) | FieldValue f e <- fvs,
let v = eval env e]
EVar id -> lookupEnv env id
EType -> VType
EStr str -> VStr str
EInteger n -> VInt n
EDouble n -> VDbl n
EMeta (TMeta t) -> VMeta (read $ drop 1 t)
firstMatch :: Env -> Value -> [Case] -> Maybe (Exp,Env)
firstMatch _ _ [] = Nothing
firstMatch env v (Case p g e:cs) =
case match p v of
Nothing -> firstMatch env v cs
Just bs -> let env' = bs `addToEnv` env
in case eval env' g of
VCons (CIdent "True") [] -> Just (e,env')
VCons (CIdent "False") [] -> firstMatch env v cs
x -> error $ "Error in guard: " ++ printValue x
++ " is not a Bool"
bind :: PatternVariable -> Value -> [(CIdent,Value)]
bind (PVVar x) v = [(x,v)]
bind PVWild _ = []
match :: Pattern -> Value -> Maybe [(CIdent,Value)]
match (PCons c' ps) (VCons c vs)
| c == c' = if length vs == length ps
then concatM $ zipWith match ps vs
else error $ "Wrong number of arguments to " ++ printTree c
match (PVar x) v = Just (bind x v)
match (PRec fps) (VRec fs) = concatM [ match p (recLookup f fs) | FieldPattern f p <- fps ]
match (PInt i) (VInt i') | i == i' = Just []
match (PStr s) (VStr s') | s == s' = Just []
match (PInt i) (VInt i') | i == i' = Just []
match _ _ = Nothing
recLookup :: CIdent -> [(CIdent,Value)] -> Value
recLookup l fs =
case lookup l fs of
Just x -> x
Nothing -> error $ printValue (VRec fs) ++ " has no field " ++ printTree l
--
-- * Utilities
--
concatM :: Monad m => [m [a]] -> m [a]
concatM = liftM concat . sequence
-- | Force a list and its values.
deepSeqList :: [a] -> [a]
deepSeqList = foldr (\x xs -> x `seq` xs `seq` (x:xs)) []
--
-- * Convert values to expressions
--
valueToExp :: Value -> Exp
valueToExp v =
case v of
VStr s -> EStr s
VInt i -> EInteger i
VDbl i -> EDouble i
VType -> EType
VRec fs -> ERec [ FieldValue f (valueToExp v) | (f,v) <- fs]
VClos env e -> e
VCons c vs -> foldl EApp (EVar c) (map valueToExp vs)
VPrim _ -> EVar (CIdent "<<primitive>>") -- FIXME: what to return here?
VMeta n -> EMeta $ TMeta $ "?" ++ show n
--
-- * Pretty printing of values
--
printValue :: Value -> String
printValue v = printTree (valueToExp v)
|
