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, id
   7
   8 import Control.Monad
   9 import Data.Either
  10 import Data.Monoid
  11 import Data.List
  12
  13 import StdString
  14 import StdList
  15 import StdMisc
  16 import StdEnum
  17 import RWST
  18 import GenEq
  19
  20 from Text import class Text(concat), instance Text String
  21
  22 import AST
  23
  24 :: Scheme = Forall [String] Type
  25 :: Gamma :== 'Map'.Map String Scheme
  26 :: Constraints :== [(Type, Type)]
  27 :: Infer a :== RWST Gamma Constraints [String] (Either SemError) a
  28 :: SemError
  29         = ParseError Pos String
  30         | UnifyError Pos Type Type
  31     | FieldSelectorError Pos Type FieldSelector
  32         | OperatorError Pos Op2 Type
  33     | UndeclaredVariableError Pos String
  34     | ArgumentMisMatchError Pos String
  35         | Error String
  36
  37 variableStream :: [String]
  38 variableStream = map toString [1..]
  39
  40 sem :: AST -> SemOutput
  41 sem (AST fd) = Right (AST fd, 'Map'.newMap)
  42
  43 instance toString Scheme where
  44         toString (Forall x t) =
  45                 concat ["Forall ": map ((+++) "\n") x] +++ toString t
  46
  47 instance toString Gamma where
  48         toString mp =
  49                 concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]
  50
  51 instance toString SemError where
  52         toString se = "SemError: "
  53
  54 uni :: Type Type -> Infer ()
  55 uni t1 t2 = tell [(t1, t2)]
  56
  57 inEnv :: (String, Scheme) (Infer a) -> (Infer a)
  58 inEnv (x, sc) m = local scope m
  59         where
  60                 scope e = 'Map'.put x sc ('Map'.del x e )
  61
  62 fresh :: Infer Type
  63 fresh = (gets id) >>= \vars-> (put $ tail vars) >>| (pure $ IdType $ head vars)
  64
  65 class infer a :: a -> Infer Type
  66
  67 op2Type :: Op2 -> Infer Type
  68 op2Type op  | elem op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod]
  69                 = pure (IntType ->> IntType ->> IntType)
  70             | elem op [BiEquals, BiUnEqual]
  71                 = fresh >>= \t1-> fresh >>= \t2-> pure (t1 ->> t2 ->> BoolType)
  72             | elem op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq]
  73                 = pure (IntType ->> IntType ->> BoolType)
  74             | elem op [BiAnd, BiOr]
  75                 = pure (BoolType ->> BoolType ->> BoolType)
  76             | op == BiCons
  77                 = fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)
  78
  79 op1Type :: Op1 -> Infer Type
  80 op1Type UnNegation = pure $ (BoolType ->> BoolType)
  81 op1Type UnMinus = pure $ (IntType ->> IntType)
  82
  83 instance infer Expr where
  84         infer (VarExpr _ vd) = undef
  85         infer (Op2Expr _ e1 op e2) = case op of
  86                 BiPlus = pure IntType
  87                 BiMinus = pure IntType
  88                 BiTimes = pure IntType
  89                 BiDivide = pure IntType
  90                 BiMod = pure IntType
  91                 BiLesser = pure IntType
  92                 BiGreater = pure IntType
  93                 BiLesserEq = pure IntType
  94                 BiGreaterEq = pure IntType
  95                 BiAnd = pure BoolType
  96                 BiOr = pure BoolType
  97                 BiEquals = infer e1
  98                 BiUnEqual = infer e1 // maybe check e2?
  99                 BiCons = infer e1 >>= \it1->pure $ ListType it1
 100         infer (Op1Expr _ op e) = case op of
 101                 UnMinus = pure IntType
 102                 UnNegation = pure BoolType
 103         infer (IntExpr _ _) = pure IntType
 104         infer (CharExpr _ _) = pure CharType
 105         infer (BoolExpr _ _) = pure BoolType
 106         infer (FunExpr _ _ _ _) = undef
 107         infer (EmptyListExpr _) = undef
 108         infer (TupleExpr _ (e1, e2)) =
 109                 infer e1 >>= \et1->infer e2 >>= \et2->pure $ TupleType (et1, et2)
 110
 111 //:: VarDef = VarDef String [FieldSelector]
 112 //:: FieldSelector = FieldHd | FieldTl | FieldFst | FieldSnd
 113 //:: Op1 = UnNegation | UnMinus
 114 //:: Op2 = BiPlus | BiMinus | BiTimes | BiDivide | BiMod | BiEquals | BiLesser |
 115 //      BiGreater | BiLesserEq | BiGreaterEq | BiUnEqual | BiAnd | BiOr | BiCons
 116 //:: FunDecl = FunDecl Pos String [String] (Maybe Type) [VarDecl] [Stmt]
 117 //:: FunCall = FunCall String [Expr]
 118 //:: Stmt
 119 //      = IfStmt Expr [Stmt] [Stmt]
 120 //      | WhileStmt Expr [Stmt]
 121 //      | AssStmt VarDef Expr
 122 //      | FunStmt FunCall
 123 //      | ReturnStmt (Maybe Expr)
 124 //:: Pos = {line :: Int, col :: Int}
 125 //:: AST = AST [VarDecl] [FunDecl]
 126 //:: VarDecl = VarDecl Pos Type String Expr
 127 //:: Type
 128 //      = TupleType (Type, Type)
 129 //      | ListType Type
 130 //      | IdType String
 131 //      | IntType
 132 //      | BoolType
 133 //      | CharType
 134 //      | VarType
 135 //    | VoidType
 136 //    | (->>) infixl 7 Type Type