1 implementation module sem
3 import qualified Data.Map as Map
5 from Data.Func import $
6 from StdFunc import o, flip, const
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 )
93 class infer a :: a -> Infer Type
95 instance infer Expr where
96 infer (VarExpr _ vd) = undef
97 infer (Op2Expr _ e1 op e2) = case op of
99 BiMinus = pure IntType
100 BiTimes = pure IntType
101 BiDivide = pure IntType
103 BiLesser = pure IntType
104 BiGreater = pure IntType
105 BiLesserEq = pure IntType
106 BiGreaterEq = pure IntType
107 BiAnd = pure BoolType
110 BiUnEqual = infer e1 // maybe check e2?
111 BiCons = infer e1 >>= \it1->pure $ ListType it1
112 infer (Op1Expr _ op e) = case op of
113 UnMinus = pure IntType
114 UnNegation = pure BoolType
115 infer (IntExpr _ _) = pure IntType
116 infer (CharExpr _ _) = pure CharType
117 infer (BoolExpr _ _) = pure BoolType
118 infer (FunExpr _ _ _ _) = undef
119 infer (EmptyListExpr _) = undef
120 infer (TupleExpr _ (e1, e2)) =
121 infer e1 >>= \et1->infer e2 >>= \et2->pure $ TupleType (et1, et2)
123 //:: VarDef = VarDef String [FieldSelector]
124 //:: FieldSelector = FieldHd | FieldTl | FieldFst | FieldSnd
125 //:: Op1 = UnNegation | UnMinus
126 //:: Op2 = BiPlus | BiMinus | BiTimes | BiDivide | BiMod | BiEquals | BiLesser |
127 // BiGreater | BiLesserEq | BiGreaterEq | BiUnEqual | BiAnd | BiOr | BiCons
128 //:: FunDecl = FunDecl Pos String [String] (Maybe Type) [VarDecl] [Stmt]
129 //:: FunCall = FunCall String [Expr]
131 // = IfStmt Expr [Stmt] [Stmt]
132 // | WhileStmt Expr [Stmt]
133 // | AssStmt VarDef Expr
135 // | ReturnStmt (Maybe Expr)
136 //:: Pos = {line :: Int, col :: Int}
137 //:: AST = AST [VarDecl] [FunDecl]
138 //:: VarDecl = VarDecl Pos Type String Expr
140 // = TupleType (Type, Type)
148 // | (->>) infixl 7 Type Type