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
|
{-# LANGUAGE TupleSections #-}
module Typecheck
(inferExpr,
checkExpr,
Environment)
where
import Syntax
--import Control.Monad
import Control.Monad.Except
type Environment = [(Idnt,Typ)]
type Error = Except String
assertInt :: Typ -> Expr -> Error ()
assertInt TInt _ = return ()
assertInt t e = throwError $ "Expected type of expression "++ show e ++ " to be (TInt), instead got" ++ show t
assertRec :: Typ -> Expr -> Error TypeDict
assertRec (TRecord ts) _ = return ts
assertRec t e = throwError $ "Expected type of expression "++ show e ++ " to be (TRecord _), instead got" ++ show t
assertVar :: Typ -> Expr -> Error TypeDict
assertVar (TVariant ts) _ = return ts
assertVar t e = throwError $ "Expected type of expression "++ show e ++ " to be (TVariant _), instead got" ++ show t
assertPtr :: Typ -> Expr -> Error Typ
assertPtr (TPtr t) _ = return t
assertPtr t e = throwError $ "Expected type of expression "++ show e ++ " to be (TPtr _), instead got" ++ show t
envlookup :: Idnt -> TypeDict -> Expr -> Error Typ
envlookup name env expr = case lookup name env of
Just t -> return t
Nothing -> throwError $ "Variable "++ name ++ "not defined in expr" ++ show expr
inferExpr :: Expr -> Environment -> Error Typ
inferExpr e@(Var name) env = envlookup name env e
inferExpr (IntLit _) _ = return TInt
inferExpr (Record ts) env = do
tts <- mapM (\(v,e) -> (v,) <$> inferExpr e env) ts
return $ TRecord tts
inferExpr ee@(Variant t v e) env = do
ts <- assertVar t e
tt <- envlookup v ts ee
checkExpr e env tt
return t
inferExpr (Add e1 e2) env = do
checkExpr e1 env TInt
checkExpr e2 env TInt
return TInt
inferExpr (Mult e1 e2) env = do
checkExpr e1 env TInt
checkExpr e2 env TInt
return TInt
inferExpr (Neg e) env = do
checkExpr e env TInt
return TInt
inferExpr (Deref e1) env = do
t <- inferExpr e1 env
tt <- assertPtr t e1
return tt
inferExpr c@(Match e cases) env = do
varType <- inferExpr e env
variants <- assertVar varType e
-- TODO ensure variants and cases cover the same names
caseTypes <- mapM (\(v,e) ->(v,) <$> inferExpr e env) cases
ret <- allSame caseTypes
return $ snd ret
where
allSame :: [(Idnt,Typ)] -> Error (Idnt,Typ)
allSame (x:[]) = return x
allSame [] = throwError $ "Empty case "++ show c
allSame ((xx,x):xs) = do
(v,t) <- allSame xs
if t==x then return (v,t) else
throwError $ "Different types in branches " ++ show v ++ "," ++ show xx ++ "of expression" ++ show c
inferExpr (Proj name e) env = do
t <- inferExpr e env
tt <- assertRec t e
case lookup name tt of
Just typ -> return typ
Nothing -> throwError $ "Record " ++show e ++ "doesn't have field" ++ name
checkExpr :: Expr -> Environment -> Typ -> Error ()
checkExpr e@(Add e1 e2) env t = do
assertInt t e
checkExpr e1 env TInt
checkExpr e2 env TInt
checkExpr e@(Mult e1 e2) env t = do
assertInt t e
checkExpr e1 env TInt
checkExpr e2 env TInt
checkExpr e@(Neg ee) env t = do
assertInt t e
checkExpr ee env TInt
checkExpr (Deref e1) env t = do
checkExpr e1 env (TPtr t)
checkExpr e env t = do
t' <- inferExpr e env
if t == t' then return ()
else throwError $ "Expected type of expression " ++
show e ++ " to be"++ show t ++" instead got" ++ show t'
|
