1 implementation module sem
3 import qualified Data.Map as Map
4 from Data.Func import $
8 import Control.Applicative
10 import Control.Monad.State
11 import Control.Monad.Identity
13 from StdFunc import id, const
17 from Text import class Text(concat), instance Text String
20 from parse import :: ParserOutput, :: Error
22 :: Gamma :== 'Map'.Map String Type
23 :: Env a :== (State Gamma (Either SemError a))
25 get = state $ \s -> (s,s)
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)
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 [
40 "SemError: Cannot unify types. Expected: ",
41 toString t1, ". Given: ", toString t2]
43 sem :: AST -> SemOutput
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
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]
58 semFunDecl :: FunDecl -> Env FunDecl
59 semFunDecl f = pure $ Right f
61 semVarDecl :: VarDecl -> Env VarDecl
62 semVarDecl v = pure $ 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
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
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
93 class unify a :: Type a -> Env Type
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
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