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 import Data.Functor
  15
  16 import StdString
  17 import StdList
  18 import StdMisc
  19 import StdEnum
  20 import RWST
  21 import GenEq
  22
  23 from Text import class Text(concat), instance Text String
  24
  25 import AST
  26
  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
  31 :: SemError
  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
  39         | Error String
  40
  41 instance zero Gamma where
  42         zero = 'Map'.newMap
  43
  44 //runInfer :: Gamma (Infer a) -> Either SemError a
  45 //runInfer env m = evalRWST m env variableStream
  46
  47 variableStream :: [String]
  48 variableStream = map toString [1..]
  49
  50 sem :: AST -> Either [SemError] Constraints
  51 sem (AST fd) = case foldM (const $ hasNoDups fd) () fd
  52                 >>| foldM (const isNiceMain) () fd
  53                 >>| hasMain fd of
  54         Left e = Left [e]
  55         _ = case execRWST (constraints fd) zero variableStream of
  56                 Left e = Left [e]
  57                 Right (a, b) = Right b
  58 where
  59                 constraints :: [FunDecl] -> Infer ()
  60                 constraints fds = mapM_ funconstraint fds >>| pure ()
  61
  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 ())
  67
  68                 vardeclconstraint :: VarDecl -> Infer ()
  69                 vardeclconstraint (VarDecl p mt ident expr) = infer expr
  70                         >>= \it->inEnv (ident, (Forall [] it)) (pure ())
  71
  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"
  77                         [x] = pure ()
  78                         [_:x] = Left $ SanityError p (concat
  79                                 [n, " multiply defined at ", toString p])
  80
  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"
  85
  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"
  89                         ([], t) = (case t of
  90                                 Nothing = pure ()
  91                                 Just VoidType = pure ()
  92                                 _ = Left $ SanityError p "main has to return Void")
  93                 isNiceMain _ = pure ()
  94
  95 instance toString Scheme where
  96         toString (Forall x t) =
  97                 concat ["Forall ": map ((+++) "\n") x] +++ toString t
  98
  99 instance toString Gamma where
 100         toString mp =
 101                 concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]
 102
 103 instance toString SemError where
 104         toString (SanityError p e) = concat [toString p,
 105                 "SemError: SanityError: ", e]
 106         toString se = "SemError: "
 107
 108 // ------------------------
 109 // First step: Inference
 110 // ------------------------
 111
 112 unify :: Type Type -> Infer ()
 113 unify t1 t2 = tell [(t1, t2)]
 114
 115 inEnv :: (String, Scheme) (Infer a) -> Infer a
 116 inEnv (x, sc) m = local ('Map'.put x sc) m
 117
 118 fresh :: Infer Type
 119 fresh = (gets id) >>= \vars-> (put $ tail vars) >>| (pure $ IdType $ head vars)
 120
 121 op2Type :: Op2 -> Infer Type
 122 op2Type op
 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)
 131 | op == BiCons
 132         = fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)
 133
 134 op1Type :: Op1 -> Infer Type
 135 op1Type UnNegation = pure $ (BoolType ->> BoolType)
 136 op1Type UnMinus = pure $ (IntType ->> IntType)
 137
 138 //instantiate :: Scheme -> Infer Type
 139 //instantiate (Forall as t) = mapM (const fresh) as
 140
 141 lookupEnv :: String -> Infer Type
 142 lookupEnv ident = asks ('Map'.get ident)
 143         >>= \m->case m of
 144                 Nothing = liftT $ Left $ UndeclaredVariableError zero ident
 145                 Just (Forall as t) = pure t //instantiate ???
 146
 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) =
 151         infer e1 >>= \t1 ->
 152         infer e2 >>= \t2 ->
 153         fresh >>= \frsh ->
 154         let given = t1 ->> (t2 ->> frsh) in
 155         op2Type op >>= \expected ->
 156         unify expected given >>|
 157         return frsh
 158         infer (Op1Expr _ op e) =
 159         infer e >>= \t1 ->
 160         fresh >>= \frsh ->
 161         let given = t1 ->> frsh in
 162         op1Type op >>= \expected ->
 163         unify expected given >>|
 164         pure frsh
 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 ->
 170         fresh >>= \frsh ->
 171         mapM infer args >>= \argTypes ->
 172         let given = foldr (->>) frsh argTypes in
 173         unify expected given >>|
 174         pure frsh
 175         infer (EmptyListExpr _) = ListType <$> fresh
 176         infer (TupleExpr _ (e1, e2)) =
 177                 infer e1 >>= \et1->infer e2 >>= \et2->pure $ TupleType (et1, et2)
 178
 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]
 186 //:: Stmt
 187 //      = IfStmt Expr [Stmt] [Stmt]
 188 //      | WhileStmt Expr [Stmt]
 189 //      | AssStmt VarDef Expr
 190 //      | FunStmt FunCall
 191 //      | ReturnStmt (Maybe Expr)
 192 //:: Pos = {line :: Int, col :: Int}
 193 //:: AST = AST [VarDecl] [FunDecl]
 194 //:: VarDecl = VarDecl Pos Type String Expr
 195 //:: Type
 196 //      = TupleType (Type, Type)
 197 //      | ListType Type
 198 //      | IdType String
 199 //      | IntType
 200 //      | BoolType
 201 //      | CharType
 202 //      | VarType
 203 //    | VoidType
 204 //    | (->>) infixl 7 Type Type