X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=sem.icl;h=68b804d42939c49739bb662f0688ccd527740913;hb=483bcde4dbb75d1901cffad6cc2c45307b7e90a2;hp=791ae69a46b3601530d02822edf315404df53a67;hpb=51921a9587d60b6411610845f56d62ebd73f80cb;p=cc1516.git

diff --git a/sem.icl b/sem.icl
index 791ae69..68b804d 100644
--- a/sem.icl
+++ b/sem.icl
@@ -50,35 +50,13 @@ variableStream :: [TVar]
 variableStream = map toString [1..]
 
 sem :: AST -> Either [SemError] AST
-//sem a = pure a
 sem (AST fd) = case foldM (const $ hasNoDups fd) () fd 
             		>>| foldM (const isNiceMain) () fd
             		>>| hasMain fd
                     >>| evalStateT (type fd) (zero, variableStream) of
 	Left e = Left [e]
-    Right fds = Right (AST fds)
-	//_ = case execRWST (constraints fd) zero variableStream of
-	//	Left e = Left [e]
-	//	Right (a, b) = Right b
+    Right (_,fds) = Right (AST fds)
 where
-		constraints :: [FunDecl] -> Typing ()
-        constraints _ = pure ()
-        //TODO: fix
-		//constraints fds = mapM_ funconstraint fds >>| pure ()
-
-		funconstraint :: FunDecl -> Typing ()
-		funconstraint fd=:(FunDecl _ ident args mt vardecls stmts) = case mt of
-			Nothing = abort "Cannot infer functions yet"
-            _ = pure ()
-			//Just t = inEnv (ident, (Forall [] t)) (
-			//	mapM_ vardeclconstraint vardecls >>| pure ())
-
-		vardeclconstraint :: VarDecl -> Typing ()
-        vardeclconstraint _ = pure ()
-        //TODO: fix!
-		//vardeclconstraint (VarDecl p mt ident expr) = infer expr
-			//>>= \it->inEnv (ident, (Forall [] it)) (pure ())
-
 		hasNoDups :: [FunDecl] FunDecl -> Either SemError ()
 		hasNoDups fds (FunDecl p n _ _ _ _)
 		# mbs = map (\(FunDecl p` n` _ _ _ _)->if (n == n`) (Just p`) Nothing) fds
@@ -222,7 +200,6 @@ instance infer Expr where
         pure ((compose s3 $ compose s2 s1), subst s3 tv)
 
     Op1Expr _ op e1 =
-        abort "infereing op1" >>|
         infer e1 >>= \(s1, t1) -> 
         fresh >>= \tv ->
         let given = t1 ->> tv in 
@@ -230,10 +207,9 @@ instance infer Expr where
         lift (unify expected given) >>= \s2 ->
         pure (compose s2 s1, subst s2 tv)
 
-    EmptyListExpr _ = abort "infereing []" >>| (\tv->(zero,tv)) <$> fresh
+    EmptyListExpr _ = (\tv->(zero,tv)) <$> fresh
 
     TupleExpr _ (e1, e2) = 
-        abort "infereing (,)" >>|
         infer e1 >>= \(s1, t1) -> 
         infer e2 >>= \(s2, t2) ->
         pure (compose s2 s1, TupleType (t1,t2))
@@ -242,7 +218,6 @@ instance infer Expr where
         lookup f >>= \expected ->
         let accST = (\(s,ts) e->infer e >>= \(s_,et)->pure (compose s_ s,ts++[et])) in
         foldM accST (zero,[]) args >>= \(s1, argTs)->
-        //abort (concat (["argsTs: "] ++ (map toString argTs))) >>|
         fresh >>= \tv->
         let given = foldr (->>) tv argTs in
         lift (unify expected given) >>= \s2->
@@ -295,10 +270,13 @@ instance infer Stmt where
         pure (compose s3 $ compose s2 s1, subst s3 wht)
 
     AssStmt (VarDef k fs) e =
