From 59fb773bc1cc3d8d37531a08df223a706d2dc7a2 Mon Sep 17 00:00:00 2001
From: Martin Fredin <fredin.martin@gmail.com>
Date: Thu, 9 Feb 2023 20:24:25 +0100
Subject: [PATCH] Some clean up and documenting

---
 src/LambdaLifter.hs | 62 +++++++++++++++------------------------------
 src/Main.hs         |  9 ++++---
 2 files changed, 26 insertions(+), 45 deletions(-)

diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs
index c9253b6..ac9cee0 100644
--- a/src/LambdaLifter.hs
+++ b/src/LambdaLifter.hs
@@ -14,17 +14,19 @@ import           Data.Tuple.Extra (uncurry3)
 import           Grammar.Abs
 import           Prelude          hiding (exp)
 
+
+
+-- | Lift lambdas and let expression into supercombinators.
 lambdaLift :: Program -> Program
 lambdaLift = collectScs . rename . abstract . freeVars
 
--- Annotate free variables
 
+-- | Annotate free variables
 freeVars :: Program -> AnnProgram
 freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e)
                         | Bind n xs e <- ds
                         ]
 
-
 freeVarsExp :: Set Ident -> Exp -> AnnExp
 freeVarsExp lv = \case
 
@@ -63,8 +65,22 @@ freeVarsOf = fst
 fromBinders :: [Bind] -> ([Ident], [[Ident]], [Exp])
 fromBinders bs = unzip3 [ (n, xs, e) | Bind n xs e <- bs ]
 
--- Lift lambda expression into let with binder "sc"
+-- AST annotated with free variables
+type AnnProgram = [(Ident, [Ident], AnnExp)]
 
+type AnnExp = (Set Ident, AnnExp')
+
+data ABind = ABind Ident [Ident] AnnExp deriving Show
+
+data AnnExp' = AId Ident
+             | AInt Integer
+             | AApp AnnExp  AnnExp
+             | AAdd AnnExp  AnnExp
+             | AAbs Ident   AnnExp
+             | ALet [ABind] AnnExp
+             deriving Show
+
+-- | Lift lambdas to let expression of the form @let sc = \x -> rhs@
 abstract :: AnnProgram -> Program
 abstract prog = Program $ map f prog
   where
@@ -74,15 +90,6 @@ abstract prog = Program $ map f prog
       AAbs par body -> Bind name (snoc par pars) $ abstractExp body
       _             -> Bind name pars            $ abstractExp rhs
 
-
-
--- [ case rhs of
---     EAbs par body -> Bind name (snoc par pars) body
---     _             -> Bind name pars rhs
---
--- | (name, pars, rhs) <- prog
-
-
 abstractExp :: AnnExp -> Exp
 abstractExp (free, exp) = case exp of
   AId  n     -> EId n
@@ -101,8 +108,7 @@ abstractExp (free, exp) = case exp of
 snoc :: a -> [a] -> [a]
 snoc x xs = xs ++ [x]
 
--- Rename
-
+-- | Rename all supercombinators and variables
 rename :: Program -> Program
 rename (Program ds) = Program $ map (uncurry3 Bind) tuples
   where
@@ -163,24 +169,12 @@ makeName :: String -> Int -> Ident
 makeName prefix i = Ident (prefix ++ "_" ++ show i)
 
 
--- Collect supercombinators
-
+-- | Collects supercombinators by lifting appropriate let expressions
 collectScs :: Program -> Program
 collectScs (Program ds) = Program $ concatMap collectOneSc ds
   where
     collectOneSc (Bind name args rhs) = Bind name args rhs' : scs
       where (scs, rhs') = collectScsExp rhs
-  {-
-
-
-
-Bind (Ident "f") []
-
-  (ELet [Bind (Ident "sc") [] (EAbs (Ident "x") (EAdd (EId (Ident "x")) (EInt 1)))] (EId (Ident "sc")))
-
-
-  -}
-
 
 collectScsExp :: Exp -> ([Bind], Exp)
 collectScsExp = \case
@@ -225,17 +219,3 @@ mkEAbs [] e = e
 mkEAbs bs e = ELet bs e
 
 
--- Annotated AST
-
-type AnnProgram = [(Ident, [Ident], AnnExp)]
-type AnnExp = (Set Ident, AnnExp')
-
-data ABind = ABind Ident [Ident] AnnExp deriving Show
-
-data AnnExp' = AId Ident
-             | AInt Integer
-             | AApp AnnExp  AnnExp
-             | AAdd AnnExp  AnnExp
-             | AAbs Ident   AnnExp
-             | ALet [ABind] AnnExp
-             deriving Show
diff --git a/src/Main.hs b/src/Main.hs
index 211bf3a..9af1753 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -20,12 +20,13 @@ main = getArgs >>= \case
       Right prg -> do
         putStrLn "-- Parse"
         putStrLn $ printTree prg
-        putStrLn "\n-- Abstract"
-        putStrLn . printTree $ (abstract . freeVars) prg
-        putStrLn "\n-- Rename"
-        putStrLn . printTree $ (rename . abstract . freeVars) prg
+        -- putStrLn "\n-- Abstract"
+        -- putStrLn . printTree $ (abstract . freeVars) prg
+        -- putStrLn "\n-- Rename"
+        -- putStrLn . printTree $ (rename . abstract . freeVars) prg
         putStrLn "\n-- Lamda lifter"
         putStrLn . printTree $ lambdaLift prg
+        putStrLn ""
         exitSuccess