start of code generation
[cc1516.git] / sem.icl
diff --git a/sem.icl b/sem.icl
index 7f7cdf4..68b804d 100644 (file)
--- 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
@@ -292,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? 
 
@@ -320,7 +301,7 @@ 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) = 
@@ -334,31 +315,38 @@ instance type VarDecl where
         let vtype = subst (compose s2 s1) given in
         generalize vtype >>= \t ->
         changeGamma (extend k t) >>| 
-        pure (VarDecl p (Just vtype) 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 = 
@@ -401,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)
 
@@ -409,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