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
66 // //TODO ident in de environment
67 // Right e = Right $ pure vd
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
92 class unify a :: Type a -> Env Type
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
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
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