-        infer e >>= \(s1, et)->
-        applySubst s1 >>|
-        changeGamma (extend k (Forall [] et)) >>| //todo: fieldselectors
-        pure (s1, VoidType)
+        lookup k >>= \expected ->
+        infer e >>= \(s1, given)->
+        lift (unify expected given) >>= \s2->
+        let s = compose s2 s1 in
+        applySubst s >>|
+        changeGamma (extend k (Forall [] given)) >>| //todo: fieldselectors
+        pure (s, VoidType)
 
     FunStmt f es = undef //what is this? 
 
@@ -323,43 +301,52 @@ instance infer [a] | infer a where
 
 //the type class inferes the type of an AST element (VarDecl or FunDecl)
 //and adds it to the AST element
-class type a :: a -> Typing a
+class type a :: a -> Typing (Substitution, a)
 
 instance type VarDecl where
     type (VarDecl p expected k e) = 
-        infer e >>= \(s, given) ->
-        applySubst s >>| 
+        infer e >>= \(s1, given) ->
+        applySubst s1 >>| 
         case expected of
             Nothing = pure zero
             Just expected_ = lift (unify expected_ given)
-        >>|
-        generalize given >>= \t ->
+        >>= \s2->
+        applySubst s2 >>|
+        let vtype = subst (compose s2 s1) given in
+        generalize vtype >>= \t ->
         changeGamma (extend k t) >>| 
-        pure (VarDecl p (Just given) k e)
+        pure (compose s2 s1, VarDecl p (Just vtype) k e)
 
 instance type FunDecl where
     type (FunDecl p f args expected vds stmts) = 
+        gamma >>= \outerScope-> //functions are infered in their own scopde
         introduce f >>|
         mapM introduce args >>= \argTs->
-        type vds >>= \tVds->
-        infer stmts >>= \(s1, result)->
-        let given = foldr (->>) result argTs in 
+        type vds >>= \(s1, tVds)->
         applySubst s1 >>|
+        infer stmts >>= \(s2, result)->
+        applySubst s1 >>|
+        let argTs_ = map (subst $ compose s2 s1) argTs in 
+        //abort (concat $ intersperse "\n" $ map toString argTs_) >>|
+        let given = foldr (->>) result argTs_ in 
         (case expected of
             Nothing = pure zero
             Just expected_ = lift (unify expected_ given))
-        >>= \s2 ->
-        let ftype = subst (compose s2 s1) given in
+        >>= \s3 ->
+        let ftype = subst (compose s3 $ compose s2 s1) given in
         generalize ftype >>= \t->
+        putGamma outerScope >>|
         changeGamma (extend f t) >>| 
-        pure (FunDecl p f args (Just ftype) tVds stmts)
-
-instance toString (Maybe a) | toString a where
-    toString Nothing = "Nothing"
-    toString (Just e) = concat ["Just ", toString e]
+        pure (compose s3 $ compose s2 s1, FunDecl p f args (Just ftype) tVds stmts)
 
 instance type [a] | type a where
-    type dcls = mapM type dcls
+    type []     = pure (zero, [])
+    type [v:vs] = 
+        type v >>= \(s1, v_)->
+        applySubst s1 >>|
+        type vs >>= \(s2, vs_)->
+        applySubst (compose s2 s1) >>|
+        pure (compose s2 s1, [v_:vs_])
 
 introduce :: String -> Typing Type
 introduce k = 
@@ -402,6 +389,10 @@ instance toString SemError where
     toString (Error e) = concat ["Unknown error during semantical",
         "analysis: ", e]
 
+instance toString (Maybe a) | toString a where
+    toString Nothing = "Nothing"
+    toString (Just e) = concat ["Just ", toString e]
+
 instance MonadTrans (StateT (Gamma, [TVar])) where
     liftT m = StateT \s-> m >>= \a-> return (a, s)
 
@@ -410,98 +401,3 @@ Mapmap _ 'Map'.Tip = 'Map'.Tip
 Mapmap f ('Map'.Bin sz k v ml mr) = 'Map'.Bin sz k (f v) 
                                         (Mapmap f ml) 
                                         (Mapmap f mr)
