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
27 :: Scheme = Forall [String] Type
28 :: Gamma :== 'Map'.Map String Scheme
29 :: Constraints :== [(Type, Type)]
30 :: Infer a :== RWST Gamma Constraints [String] (Either SemError) a
32 = ParseError Pos String
33 | UnifyError Pos Type Type
34 | FieldSelectorError Pos Type FieldSelector
35 | OperatorError Pos Op2 Type
36 | UndeclaredVariableError Pos String
37 | ArgumentMisMatchError Pos String
38 | SanityError Pos String
41 instance zero Gamma where
44 //runInfer :: Gamma (Infer a) -> Either SemError a
45 //runInfer env m = evalRWST m env variableStream
47 variableStream :: [String]
48 variableStream = map toString [1..]
50 sem :: AST -> Either [SemError] Constraints
51 sem (AST fd) = case foldM (const $ hasNoDups fd) () fd
52 >>| foldM (const isNiceMain) () fd
55 _ = case execRWST (constraints fd) zero variableStream of
57 Right (a, b) = Right b
59 constraints :: [FunDecl] -> Infer ()
60 constraints fds = mapM_ funconstraint fds >>| pure ()
62 funconstraint :: FunDecl -> Infer ()
63 funconstraint fd=:(FunDecl _ ident args mt vardecls stmts) = case mt of
64 Nothing = abort "Cannot infer functions yet"
65 Just t = inEnv (ident, (Forall [] t)) (
66 mapM_ vardeclconstraint vardecls >>| pure ())
68 vardeclconstraint :: VarDecl -> Infer ()
69 vardeclconstraint (VarDecl p mt ident expr) = infer expr
70 >>= \it->inEnv (ident, (Forall [] it)) (pure ())
72 hasNoDups :: [FunDecl] FunDecl -> Either SemError ()
73 hasNoDups fds (FunDecl p n _ _ _ _)
74 # mbs = map (\(FunDecl p` n` _ _ _ _)->if (n == n`) (Just p`) Nothing) fds
75 = case catMaybes mbs of
76 [] = Left $ SanityError p "HUH THIS SHOULDN'T HAPPEN"
78 [_:x] = Left $ SanityError p (concat
79 [n, " multiply defined at ", toString p])
81 hasMain :: [FunDecl] -> Either SemError ()
82 hasMain [(FunDecl _ "main" _ _ _ _):fd] = pure ()
83 hasMain [_:fd] = hasMain fd
84 hasMain [] = Left $ SanityError zero "no main function defined"
86 isNiceMain :: FunDecl -> Either SemError ()
87 isNiceMain (FunDecl p "main" as mt _ _) = case (as, mt) of
88 ([_:_], _) = Left $ SanityError p "main must have arity 0"
91 Just VoidType = pure ()
92 _ = Left $ SanityError p "main has to return Void")
93 isNiceMain _ = pure ()
95 instance toString Scheme where
96 toString (Forall x t) =
97 concat ["Forall ": map ((+++) "\n") x] +++ toString t
99 instance toString Gamma where
101 concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]
103 instance toString SemError where
104 toString (SanityError p e) = concat [toString p,
105 "SemError: SanityError: ", e]
106 toString se = "SemError: "
108 // ------------------------
109 // First step: Inference
110 // ------------------------
112 unify :: Type Type -> Infer ()
113 unify t1 t2 = tell [(t1, t2)]
115 inEnv :: (String, Scheme) (Infer a) -> Infer a
116 inEnv (x, sc) m = local ('Map'.put x sc) m
119 fresh = (gets id) >>= \vars-> (put $ tail vars) >>| (pure $ IdType $ head vars)
121 op2Type :: Op2 -> Infer Type
123 | elem op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod]
124 = pure (IntType ->> IntType ->> IntType)
125 | elem op [BiEquals, BiUnEqual]
126 = fresh >>= \t1-> fresh >>= \t2-> pure (t1 ->> t2 ->> BoolType)
127 | elem op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq]
128 = pure (IntType ->> IntType ->> BoolType)
129 | elem op [BiAnd, BiOr]
130 = pure (BoolType ->> BoolType ->> BoolType)
132 = fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)
134 op1Type :: Op1 -> Infer Type
135 op1Type UnNegation = pure $ (BoolType ->> BoolType)
136 op1Type UnMinus = pure $ (IntType ->> IntType)
138 //instantiate :: Scheme -> Infer Type
139 //instantiate (Forall as t) = mapM (const fresh) as
141 lookupEnv :: String -> Infer Type
142 lookupEnv ident = asks ('Map'.get ident)
144 Nothing = liftT $ Left $ UndeclaredVariableError zero ident
145 Just (Forall as t) = pure t //instantiate ???
147 class infer a :: a -> Infer Type
148 instance infer Expr where
149 infer (VarExpr _ (VarDef ident fs)) = lookupEnv ident
150 infer (Op2Expr _ e1 op e2) =
154 let given = t1 ->> (t2 ->> frsh) in
155 op2Type op >>= \expected ->
156 unify expected given >>|
158 infer (Op1Expr _ op e) =
161 let given = t1 ->> frsh in
162 op1Type op >>= \expected ->
163 unify expected given >>|
165 infer (IntExpr _ _) = pure IntType
166 infer (CharExpr _ _) = pure CharType
167 infer (BoolExpr _ _) = pure BoolType
168 infer (FunExpr _ f args sels) = //todo, iets met field selectors
169 lookupEnv f >>= \expected ->
171 mapM infer args >>= \argTypes ->
172 let given = foldr (->>) frsh argTypes in
173 unify expected given >>|
175 infer (EmptyListExpr _) = ListType <$> fresh
176 infer (TupleExpr _ (e1, e2)) =
177 infer e1 >>= \et1->infer e2 >>= \et2->pure $ TupleType (et1, et2)
179 //:: VarDef = VarDef String [FieldSelector]
180 //:: FieldSelector = FieldHd | FieldTl | FieldFst | FieldSnd
181 //:: Op1 = UnNegation | UnMinus
182 //:: Op2 = BiPlus | BiMinus | BiTimes | BiDivide | BiMod | BiEquals | BiLesser |
183 // BiGreater | BiLesserEq | BiGreaterEq | BiUnEqual | BiAnd | BiOr | BiCons
184 //:: FunDecl = FunDecl Pos String [String] (Maybe Type) [VarDecl] [Stmt]
185 //:: FunCall = FunCall String [Expr]
187 // = IfStmt Expr [Stmt] [Stmt]
188 // | WhileStmt Expr [Stmt]
189 // | AssStmt VarDef Expr
191 // | ReturnStmt (Maybe Expr)
192 //:: Pos = {line :: Int, col :: Int}
193 //:: AST = AST [VarDecl] [FunDecl]
194 //:: VarDecl = VarDecl Pos Type String Expr
196 // = TupleType (Type, Type)
204 // | (->>) infixl 7 Type Type