fp-il

commit 00f123d6c5df592b3660fe0e6fb2e80b216b2ca3
parent 5ded005cb6dab79c96e84e67ba6f4f7eddda17d6
Author: Erik Oosting <crazazy@tilde.cafe>
Date:   Thu,  1 Feb 2024 03:40:54 +0100

added example function

Diffstat:
M
haskell/app/Lift.hs
 | 
45
+++++++++++++++++++++++++++++++++++----------

1 file changed, 35 insertions(+), 10 deletions(-)
diff --git a/haskell/app/Lift.hs b/haskell/app/Lift.hs
@@ -21,6 +21,22 @@ factorial =
         )
     )
 
+three :: CExp
+three =
+    ( Let
+        "n"
+        (Atom (Number 1))
+        ( Let
+            "n"
+            (Atom (AAdd (Ident "n") (Number 1)))
+            ( Let
+                "n"
+                (Atom (AAdd (Ident "n") (Number 1)))
+                (FC (Atom (Ident "n")))
+            )
+        )
+    )
+
 liftArgs :: AExp -> AExp
 liftArgs lam@(Lam args body) = Lam (args ++ cata findVarsAExp lam) body
 liftArgs rest = rest
@@ -97,7 +113,7 @@ subVarsCExp (env, queue, LetF name fc rest) =
     let
         (newName, oldNames) =
             foldr
-                (\m (n, ns) -> if n == m then (n ++ "_", n:ns) else (n, ns)) -- repeatedly replace variables in the function call
+                (\m (n, ns) -> if n == m then (n ++ "_", n : ns) else (n, ns)) -- repeatedly replace variables in the function call
                 (name, [])
                 queue -- make sure to do oldest first!
         newFC = foldr replaceVarsFC fc $ oldNames \\ [newName]
@@ -110,15 +126,24 @@ subVarsCExp (env, queue, IfF cond thenPart elsePart) =
         (env, queue, elsePart)
 subVarsCExp (env, queue, FCF fc) = FCF $ foldr replaceVarsFC fc queue
 
-
+unsafeCotransverse ::
+    (Corecursive t, Recursive a, Functor f) =>
+    (f (Base a a) -> Base t (f a)) ->
+    f a ->
+    t
 unsafeCotransverse n = ana (n . fmap project)
 
-subVarsCExp' (env, LetF name fc body) 
-            | name `elem` env =
-              let
-                newName = name ++ "_"
-                newFC = replaceVarsFC newName fc
-                newBody = cata replaceVarsCExp body name
-              in LetF newName newFC (newName : env, newBody)
-            | otherwise = LetF name fc (name : env, body)
+subVarsCExp' :: ([String], CExpF CExp) -> CExpF ([String], CExp)
+subVarsCExp' (env, LetF name fc body)
+    | name `elem` env =
+        let
+            newName = name ++ "_"
+            newFC = replaceVarsFC newName fc
+            newBody = cata replaceVarsCExp body name
+         in
+            LetF newName newFC (newName : env, newBody)
+    | otherwise = LetF name fc (name : env, body)
 subVarsCExp' (env, rest) = fmap (env,) rest
+
+substitute :: CExp -> CExp
+substitute = unsafeCotransverse subVarsCExp' . ([],)