From: pimjager 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->