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