1 implementation module sem
3 import qualified Data.Map as Map
5 from Data.Func import $
6 from StdFunc import o, flip, const, id
9 import Control.Monad.Trans
23 from Text import class Text(concat), instance Text String
28 :: Scheme = Forall [TVar] Type
29 :: Gamma :== 'Map'.Map String Scheme //map from Variables! to types
30 :: Substitution :== 'Map'.Map TVar Type
31 :: Constraints :== [(Type, Type)]
32 :: Infer a :== RWST Gamma Constraints [String] (Either SemError) a
34 = ParseError Pos String
35 | UnifyError Pos Type Type
36 | FieldSelectorError Pos Type FieldSelector
37 | OperatorError Pos Op2 Type
38 | UndeclaredVariableError Pos String
39 | ArgumentMisMatchError Pos String
40 | SanityError Pos String
43 instance zero Gamma where
46 variableStream :: [String]
47 variableStream = map toString [1..]
49 sem :: AST -> Either [SemError] Constraints
50 sem (AST fd) = case foldM (const $ hasNoDups fd) () fd
51 >>| foldM (const isNiceMain) () fd
54 _ = case execRWST (constraints fd) zero variableStream of
56 Right (a, b) = Right b
58 constraints :: [FunDecl] -> Infer ()
59 constraints _ = pure ()
61 //constraints fds = mapM_ funconstraint fds >>| pure ()
63 funconstraint :: FunDecl -> Infer ()
64 funconstraint fd=:(FunDecl _ ident args mt vardecls stmts) = case mt of
65 Nothing = abort "Cannot infer functions yet"
66 Just t = inEnv (ident, (Forall [] t)) (
67 mapM_ vardeclconstraint vardecls >>| pure ())
69 vardeclconstraint :: VarDecl -> Infer ()
70 vardeclconstraint _ = pure ()
72 //vardeclconstraint (VarDecl p mt ident expr) = infer expr
73 //>>= \it->inEnv (ident, (Forall [] it)) (pure ())
75 hasNoDups :: [FunDecl] FunDecl -> Either SemError ()
76 hasNoDups fds (FunDecl p n _ _ _ _)
77 # mbs = map (\(FunDecl p` n` _ _ _ _)->if (n == n`) (Just p`) Nothing) fds
78 = case catMaybes mbs of
79 [] = Left $ SanityError p "HUH THIS SHOULDN'T HAPPEN"
81 [_:x] = Left $ SanityError p (concat
82 [n, " multiply defined at ", toString p])
84 hasMain :: [FunDecl] -> Either SemError ()
85 hasMain [(FunDecl _ "main" _ _ _ _):fd] = pure ()
86 hasMain [_:fd] = hasMain fd
87 hasMain [] = Left $ SanityError zero "no main function defined"
89 isNiceMain :: FunDecl -> Either SemError ()
90 isNiceMain (FunDecl p "main" as mt _ _) = case (as, mt) of
91 ([_:_], _) = Left $ SanityError p "main must have arity 0"
94 Just VoidType = pure ()
95 _ = Left $ SanityError p "main has to return Void")
96 isNiceMain _ = pure ()
98 instance toString Scheme where
99 toString (Forall x t) =
100 concat ["Forall ": map ((+++) "\n") x] +++ toString t
102 instance toString Gamma where
104 concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]
106 instance toString SemError where
107 toString (SanityError p e) = concat [toString p,
108 "SemError: SanityError: ", e]
109 toString se = "SemError: "
111 inEnv :: (String, Scheme) (Infer a) -> Infer a
112 inEnv (x, sc) m = local ('Map'.put x sc) m
114 class Typeable a where
116 subst :: Substitution a -> a
118 instance Typeable Scheme where
119 ftv (Forall bound t) = difference (ftv t) bound
120 subst s (Forall bound t) = Forall bound $ subst s_ t
121 where s_ = 'Map'.filterWithKey (\k _ -> not (elem k bound)) s
123 instance Typeable [a] | Typeable a where
124 ftv types = foldr (\t ts-> ftv t ++ ts) [] types
125 subst s ts = map (\t->subst s t) ts
127 instance Typeable Type where
128 ftv (TupleType (t1, t2)) = ftv t1 ++ ftv t2
129 ftv (ListType t) = ftv t
130 ftv (IdType tvar) = [tvar]
131 ftv (t1 ->> t2) = ftv t1 ++ ftv t2
133 subst s (TupleType (t1, t2))= TupleType (subst s t1, subst s t2)
134 subst s (ListType t1) = ListType (subst s t1)
135 subst s (t1 ->> t2) = (subst s t1) ->> (subst s t2)
136 subst s t1=:(IdType tvar) = 'Map'.findWithDefault t1 tvar s
139 instance Typeable Gamma where
140 ftv gamma = concatMap id $ map ftv ('Map'.elems gamma)
141 subst s gamma = Mapmap (subst s) gamma
143 //// ------------------------
144 //// algorithm U, Unification (outside of Monad)
145 //// ------------------------
146 instance zero Substitution where zero = 'Map'.newMap
147 compose :: Substitution Substitution -> Substitution
148 compose s1 s2 = undef
154 Mapmap :: (a->b) ('Map'.Map k a) -> ('Map'.Map k b)
155 Mapmap _ 'Map'.Tip = 'Map'.Tip
156 Mapmap f ('Map'.Bin sz k v ml mr) = 'Map'.Bin sz k (f v)
160 //// ------------------------
161 //// First step: Inference
162 //// ------------------------//
164 //unify :: Type Type -> Infer ()
165 //unify t1 t2 = tell [(t1, t2)]//
167 //fresh :: Infer Type
168 //fresh = (gets id) >>= \vars-> (put $ tail vars) >>| (pure $ IdType $ head vars)//
170 //op2Type :: Op2 -> Infer Type
172 //| elem op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod]
173 // = pure (IntType ->> IntType ->> IntType)
174 //| elem op [BiEquals, BiUnEqual]
175 // = fresh >>= \t1-> fresh >>= \t2-> pure (t1 ->> t2 ->> BoolType)
176 //| elem op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq]
177 // = pure (IntType ->> IntType ->> BoolType)
178 //| elem op [BiAnd, BiOr]
179 // = pure (BoolType ->> BoolType ->> BoolType)
181 // = fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)//
183 //op1Type :: Op1 -> Infer Type
184 //op1Type UnNegation = pure $ (BoolType ->> BoolType)
185 //op1Type UnMinus = pure $ (IntType ->> IntType)//
187 ////instantiate :: Scheme -> Infer Type
188 ////instantiate (Forall as t) = mapM (const fresh) as//
190 //lookupEnv :: String -> Infer Type
191 //lookupEnv ident = asks ('Map'.get ident)
193 // Nothing = liftT $ Left $ UndeclaredVariableError zero ident
194 // Just (Forall as t) = pure t //instantiate ???//
196 //class infer a :: a -> Infer Type
197 //instance infer Expr where
198 // infer (VarExpr _ (VarDef ident fs)) = lookupEnv ident
199 // infer (Op2Expr _ e1 op e2) =
200 // infer e1 >>= \t1 ->
201 // infer e2 >>= \t2 ->
202 // fresh >>= \frsh ->
203 // let given = t1 ->> (t2 ->> frsh) in
204 // op2Type op >>= \expected ->
205 // unify expected given >>|
207 // infer (Op1Expr _ op e) =
208 // infer e >>= \t1 ->
209 // fresh >>= \frsh ->
210 // let given = t1 ->> frsh in
211 // op1Type op >>= \expected ->
212 // unify expected given >>|
214 // infer (IntExpr _ _) = pure IntType
215 // infer (CharExpr _ _) = pure CharType
216 // infer (BoolExpr _ _) = pure BoolType
217 // infer (FunExpr _ f args sels) = //todo, iets met field selectors
218 // lookupEnv f >>= \expected ->
219 // fresh >>= \frsh ->
220 // mapM infer args >>= \argTypes ->
221 // let given = foldr (->>) frsh argTypes in
222 // unify expected given >>|
224 // infer (EmptyListExpr _) = ListType <$> fresh
225 // infer (TupleExpr _ (e1, e2)) =
226 // infer e1 >>= \et1->infer e2 >>= \et2->pure $ TupleType (et1, et2)//
228 ////:: VarDef = VarDef String [FieldSelector]
229 ////:: FieldSelector = FieldHd | FieldTl | FieldFst | FieldSnd
230 ////:: Op1 = UnNegation | UnMinus
231 ////:: Op2 = BiPlus | BiMinus | BiTimes | BiDivide | BiMod | BiEquals | BiLesser |
232 //// BiGreater | BiLesserEq | BiGreaterEq | BiUnEqual | BiAnd | BiOr | BiCons
233 ////:: FunDecl = FunDecl Pos String [String] (Maybe Type) [VarDecl] [Stmt]
234 ////:: FunCall = FunCall String [Expr]
236 //// = IfStmt Expr [Stmt] [Stmt]
237 //// | WhileStmt Expr [Stmt]
238 //// | AssStmt VarDef Expr
239 //// | FunStmt FunCall
240 //// | ReturnStmt (Maybe Expr)
241 ////:: Pos = {line :: Int, col :: Int}
242 ////:: AST = AST [VarDecl] [FunDecl]
243 ////:: VarDecl = VarDecl Pos Type String Expr
245 //// = TupleType (Type, Type)
253 //// | (->>) infixl 7 Type Type