sem.icl

   1 implementation module sem
   2
   3 import qualified Data.Map as Map
   4 from Data.Func import $
   5 import Data.Maybe
   6 import Data.Either
   7 import Data.Functor
   8 import Control.Applicative
   9 import Control.Monad
  10 import Control.Monad.State
  11 import Control.Monad.Identity
  12 import Control.Monad.Trans
  13 import StdMisc
  14 from StdFunc import id, const
  15 import StdString
  16 import StdList
  17
  18 from Text import class Text(concat), instance Text String
  19
  20 import AST
  21 from parse import :: ParserOutput, :: Error
  22
  23 :: Gamma :== 'Map'.Map String Type
  24 :: Env a :== StateT Gamma (Either SemError) a
  25
  26 //we need to redefine this even though it is in Control.Monad.State
  27 instance MonadTrans (StateT Gamma) where
  28     liftT m = StateT \s-> m >>= \a-> return (a, s)
  29
  30 get = gets id
  31
  32 instance toString SemError where
  33     toString (ParseError p e) = concat [
  34         toString p,"SemError: ParseError: ", e]
  35     toString (Error e) = "SemError: " +++ e
  36     toString (UnifyErrorStub t1 t2) = toString (UnifyError {line=0,col=0} t1 t2)
  37     toString (UnifyError p t1 t2) = concat [
  38         toString p,
  39         "SemError: Cannot unify types. Expected: ",
  40         toString t1, ". Given: ", toString t2]
  41
  42 putIdent :: String Type -> Env Void
  43 putIdent i t = gets ('Map'.get i) >>= \mt -> case mt of
  44     Nothing = modify ('Map'.put i t)
  45     Just t2 = unify t t2 >>= \t3-> modify ('Map'.put i t3)
  46
  47 sem :: AST -> SemOutput
  48 sem (AST vd fd) = case evalStateT m 'Map'.newMap of
  49     Left e = Left [e]
  50     Right (vds, fds) = Right (AST vds fds)
  51 where
  52     m :: Env (([VarDecl], [FunDecl]))
  53     m = (mapM semVarDecl vd) >>= \vds ->
  54         mapM semFunDecl fd >>= \fds ->
  55         pure (vds, fds)
  56
  57 splitEithers :: [Either a b] -> Either [a] [b]
  58 splitEithers [] = Right []
  59 splitEithers [Right x:xs] = splitEithers xs >>= \rest->Right [x:rest]
  60 splitEithers xs = Left $ [x\\(Left x)<-xs]
  61
  62 semFunDecl :: FunDecl -> Env FunDecl
  63 semFunDecl f = pure f
  64
  65 semVarDecl :: VarDecl -> Env VarDecl
  66 semVarDecl (VarDecl pos type ident ex) = unify type ex
  67     >>= \t-> putIdent ident t >>| (pure $ VarDecl pos t ident ex)
  68
  69 typeExpr :: Expr -> Env Type
  70 typeExpr (IntExpr _ _) = pure IntType
  71 typeExpr (CharExpr _ _) = pure CharType
  72 typeExpr (BoolExpr _ _) = pure BoolType
  73 typeExpr (Op1Expr p UnNegation expr) = unify BoolType expr
  74 typeExpr (Op1Expr p UnMinus expr) = unify IntType expr
  75 typeExpr (TupleExpr p (e1, e2)) = typeExpr e1
  76     >>= \t1-> typeExpr e2 >>= \t2-> pure $ TupleType (t1, t2)
  77 //Int
  78 typeExpr (Op2Expr p e1 BiPlus e2) = unify IntType e1 >>| unify IntType e2
  79 typeExpr (Op2Expr p e1 BiMinus e2) = unify IntType e1 >>| unify IntType e2
  80 typeExpr (Op2Expr p e1 BiTimes e2) = unify IntType e1 >>| unify IntType e2
  81 typeExpr (Op2Expr p e1 BiDivide e2) = unify IntType e1 >>| unify IntType e2
  82 typeExpr (Op2Expr p e1 BiMod e2) = unify IntType e1 >>| unify IntType e2
  83 //bool, char of int
  84 typeExpr (Op2Expr p e1 BiEquals e2) = undef
  85 typeExpr (Op2Expr p e1 BiUnEqual e2) = undef
  86 //char of int
  87 typeExpr (Op2Expr p e1 BiLesser e2) = undef
  88 typeExpr (Op2Expr p e1 BiGreater e2) = undef
  89 typeExpr (Op2Expr p e1 BiLesserEq e2) = undef
  90 typeExpr (Op2Expr p e1 BiGreaterEq e2) = undef
  91 //bool
  92 typeExpr (Op2Expr p e1 BiAnd e2) = undef
  93 typeExpr (Op2Expr p e1 BiOr e2) = undef
  94 //a
  95 typeExpr (Op2Expr p e1 BiCons e2) = undef
  96 //typeExpr (FunExpr Pos FunCall) = undef
  97 //typeExpr (EmptyListExpr Pos) = undef
  98 //typeExpr (VarExpr Pos VarDef) = undef //when checking var-expr, be sure to put the infered type
  99                                         //in the context
 100
 101 class unify a :: Type a -> Env Type
 102
 103 instance unify Expr where
 104         unify (_ ->> _) e = liftT $ Left $ ParseError (extrPos e)
 105                         "Expression cannot be a higher order function. Yet..."
 106         unify VoidType e = liftT $ Left $ ParseError (extrPos e)
 107                         "Expression cannot be a Void type."
 108         unify (IdType _) e = liftT $ Left $ ParseError (extrPos e)
 109                         "Expression cannot be an polymorf type."
 110     unify VarType e = typeExpr e
 111     //we have to cheat to decorate the error, can be done nicer?
 112     unify t e = StateT $ \s0 -> let res = runStateT m s0 in case res of
 113         Left err = Left $ decErr e err
 114         Right t = Right t //note, t :: (Type, Gamma)
 115     where m = typeExpr e >>= \tex-> unify t tex
 116
 117 instance unify Type where
 118         unify IntType IntType = pure IntType
 119         unify BoolType BoolType = pure BoolType
 120         unify CharType CharType = pure CharType
 121         unify t1 t2 = liftT $ Left $ UnifyError zero t1 t2
 122
 123 instance zero Pos where
 124         zero = {line=0,col=0}
 125
 126 decErr :: Expr SemError -> SemError
 127 decErr e (UnifyError _ t1 t2) = UnifyError (extrPos e) t1 t2
 128 decErr e (ParseError _ s) = ParseError (extrPos e) s
 129 decErr e err = err
 130
 131 dc2 :: Expr (Either SemError a) -> Either SemError a
 132 dc2 e (Right t) = Right t
 133 dc2 e (Left err) = Left err
 134
 135 extrPos :: Expr -> Pos
 136 extrPos (VarExpr p _) = p
 137 extrPos (Op2Expr p _ _ _) = p
 138 extrPos (Op1Expr p _ _) = p
 139 extrPos (IntExpr p _) = p
 140 extrPos (CharExpr p _) = p
 141 extrPos (BoolExpr p _) = p
 142 extrPos (FunExpr p _) = p
 143 extrPos (EmptyListExpr p) = p
 144 extrPos (TupleExpr p _) = p