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
22 from Text import class Text(concat), instance Text String
26 :: Scheme = Forall [String] Type
27 :: Gamma :== 'Map'.Map String Scheme
28 :: Constraints :== [(Type, Type)]
29 :: Infer a :== RWST Gamma Constraints [String] (Either SemError) a
31 = ParseError Pos String
32 | UnifyError Pos Type Type
33 | FieldSelectorError Pos Type FieldSelector
34 | OperatorError Pos Op2 Type
35 | UndeclaredVariableError Pos String
36 | ArgumentMisMatchError Pos String
37 | SanityError Pos String
40 instance zero Gamma where
43 variableStream :: [String]
44 variableStream = map toString [1..]
46 sem :: AST -> Either [SemError] Constraints
47 sem (AST fd) = case foldM (const $ hasNoDups fd) () fd
48 >>| foldM (const isNiceMain) () fd
51 _ = case execRWST (constraints fd) zero variableStream of
53 Right (a, b) = Right b
55 constraints :: [FunDecl] -> Infer ()
56 constraints fds = mapM_ funconstraint fds >>| pure ()
58 funconstraint :: FunDecl -> Infer ()
59 funconstraint fd=:(FunDecl _ ident args mt vardecls stmts) = case mt of
60 Nothing = abort "Cannot infer functions yet"
61 Just t = inEnv (ident, (Forall [] t)) (
62 mapM_ vardeclconstraint vardecls >>| pure ())
64 vardeclconstraint :: VarDecl -> Infer ()
65 vardeclconstraint (VarDecl p mt ident expr) = infer expr
66 >>= \it->inEnv (ident, (Forall [] it)) (pure ())
68 hasNoDups :: [FunDecl] FunDecl -> Either SemError ()
69 hasNoDups fds (FunDecl p n _ _ _ _)
70 # mbs = map (\(FunDecl p` n` _ _ _ _)->if (n == n`) (Just p`) Nothing) fds
71 = case catMaybes mbs of
72 [] = Left $ SanityError p "HUH THIS SHOULDN'T HAPPEN"
74 [_:x] = Left $ SanityError p (concat
75 [n, " multiply defined at ", toString p])
77 hasMain :: [FunDecl] -> Either SemError ()
78 hasMain [(FunDecl _ "main" _ _ _ _):fd] = pure ()
79 hasMain [_:fd] = hasMain fd
80 hasMain [] = Left $ SanityError zero "no main function defined"
82 isNiceMain :: FunDecl -> Either SemError ()
83 isNiceMain (FunDecl p "main" as mt _ _) = case (as, mt) of
84 ([_:_], _) = Left $ SanityError p "main must have arity 0"
87 Just VoidType = pure ()
88 _ = Left $ SanityError p "main has to return Void")
89 isNiceMain _ = pure ()
91 instance toString Scheme where
92 toString (Forall x t) =
93 concat ["Forall ": map ((+++) "\n") x] +++ toString t
95 instance toString Gamma where
97 concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]
99 instance toString SemError where
100 toString (SanityError p e) = concat [toString p,
101 "SemError: SanityError: ", e]
102 toString se = "SemError: "
104 uni :: Type Type -> Infer ()
105 uni t1 t2 = tell [(t1, t2)]
107 inEnv :: (String, Scheme) (Infer a) -> Infer a
108 inEnv (x, sc) m = local ('Map'.put x sc) m
111 fresh = (gets id) >>= \vars-> (put $ tail vars) >>| (pure $ IdType $ head vars)
113 op2Type :: Op2 -> Infer Type
115 | elem op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod]
116 = pure (IntType ->> IntType ->> IntType)
117 | elem op [BiEquals, BiUnEqual]
118 = fresh >>= \t1-> fresh >>= \t2-> pure (t1 ->> t2 ->> BoolType)
119 | elem op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq]
120 = pure (IntType ->> IntType ->> BoolType)
121 | elem op [BiAnd, BiOr]
122 = pure (BoolType ->> BoolType ->> BoolType)
124 = fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)
126 op1Type :: Op1 -> Infer Type
127 op1Type UnNegation = pure $ (BoolType ->> BoolType)
128 op1Type UnMinus = pure $ (IntType ->> IntType)
130 //instantiate :: Scheme -> Infer Type
131 //instantiate (Forall as t) = mapM (const fresh) as
133 lookupEnv :: String -> Infer Type
134 lookupEnv ident = asks ('Map'.get ident)
136 Nothing = liftT $ Left $ UndeclaredVariableError zero ident
137 Just (Forall as t) = pure t //instantiate ???
139 class infer a :: a -> Infer Type
140 instance infer Expr where
141 infer (VarExpr _ (VarDef ident fs)) = lookupEnv ident
142 infer (Op2Expr _ e1 op e2) = case op of
143 BiPlus = pure IntType
144 BiMinus = pure IntType
145 BiTimes = pure IntType
146 BiDivide = pure IntType
148 BiLesser = pure IntType
149 BiGreater = pure IntType
150 BiLesserEq = pure IntType
151 BiGreaterEq = pure IntType
152 BiAnd = pure BoolType
155 BiUnEqual = infer e1 // maybe check e2?
156 BiCons = infer e1 >>= \it1->pure $ ListType it1
157 infer (Op1Expr _ op e) = case op of
158 UnMinus = pure IntType
159 UnNegation = pure BoolType
160 infer (IntExpr _ _) = pure IntType
161 infer (CharExpr _ _) = pure CharType
162 infer (BoolExpr _ _) = pure BoolType
163 infer (FunExpr _ _ _ _) = undef
164 infer (EmptyListExpr _) = undef
165 infer (TupleExpr _ (e1, e2)) =
166 infer e1 >>= \et1->infer e2 >>= \et2->pure $ TupleType (et1, et2)
168 //:: VarDef = VarDef String [FieldSelector]
169 //:: FieldSelector = FieldHd | FieldTl | FieldFst | FieldSnd
170 //:: Op1 = UnNegation | UnMinus
171 //:: Op2 = BiPlus | BiMinus | BiTimes | BiDivide | BiMod | BiEquals | BiLesser |
172 // BiGreater | BiLesserEq | BiGreaterEq | BiUnEqual | BiAnd | BiOr | BiCons
173 //:: FunDecl = FunDecl Pos String [String] (Maybe Type) [VarDecl] [Stmt]
174 //:: FunCall = FunCall String [Expr]
176 // = IfStmt Expr [Stmt] [Stmt]
177 // | WhileStmt Expr [Stmt]
178 // | AssStmt VarDef Expr
180 // | ReturnStmt (Maybe Expr)
181 //:: Pos = {line :: Int, col :: Int}
182 //:: AST = AST [VarDecl] [FunDecl]
183 //:: VarDecl = VarDecl Pos Type String Expr
185 // = TupleType (Type, Type)
193 // | (->>) infixl 7 Type Type