sem.icl

   1 implementation module sem
   2
   3 import qualified Data.Map as Map
   4
   5 from Data.Func import $
   6 from StdFunc import o, flip, const, id
   7
   8 import Control.Monad
   9 import Control.Monad.Trans
  10 import Data.Either
  11 import Data.Maybe
  12 import Data.Monoid
  13 import Data.List
  14
  15 import StdString
  16 import StdList
  17 import StdMisc
  18 import StdEnum
  19 import RWST
  20 import GenEq
  21
  22 from Text import class Text(concat), instance Text String
  23
  24 import AST
  25
  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
  30 :: SemError
  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
  38         | Error String
  39
  40 instance zero Gamma where
  41         zero = 'Map'.newMap
  42
  43 variableStream :: [String]
  44 variableStream = map toString [1..]
  45
  46 sem :: AST -> Either [SemError] Constraints
  47 sem (AST fd) = case foldM (const $ hasNoDups fd) () fd
  48                 >>| foldM (const isNiceMain) () fd
  49                 >>| hasMain fd of
  50         Left e = Left [e]
  51         _ = case execRWST (constraints fd) zero variableStream of
  52                 Left e = Left [e]
  53                 Right (a, b) = Right b
  54 where
  55                 constraints :: [FunDecl] -> Infer ()
  56                 constraints fds = mapM_ funconstraint fds >>| pure ()
  57
  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 ())
  63
  64                 vardeclconstraint :: VarDecl -> Infer ()
  65                 vardeclconstraint (VarDecl p mt ident expr) = infer expr
  66                         >>= \it->inEnv (ident, (Forall [] it)) (pure ())
  67
  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"
  73                         [x] = pure ()
  74                         [_:x] = Left $ SanityError p (concat
  75                                 [n, " multiply defined at ", toString p])
  76
  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"
  81
  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"
  85                         ([], t) = (case t of
  86                                 Nothing = pure ()
  87                                 Just VoidType = pure ()
  88                                 _ = Left $ SanityError p "main has to return Void")
  89                 isNiceMain _ = pure ()
  90
  91 instance toString Scheme where
  92         toString (Forall x t) =
  93                 concat ["Forall ": map ((+++) "\n") x] +++ toString t
  94
  95 instance toString Gamma where
  96         toString mp =
  97                 concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]
  98
  99 instance toString SemError where
 100         toString (SanityError p e) = concat [toString p,
 101                 "SemError: SanityError: ", e]
 102         toString se = "SemError: "
 103
 104 uni :: Type Type -> Infer ()
 105 uni t1 t2 = tell [(t1, t2)]
 106
 107 inEnv :: (String, Scheme) (Infer a) -> Infer a
 108 inEnv (x, sc) m = local ('Map'.put x sc) m
 109
 110 fresh :: Infer Type
 111 fresh = (gets id) >>= \vars-> (put $ tail vars) >>| (pure $ IdType $ head vars)
 112
 113 op2Type :: Op2 -> Infer Type
 114 op2Type op
 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)
 123 | op == BiCons
 124         = fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)
 125
 126 op1Type :: Op1 -> Infer Type
 127 op1Type UnNegation = pure $ (BoolType ->> BoolType)
 128 op1Type UnMinus = pure $ (IntType ->> IntType)
 129
 130 //instantiate :: Scheme -> Infer Type
 131 //instantiate (Forall as t) = mapM (const fresh) as
 132
 133 lookupEnv :: String -> Infer Type
 134 lookupEnv ident = asks ('Map'.get ident)
 135         >>= \m->case m of
 136                 Nothing = liftT $ Left $ UndeclaredVariableError zero ident
 137                 Just (Forall as t) = pure t //instantiate ???
 138
 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
 147                 BiMod = pure IntType
 148                 BiLesser = pure IntType
 149                 BiGreater = pure IntType
 150                 BiLesserEq = pure IntType
 151                 BiGreaterEq = pure IntType
 152                 BiAnd = pure BoolType
 153                 BiOr = pure BoolType
 154                 BiEquals = infer e1
 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)
 167
 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]
 175 //:: Stmt
 176 //      = IfStmt Expr [Stmt] [Stmt]
 177 //      | WhileStmt Expr [Stmt]
 178 //      | AssStmt VarDef Expr
 179 //      | FunStmt FunCall
 180 //      | ReturnStmt (Maybe Expr)
 181 //:: Pos = {line :: Int, col :: Int}
 182 //:: AST = AST [VarDecl] [FunDecl]
 183 //:: VarDecl = VarDecl Pos Type String Expr
 184 //:: Type
 185 //      = TupleType (Type, Type)
 186 //      | ListType Type
 187 //      | IdType String
 188 //      | IntType
 189 //      | BoolType
 190 //      | CharType
 191 //      | VarType
 192 //    | VoidType
 193 //    | (->>) infixl 7 Type Type