Fix first unnecessary supercombinator

Grammar.cf

@@ -1,12 +1,6 @@
 
 
-Program. Program ::= [ScDef];
-
-ScDef. ScDef ::= Bind; 
-separator ScDef ";";
-
-separator Ident " ";
-
+Program. Program ::= [Bind];
 
 EId.  Exp3 ::= Ident;
 EInt. Exp3 ::= Integer;
@@ -17,6 +11,7 @@ EAbs. Exp  ::= "\\" Ident "." Exp;
 
 Bind. Bind ::= Ident [Ident] "=" Exp;
 separator Bind ";";
+separator Ident " ";
 
 coercions Exp 3;
 

basic-2

@@ -1,4 +0,0 @@
-add x = \y. x + y;
-
-main = (\z. z + z) ((add 4) 6);
-

sample-programs/basic-1

@@ -0,0 +1,2 @@
+
+f = \x. x+1;

sample-programs/basic-2

@@ -0,0 +1,4 @@
+add x = \y. x+y;
+
+main = (\z. z+z) ((add 4) 6);
+

sample-programs/basic-3

@@ -0,0 +1,2 @@
+
+main = (\x. x+x+3) ((\x. x) 2)

sample-programs/basic-4

@@ -0,0 +1,2 @@
+
+f x = let g = (\y. y+1) in g (g x)

sample-programs/basic-5

@@ -0,0 +1,9 @@
+id x = x;
+
+add x y = x + y;
+
+double n = n + n;
+
+apply f x = \y -> f x y;
+
+main = apply (id add) ((\x. x + 1) 1) (double 3);

src/LambdaLifter.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms   #-}
 
 
 module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where
@@ -15,20 +14,14 @@ import           Data.Tuple.Extra (uncurry3)
 import           Grammar.Abs
 import           Prelude          hiding (exp)
 
-pattern Sc :: Ident -> [Ident] -> Exp -> ScDef
-pattern Sc n xs e = ScDef (Bind n xs e)
-
-
-
 lambdaLift :: Program -> Program
 lambdaLift = collectScs . rename . abstract . freeVars
 
-
 -- Annotate free variables
 
 freeVars :: Program -> AnnProgram
 freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e)
-                        | Sc n xs e <- ds
+                        | Bind n xs e <- ds
                         ]
 
 
@@ -64,7 +57,6 @@ freeVarsExp lv = \case
       freeInValues = foldr1 Set.union (map freeVarsOf es')
 
 
-
 freeVarsOf :: AnnExp -> Set Ident
 freeVarsOf = fst
 
@@ -74,10 +66,21 @@ fromBinders bs = unzip3 [ (n, xs, e) | Bind n xs e <- bs ]
 -- Lift lambda expression into let with binder "sc"
 
 abstract :: AnnProgram -> Program
-abstract p = Program
-  [ Sc sc_name xs $ abstractExp rhs
-  | (sc_name, xs, rhs) <- p
-  ]
+abstract prog = Program $ map f prog
+  where
+  f :: (Ident, [Ident], AnnExp) -> Bind
+  f (name, pars, rhs@(_, e)) =
+    case e of
+      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
@@ -94,13 +97,17 @@ abstractExp (free, exp) = case exp of
       e' = foldr EAbs (abstractExp e) (fvList ++ [n])
       sc = ELet [bind] (EId (Ident "sc"))
 
+
+snoc :: a -> [a] -> [a]
+snoc x xs = xs ++ [x]
+
 -- Rename
 
 rename :: Program -> Program
-rename (Program ds) = Program $ map (uncurry3 Sc) tuples
+rename (Program ds) = Program $ map (uncurry3 Bind) tuples
   where
     tuples = snd (mapAccumL renameSc 0 ds)
-    renameSc i (Sc n xs e) = (i2, (n, xs', e'))
+    renameSc i (Bind n xs e) = (i2, (n, xs', e'))
       where
         (i1, xs', env) = newNames i xs
         (i2, e')       = renameExp env i1 e
@@ -159,14 +166,23 @@ makeName prefix i = Ident (prefix ++ "_" ++ show i)
 -- Collect supercombinators
 
 collectScs :: Program -> Program
-collectScs (Program ds) = Program $ concatMap collect_one_sc ds
+collectScs (Program ds) = Program $ concatMap collectOneSc ds
   where
-    collect_one_sc (Sc n xs e) = Sc n xs e' : scs
-      where (scs, e') = collectScsExp e
+    collectOneSc (Bind name args rhs) = Bind name args rhs' : scs
+      where (scs, rhs') = collectScsExp rhs
+  {-
 
 
 
-collectScsExp :: Exp -> ([ScDef], Exp)
+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
 
   EId  n     -> ([], EId n)
@@ -190,25 +206,15 @@ collectScsExp = \case
   ELet bs e  -> (rhss_scs ++ e_scs ++ local_scs, mkEAbs non_scs' e')
     where
       (rhss_scs, bs') = mapAccumL collectScs_d [] bs
-      scs'            = [ Sc n xs rhs | Sc n xs rhs <- bs', isEAbs rhs]
-      non_scs'        = [ Bind n xs rhs | Sc n xs rhs <- bs', not $ isEAbs rhs]
-      local_scs       = map peelLambda scs'
-      -- local_scs       = [ Sc n (xs ++ [x]) e1 | Sc n xs (EAbs x e1) <- scs']
+      scs'            = [ Bind n xs rhs | Bind n xs rhs <- bs', isEAbs rhs]
+      non_scs'        = [ Bind n xs rhs | Bind n xs rhs <- bs', not $ isEAbs rhs]
+      local_scs       = [ Bind n (xs ++ [x]) e1 | Bind n xs (EAbs x e1) <- scs']
       (e_scs, e')     = collectScsExp e
 
-      collectScs_d scs (Bind n xs rhs) = (scs ++ rhs_scs1, Sc n xs rhs')
+      collectScs_d scs (Bind n xs rhs) = (scs ++ rhs_scs1, Bind n xs rhs')
         where
           (rhs_scs1, rhs') = collectScsExp rhs
 
-
-
-peelLambda :: ScDef -> ScDef
-peelLambda sc@(Sc n xs e) = case e of
-                           EAbs x e1 -> peelLambda (Sc n (xs ++ [x]) e1)
-                           _         -> sc
-
-
-
 isEAbs :: Exp -> Bool
 isEAbs = \case
   EAbs {} -> True

src/Main.hs

@@ -18,9 +18,13 @@ main = getArgs >>= \case
        putStrLn err
        exitFailure
       Right prg -> do
-        putStrLn "-- Parser"
+        putStrLn "-- Parse"
         putStrLn $ printTree prg
-        putStrLn "\n--Lamda lifter"
+        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
         exitSuccess
 

test_program

@@ -1,5 +0,0 @@
-
-
-
-
-main = (\x. x + x + 3) ((\x. x) 2)