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 StdMisc
  13 from StdFunc import id, const
  14 import StdString
  15 import StdList
  16
  17 from Text import class Text(concat), instance Text String
  18
  19 import AST
  20 from parse import :: ParserOutput, :: Error
  21
  22 :: Gamma :== 'Map'.Map String Type
  23 :: Env a :== (State Gamma (Either SemError a))
  24
  25 get = state $ \s -> (s,s)
  26
  27 putIdent :: String Type -> Env Void
  28 putIdent i t = gets ('Map'.get i) >>= \mt -> case mt of
  29     Nothing = pure <$> modify ('Map'.put i t)
  30     Just t2 = unify t t2 >>= \r -> case r of
  31         Left e  = pure $ Left e
  32         Right t3 = pure <$> modify ('Map'.put i t3)
  33
  34 instance toString SemError where
  35         toString (ParseError p e) = concat [
  36                 toString p,"SemError: ParseError: ", e]
  37         toString (Error e) = "SemError: " +++ e
  38         toString (UnifyErrorStub t1 t2) = toString (UnifyError {line=0,col=0} t1
  39 t2)
  40         toString (UnifyError p t1 t2) = concat [
  41                 toString p,
  42                 "SemError: Cannot unify types. Expected: ",
  43                 toString t1, ". Given: ", toString t2]
  44
  45 sem :: AST -> SemOutput
  46 sem (AST vd fd)
  47 # (eithervds, gamma) = runState (mapM semVarDecl vd) 'Map'.newMap
  48 # (eitherfds, gamma) = runState (mapM semFunDecl fd) gamma
  49 = case splitEithers eithervds of
  50         (Left errs) = Left $ errs ++ [x\\(Left x)<-eitherfds]
  51         (Right vds) = case splitEithers eitherfds of
  52                 (Left errs) = Left errs
  53                 (Right fds) = Right $ AST vds fds
  54
  55 splitEithers :: [Either a b] -> Either [a] [b]
  56 splitEithers [] = Right []
  57 splitEithers [Right x:xs] = splitEithers xs >>= \rest->Right [x:rest]
  58 splitEithers xs = Left $ [x\\(Left x)<-xs]
  59
  60 semFunDecl :: FunDecl -> Env FunDecl
  61 semFunDecl f = pure $ Right f
  62
  63 semVarDecl :: VarDecl -> Env VarDecl
  64 semVarDecl vd=:(VarDecl pos type ident ex) = unify type ex
  65         >>= \et->case et of
  66                 Left err = pure $ Left err
  67                 Right t = putIdent ident t >>| pure (Right $ VarDecl pos t ident ex)
  68
  69 typeExpr :: Expr -> Env Type
  70 typeExpr (IntExpr _ _) = pure $ Right IntType
  71 typeExpr (CharExpr _ _) = pure $ Right CharType
  72 typeExpr (BoolExpr _ _) = pure $ Right 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         >>= \ete1->typeExpr e2 >>= \ete2->pure (
  77                 ete1 >>= \te1->ete2 >>= \te2->Right $ TupleType (te1, te2))
  78 //Int
  79 typeExpr (Op2Expr p e1 BiPlus e2) = unify IntType e1 >>| unify IntType e2
  80 typeExpr (Op2Expr p e1 BiMinus e2) = unify IntType e1 >>| unify IntType e2
  81 typeExpr (Op2Expr p e1 BiTimes e2) = unify IntType e1 >>| unify IntType e2
  82 typeExpr (Op2Expr p e1 BiDivide e2) = unify IntType e1 >>| unify IntType e2
  83 typeExpr (Op2Expr p e1 BiMod e2) = unify IntType e1 >>| unify IntType e2
  84 //bool, char of int
  85 typeExpr (Op2Expr p e1 BiEquals e2) =
  86 typeExpr (Op2Expr p e1 BiUnEqual e2) = undef
  87 //char of int
  88 typeExpr (Op2Expr p e1 BiLesser e2) = undef
  89 typeExpr (Op2Expr p e1 BiGreater e2) = undef
  90 typeExpr (Op2Expr p e1 BiLesserEq e2) = undef
  91 typeExpr (Op2Expr p e1 BiGreaterEq e2) = undef
  92 //bool
  93 typeExpr (Op2Expr p e1 BiAnd e2) = undef
  94 typeExpr (Op2Expr p e1 BiOr e2) = undef
  95 //a
  96 typeExpr (Op2Expr p e1 BiCons e2) = undef
  97 //typeExpr (FunExpr Pos FunCall) = undef
  98 //typeExpr (EmptyListExpr Pos) = undef
  99 //typeExpr (VarExpr Pos VarDef) = undef //when checking var-expr, be sure to
 100 //put the infered type
 101                                         //in the context
 102
 103 class unify a :: Type a -> Env Type
 104
 105 instance unify Expr where
 106         unify (_ ->> _) e = pure $ Left $ ParseError (extrPos e)
 107                         "Expression cannot be a higher order function. Yet..."
 108         unify VoidType e = pure $ Left $ ParseError (extrPos e)
 109                         "Expression cannot be a Void type."
 110         unify (IdType _) e = pure $ Left $ ParseError (extrPos e)
 111                         "Expression cannot be an polymorf type."
 112     unify VarType e = typeExpr e
 113         unify t e = typeExpr e
 114                 >>= \eithertype->case eithertype of
 115                         Left e = pure $ Left e
 116                         Right tex = unify t tex >>= \eitherun->case eitherun of
 117                                 Left err = pure $ Left $ decErr e err
 118                                 Right t = pure $ Right t
 119
 120 instance unify Type where
 121         unify IntType IntType = pure $ Right IntType
 122         unify BoolType BoolType = pure $ Right BoolType
 123         unify CharType CharType = pure $ Right CharType
 124         unify t1 t2 = pure $ Left $ UnifyError zero t1 t2
 125
 126 instance zero Pos where
 127         zero = {line=0,col=0}
 128
 129 decErr :: Expr SemError -> SemError
 130 decErr e (UnifyError _ t1 t2) = UnifyError (extrPos e) t1 t2
 131 decErr e (ParseError _ s) = ParseError (extrPos e) s
 132 decErr e err = 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