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 t2)
  39         toString (UnifyError p t1 t2) = concat [
  40                 toString p,
  41                 "SemError: Cannot unify types. Expected: ",
  42                 toString t1, ". Given: ", toString t2]
  43
  44 sem :: AST -> SemOutput
  45 sem (AST vd fd)
  46 # (eithervds, gamma) = runState (mapM semVarDecl vd) 'Map'.newMap
  47 # (eitherfds, gamma) = runState (mapM semFunDecl fd) gamma
  48 = case splitEithers eithervds of
  49         (Left errs) = Left $ errs ++ [x\\(Left x)<-eitherfds]
  50         (Right vds) = case splitEithers eitherfds of
  51                 (Left errs) = Left errs
  52                 (Right fds) = Right $ AST vds fds
  53
  54 splitEithers :: [Either a b] -> Either [a] [b]
  55 splitEithers [] = Right []
  56 splitEithers [Right x:xs] = splitEithers xs >>= \rest->Right [x:rest]
  57 splitEithers xs = Left $ [x\\(Left x)<-xs]
  58
  59 semFunDecl :: FunDecl -> Env FunDecl
  60 semFunDecl f = pure $ Right f
  61
  62 semVarDecl :: VarDecl -> Env VarDecl
  63 semVarDecl vd=:(VarDecl pos type ident ex) = unify type ex
  64         >>= \et->case et of
  65                 Left err = pure $ Left err
  66                 Right t = putIdent ident t >>| pure (Right $ VarDecl pos t ident ex)
  67
  68 typeExpr :: Expr -> Env Type
  69 typeExpr (IntExpr _ _) = pure $ Right IntType
  70 typeExpr (CharExpr _ _) = pure $ Right CharType
  71 typeExpr (BoolExpr _ _) = pure $ Right 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         >>= \ete1->typeExpr e2 >>= \ete2->pure (
  76                 ete1 >>= \te1->ete2 >>= \te2->Right $ TupleType (te1, te2))
  77 //Int
  78 typeExpr (Op2Expr p e1 BiPlus e2) = undef
  79 typeExpr (Op2Expr p e1 BiMinus e2) = undef
  80 typeExpr (Op2Expr p e1 BiTimes e2) = undef
  81 typeExpr (Op2Expr p e1 BiDivide e2) = undef
  82 typeExpr (Op2Expr p e1 BiMod e2) = undef
  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
  99
 100 class unify a :: Type a -> Env Type
 101
 102 instance unify Expr where
 103         unify (_ ->> _) e = pure $ Left $ ParseError (extrPos e)
 104                         "Expression cannot be a higher order function. Yet..."
 105         unify VoidType e = pure $ Left $ ParseError (extrPos e)
 106                         "Expression cannot be a Void type."
 107         unify (IdType _) e = pure $ Left $ ParseError (extrPos e)
 108                         "Expression cannot be an polymorf type."
 109         unify t e = typeExpr e
 110                 >>= \eithertype->case eithertype of
 111                         Left e = pure $ Left e
 112                         Right tex = unify t tex >>= \eitherun->case eitherun of
 113                                 Left err = pure $ Left $ decErr e err
 114                                 Right t = pure $ Right t
 115
 116 instance unify Type where
 117         unify IntType IntType = pure $ Right IntType
 118         unify BoolType BoolType = pure $ Right BoolType
 119         unify CharType CharType = pure $ Right CharType
 120         unify t1 t2 = pure $ 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 extrPos :: Expr -> Pos
 131 extrPos (VarExpr p _) = p
 132 extrPos (Op2Expr p _ _ _) = p
 133 extrPos (Op1Expr p _ _) = p
 134 extrPos (IntExpr p _) = p
 135 extrPos (CharExpr p _) = p
 136 extrPos (BoolExpr p _) = p
 137 extrPos (FunExpr p _) = p
 138 extrPos (EmptyListExpr p) = p
 139 extrPos (TupleExpr p _) = p