From: pimjager <pim@pimjager.nl>
Date: Thu, 26 May 2016 15:48:31 +0000 (+0200)
Subject: Working lambdas uitroepteken
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=0c63934559bd972f4880552315dbe157e98f1cca;p=cc1516.git

Working lambdas uitroepteken
---

diff --git a/AST.dcl b/AST.dcl
index e9afa4f..b005f62 100644
--- a/AST.dcl
+++ b/AST.dcl
@@ -48,6 +48,7 @@ instance toString FieldSelector
 instance toString Op2
 instance toString Expr
 instance toString VarDecl
+instance toString FunDecl
 
 instance zero Pos
 instance == Op1
diff --git a/AST.icl b/AST.icl
index 774e158..d2d1a95 100644
--- a/AST.icl
+++ b/AST.icl
@@ -26,6 +26,9 @@ instance print FunDecl where
 		["{\n\t":printersperse "\n\t" vs] ++
 		["\n":printStatements ss 1] ++ ["}\n"]
 
+instance toString FunDecl where
+    toString fd = concat $ print fd
+
 printStatements :: [Stmt] Int -> [String]
 printStatements [] i = []
 printStatements [s:ss] i = (case s of
diff --git a/examples/tempTest.spl b/examples/tempTest.spl
index e8be43b..cf339cf 100644
--- a/examples/tempTest.spl
+++ b/examples/tempTest.spl
@@ -1,6 +1,6 @@
-plus(x,y){
-    return x+y;
-}
+//plus(x,y){
+//    return x+y;
+//}//
 
 map(f, xs) {
     if (isEmpty(xs)) {
@@ -10,19 +10,18 @@ map(f, xs) {
     }
 }
 
-foldr(f, acc, xs) {
-    if(isEmpty(xs)) {
-        return acc;
-    } else {
-        return foldr(f, f(xs.hd, acc), xs.tl);
-    }
-}
+//foldr(f, acc, xs) {
+//    if(isEmpty(xs)) {
+//        return acc;
+//    } else {
+//        return foldr(f, f(xs.hd, acc), xs.tl);
+//    }
+//}
 
 main() {
-    var f = plus(1);
-    var z = map(f, 1:2:[]);
-    var x = foldr(plus, 0, 1:2:[]);
-    print(x);
+    var f = \x -> x+1;
+    var z = map(\x->x+1, 1:2:[]);
+    //var x = foldr(plus, 0, 1:2:[]);
+    //print(x);
     return;
->>>>>>> master
 }
\ No newline at end of file
diff --git a/parse.icl b/parse.icl
index a79ad2f..426e47e 100644
--- a/parse.icl
+++ b/parse.icl
@@ -114,6 +114,7 @@ parseType =
 
 parseExpr :: Parser Token Expr
 parseExpr = parseValueExpr <|> parseLambda
+
 parseValueExpr :: Parser Token Expr
 parseValueExpr = //Operators in order of binding strength
 	parseOpR (trans1 ColonToken BiCons) $
diff --git a/sem.icl b/sem.icl
index 364eac4..4f4e874 100644
--- a/sem.icl
+++ b/sem.icl
@@ -62,7 +62,7 @@ sem :: AST -> Either [SemError] (AST, Gamma)
 sem (AST fd) = case foldM (const $ hasNoDups fd) () fd 
             		>>| foldM (const isNiceMain) () fd
             		>>| hasMain fd
-                    >>| runStateT (type fd) (defaultGamma, variableStream) of
+                    >>| runStateT (unfoldLambda fd >>= type) (defaultGamma, variableStream) of
 	Left e = Left [e]
     Right ((_,fds),(gam,_)) = Right (AST fds, gam)
 where
@@ -89,20 +89,56 @@ where
 				_ = Left $ SanityError p "main has to return Void")
 		isNiceMain _ = pure ()
 
+
+//------------------
+// LAMBDA UNFOLDING
+//------------------
 unfoldLambda :: [FunDecl] -> Typing [FunDecl]
-unfoldLambda [fd:fds] = unf_ fd >>= \fds1-> 
-                        unfoldLambda fds >>= \fds2->
-                        pure $ fds1 ++ fds2
-where
-    unf_ :: FunDecl -> Typing [FunDecl]
-    unf_ fd=:(FunDecl _ _ _ _ vds stmts) = 
-        flatten <$> mapM unfv_ vds >>= \fds1->
-        flatten <$> mapM unfs_ stmts >>= \fds2->
-        pure $ [fd:fds1] ++ fds2
-    unfv_ :: VarDecl -> Typing [FunDecl]
-    unfv_ (VarDecl _ _ _ e) = pure []
-    unfs_ :: Stmt -> Typing [FunDecl]
-    unfs_ _ = pure []
+unfoldLambda [] = pure []
+unfoldLambda [fd:fds] = unfoldL_ fd >>= \(gen1, fs_)-> 
+                        unfoldLambda fds >>= \gen2->
+                        pure $ gen1 ++ [fs_] ++ gen2
+
+flattenT :: [([a],b)] -> ([a],[b])
+flattenT ts = (flatten $ map fst ts, map snd ts)
+
+class unfoldL_ a :: a -> Typing ([FunDecl], a)
+
+instance unfoldL_ FunDecl where
+    unfoldL_ (FunDecl p f args mt vds stmts) = 
+        flattenT <$> mapM unfoldL_ vds >>= \(fds1,vds_) ->
+        flattenT <$> mapM unfoldL_ stmts >>= \(fds2,stmts_)->
+        pure (fds1 ++ fds2, FunDecl p f args mt vds_ stmts_)
+
+instance unfoldL_ VarDecl where
+    unfoldL_ (VarDecl p mt v e) = unfoldL_ e >>= \(fds, e_)->pure (fds, VarDecl p mt v e_)
+
+instance unfoldL_ Stmt where
+    unfoldL_ (IfStmt e th el) = unfoldL_ e >>= \(fds, e_)->pure (fds, IfStmt e_ th el)
+    unfoldL_ (WhileStmt e c) = unfoldL_ e >>= \(fds, e_)->pure (fds, WhileStmt e_ c)
+    unfoldL_ (AssStmt vd e) = unfoldL_ e >>= \(fds, e_)->pure (fds, AssStmt vd e_)
+    unfoldL_ (FunStmt f es fs) = flattenT <$> mapM unfoldL_ es >>= \(fds, es_)->
+        pure (fds, FunStmt f es_ fs)
+    unfoldL_ (ReturnStmt (Just e)) = unfoldL_ e >>= \(fds, e_) -> 
+        pure (fds, ReturnStmt (Just e_))
+    unfoldL_ (ReturnStmt Nothing) = pure ([], ReturnStmt Nothing)
+
+instance unfoldL_ Expr where
+    unfoldL_ (LambdaExpr p args e) = 
+        fresh >>= \(IdType n) ->
+        let f = ("lambda_"+++n) in
+        let fd = FunDecl p f args Nothing [] [ReturnStmt $ Just e] in 
+        let fe = FunExpr p f [] [] in
+        pure ([fd], fe)
+    unfoldL_ (FunExpr p f es fs) = flattenT <$> mapM unfoldL_ es >>= \(fds, es_)->
+        pure (fds, FunExpr p f es_ fs)
+    unfoldL_ e = pure ([], e)
+
+//------------
+//------------
+//      TYPING 
+//------------
+//------------
 
 class Typeable a where
     ftv :: a -> [TVar]
@@ -389,7 +425,8 @@ instance type VarDecl where
         pure (compose s2 s1, VarDecl p (Just vtype) k e_)
 
 instance type FunDecl where
-    type (FunDecl p f args expected vds stmts) = 
+    type fd=:(FunDecl p f args expected vds stmts) = 
+        //if (f=="main") (abort (toString fd)) (pure ()) >>|
         gamma >>= \outerScope-> //functions are infered in their own scopde
         introduce f >>|
         mapM introduce args >>= \argTs->