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->pure (
  65                 et >>= \t->pure $ VarDecl pos t ident ex)
  66 //Right v
  67 //      //TODO ident in de environment
  68 //      Right e = Right $ pure vd
  69
  70 typeOp1 :: Pos Expr Type -> Env Type
  71 typeOp1 p expr rtype = unify rtype expr
  72
  73 typeExpr :: Expr -> Env Type
  74 typeExpr (IntExpr _ _) = pure $ Right IntType
  75 typeExpr (CharExpr _ _) = pure $ Right CharType
  76 typeExpr (BoolExpr _ _) = pure $ Right BoolType
  77 typeExpr (Op1Expr p UnNegation expr) = typeOp1 p expr BoolType
  78 typeExpr (Op1Expr p UnMinus expr) = typeOp1 p expr IntType
  79 typeExpr (TupleExpr p (e1, e2)) = typeExpr e1
  80         >>= \ete1->typeExpr e2 >>= \ete2->pure (
  81                 ete1 >>= \te1->ete2 >>= \te2->Right $ TupleType (te1, te2))
  82 //typeExpr (Op2Expr Pos Expr Op2 Expr) = undef
  83 //typeExpr (FunExpr Pos FunCall) = undef
  84 //typeExpr (EmptyListExpr Pos) = undef
  85 //typeExpr (VarExpr Pos VarDef) = undef
  86
  87 class unify a :: Type a -> Env Type
  88
  89 instance unify Expr where
  90         unify (_ ->> _) e = pure $ Left $ ParseError (extrPos e)
  91                         "Expression cannot be a higher order function. Yet..."
  92         unify VoidType e = pure $ Left $ ParseError (extrPos e)
  93                         "Expression cannot be a Void type."
  94         unify (IdType _) e = pure $ Left $ ParseError (extrPos e)
  95                         "Expression cannot be an polymorf type."
  96         unify t e = typeExpr e
  97                 >>= \eithertype->case eithertype of
  98                         Left e = pure $ Left e
  99                         Right tex = unify t tex >>= \eitherun->case eitherun of
 100                                 Left err = pure $ Left $ decErr e err
 101                                 Right t = pure $ Right t
 102
 103 instance unify Type where
 104         unify IntType IntType = pure $ Right IntType
 105         unify BoolType BoolType = pure $ Right BoolType
 106         unify CharType CharType = pure $ Right CharType
 107         unify t1 t2 = pure $ Left $ UnifyError zero t1 t2
 108
 109 instance zero Pos where
 110         zero = {line=0,col=0}
 111
 112 decErr :: Expr SemError -> SemError
 113 decErr e (UnifyError _ t1 t2) = UnifyError (extrPos e) t1 t2
 114 decErr e (ParseError _ s) = ParseError (extrPos e) s
 115 decErr e err = err
 116
 117 extrPos :: Expr -> Pos
 118 extrPos (VarExpr p _) = p
 119 extrPos (Op2Expr p _ _ _) = p
 120 extrPos (Op1Expr p _ _) = p
 121 extrPos (IntExpr p _) = p
 122 extrPos (CharExpr p _) = p
 123 extrPos (BoolExpr p _) = p
 124 extrPos (FunExpr p _) = p
 125 extrPos (EmptyListExpr p) = p
 126 extrPos (TupleExpr p _) = p