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 instance infer Expr where
  80         infer (VarExpr _ vd) = undef
  81         infer (Op2Expr _ e1 op e2) = case op of
  82                 BiPlus = pure IntType
  83                 BiMinus = pure IntType
  84                 BiTimes = pure IntType
  85                 BiDivide = pure IntType
  86                 BiMod = pure IntType
  87                 BiLesser = pure IntType
  88                 BiGreater = pure IntType
  89                 BiLesserEq = pure IntType
  90                 BiGreaterEq = pure IntType
  91                 BiAnd = pure BoolType
  92                 BiOr = pure BoolType
  93                 BiEquals = infer e1
  94                 BiUnEqual = infer e1 // maybe check e2?
  95                 BiCons = infer e1 >>= \it1->pure $ ListType it1
  96         infer (Op1Expr _ op e) = case op of
  97                 UnMinus = pure IntType
  98                 UnNegation = pure BoolType
  99         infer (IntExpr _ _) = pure IntType
 100         infer (CharExpr _ _) = pure CharType
 101         infer (BoolExpr _ _) = pure BoolType
 102         infer (FunExpr _ _ _ _) = undef
 103         infer (EmptyListExpr _) = undef
 104         infer (TupleExpr _ (e1, e2)) =
 105                 infer e1 >>= \et1->infer e2 >>= \et2->pure $ TupleType (et1, et2)
 106
 107 //:: VarDef = VarDef String [FieldSelector]
 108 //:: FieldSelector = FieldHd | FieldTl | FieldFst | FieldSnd
 109 //:: Op1 = UnNegation | UnMinus
 110 //:: Op2 = BiPlus | BiMinus | BiTimes | BiDivide | BiMod | BiEquals | BiLesser |
 111 //      BiGreater | BiLesserEq | BiGreaterEq | BiUnEqual | BiAnd | BiOr | BiCons
 112 //:: FunDecl = FunDecl Pos String [String] (Maybe Type) [VarDecl] [Stmt]
 113 //:: FunCall = FunCall String [Expr]
 114 //:: Stmt
 115 //      = IfStmt Expr [Stmt] [Stmt]
 116 //      | WhileStmt Expr [Stmt]
 117 //      | AssStmt VarDef Expr
 118 //      | FunStmt FunCall
 119 //      | ReturnStmt (Maybe Expr)
 120 //:: Pos = {line :: Int, col :: Int}
 121 //:: AST = AST [VarDecl] [FunDecl]
 122 //:: VarDecl = VarDecl Pos Type String Expr
 123 //:: Type
 124 //      = TupleType (Type, Type)
 125 //      | ListType Type
 126 //      | IdType String
 127 //      | IntType
 128 //      | BoolType
 129 //      | CharType
 130 //      | VarType
 131 //    | VoidType
 132 //    | (->>) infixl 7 Type Type