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 variableStream :: [String]
  41 variableStream = map toString [1..]
  42
  43 sem :: AST -> SemOutput
  44 sem a=:(AST fd) = case foldM (const $ hasNoDups fd) () fd
  45                 >>| foldM (const isNiceMain) () fd
  46                 >>| hasMain fd of
  47         Left e = Left [e]
  48         _ = pure (a, 'Map'.newMap)
  49 where
  50                 hasNoDups :: [FunDecl] FunDecl -> Either SemError ()
  51                 hasNoDups fds (FunDecl p n _ _ _ _)
  52                 # mbs = map (\(FunDecl p` n` _ _ _ _)->if (n == n`) (Just p`) Nothing) fds
  53                 = case catMaybes mbs of
  54                         [] = Left $ SanityError p "HUH THIS SHOULDN'T HAPPEN"
  55                         [x] = pure ()
  56                         [_:x] = Left $ SanityError p (concat
  57                                 [n, " multiply defined at ", toString p])
  58
  59                 hasMain :: [FunDecl] -> Either SemError ()
  60                 hasMain [(FunDecl _ "main" _ _ _ _):fd] = pure ()
  61                 hasMain [_:fd] = hasMain fd
  62                 hasMain [] = Left $ SanityError zero "no main function defined"
  63
  64                 isNiceMain :: FunDecl -> Either SemError ()
  65                 isNiceMain (FunDecl p "main" as mt _ _) = case (as, mt) of
  66                         ([_:_], _) = Left $ SanityError p "main must have arity 0"
  67                         ([], t) = (case t of
  68                                 Nothing = pure ()
  69                                 Just VoidType = pure ()
  70                                 _ = Left $ SanityError p "main has to return Void")
  71                 isNiceMain _ = pure ()
  72
  73 instance toString Scheme where
  74         toString (Forall x t) =
  75                 concat ["Forall ": map ((+++) "\n") x] +++ toString t
  76
  77 instance toString Gamma where
  78         toString mp =
  79                 concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]
  80
  81 instance toString SemError where
  82         toString (SanityError p e) = concat [toString p,
  83                 "SemError: SanityError: ", e]
  84         toString se = "SemError: "
  85
  86 uni :: Type Type -> Infer ()
  87 uni t1 t2 = tell [(t1, t2)]
  88
  89 inEnv :: (String, Scheme) (Infer a) -> (Infer a)
  90 inEnv (x, sc) m = local scope m
  91         where
  92                 scope e = 'Map'.put x sc ('Map'.del x e )
  93
  94 fresh :: Infer Type
  95 fresh = (gets id) >>= \vars-> (put $ tail vars) >>| (pure $ IdType $ head vars)
  96
  97 class infer a :: a -> Infer Type
  98
  99 op2Type :: Op2 -> Infer Type
 100 op2Type op
 101 | elem op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod]
 102         = pure (IntType ->> IntType ->> IntType)
 103 | elem op [BiEquals, BiUnEqual]
 104         = fresh >>= \t1-> fresh >>= \t2-> pure (t1 ->> t2 ->> BoolType)
 105 | elem op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq]
 106         = pure (IntType ->> IntType ->> BoolType)
 107 | elem op [BiAnd, BiOr]
 108         = pure (BoolType ->> BoolType ->> BoolType)
 109 | op == BiCons
 110         = fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)
 111
 112 op1Type :: Op1 -> Infer Type
 113 op1Type UnNegation = pure $ (BoolType ->> BoolType)
 114 op1Type UnMinus = pure $ (IntType ->> IntType)
 115
 116 //instantiate :: Scheme -> Infer Type
 117 //instantiate (Forall as t) = mapM (const fresh) as
 118
 119 lookupEnv :: String -> Infer Type
 120 lookupEnv ident = asks ('Map'.get ident)
 121         >>= \m->case m of
 122                 Nothing = liftT $ Left $ UndeclaredVariableError zero ident
 123                 Just (Forall as t) = pure t //instantiate ???
 124
 125 instance infer Expr where
 126         infer (VarExpr _ (VarDef ident fs)) = lookupEnv ident
 127         infer (Op2Expr _ e1 op e2) = case op of
 128                 BiPlus = pure IntType
 129                 BiMinus = pure IntType
 130                 BiTimes = pure IntType
 131                 BiDivide = pure IntType
 132                 BiMod = pure IntType
 133                 BiLesser = pure IntType
 134                 BiGreater = pure IntType
 135                 BiLesserEq = pure IntType
 136                 BiGreaterEq = pure IntType
 137                 BiAnd = pure BoolType
 138                 BiOr = pure BoolType
 139                 BiEquals = infer e1
 140                 BiUnEqual = infer e1 // maybe check e2?
 141                 BiCons = infer e1 >>= \it1->pure $ ListType it1
 142         infer (Op1Expr _ op e) = case op of
 143                 UnMinus = pure IntType
 144                 UnNegation = pure BoolType
 145         infer (IntExpr _ _) = pure IntType
 146         infer (CharExpr _ _) = pure CharType
 147         infer (BoolExpr _ _) = pure BoolType
 148         infer (FunExpr _ _ _ _) = undef
 149         infer (EmptyListExpr _) = undef
 150         infer (TupleExpr _ (e1, e2)) =
 151                 infer e1 >>= \et1->infer e2 >>= \et2->pure $ TupleType (et1, et2)
 152
 153 //:: VarDef = VarDef String [FieldSelector]
 154 //:: FieldSelector = FieldHd | FieldTl | FieldFst | FieldSnd
 155 //:: Op1 = UnNegation | UnMinus
 156 //:: Op2 = BiPlus | BiMinus | BiTimes | BiDivide | BiMod | BiEquals | BiLesser |
 157 //      BiGreater | BiLesserEq | BiGreaterEq | BiUnEqual | BiAnd | BiOr | BiCons
 158 //:: FunDecl = FunDecl Pos String [String] (Maybe Type) [VarDecl] [Stmt]
 159 //:: FunCall = FunCall String [Expr]
 160 //:: Stmt
 161 //      = IfStmt Expr [Stmt] [Stmt]
 162 //      | WhileStmt Expr [Stmt]
 163 //      | AssStmt VarDef Expr
 164 //      | FunStmt FunCall
 165 //      | ReturnStmt (Maybe Expr)
 166 //:: Pos = {line :: Int, col :: Int}
 167 //:: AST = AST [VarDecl] [FunDecl]
 168 //:: VarDecl = VarDecl Pos Type String Expr
 169 //:: Type
 170 //      = TupleType (Type, Type)
 171 //      | ListType Type
 172 //      | IdType String
 173 //      | IntType
 174 //      | BoolType
 175 //      | CharType
 176 //      | VarType
 177 //    | VoidType
 178 //    | (->>) infixl 7 Type Type