-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
+//------------
+//------------