1 implementation module sem
3 import qualified Data.Map as Map
4 from Data.Func import $
9 import Control.Applicative
11 import Control.Monad.State
12 import Control.Monad.Identity
14 import Control.Monad.Trans
16 from StdFunc import id, const, o
23 from Text import class Text(concat), instance Text String
26 from parse import :: ParserOutput, :: Error
28 :: Gamma :== ('Map'.Map String Type, [String])
29 :: Env a :== StateT Gamma (Either SemError) a
30 //StateT (Gamma -> Either SemError (a, Gamma))
32 //we need to redefine this even though it is in Control.Monad.State
33 instance MonadTrans (StateT Gamma) where
34 liftT m = StateT \s-> m >>= \a-> return (a, s)
38 sem :: AST -> SemOutput
39 sem (AST vd fd) = case runStateT m ('Map'.newMap, getRandomStream 1) of
41 Right ((vds, fds), gamma) = Right ((AST vds fds), gamma)
43 m :: Env ([VarDecl], [FunDecl])
44 m = mapM semVarDecl vd >>= \vds ->
45 mapM semFunDecl fd >>= \fds1 ->
46 mapM semFunDecl fds1 >>= \fds2 ->
49 semFunDecl :: FunDecl -> Env FunDecl
50 semFunDecl fd=:(FunDecl p f args mt vds stmts) =
52 Nothing = genType args >>= \infft->putIdent f infft >>| pure infft
53 Just t = putIdent f t >>| pure t) >>= \ft ->
54 saveGamma >>= \gamma ->
55 matchFunctions args ft >>= \tres->
56 mapM semVarDecl vds >>= \newvds->
57 mapM (checkStmt tres) stmts >>= \newstmts->
59 Nothing = inferReturnType stmts
60 >>= \returntype->reconstructType args tres
61 >>= \ftype->pure Void//restoreGamma gamma
62 >>| putIdent f ftype >>| pure (
63 FunDecl p f args (Just ftype) newvds newstmts)
64 Just t = restoreGamma gamma
65 >>| pure (FunDecl p f args mt newvds newstmts)
67 inferReturnType :: [Stmt] -> Env Type
68 inferReturnType [] = pure VoidType
69 inferReturnType [ReturnStmt (Just t):rest] = typeExpr t
70 inferReturnType [ReturnStmt _:rest] = pure VoidType
71 inferReturnType [_:rest] = inferReturnType rest
73 reconstructType :: [String] Type -> Env Type
74 reconstructType [] t = pure t
75 reconstructType [x:xs] t = gets (\(st, r)->'Map'.get x st)
76 >>= \mtype->case mtype of
77 Nothing = liftT $ Left $ Error "Not used ????"
78 Just type = reconstructType xs t >>= \resttype->pure (type ->> resttype)
80 genType :: [String] -> Env Type
81 genType [] = freshIdent >>= \fi->pure $ IdType fi
82 genType [x:xs] = liftM2 (->>) (freshIdent >>= \fi->pure $ IdType fi)
85 matchFunctions :: [String] Type -> Env Type
86 matchFunctions [] (_ ->> _) = liftT $ Left $ Error "Not enough arguments"
87 matchFunctions _ (VoidType ->> _) = liftT $ Left $ Error "Cannot have a void type in the middle of the function definition"
88 matchFunctions [x:xs] (t1 ->> t2) =
89 modify (\(st, r)->('Map'.put x t1 st, r)) >>| matchFunctions xs t2
90 matchFunctions [] t = pure t
91 matchFunctions _ t = liftT $ Left $ Error "Too much argumnts"
93 semVarDecl :: VarDecl -> Env VarDecl
94 semVarDecl (VarDecl pos type ident ex) = unify type ex
95 >>= \t-> putIdent ident t >>| (pure $ VarDecl pos t ident ex)
97 checkStmt ::Type Stmt -> Env Stmt
98 checkStmt t (IfStmt c st se) = unify BoolType c >>| mapM (checkStmt t) st
99 >>= \st1-> mapM (checkStmt t) se >>= \se1-> pure (IfStmt c st1 se1)
100 checkStmt t w=:(WhileStmt c et) = unify BoolType c >>| mapM (checkStmt t) et
102 checkStmt t a=:(AssStmt (VarDef ident fs) e) = gets (\(st, r)->'Map'.get ident st)
104 Nothing = liftT $ Left $ UndeclaredVariableError zero ident
105 Just t = unify t fs >>= \t1 -> unify t1 e >>| pure a
106 checkStmt t r=:(FunStmt (FunCall f es)) = typeFun f es >>| pure r
107 checkStmt VoidType r=:(ReturnStmt Nothing) = pure r
108 checkStmt t r=:(ReturnStmt (Just e)) = unify t e >>| pure r
110 typeExpr :: Expr -> Env Type
111 typeExpr (IntExpr _ _) = pure IntType
112 typeExpr (CharExpr _ _) = pure CharType
113 typeExpr (BoolExpr _ _) = pure BoolType
114 typeExpr (Op1Expr p UnNegation expr) = unify BoolType expr
115 typeExpr (Op1Expr p UnMinus expr) = unify IntType expr
116 typeExpr (TupleExpr p (e1, e2)) = typeExpr e1
117 >>= \t1-> typeExpr e2 >>= \t2-> pure $ TupleType (t1, t2)
118 typeExpr (Op2Expr p e1 op e2)
119 | isMember op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod] =
120 typeOp2 e1 e2 op [IntType] IntType
121 | isMember op [BiEquals, BiUnEqual] =
122 typeOp2 e1 e2 op [IntType, BoolType, CharType] BoolType
123 | isMember op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq] =
124 typeOp2 e1 e2 op [IntType, CharType] BoolType
125 | isMember op [BiAnd, BiOr] =
126 typeOp2 e1 e2 op [BoolType] BoolType
127 | op == BiCons = typeExpr e1 >>= \t1-> typeExpr e2
128 >>= \t2-> unify (ListType t1) t2
129 typeExpr (EmptyListExpr p) = freshIdent >>= \frsh-> let t = IdType frsh in
130 putIdent frsh t >>| pure t
131 typeExpr (FunExpr p (FunCall f es)) = typeFun f es
132 typeExpr (VarExpr p (VarDef ident fs)) = gets (\(st, r)->'Map'.get ident st)
134 Nothing = liftT $ Left $ UndeclaredVariableError p ident
136 typeOp2 :: Expr Expr Op2 [Type] Type -> Env Type
137 typeOp2 e1 e2 op ts ret = typeExpr e1 >>= \t1-> typeExpr e2 >>= \t2->
138 unify t1 t2 >>= \t3->if (isMember t3 [IdType "":ts]) (pure ret)
139 (liftT $ Left $ OperatorError (extrPos e1) op t3)
141 buildFunctionType :: String [Expr] -> Env Type
142 buildFunctionType frsh [] = let t = IdType frsh in putIdent frsh t >>| pure t
143 buildFunctionType frsh [e:es] = (->>) <$> typeExpr e <*> buildFunctionType frsh es
145 unifyApp :: Type [Expr] -> Env Type
146 unifyApp t [] = pure t
147 unifyApp (tf1 ->> tf2) [t1:ts] = unify tf1 t1 >>| unifyApp tf2 ts
148 unifyApp t1 t2 = liftT $ Left $ UnifyError zero t1 (IdType "[expressions, FIXME]")
150 typeFun :: String [Expr] -> Env Type
151 typeFun f es = gets (\(st, r)->'Map'.get f st) >>= \mt-> case mt of
152 Nothing = freshIdent >>= \frsh-> buildFunctionType frsh es
153 >>= \ft-> putIdent f ft >>| (pure $ IdType frsh)
154 Just t = unifyApp t es
156 resultType :: Type -> Type
157 resultType (_ ->> t) = resultType t
160 class unify a :: Type a -> Env Type
162 instance unify [FieldSelector] where
164 unify (ListType t) [FieldHd:fs] = unify t fs
165 unify t=:(ListType _) [FieldTl:fs] = unify t fs
166 unify (TupleType (t, _)) [FieldFst:fs] = unify t fs
167 unify (TupleType (_, t)) [FieldSnd:fs] = unify t fs
168 unify t [fs:_] = liftT $ Left $ FieldSelectorError zero t fs
170 instance unify Expr where
171 unify (_ ->> _) e = liftT $ Left $ ParseError (extrPos e)
172 "Expression cannot be a higher order function. Yet..."
173 unify VoidType e = liftT $ Left $ ParseError (extrPos e)
174 "Expression cannot be a Void type."
175 // unify (IdType _) e = liftT $ Left $ ParseError (extrPos e)
176 // "Expression cannot be an polymorf type."
177 unify VarType e = typeExpr e
178 //we have to cheat to decorate the error, can be done nicer?
179 unify t e = StateT $ \s0 -> let res = runStateT m s0 in case res of
180 Left err = Left $ decErr e err
181 Right t = Right t //note, t :: (Type, Gamma)
182 where m = typeExpr e >>= \tex-> unify t tex
184 instance unify Type where
185 unify IntType IntType = pure IntType
186 unify BoolType BoolType = pure BoolType
187 unify CharType CharType = pure CharType
188 unify (IdType i) t=:(IdType j) = replace i t >>| pure t
189 unify t (IdType i) = unify (IdType i) t
190 unify (IdType i) t = replace i t >>| pure t
191 unify (ListType t1) (ListType t2) = unify t1 t2 >>| (pure $ ListType t1)
192 unify (ta1 ->> ta2) (tb1 ->> tb2) = unify ta1 tb1 >>= \ta-> unify ta2 tb2
193 >>= \tb-> pure (ta ->> tb)
194 unify VoidType VoidType = pure VoidType
195 unify t1 t2 = liftT $ Left $ UnifyError zero t1 t2
197 instance zero Pos where
198 zero = {line=0,col=0}
200 decErr :: Expr SemError -> SemError
201 decErr e (UnifyError _ t1 t2) = UnifyError (extrPos e) t1 t2
202 decErr e (FieldSelectorError _ t fs) = FieldSelectorError (extrPos e) t fs
203 decErr e (ParseError _ s) = ParseError (extrPos e) s
206 dc2 :: Expr (Either SemError a) -> Either SemError a
207 dc2 e (Right t) = Right t
208 dc2 e (Left err) = Left err
210 extrPos :: Expr -> Pos
211 extrPos (VarExpr p _) = p
212 extrPos (Op2Expr p _ _ _) = p
213 extrPos (Op1Expr p _ _) = p
214 extrPos (IntExpr p _) = p
215 extrPos (CharExpr p _) = p
216 extrPos (BoolExpr p _) = p
217 extrPos (FunExpr p _) = p
218 extrPos (EmptyListExpr p) = p
219 extrPos (TupleExpr p _) = p
221 instance toString Gamma where
222 toString (mp, _) = concat
223 [concat [k, ": ", toString v, "\n"]\\(k, v) <- 'Map'.toList mp]
225 getRandomStream :: Int -> [String]
226 getRandomStream i = genIdents $ filter (isAlpha o toChar) (genRandInt i)
228 genIdents r = let (ic, r2) = splitAt 5 r in [toString ic: genIdents r2]
230 freshIdent :: Env String
231 freshIdent = get >>= \(st, [ident:rest])-> put (st, rest)
232 >>| case 'Map'.get ident st of
236 putIdent :: String Type -> Env Void
237 putIdent i t = gets (\(st, r)->'Map'.get i st) >>= \mt -> case mt of
238 Nothing = modify (\(st, r)->('Map'.put i t st, r))
239 Just t2 = unify t t2 >>= \t3-> modify (\(st, r)->('Map'.put i t3 st, r))
241 replace :: String Type -> Env Void
242 replace ident type = get >>= \(st, fr)->put ('Map'.fromList $
243 map (itupdate ident type) ('Map'.toList st), fr)
245 itupdate :: String Type (String, Type) -> (String, Type)
246 itupdate ident newtype ov=:(key, IdType type) = if (ident == type)
248 itupdate ident newtype (key, TupleType (t1, t2))
249 # (_, t1) = itupdate ident newtype (key, t1)
250 # (_, t2) = itupdate ident newtype (key, t2)
251 = (key, TupleType (t1, t2))
252 itupdate ident newtype (key, ListType t1)
253 # (_, t1) = itupdate ident newtype (key, t1)
257 instance toString SemError where
258 toString (ParseError p e) = concat [
259 toString p,"SemError: ParseError: ", e]
260 toString (Error e) = "SemError: " +++ e
261 toString (UnifyError p t1 t2) = concat [
263 "SemError: Cannot unify types. Expected: ",
264 toString t1, ". Given: ", toString t2]
265 toString (FieldSelectorError p t fs) = concat [
267 "SemError: Cannot select ", toString fs, " from type: ",
269 toString (OperatorError p o t) = concat [
271 "SemError: No ", toString o, " for type ",
273 toString (UndeclaredVariableError p ident) = concat [
274 toString p, "SemError: identifier: ", ident, " undefined."]
276 saveGamma :: Env Gamma
279 restoreGamma :: Gamma -> Env Void
280 restoreGamma (oldstate, _) = gets snd >>= \newr->put (oldstate, newr)
283 instance == Type where
284 (==) (IdType _) (IdType _) = True
285 (==) o1 o2 = gEq{|*|} o1 o2