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 (UnifyError p t1 t2) = concat [
  39                 toString p,
  40                 "SemError: Cannot unify types. Expected: ",
  41                 toString t1, ". Given: ", toString t2]
  42
  43 sem :: AST -> SemOutput
  44 sem (AST vd fd)
  45 # (eithervds, gamma) = runState (mapM semVarDecl vd) 'Map'.newMap
  46 # (eitherfds, gamma) = runState (mapM semFunDecl fd) gamma
  47 = case splitEithers eithervds of
  48         (Left errs) = Left $ errs ++ [x\\(Left x)<-eitherfds]
  49         (Right vds) = case splitEithers eitherfds of
  50                 (Left errs) = Left errs
  51                 (Right fds) = Right $ AST vds fds
  52
  53 splitEithers :: [Either a b] -> Either [a] [b]
  54 splitEithers [] = Right []
  55 splitEithers [Right x:xs] = splitEithers xs >>= \rest->Right [x:rest]
  56 splitEithers xs = Left $ [x\\(Left x)<-xs]
  57
  58 semFunDecl :: FunDecl -> Env FunDecl
  59 semFunDecl f = pure $ Right f
  60
  61 semVarDecl :: VarDecl -> Env VarDecl
  62 semVarDecl v = pure $ Right v
  63 //Right v
  64 //semVarDecl vd=:(VarDecl pos type ident expr) = case unify type expr of //     Left e = Left e
  65 //      //TODO ident in de environment
  66 //      Right e = Right $ pure vd
  67
  68 typeOp1 :: Pos Expr Type -> Env Type
  69 typeOp1 p expr rtype = typeExpr expr >>= \exprtype->case exprtype of
  70         Left e = pure $ Left e
  71         Right rtype = pure $ Right rtype
  72         Right (IdType ident) = putIdent ident rtype >>| pure (Right rtype)
  73         Right t = pure $ Left $ UnifyError p rtype t
  74
  75 typeExpr :: Expr -> Env Type
  76 typeExpr (IntExpr _ _) = pure $ Right IntType
  77 typeExpr (CharExpr _ _) = pure $ Right CharType
  78 typeExpr (BoolExpr _ _) = pure $ Right BoolType
  79 typeExpr (Op1Expr p UnNegation expr) = typeOp1 p expr BoolType
  80 typeExpr (Op1Expr p UnMinus expr) = typeOp1 p expr IntType
  81 typeExpr (TupleExpr p (e1, e2)) = typeExpr e1
  82         >>= \ete1->typeExpr e2 >>= \ete2->pure (
  83                 ete1 >>= \te1->ete2 >>= \te2->Right $ TupleType (te1, te2))
  84 //typeExpr (Op1Expr p UnMinus expr) = typeExpr expr
  85 //      >>= \exprtype->case exprtype of
  86 //              IntType = pure $ Right IntType
  87 //              t = Left $ UnifyError p IntType exprtype
  88 //typeExpr (Op2Expr Pos Expr Op2 Expr) = undef
  89 //typeExpr (FunExpr Pos FunCall) = undef
  90 //typeExpr (EmptyListExpr Pos) = undef
  91 //typeExpr (VarExpr Pos VarDef) = undef
  92
  93 class unify a :: Type a -> Env Type
  94
  95 instance unify Type where
  96         unify IntType IntType = pure $ Right IntType
  97         unify BoolType BoolType = pure $ Right BoolType
  98         unify CharType CharType = pure $ Right CharType
  99         unify _ _ = undef
 100 //
 101 //instance unify Expr where
 102 //      unify type expr = case type of
 103 //              _ ->> _ = Left $ ParseError (extrPos expr)
 104 //                      "Expression cannot be a higher order function. Yet..."
 105 //              VoidType = Left $ ParseError (extrPos expr)
 106 //                      "Expression cannot be a Void type."
 107 //              IdType _ = Left $ ParseError (extrPos expr)
 108 //                      "Expression cannot be an polymorf type."
 109 //              TupleType (_, _) = undef
 110 //              ListType _ = undef
 111 //              IntType = undef
 112 //              BoolType = undef
 113 //              CharType = undef
 114 //              VarType = undef