rotten codebase

src/Core2Core.hs

@@ -11,8 +11,8 @@ module Core2Core
 ----------------------------------------------------------------------------------
 import Data.Functor.Foldable
 import Data.Maybe               (fromJust)
-import Data.Set                 (Set)
-import Data.Set                 qualified as S
+import Data.HashSet             (HashSet)
+import Data.HashSet             qualified as S
 import Data.List
 import Data.Foldable
 import Control.Monad.Writer
@@ -22,6 +22,8 @@ import Data.Text                qualified as T
 import Data.HashMap.Strict      (HashMap)
 import Numeric                  (showHex)
 
+import Misc.MonadicRecursionSchemes
+
 import Data.Pretty
 import Compiler.RLPC
 import Control.Lens
@@ -46,10 +48,14 @@ gmPrep :: Program' -> Program'
 gmPrep p = p & appFloater (floatNonStrictCases globals)
              & tagData
              & defineData
+             & etaReduce
     where
         globals = p ^.. programScDefs . each . _lhs . _1
                 & S.fromList
 
+programGlobals :: Program b -> HashSet b
+programGlobals = undefined
+
 -- | Define concrete supercombinators for all datatags defined via pragmas (or
 -- desugaring)
 
@@ -92,7 +98,7 @@ runFloater = flip evalStateT ns >>> runWriter
 
 -- TODO: formally define a "strict context" and reference that here
 -- the returned ScDefs are guaranteed to be free of non-strict cases.
-floatNonStrictCases :: Set Name -> Expr' -> Floater Expr'
+floatNonStrictCases :: HashSet Name -> Expr' -> Floater Expr'
 floatNonStrictCases g = goE
     where
         goE :: Expr' -> Floater Expr'
@@ -104,24 +110,20 @@ floatNonStrictCases g = goE
         goE e                   = goC e
 
         goC :: Expr' -> Floater Expr'
-        -- the only truly non-trivial case: when a case expr is found in a
-        -- non-strict context, we float it into a supercombinator, give it a
-        -- name consumed from the state, record the newly created sc within the
-        -- Writer, and finally return an expression appropriately calling the sc
-        goC p@(Case e as)       = do
-            n <- name
-            let (e',sc) = floatCase g n p
-                altBodies = (\(Alter _ _ b) -> b) <$> as
-            tell [sc]
-            goE e
-            traverse_ goE altBodies
-            pure e'
-        goC (App f x)           = App <$> goC f <*> goC x
-        goC (Let r bs e)        = Let r <$> bs' <*> goE e
-            where bs' = travBs goC bs
-        goC (Lit l)             = pure (Lit l)
-        goC (Var k)             = pure (Var k)
-        goC (Con t as)          = pure (Con t as)
+        goC = cataM \case
+            -- the only truly non-trivial case: when a case expr is found in a
+            -- non-strict context, we float it into a supercombinator, give it a
+            -- name consumed from the state, record the newly created sc within the
+            -- Writer, and finally return an expression appropriately calling the sc
+            CaseF e as -> do
+                n <- name
+                let (e',sc) = floatCase g n (Case e as)
+                    altBodies = (\(Alter _ _ b) -> b) <$> as
+                tell [sc]
+                goE e
+                traverse_ goE altBodies
+                pure e'
+            t -> pure $ embed t
 
         name = state (fromJust . Data.List.uncons)
 
@@ -132,10 +134,15 @@ floatNonStrictCases g = goE
         -- ^ ??? what the fuck?
         -- ^ 24/02/22: what is this shit lol?
 
+etaReduce :: Program' -> Program'
+etaReduce = programScDefs . each %~ \case
+    ScDef n as (Lam bs e) -> ScDef n (as ++ bs) e
+    ScDef n as e -> ScDef n as e
+
 -- when provided with a case expr, floatCase will float the case into a
 -- supercombinator of its free variables. the sc is returned along with an
 -- expression that calls the sc with the necessary arguments
-floatCase :: Set Name -> Name -> Expr' -> (Expr', ScDef')
+floatCase :: HashSet Name -> Name -> Expr' -> (Expr', ScDef')
 floatCase g n c@(Case e as) = (e', sc)
     where
         sc = ScDef n caseFrees c