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
   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 class infer a :: a -> Infer Type
  94
  95 instance infer Expr where
  96         infer (VarExpr _ vd) = undef
  97         infer (Op2Expr _ e1 op e2) = case op of
  98                 BiPlus = pure IntType
  99                 BiMinus = pure IntType
 100                 BiTimes = pure IntType
 101                 BiDivide = pure IntType
 102                 BiMod = pure IntType
 103                 BiLesser = pure IntType
 104                 BiGreater = pure IntType
 105                 BiLesserEq = pure IntType
 106                 BiGreaterEq = pure IntType
 107                 BiAnd = pure BoolType
 108                 BiOr = pure BoolType
 109                 BiEquals = infer e1
 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)
 122
 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]
 130 //:: Stmt
 131 //      = IfStmt Expr [Stmt] [Stmt]
 132 //      | WhileStmt Expr [Stmt]
 133 //      | AssStmt VarDef Expr
 134 //      | FunStmt FunCall
 135 //      | ReturnStmt (Maybe Expr)
 136 //:: Pos = {line :: Int, col :: Int}
 137 //:: AST = AST [VarDecl] [FunDecl]
 138 //:: VarDecl = VarDecl Pos Type String Expr
 139 //:: Type
 140 //      = TupleType (Type, Type)
 141 //      | ListType Type
 142 //      | IdType String
 143 //      | IntType
 144 //      | BoolType
 145 //      | CharType
 146 //      | VarType
 147 //    | VoidType
 148 //    | (->>) infixl 7 Type Type