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
|
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
| 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 "Int",VType),
(CIdent "String",VType),
mkIntUn "neg" negate,
mkIntBin "add" (+),
mkIntBin "sub" (-),
mkIntBin "mul" (*),
mkIntBin "div" div,
mkIntBin "mod" mod,
mkIntCmp "lt" (<),
mkIntCmp "le" (<=),
mkIntCmp "gt" (>),
mkIntCmp "ge" (>=),
mkIntCmp "eq" (==),
mkIntCmp "ne" (/=)]
where
mkIntUn x f = let c = CIdent ("prim_"++x++"_Int")
in (c, VPrim (\n -> appInt1 (VInt . f) n))
mkIntBin x f = let c = CIdent ("prim_"++x++"_Int")
in (c, VPrim (\n -> VPrim (\m -> appInt2 (\n m -> VInt (f n m)) n m )))
mkIntCmp x f = let c = CIdent ("prim_"++x++"_Int")
in (c, VPrim (\n -> VPrim (\m -> appInt2 (\n m -> toBool (f n m)) n m)))
toBool b = VCons (CIdent (if b then "True" else "False")) []
appInt1 f x = case x of
VInt n -> f n
_ -> error $ printValue x ++ " is not an integer"
appInt2 f x y = case (x,y) of
(VInt n,VInt m) -> f n m
_ -> error $ printValue x ++ " and " ++ printValue y
++ " are not both integers"
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 v cases of
Nothing -> error $ "No pattern matched " ++ printValue v
Just (e,bs) -> eval (bs `addToEnv` 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
EInt n -> VInt n
EMeta (TMeta t) -> VMeta (read $ drop 1 t)
firstMatch :: Value -> [Case] -> Maybe (Exp,[(CIdent,Value)])
firstMatch _ [] = Nothing
firstMatch v (Case p e:cs) = case match p v of
Nothing -> firstMatch v cs
Just env -> Just (e,env)
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 PType VType = 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 -> EInt 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)
|
