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 Data.Either
  10 import Data.Maybe
  11 import Data.Monoid
  12 import Data.List
  13
  14 import StdString
  15 import StdList
  16 import StdMisc
  17 import StdEnum
  18 import RWST
  19 import GenEq
  20
  21 from Text import class Text(concat), instance Text String
  22
  23 import AST
  24
  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
  29 :: SemError
  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
  37         | Error String
  38
  39 variableStream :: [String]
  40 variableStream = map toString [1..]
  41
  42 sem :: AST -> SemOutput
  43 sem a=:(AST fd) = case foldM (const $ hasNoDups fd) () fd
  44                 >>| foldM (const isNiceMain) () fd
  45                 >>| hasMain fd of
  46         Left e = Left [e]
  47         _ = pure (a, 'Map'.newMap)
  48 where
  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"
  54                         [x] = pure ()
  55                         [_:x] = Left $ SanityError p (concat
  56                                 [n, " multiply defined at ", toString p])
  57
  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"
  62
  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"
  66                         ([], t) = (case t of
  67                                 Nothing = pure ()
  68                                 Just VoidType = pure ()
  69                                 _ = Left $ SanityError p "main has to return Void")
  70                 isNiceMain _ = pure ()
  71
  72 instance toString Scheme where
  73         toString (Forall x t) =
  74                 concat ["Forall ": map ((+++) "\n") x] +++ toString t
  75
  76 instance toString Gamma where
  77         toString mp =
  78                 concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]
  79
  80 instance toString SemError where
  81         toString (SanityError p e) = concat [toString p,
  82                 "SemError: SanityError: ", e]
  83         toString se = "SemError: "
  84
  85 uni :: Type Type -> Infer ()
  86 uni t1 t2 = tell [(t1, t2)]
  87
  88 inEnv :: (String, Scheme) (Infer a) -> (Infer a)
  89 inEnv (x, sc) m = local scope m
  90         where
  91                 scope e = 'Map'.put x sc ('Map'.del x e )
  92
  93 fresh :: Infer Type
  94 fresh = (gets id) >>= \vars-> (put $ tail vars) >>| (pure $ IdType $ head vars)
  95
  96 class infer a :: a -> Infer Type
  97
  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)
 107             | op == BiCons
 108                 = fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)
 109
 110 op1Type :: Op1 -> Infer Type
 111 op1Type UnNegation = pure $ (BoolType ->> BoolType)
 112 op1Type UnMinus = pure $ (IntType ->> IntType)
 113
 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
 121                 BiMod = pure IntType
 122                 BiLesser = pure IntType
 123                 BiGreater = pure IntType
 124                 BiLesserEq = pure IntType
 125                 BiGreaterEq = pure IntType
 126                 BiAnd = pure BoolType
 127                 BiOr = pure BoolType
 128                 BiEquals = infer e1
 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)
 141
 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]
 149 //:: Stmt
 150 //      = IfStmt Expr [Stmt] [Stmt]
 151 //      | WhileStmt Expr [Stmt]
 152 //      | AssStmt VarDef Expr
 153 //      | FunStmt FunCall
 154 //      | ReturnStmt (Maybe Expr)
 155 //:: Pos = {line :: Int, col :: Int}
 156 //:: AST = AST [VarDecl] [FunDecl]
 157 //:: VarDecl = VarDecl Pos Type String Expr
 158 //:: Type
 159 //      = TupleType (Type, Type)
 160 //      | ListType Type
 161 //      | IdType String
 162 //      | IntType
 163 //      | BoolType
 164 //      | CharType
 165 //      | VarType
 166 //    | VoidType
 167 //    | (->>) infixl 7 Type Type