rotten codebase

README.org

@@ -164,6 +164,10 @@ Available debug flags include:
    
    id : ∀ ($a0 : Type). $a0 -> $a0  = <lambda>;
    #end_src
+
+
+** TODO Core.Utils.freeVariables does not handle let-bindings              :bug:
+
 * Releases
 
 ** +December Release+

src/Core/Syntax.hs

@@ -263,6 +263,7 @@ type ScDef' = ScDef Name
 
 lambdaLifting :: Iso (ScDef b) (ScDef b') (b, Expr b) (b', Expr b')
 lambdaLifting = iso sa bt where
+    sa (ScDef n [] e) = (n, e) where
     sa (ScDef n as e) = (n, e') where
         e' = Lam as e
 

src/Core/Utils.hs

@@ -8,8 +8,8 @@ module Core.Utils
 ----------------------------------------------------------------------------------
 import Data.Functor.Foldable.TH     (makeBaseFunctor)
 import Data.Functor.Foldable
-import Data.Set                     (Set)
-import Data.Set                     qualified as S
+import Data.HashSet                 (HashSet)
+import Data.HashSet                 qualified as S
 import Core.Syntax
 import Control.Lens
 import GHC.Exts                     (IsList(..))
@@ -28,29 +28,10 @@ isAtomic _        = False
 
 ----------------------------------------------------------------------------------
 
-freeVariables :: Expr b -> Set b
+freeVariables :: Expr' -> HashSet Name
 freeVariables = undefined
-
--- freeVariables :: Expr' -> Set Name
--- freeVariables = cata go
---     where
---         go :: ExprF Name (Set Name) -> Set Name
---         go (VarF k)         = S.singleton k
---         -- TODO: collect free vars in rhss of bs
---         go (LetF _ bs e)    = (e `S.union` esFree) `S.difference` ns
---             where
---                 es = bs ^.. each . _rhs :: [Expr']
---                 ns = S.fromList $ bs ^.. each . _lhs
---                 -- TODO: this feels a little wrong. maybe a different scheme is
---                 -- appropriate
---                 esFree = foldMap id $ freeVariables <$> es
-
---         go (CaseF e as)     = e `S.union` asFree
---             where
---                 -- asFree = foldMap id $ freeVariables <$> (fmap altToLam as)
---                 asFree = foldMap (freeVariables . altToLam) as
---                 -- we map alts to lambdas to avoid writing a 'freeVariablesAlt'
---                 altToLam (Alter _ ns e) = Lam ns e
---         go (LamF bs e)      = e `S.difference` (S.fromList bs)
---         go e                = foldMap id e
+-- freeVariables = cata \case
+--     VarF n -> S.singleton n
+--     CaseF e as -> e <> (foldMap f as)
+--         where f (AlterF _ bs e) = fold e `S.difference` S.fromList bs
 

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

src/Rlp2Core.hs

@@ -84,8 +84,8 @@ runNameSupply :: Text -> Eff (NameSupply ': es) a -> Eff es a
 runNameSupply pre = runLabeled $ evalState [ pre <> "_" <> tshow name | name <- [0..] ]
     where tshow = T.pack . show
 
-single :: (Monoid s, Applicative f) => ASetter s t a (f b) -> b -> t
-single l a = mempty & l .~ pure a
+single :: (Monoid s) => ASetter s t a b -> b -> t
+single l a = mempty & l .~ a
 
 -- the rl' program is desugared by desugaring each declaration as a separate
 -- program, and taking the monoidal product of the lot :3
@@ -97,16 +97,41 @@ rlpProgToCore = foldMapOf (programDecls . each) declToCore
 
 declToCore :: Rlp.Decl PsName TypedRlpExpr' -> Core.Program Var
 
+declToCore (DataD n as ds)
+    = foldMap (uncurry $ conToCore t) ([0..] `zip` ds)
+   <> single programTyCons (H.singleton n k)
+  where
+    as' = TyVar <$> as
+    k = foldr (:->) t as'
+    t = foldl TyApp (TyCon n) as'
+
 -- assume full eta-expansion for now
 declToCore (FunD b [] e) = single programScDefs $
-    ScDef b' [] e'
+    [ScDef b' [] e']
   where
     b' = MkVar b (typeToCore $ extract e)
     e' = runPureEff . runNameSupply b . cataM exprToCore . retype $ e
 
+conToCore :: Core.Type -> Int -> DataCon PsName -> Core.Program Var
+conToCore t tag (DataCon b as)
+    = single programScDefs [ScDef b' [] $ Con tag arity]
+  where
+    arity = lengthOf arrowStops t - 1
+    b' = MkVar b t
+
 dummyExpr :: Text -> Core.Expr b
 dummyExpr a = Var ("<" <> a <> ">")
 
+stripTypes :: Core.Program Var -> Core.Program Name
+stripTypes p = Core.Program
+    { _programTyCons = p ^. programTyCons 
+    , _programDataTags = p ^. programDataTags
+    , _programScDefs =  p ^. programScDefs
+            & each . binders %~ (\ (MkVar n _) -> n)
+    -- TEMP
+    , _programTypeSigs = mempty
+    }
+
 --------------------------------------------------------------------------------
 
 -- | convert rl' types to Core types, annotate binders, and strip excess type
@@ -124,6 +149,9 @@ retype = (_extract %~ unquantify) >>> fmap typeToCore >>> cata \case
     t :<$ InR (LetEF r bs e)
         -> Finr (LetEF r _ _)
 
+    t :<$ InR (CaseEF e as)
+        -> _
+
 unquantify :: Rlp.Type b
            -> Rlp.Type b
 unquantify (ForallT _ x) = unquantify x
@@ -145,15 +173,28 @@ exprToCore :: (NameSupply :> es)
            -> Eff es (Core.Expr Var)
 
 exprToCore (InL e) = pure . embed $ e
-exprToCore (InR _) = _
 
-exprToCore _ = pure $ dummyExpr "expr"
+exprToCore (InR e) = exprToCore' e
+
+exprToCore' :: (NameSupply :> es)
+            => Rlp.ExprF Var (Core.Expr Var) -> Eff es (Core.Expr Var)
+
+exprToCore' (CaseEF e as) = pure $ Case e (alterToCore <$> as)
+
+exprToCore' _ = pure $ dummyExpr "expr"
+
+alterToCore :: Rlp.Alter Var (Expr Var) -> Core.Alter Var
+alterToCore (Rlp.Alter (ConP' (MkVar n _) bs) e)
+    = Core.Alter (AltData n) (noPatterns bs) e
+
+noPatterns :: [Pat b] -> [b]
+noPatterns ps = ps ^.. each . singular _VarP
 
 --------------------------------------------------------------------------------
 
 annotateVar :: Core.Type -> Core.ExprF PsName a -> Core.ExprF Var a
 
--- fixed points:
+-- fix-points:
 annotateVar _ (VarF n)   = VarF n
 annotateVar _ (ConF t a) = ConF t a
 annotateVar _ (AppF f x) = AppF f x