-
-//// ------------------------
-//// First step: Inference
-//// ------------------------//
-
-//unify :: Type Type -> Infer ()
-//unify t1 t2 = tell [(t1, t2)]//
-
-//fresh :: Infer Type
-//fresh = (gets id) >>= \vars-> (put $ tail vars) >>| (pure $ IdType $ head vars)//
-
-//op2Type :: Op2 -> Infer Type
-//op2Type op
-//| elem op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod]
-//	= pure (IntType ->> IntType ->> IntType)
-//| elem op [BiEquals, BiUnEqual]
-//	= fresh >>= \t1-> fresh >>= \t2-> pure (t1 ->> t2 ->> BoolType)
-//| elem op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq]
-//	= pure (IntType ->> IntType ->> BoolType)
-//| elem op [BiAnd, BiOr]
-//	= pure (BoolType ->> BoolType ->> BoolType)
-//| op == BiCons 
-//	= fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)//
-
-//op1Type :: Op1 -> Infer Type
-//op1Type UnNegation = pure $ (BoolType ->> BoolType)
-//op1Type UnMinus = pure $ (IntType ->> IntType)//
-
-////instantiate :: Scheme -> Infer Type
-////instantiate (Forall as t) = mapM (const fresh) as//
-
-//lookupEnv :: String -> Infer Type
-//lookupEnv ident = asks ('Map'.get ident)
-//	>>= \m->case m of
-//		Nothing = liftT $ Left $ UndeclaredVariableError zero ident
-//		Just (Forall as t) = pure t //instantiate ???//
-
-//class infer a :: a -> Infer Type
-//instance infer Expr where
-//	infer (VarExpr _ (VarDef ident fs)) = lookupEnv ident
-//    infer (Op2Expr _ e1 op e2) = 
-//        infer e1 >>= \t1 -> 
-//        infer e2 >>= \t2 ->
-//        fresh >>= \frsh -> 
-//        let given = t1 ->> (t2 ->> frsh) in
-//        op2Type op >>= \expected -> 
-//        unify expected given >>| 
-//        return frsh
-//	infer (Op1Expr _ op e) = 
-//        infer e >>= \t1 -> 
-//        fresh >>= \frsh -> 
-//        let given = t1 ->> frsh in
-//        op1Type op >>= \expected -> 
-//        unify expected given >>| 
-//        pure frsh
-//	infer (IntExpr _ _) = pure IntType
-//	infer (CharExpr _ _) = pure CharType
-//	infer (BoolExpr _ _) = pure BoolType
-//	infer (FunExpr _ f args sels) =  //todo, iets met field selectors
-//        lookupEnv f >>= \expected ->
-//        fresh >>= \frsh -> 
-//        mapM infer args >>= \argTypes ->
-//        let given = foldr (->>) frsh argTypes in
-//        unify expected given >>|
-//        pure frsh
-//	infer (EmptyListExpr _) = ListType <$> fresh
-//	infer (TupleExpr _ (e1, e2)) =
-//		infer e1 >>= \et1->infer e2 >>= \et2->pure $ TupleType (et1, et2)//
-
-////:: VarDef = VarDef String [FieldSelector]
-////:: FieldSelector = FieldHd | FieldTl | FieldFst | FieldSnd
-////:: Op1 = UnNegation | UnMinus
-////:: Op2 = BiPlus | BiMinus | BiTimes | BiDivide | BiMod | BiEquals | BiLesser |
-////	BiGreater | BiLesserEq | BiGreaterEq | BiUnEqual | BiAnd | BiOr | BiCons
-////:: FunDecl = FunDecl Pos String [String] (Maybe Type) [VarDecl] [Stmt]
-////:: FunCall = FunCall String [Expr]
-////:: Stmt 
-////	= IfStmt Expr [Stmt] [Stmt]
-////	| WhileStmt Expr [Stmt]
-////	| AssStmt VarDef Expr
-////	| FunStmt FunCall
-////	| ReturnStmt (Maybe Expr)
-////:: Pos = {line :: Int, col :: Int}
-////:: AST = AST [VarDecl] [FunDecl]
-////:: VarDecl = VarDecl Pos Type String Expr
-////:: Type 
-////	= TupleType (Type, Type)
-////	| ListType Type
-////	| IdType String 
-////	| IntType 
-////	| BoolType
-////	| CharType
-////	| VarType
-////    | VoidType
-////    | (->>) infixl 7 Type Type