Pmc: Implement `considerAccessible` (#18610)

Consider (`T18610`):
```hs
  f :: Bool -> Int
  f x = case (x, x) of
    (True,  True)  -> 1
    (False, False) -> 2
    (True,  False) -> 3 -- Warning: Redundant
```
The third clause will be flagged as redundant. Nevertheless, the
programmer might intend to keep the clause in order to avoid bitrot.

After this patch, the programmer can write
```hs
  g :: Bool -> Int
  g x = case (x, x) of
    (True,  True)  -> 1
    (False, False) -> 2
    (True,  False) | GHC.Exts.considerAccessible -> 3 -- No warning
```
And won't be bothered any longer. See also `Note [considerAccessible]`
and the updated entries in the user's guide.

Fixes #18610 and #19228.

9 files changed, 248 insertions, 25 deletions

diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 40af981264..2dc6e47493 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -319,6 +319,7 @@ basicKnownKeyNames
 
         -- GHC Extensions
         groupWithName,
+        considerAccessibleName,
 
         -- Strings and lists
         unpackCStringName, unpackCStringUtf8Name,
@@ -1122,8 +1123,9 @@ alternativeClassKey = mkPreludeMiscIdUnique 754
 
 
 -- Functions for GHC extensions
-groupWithName :: Name
-groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey
+groupWithName, considerAccessibleName :: Name
+groupWithName          = varQual gHC_EXTS (fsLit "groupWith")          groupWithIdKey
+considerAccessibleName = varQual gHC_EXTS (fsLit "considerAccessible") considerAccessibleIdKey
 
 -- Random PrelBase functions
 fromStringName, otherwiseIdName, foldrName, buildName, augmentName,
@@ -2362,15 +2364,13 @@ inlineIdKey, noinlineIdKey :: Unique
 inlineIdKey                   = mkPreludeMiscIdUnique 120
 -- see below
 
-mapIdKey, groupWithIdKey, dollarIdKey :: Unique
-mapIdKey              = mkPreludeMiscIdUnique 121
-groupWithIdKey        = mkPreludeMiscIdUnique 122
-dollarIdKey           = mkPreludeMiscIdUnique 123
-
-coercionTokenIdKey :: Unique
-coercionTokenIdKey    = mkPreludeMiscIdUnique 124
-
-noinlineIdKey                 = mkPreludeMiscIdUnique 125
+mapIdKey, groupWithIdKey, dollarIdKey, coercionTokenIdKey, considerAccessibleIdKey :: Unique
+mapIdKey                = mkPreludeMiscIdUnique 121
+groupWithIdKey          = mkPreludeMiscIdUnique 122
+dollarIdKey             = mkPreludeMiscIdUnique 123
+coercionTokenIdKey      = mkPreludeMiscIdUnique 124
+noinlineIdKey           = mkPreludeMiscIdUnique 125
+considerAccessibleIdKey = mkPreludeMiscIdUnique 126
 
 rationalToFloatIdKey, rationalToDoubleIdKey :: Unique
 rationalToFloatIdKey   = mkPreludeMiscIdUnique 130
diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs
index 651f37f909..3292372e6e 100644
--- a/compiler/GHC/HsToCore/Pmc.hs
+++ b/compiler/GHC/HsToCore/Pmc.hs
@@ -238,10 +238,6 @@ instance Semigroup CIRB where
 instance Monoid CIRB where
   mempty = CIRB mempty mempty mempty mempty
 
-markAllRedundant :: CIRB -> CIRB
-markAllRedundant CIRB { cirb_cov = cov, cirb_inacc = inacc, cirb_red = red } =
-  mempty { cirb_red = cov Semi.<> inacc Semi.<> red }
-
 -- See Note [Determining inaccessible clauses]
 ensureOneNotRedundant :: CIRB -> CIRB
 ensureOneNotRedundant ci = case ci of
@@ -279,12 +275,14 @@ cirbsMatchGroup (PmMatchGroup matches) =
 
 cirbsMatch :: PmMatch Post -> DsM CIRB
 cirbsMatch PmMatch { pm_pats = red, pm_grhss = grhss } = do
-  (is_covered, may_diverge, red_bangs) <- testRedSets red
+  (_is_covered, may_diverge, red_bangs) <- testRedSets red
+  -- Don't look at is_covered: If it is True, all children are redundant anyway,
+  -- unless there is a 'considerAccessible', which may break that rule
+  -- intentionally. See Note [considerAccessible] in "GHC.HsToCore.Pmc.Check".
   cirb <- cirbsGRHSs grhss
   pure $ addRedundantBangs red_bangs
        -- See Note [Determining inaccessible clauses]
        $ applyWhen may_diverge ensureOneNotRedundant
-       $ applyWhen (not is_covered) markAllRedundant
        $ cirb
 
 cirbsGRHSs :: PmGRHSs Post -> DsM CIRB
diff --git a/compiler/GHC/HsToCore/Pmc/Check.hs b/compiler/GHC/HsToCore/Pmc/Check.hs
index 3ffd51fe7a..10d8574093 100644
--- a/compiler/GHC/HsToCore/Pmc/Check.hs
+++ b/compiler/GHC/HsToCore/Pmc/Check.hs
@@ -26,6 +26,7 @@ module GHC.HsToCore.Pmc.Check (
 
 import GHC.Prelude
 
+import GHC.Builtin.Names ( hasKey, considerAccessibleIdKey, trueDataConKey )
 import GHC.HsToCore.Monad ( DsM )
 import GHC.HsToCore.Pmc.Types
 import GHC.HsToCore.Pmc.Utils
@@ -124,6 +125,13 @@ checkGrd grd = CA $ \inc -> case grd of
     pure CheckResult { cr_ret = RedSets { rs_cov = matched, rs_div = div, rs_bangs = bangs }
                      , cr_uncov = mempty
                      , cr_approx = Precise }
+  -- See point (3) of Note [considerAccessible]
+  PmCon x (PmAltConLike con) _ _ _
+    | x `hasKey` considerAccessibleIdKey
+    , con `hasKey` trueDataConKey
+    -> pure CheckResult { cr_ret = emptyRedSets { rs_cov = initNablas }
+                        , cr_uncov = mempty
+                        , cr_approx = Precise }
   -- Con: Fall through on x ≁ K and refine with x ~ K ys and type info
   PmCon x con tvs dicts args -> do
     !div <- if isPmAltConMatchStrict con
@@ -269,4 +277,77 @@ Guards are an extreme example in this regard, with #11195 being a particularly
 dreadful example: Since their RHS are often pretty much unique, we split on a
 variable (the one representing the RHS) that doesn't occur anywhere else in the
 program, so we don't actually get useful information out of that split!
+
+Note [considerAccessible]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (T18610)
+
+  f :: Bool -> Int
+  f x = case (x, x) of
+    (True,  True)  -> 1
+    (False, False) -> 2
+    (True,  False) -> 3 -- Warning: Redundant
+
+The third case is detected as redundant. But it may be the intent of the
+programmer to keep the dead code, in order for it not to bitrot or to support
+debugging scenarios. But there is no way to communicate that to the
+pattern-match checker! The only way is to deactivate pattern-match checking
+whole-sale, which is quite annoying. Hence, we define in "GHC.Exts":
+
+  considerAccessible = True
+
+'considerAccessible' is treated specially by the pattern-match checker in that a
+guard with it as the scrutinee expression will keep its parent clause alive:
+
+  g :: Bool -> Int
+  g x = case (x, x) of
+    (True,  True)  -> 1
+    (False, False) -> 2
+    (True,  False) | GHC.Exts.considerAccessible -> 3 -- No warning
+
+The key bits of the implementation are:
+
+  1. Its definition is recognised as known-key (see "GHC.Builtin.Names").
+  2. After "GHC.HsToCore.Pmc.Desugar", the guard will end up as a 'PmCon', where
+     the match var is the known-key 'considerAccessible' and the constructor
+     against which it matches is 'True'.
+  3. We recognise the 'PmCon' in 'GHC.HsToCore.Check.checkGrd' and inflate the
+     incoming set of values for all guards downstream to the unconstrained
+     'initNablas' set, e.g. /all/ values.
+     (The set of values that falls through that particular guard is empty, as
+     matching 'considerAccessible' against 'True' can't fail.)
+
+Note that 'considerAccessible' breaks the invariant that incoming sets of values
+reaching syntactic children are subsets of that of the syntactic ancestor:
+A whole match, like that of the third clause of the example, might have no
+incoming value, but its single RHS has incoming values because of (3).
+
+That means the 'is_covered' flag computed in 'GHC.HsToCore.Pmc.cirbsMatch'
+is irrelevant and should not be used to flag all children as redundant (which is
+what we used to do).
+
+We achieve great benefits with a very simple implementation.
+There are caveats, though:
+
+  (A) Putting potentially failing guards /after/ the
+      'considerAccessible' guard might lead to weird check results, e.g.,
+
+        h :: Bool -> Int
+        h x = case (x, x) of
+          (True,  True)  -> 1
+          (False, False) -> 2
+          (True,  False) | GHC.Exts.considerAccessible, False <- x -> 3
+          -- Warning: Not matched: (_, _)
+
+      That *is* fixable, although we would pay with a much more complicated
+      implementation.
+  (B) If the programmer puts a 'considerAccessible' marker on an accessible
+      clause, the checker doesn't warn about it. E.g.,
+
+        f :: Bool -> Int
+        f True | considerAccessible = 0
+        f False = 1
+
+      will not emit any warning whatsoever. We could implement code that warns
+      here, but it wouldn't be as simple as it is now.
 -}
diff --git a/docs/users_guide/9.2.1-notes.rst b/docs/users_guide/9.2.1-notes.rst
index 9812279849..918f8ebae8 100644
--- a/docs/users_guide/9.2.1-notes.rst
+++ b/docs/users_guide/9.2.1-notes.rst
@@ -114,15 +114,12 @@ Runtime system
   Moreover, we now correctly account for the size of the array, meaning that
   space lost to fragmentation is no longer counted as live data.
 
-- The :rts-flag:`-h` flag has been deprecated, use either :rts-flag:`-hc` or
-  :rts-flag:`-hT` explicitly, as appropriate.
+
 
 - The ``-xt`` RTS flag has been removed. Now STACK and TSO closures are always
   included in heap profiles. Tooling can choose to filter out these closure types
-  if necessary.
+`  if necessary.
 
-``ghc-prim`` library
-~~~~~~~~~~~~~~~~~~~~
 
 - ``Void#`` is now a type synonym for the unboxed tuple ``(# #)``.
   Code using ``Void#`` now has to enable :extension:`UnboxedTuples`.
@@ -203,3 +200,13 @@ Runtime system
 
 - On POSIX, ``System.IO.openFile`` can no longer leak a file descriptor if it
   is interrupted by an asynchronous exception (#19114, #19115).
+
+- There's a new binding ``GHC.Exts.considerAccessible``. It's equivalent to
+  ``True`` and allows the programmer to turn off pattern-match redundancy
+  warnings for particular clauses, like the third one here ::
+
+    g :: Bool -> Int
+    g x = case (x, x) of
+      (True,  True)  -> 1
+      (False, False) -> 2
+      (True,  False) | considerAccessible -> 3 -- No warning!
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index a9995268ea..3c09d4c141 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -1235,6 +1235,34 @@ of ``-W(no-)*``.
     second pattern overlaps it. More often than not, redundant patterns
     is a programmer mistake/error, so this option is enabled by default.
 
+    If the programmer is dead set of keeping a redundant clause,
+    for example to prevent bitrot, they can make use of a guard
+    scrutinising ``GHC.Exts.considerAccessible`` to prevent the
+    checker from flagging the parent clause as redundant: ::
+
+        g :: String -> Int
+        g []                       = 0
+        g (_:xs)                   = 1
+        g "2" | considerAccessible = 2 -- No warning!
+
+    Note that ``considerAccessible`` should come as the last statement of
+    the guard in order not to impact the results of the checker. E.g., if
+    you write ::
+
+        h :: Bool -> Int
+        h x = case (x, x) of
+          (True,  True)  -> 1
+          (False, False) -> 2
+          (True,  False) | considerAccessible, False <- x -> 3
+
+    The pattern-match checker takes you by your word, will conclude
+    that ``False <- x`` might fail and warn that the pattern-match
+    is inexhaustive. Put ``considerAccessible`` last to avoid such
+    confusions.
+
+    Note that due to technical limitations, ``considerAccessible`` will not
+    suppress :ghc-flag:`-Winaccessible-code` warnings.
+
 .. ghc-flag:: -Winaccessible-code
     :shortdesc: warn about inaccessible code
     :type: dynamic
diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs
index d1ca1cfff8..106c7e9ea6 100755
--- a/libraries/base/GHC/Exts.hs
+++ b/libraries/base/GHC/Exts.hs
@@ -71,7 +71,7 @@ module GHC.Exts
         breakpoint, breakpointCond,
 
         -- * Ids with special behaviour
-        inline, noinline, lazy, oneShot, SPEC (..),
+        inline, noinline, lazy, oneShot, considerAccessible, SPEC (..),
 
         -- * Running 'RealWorld' state thread
         runRW#,
@@ -213,8 +213,8 @@ class IsList l where
   fromList  :: [Item l] -> l
 
   -- | The 'fromListN' function takes the input list's length and potentially
-  --   uses it to construct the structure @l@ more efficiently compared to 
-  --   'fromList'. If the given number does not equal to the input list's length 
+  --   uses it to construct the structure @l@ more efficiently compared to
+  --   'fromList'. If the given number does not equal to the input list's length
   --   the behaviour of 'fromListN' is not specified.
   --
   --   prop> fromListN (length xs) xs == fromList xs
@@ -315,3 +315,27 @@ resizeSmallMutableArray# arr0 szNew a s0 =
           (# s2, arr1 #) -> case copySmallMutableArray# arr0 0# arr1 0# szOld s2 of
             s3 -> (# s3, arr1 #)
         else (# s1, arr0 #)
+
+-- | Semantically, @considerAccessible = True@. But it has special meaning
+-- to the pattern-match checker, which will never flag the clause in which
+-- 'considerAccessible' occurs as a guard as redundant or inaccessible.
+-- Example:
+--
+-- > case (x, x) of
+-- >   (True,  True)  -> 1
+-- >   (False, False) -> 2
+-- >   (True,  False) -> 3 -- Warning: redundant
+--
+-- The pattern-match checker will warn here that the third clause is redundant.
+-- It will stop doing so if the clause is adorned with 'considerAccessible':
+--
+-- > case (x, x) of
+-- >   (True,  True)  -> 1
+-- >   (False, False) -> 2
+-- >   (True,  False) | considerAccessible -> 3 -- No warning
+--
+-- Put 'considerAccessible' as the last statement of the guard to avoid get
+-- confusing results from the pattern-match checker, which takes \"consider
+-- accessible\" by word.
+considerAccessible :: Bool
+considerAccessible = True
diff --git a/testsuite/tests/pmcheck/should_compile/T18610.hs b/testsuite/tests/pmcheck/should_compile/T18610.hs
new file mode 100644
index 0000000000..fbde93138e
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T18610.hs
@@ -0,0 +1,66 @@
+{-# OPTIONS_GHC -Wincomplete-patterns -fforce-recomp #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE BangPatterns #-}
+
+module T18610 where
+
+import GHC.Exts
+import Data.Type.Equality
+
+f :: Bool -> Int
+f x = case (x, x) of
+  (True,  True)  -> 1
+  (False, False) -> 2
+  (True,  False) -> 3 -- Warning: redundant
+
+g :: Bool -> Int
+g x = case (x, x) of
+  (True,  True)  -> 1
+  (False, False) -> 2
+  (True,  False) | considerAccessible -> 3 -- No warning!
+
+h :: Bool -> Int
+h x = case (x, x) of
+  (True,  True)  -> 1
+  (False, False) -> 2
+  (True,  False) | considerAccessible, False <- x -> 3
+  -- Warning: Not exhaustive. A non-severe leaking implementation detail of
+  -- Note [considerAccessible]
+
+--
+-- All the following bindings should not emit PMC warnings
+--
+
+-- | Clause 1 is not redundant, but has inaccessible RHS. The marker should
+-- prevent a warning.
+i :: () -> Int
+i () | False, considerAccessible = 1
+i _                              = 2
+
+-- | Clause 1 is accessible with or without the marker. It has no
+-- impact on checking the other equations.
+j :: Bool -> Int
+j x = case (x, x) of
+  (True,  True)  | considerAccessible -> 1
+  (False, False) -> 2
+
+-- | The 'Refl' makes the second clause inaccessible (even a bang would do).
+-- The marker prevents a warning. Unfortunately, it has no effect on
+-- @-Winaccessible-code@.
+k :: Int :~: Bool -> Bool -> Int
+k _    False                      = 1
+k Refl _     | considerAccessible = 2
+
+-- | Compared to 'g', the marked inaccessible clause comes first. It has no
+-- impact on checking the other equations.
+l :: Bool -> Int
+l x = case (x, x) of
+  (True,  False) | considerAccessible -> 1 -- No warning!
+  (True,  True)  -> 2
+  (False, False) -> 3
+
+-- | Warning that the second GRHS is redundant would be unsound here.
+m :: Int -> Int
+m x | False <- considerAccessible = 1
+    | otherwise                   = 2 -- Not redundant!
diff --git a/testsuite/tests/pmcheck/should_compile/T18610.stderr b/testsuite/tests/pmcheck/should_compile/T18610.stderr
new file mode 100644
index 0000000000..7f6a2dfe67
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T18610.stderr
@@ -0,0 +1,17 @@
+
+T18610.hs:15:3: warning: [-Woverlapping-patterns (in -Wdefault)]
+    Pattern match is redundant
+    In a case alternative: (True, False) -> ...
+
+T18610.hs:24:7: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In a case alternative:
+        Patterns of type ‘(Bool, Bool)’ not matched: (_, _)
+
+T18610.hs:53:3: warning: [-Winaccessible-code (in -Wdefault)]
+    • Couldn't match type ‘Bool’ with ‘Int’
+      Inaccessible code in
+        a pattern with constructor: Refl :: forall {k} (a :: k). a :~: a,
+        in an equation for ‘k’
+    • In the pattern: Refl
+      In an equation for ‘k’: k Refl _ | considerAccessible = 2
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index b922696fae..5245862851 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -154,6 +154,8 @@ test('T18572', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-incomplete-uni-patterns -fwarn-overlapping-patterns'])
 test('T18609', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
+test('T18610', normal, compile,
+     ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 test('T18670', normal, compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 test('T18708', normal, compile,