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