1 implementation module sem
3 import qualified Data.Map as Map
5 from Data.Func import $
6 from StdFunc import o, flip, const, id
21 from Text import class Text(concat), instance Text String
25 :: Scheme = Forall [String] Type
26 :: Gamma :== 'Map'.Map String Scheme
27 :: Constraints :== [(Type, Type)]
28 :: Infer a :== RWST Gamma Constraints [String] (Either SemError) a
30 = ParseError Pos String
31 | UnifyError Pos Type Type
32 | FieldSelectorError Pos Type FieldSelector
33 | OperatorError Pos Op2 Type
34 | UndeclaredVariableError Pos String
35 | ArgumentMisMatchError Pos String
36 | SanityError Pos String
39 variableStream :: [String]
40 variableStream = map toString [1..]
42 sem :: AST -> SemOutput
43 sem a=:(AST fd) = case foldM (const $ hasNoDups fd) () fd
44 >>| foldM (const isNiceMain) () fd
47 _ = pure (a, 'Map'.newMap)
49 hasNoDups :: [FunDecl] FunDecl -> Either SemError ()
50 hasNoDups fds (FunDecl p n _ _ _ _)
51 # mbs = map (\(FunDecl p` n` _ _ _ _)->if (n == n`) (Just p`) Nothing) fds
52 = case catMaybes mbs of
53 [] = Left $ SanityError p "HUH THIS SHOULDN'T HAPPEN"
55 [_:x] = Left $ SanityError p (concat
56 [n, " multiply defined at ", toString p])
58 hasMain :: [FunDecl] -> Either SemError ()
59 hasMain [(FunDecl _ "main" _ _ _ _):fd] = pure ()
60 hasMain [_:fd] = hasMain fd
61 hasMain [] = Left $ SanityError zero "no main function defined"
63 isNiceMain :: FunDecl -> Either SemError ()
64 isNiceMain (FunDecl p "main" as mt _ _) = case (as, mt) of
65 ([_:_], _) = Left $ SanityError p "main must have arity 0"
68 Just VoidType = pure ()
69 _ = Left $ SanityError p "main has to return Void")
70 isNiceMain _ = pure ()
72 instance toString Scheme where
73 toString (Forall x t) =
74 concat ["Forall ": map ((+++) "\n") x] +++ toString t
76 instance toString Gamma where
78 concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]
80 instance toString SemError where
81 toString (SanityError p e) = concat [toString p,
82 "SemError: SanityError: ", e]
83 toString se = "SemError: "
85 uni :: Type Type -> Infer ()
86 uni t1 t2 = tell [(t1, t2)]
88 inEnv :: (String, Scheme) (Infer a) -> (Infer a)
89 inEnv (x, sc) m = local scope m
91 scope e = 'Map'.put x sc ('Map'.del x e )
94 fresh = (gets id) >>= \vars-> (put $ tail vars) >>| (pure $ IdType $ head vars)
96 class infer a :: a -> Infer Type
98 op2Type :: Op2 -> Infer Type
99 op2Type op | elem op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod]
100 = pure (IntType ->> IntType ->> IntType)
101 | elem op [BiEquals, BiUnEqual]
102 = fresh >>= \t1-> fresh >>= \t2-> pure (t1 ->> t2 ->> BoolType)
103 | elem op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq]
104 = pure (IntType ->> IntType ->> BoolType)
105 | elem op [BiAnd, BiOr]
106 = pure (BoolType ->> BoolType ->> BoolType)
108 = fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)
110 op1Type :: Op1 -> Infer Type
111 op1Type UnNegation = pure $ (BoolType ->> BoolType)
112 op1Type UnMinus = pure $ (IntType ->> IntType)
114 instance infer Expr where
115 infer (VarExpr _ vd) = undef
116 infer (Op2Expr _ e1 op e2) = case op of
117 BiPlus = pure IntType
118 BiMinus = pure IntType
119 BiTimes = pure IntType
120 BiDivide = pure IntType
122 BiLesser = pure IntType
123 BiGreater = pure IntType
124 BiLesserEq = pure IntType
125 BiGreaterEq = pure IntType
126 BiAnd = pure BoolType
129 BiUnEqual = infer e1 // maybe check e2?
130 BiCons = infer e1 >>= \it1->pure $ ListType it1
131 infer (Op1Expr _ op e) = case op of
132 UnMinus = pure IntType
133 UnNegation = pure BoolType
134 infer (IntExpr _ _) = pure IntType
135 infer (CharExpr _ _) = pure CharType
136 infer (BoolExpr _ _) = pure BoolType
137 infer (FunExpr _ _ _ _) = undef
138 infer (EmptyListExpr _) = undef
139 infer (TupleExpr _ (e1, e2)) =
140 infer e1 >>= \et1->infer e2 >>= \et2->pure $ TupleType (et1, et2)
142 //:: VarDef = VarDef String [FieldSelector]
143 //:: FieldSelector = FieldHd | FieldTl | FieldFst | FieldSnd
144 //:: Op1 = UnNegation | UnMinus
145 //:: Op2 = BiPlus | BiMinus | BiTimes | BiDivide | BiMod | BiEquals | BiLesser |
146 // BiGreater | BiLesserEq | BiGreaterEq | BiUnEqual | BiAnd | BiOr | BiCons
147 //:: FunDecl = FunDecl Pos String [String] (Maybe Type) [VarDecl] [Stmt]
148 //:: FunCall = FunCall String [Expr]
150 // = IfStmt Expr [Stmt] [Stmt]
151 // | WhileStmt Expr [Stmt]
152 // | AssStmt VarDef Expr
154 // | ReturnStmt (Maybe Expr)
155 //:: Pos = {line :: Int, col :: Int}
156 //:: AST = AST [VarDecl] [FunDecl]
157 //:: VarDecl = VarDecl Pos Type String Expr
159 // = TupleType (Type, Type)
167 // | (->>) infixl 7 Type Type