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