import qualified Data.Map as Map
from Data.Func import $
import Data.Maybe
+import Data.Void
import Data.Either
import Data.Functor
import Control.Applicative
get = gets id
-getRandomStream :: Int -> [String]
-getRandomStream i = genIdents $ filter (isAlpha o toChar) (genRandInt i)
- where
- genIdents r = let (ic, r2) = splitAt 5 r in [toString ic: genIdents r2]
-
-freshIdent :: Env String
-freshIdent = get >>= \(st, [ident:rest])-> put (st, rest)
- >>| case 'Map'.get ident st of
- Nothing = pure ident
- _ = freshIdent
-
-putIdent :: String Type -> Env Void
-putIdent i t = gets (\(st, r)->'Map'.get i st) >>= \mt -> case mt of
- Nothing = modify (\(st, r)->('Map'.put i t st, r))
- Just t2 = unify t t2 >>= \t3-> modify (\(st, r)->('Map'.put i t3 st, r))
-
-replace :: String Type -> Env Void
-replace ident type = get >>= \(st, fr)->put ('Map'.fromList $
- map (itupdate ident type) ('Map'.toList st), fr)
- where
- itupdate :: String Type (String, Type) -> (String, Type)
- itupdate ident newtype ov=:(key, IdType type) = if (ident == type)
- (key, newtype) ov
- itupdate ident newtype (key, TupleType (t1, t2))
- # (_, t1) = itupdate ident newtype (key, t1)
- # (_, t2) = itupdate ident newtype (key, t2)
- = (key, TupleType (t1, t2))
- itupdate ident newtype (key, ListType t1)
- # (_, t1) = itupdate ident newtype (key, t1)
- = (key, ListType t1)
- itupdate _ _ k = k
-
-instance toString SemError where
- toString (ParseError p e) = concat [
- toString p,"SemError: ParseError: ", e]
- toString (Error e) = "SemError: " +++ e
- toString (UnifyError p t1 t2) = concat [
- toString p,
- "SemError: Cannot unify types. Expected: ",
- toString t1, ". Given: ", toString t2]
- toString (FieldSelectorError p t fs) = concat [
- toString p,
- "SemError: Cannot select ", toString fs, " from type: ",
- toString t]
- toString (OperatorError p o t) = concat [
- toString p,
- "SemError: No ", toString o, " for type ",
- toString t]
- toString (UndeclaredVariableError p ident) = concat [
- toString p, "SemError: identifier: ", ident, " undefined."]
-
sem :: AST -> SemOutput
sem (AST vd fd) = case runStateT m ('Map'.newMap, getRandomStream 1) of
Left e = Left [e]
pure (vds, fds)
semFunDecl :: FunDecl -> Env FunDecl
-semFunDecl fd=:(FunDecl p f args mt vds stmts) = (case mt of
- Nothing = typeFun f args
- Just t = putIdent f t) >>|
- mapM_ semVarDecl vds >>|
- mapM_ (checkStmt IntType) stmts >>|
- case mt of
- Nothing = let t = IdType f in putIdent f t >>| pure fd
- Just t = putIdent f t >>| pure fd
+semFunDecl fd=:(FunDecl p f args mt vds stmts) =
+ saveGamma >>= \gamma ->
+ (case mt of
+ Nothing = let t = IdType f in putIdent f t >>| pure t
+ Just t = putIdent f t >>| pure t) >>= \ft ->
+ matchFunctions args ft >>|
+ mapM semVarDecl vds >>= \newvds->
+ mapM_ (checkStmt $ resultType ft) stmts >>|
+ restoreGamma gamma >>|
+ pure (FunDecl p f args mt newvds stmts)
+
+matchFunctions :: [String] Type -> Env Void
+matchFunctions [] (_ ->> _) = liftT $ Left $ Error "Niet genoeg argumentenerror"
+matchFunctions [] t = pure Void
+matchFunctions [x:xs] (t1 ->> t2) =
+ modify (\(st, r)->('Map'.put x t1 st, r)) >>| matchFunctions xs t2
semVarDecl :: VarDecl -> Env VarDecl
semVarDecl (VarDecl pos type ident ex) = unify type ex
>>= \st1-> mapM (checkStmt t) se >>= \se1-> pure (IfStmt c st1 se1)
checkStmt t w=:(WhileStmt c et) = unify BoolType c >>| mapM (checkStmt t) et
>>= \et1-> pure w
-checkStmt t (AssStmt (VarDef ident fs) e) =
+checkStmt t a=:(AssStmt (VarDef ident fs) e) = gets (\(st, r)->'Map'.get ident st)
+ >>= \mt->case mt of
+ Nothing = liftT $ Left $ UndeclaredVariableError zero ident
+ Just t = unify t fs >>= \t1 -> unify t1 e >>| pure a
checkStmt t r=:(FunStmt (FunCall f es)) = typeFun f es >>| pure r
checkStmt VoidType r=:(ReturnStmt Nothing) = pure r
checkStmt t r=:(ReturnStmt (Just e)) = unify t e >>| pure r
-all :: [Bool] -> Bool
-all as = foldr (&&) True as
-
typeExpr :: Expr -> Env Type
typeExpr (IntExpr _ _) = pure IntType
typeExpr (CharExpr _ _) = pure CharType
>>= \mt->case mt of
Nothing = liftT $ Left $ UndeclaredVariableError p ident
Just t = unify t fs
-
typeOp2 :: Expr Expr Op2 [Type] Type -> Env Type
typeOp2 e1 e2 op ts ret = typeExpr e1 >>= \t1-> typeExpr e2 >>= \t2->
unify t1 t2 >>= \t3->if (isMember t3 ts) (pure ret)
buildFunctionType frsh [e:es] = (->>) <$> typeExpr e <*> buildFunctionType frsh es
unifyApp :: Type [Expr] -> Env Type
-unifyApp t [] = pure t //whoop whoop, functions can return functions
+unifyApp t [] = pure t
unifyApp (tf1 ->> tf2) [t1:ts] = unify tf1 t1 >>| unifyApp tf2 ts
unifyApp t1 t2 = liftT $ Left $ UnifyError zero t1 (IdType "[expressions, FIXME]")
+typeFun :: String [Expr] -> Env Type
+typeFun f es = gets (\(st, r)->'Map'.get f st) >>= \mt-> case mt of
+ Nothing = freshIdent >>= \frsh-> buildFunctionType frsh es
+ >>= \ft-> putIdent f ft >>| (pure $ IdType frsh)
+ Just t = unifyApp t es
+
+resultType :: Type -> Type
+resultType (_ ->> t) = resultType t
+resultType t = t
+
class unify a :: Type a -> Env Type
instance unify [FieldSelector] where
instance zero Pos where
zero = {line=0,col=0}
-typeFun :: String [String] -> Env Type
-typeFun f es = gets (\(st, r)->'Map'.get f st) >>= \mt-> case mt of
- Nothing = freshIdent >>= \frsh-> buildFunctionType frsh es
- >>= \ft-> putIdent f ft >>| (pure $ IdType frsh)
- Just t = unifyApp t es
-
-
-
decErr :: Expr SemError -> SemError
decErr e (UnifyError _ t1 t2) = UnifyError (extrPos e) t1 t2
decErr e (FieldSelectorError _ t fs) = FieldSelectorError (extrPos e) t fs
toString (mp, _) = concat
[concat [k, ": ", toString v, "\n"]\\(k, v) <- 'Map'.toList mp]
+getRandomStream :: Int -> [String]
+getRandomStream i = genIdents $ filter (isAlpha o toChar) (genRandInt i)
+ where
+ genIdents r = let (ic, r2) = splitAt 5 r in [toString ic: genIdents r2]
+
+freshIdent :: Env String
+freshIdent = get >>= \(st, [ident:rest])-> put (st, rest)
+ >>| case 'Map'.get ident st of
+ Nothing = pure ident
+ _ = freshIdent
+
+putIdent :: String Type -> Env Void
+putIdent i t = gets (\(st, r)->'Map'.get i st) >>= \mt -> case mt of
+ Nothing = modify (\(st, r)->('Map'.put i t st, r))
+ Just t2 = unify t t2 >>= \t3-> modify (\(st, r)->('Map'.put i t3 st, r))
+
+replace :: String Type -> Env Void
+replace ident type = get >>= \(st, fr)->put ('Map'.fromList $
+ map (itupdate ident type) ('Map'.toList st), fr)
+ where
+ itupdate :: String Type (String, Type) -> (String, Type)
+ itupdate ident newtype ov=:(key, IdType type) = if (ident == type)
+ (key, newtype) ov
+ itupdate ident newtype (key, TupleType (t1, t2))
+ # (_, t1) = itupdate ident newtype (key, t1)
+ # (_, t2) = itupdate ident newtype (key, t2)
+ = (key, TupleType (t1, t2))
+ itupdate ident newtype (key, ListType t1)
+ # (_, t1) = itupdate ident newtype (key, t1)
+ = (key, ListType t1)
+ itupdate _ _ k = k
+
+instance toString SemError where
+ toString (ParseError p e) = concat [
+ toString p,"SemError: ParseError: ", e]
+ toString (Error e) = "SemError: " +++ e
+ toString (UnifyError p t1 t2) = concat [
+ toString p,
+ "SemError: Cannot unify types. Expected: ",
+ toString t1, ". Given: ", toString t2]
+ toString (FieldSelectorError p t fs) = concat [
+ toString p,
+ "SemError: Cannot select ", toString fs, " from type: ",
+ toString t]
+ toString (OperatorError p o t) = concat [
+ toString p,
+ "SemError: No ", toString o, " for type ",
+ toString t]
+ toString (UndeclaredVariableError p ident) = concat [
+ toString p, "SemError: identifier: ", ident, " undefined."]
+
+saveGamma :: Env Gamma
+saveGamma = get
+
+restoreGamma :: Gamma -> Env Void
+restoreGamma g = put g
repositories / cc1516.git / blobdiff