From 8a1e34813449b2b0fcab2857c2820b5e20fa734e Mon Sep 17 00:00:00 2001
From: Andreas Klebinger <klebinger.andreas@gmx.at>
Date: Thu, 4 Aug 2022 21:27:57 +0200
Subject: Add a flag to optionally keep auto-generated rules around.

---
 compiler/GHC/Driver/Config/Tidy.hs |  1 +
 compiler/GHC/Driver/Flags.hs       |  1 +
 compiler/GHC/Driver/Session.hs     |  1 +
 compiler/GHC/Iface/Tidy.hs         | 12 +++++++++---
 4 files changed, 12 insertions(+), 3 deletions(-)

diff --git a/compiler/GHC/Driver/Config/Tidy.hs b/compiler/GHC/Driver/Config/Tidy.hs
index 89bdf31b2c..9a73abff00 100644
--- a/compiler/GHC/Driver/Config/Tidy.hs
+++ b/compiler/GHC/Driver/Config/Tidy.hs
@@ -43,6 +43,7 @@ initTidyOpts hsc_env = do
     , opt_expose_rules      = not (gopt Opt_OmitInterfacePragmas dflags)
     , opt_trim_ids          = gopt Opt_OmitInterfacePragmas dflags
     , opt_static_ptr_opts   = static_ptr_opts
+    , opt_keep_orphan_rules = gopt Opt_KeepAutoRules dflags
     }
 
 initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index a4e5827bc6..bb626fccfc 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -297,6 +297,7 @@ data GeneralFlag
    | Opt_IgnoreInterfacePragmas
    | Opt_OmitInterfacePragmas
    | Opt_ExposeAllUnfoldings
+   | Opt_KeepAutoRules -- ^Keep auto-generated rules even if they seem to have become useless
    | Opt_WriteInterface -- forces .hi files to be written even with -fno-code
    | Opt_WriteHie -- generate .hie files
 
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 43f58884fc..223d7789d0 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3388,6 +3388,7 @@ fFlagsDeps = [
   flagSpec "error-spans"                      Opt_ErrorSpans,
   flagSpec "excess-precision"                 Opt_ExcessPrecision,
   flagSpec "expose-all-unfoldings"            Opt_ExposeAllUnfoldings,
+  flagSpec "keep-auto-rules"                  Opt_KeepAutoRules,
   flagSpec "expose-internal-symbols"          Opt_ExposeInternalSymbols,
   flagSpec "external-dynamic-refs"            Opt_ExternalDynamicRefs,
   flagSpec "external-interpreter"             Opt_ExternalInterpreter,
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index f395c0daa8..f53d81ba81 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -358,6 +358,7 @@ data TidyOpts = TidyOpts
       -- ^ Are rules exposed or not?
   , opt_static_ptr_opts :: !(Maybe StaticPtrOpts)
       -- ^ Options for generated static pointers, if enabled (/= Nothing).
+  , opt_keep_orphan_rules :: !Bool
   }
 
 tidyProgram :: TidyOpts -> ModGuts -> IO (CgGuts, ModDetails)
@@ -382,6 +383,7 @@ tidyProgram opts (ModGuts { mg_module           = mod
   let implicit_binds = concatMap getImplicitBinds tcs
 
   (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod binds implicit_binds imp_rules
+  -- pprTraceM "findExternalRules" $ ppr imp_rules
   let (trimmed_binds, trimmed_rules) = findExternalRules opts binds imp_rules unfold_env
 
   let uf_opts = opt_unfolding_opts opts
@@ -392,6 +394,8 @@ tidyProgram opts (ModGuts { mg_module           = mod
     Nothing    -> pure ([], Nothing, tidy_binds)
     Just sopts -> sptCreateStaticBinds sopts mod tidy_binds
 
+  -- pprTraceM "trimmed_rules" (ppr trimmed_rules)
+
   let all_foreign_stubs = case mcstub of
         Nothing    -> foreign_stubs
         Just cstub -> foreign_stubs `appendStubC` cstub
@@ -976,10 +980,13 @@ findExternalRules :: TidyOpts
 findExternalRules opts binds imp_id_rules unfold_env
   = (trimmed_binds, filter keep_rule all_rules)
   where
-    imp_rules         = filter expose_rule imp_id_rules
+    imp_rules
+      | not (opt_expose_rules opts) = []
+      | otherwise = filter expose_rule imp_id_rules
     imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules
 
-    user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet
+    user_rule_rhs_fvs rule | isAutoRule rule && not (opt_keep_orphan_rules opts)
+                                             = emptyVarSet
                            | otherwise       = ruleRhsFreeVars rule
 
     (trimmed_binds, local_bndrs, _, all_rules) = trim_binds binds
@@ -998,7 +1005,6 @@ findExternalRules opts binds imp_id_rules unfold_env
         --      been discarded; see Note [Trimming auto-rules]
 
     expose_rule rule
-        | not (opt_expose_rules opts) = False
         | otherwise  = all is_external_id (ruleLhsFreeIdsList rule)
                 -- Don't expose a rule whose LHS mentions a locally-defined
                 -- Id that is completely internal (i.e. not visible to an
-- 
cgit v1.2.1