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