    {-# LANGUAGE CPP               #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE GADTs             #-}
    {-# LANGUAGE LambdaCase        #-}

    -- | This module coverage checks pattern matches. It finds
    --
    --     * Uncovered patterns, certifying non-exhaustivity
    --     * Redundant equations
    --     * Equations with an inaccessible right-hand-side
    --
    -- The algorithm is based on the paper
    -- [Lower Your Guards: A Compositional Pattern-Match Coverage Checker"](https://dl.acm.org/doi/abs/10.1145/3408989)
    --
    -- There is an overview Figure 2 in there that's probably helpful.
    -- Here is an overview of how it's implemented, which follows the structure of
    -- the entry points such as 'pmcMatches':
    --
    --  1. Desugar source syntax (like 'LMatch') to guard tree variants (like
    --     'GrdMatch'), with one of the desugaring functions (like 'desugarMatch').
    --     See "GHC.HsToCore.Pmc.Desugar".
    --     Follows Section 3.1 in the paper.
    --  2. Coverage check guard trees (with a function like 'checkMatch') to get a
    --     'CheckResult'. See "GHC.HsToCore.Pmc.Check".
    --     The normalised refinement types 'Nabla' are tested for inhabitants by
    --     "GHC.HsToCore.Pmc.Solver".
    --  3. Collect redundancy information into a 'CIRB' with a function such
    --     as 'cirbsMatch'. Follows the R function from Figure 6 of the paper.
    --  4. Format and report uncovered patterns and redundant equations ('CIRB')
    --     with 'formatReportWarnings'. Basically job of the G function, plus proper
    --     pretty printing of the warnings (Section 5.4 of the paper).
    --  5. Return 'Nablas' reaching syntactic sub-components for
    --     Note [Long-distance information]. Collected by functions such as
    --     'ldiMatch'. See Section 4.1 of the paper.
    module GHC.HsToCore.Pmc (
            -- Checking and printing
            pmcPatBind, pmcMatches, pmcGRHSs,
            isMatchContextPmChecked,

            -- See Note [Long-distance information]
            addTyCs, addCoreScrutTmCs, addHsScrutTmCs
        ) where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.HsToCore.Pmc.Types
    import GHC.HsToCore.Pmc.Utils
    import GHC.HsToCore.Pmc.Desugar
    import GHC.HsToCore.Pmc.Check
    import GHC.HsToCore.Pmc.Solver
    import GHC.HsToCore.Pmc.Ppr
    import GHC.Types.Basic (Origin(..))
    import GHC.Core (CoreExpr)
    import GHC.Driver.Session
    import GHC.Driver.Env
    import GHC.Hs
    import GHC.Types.Id
    import GHC.Types.SrcLoc
    import GHC.Utils.Misc
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Types.Var (EvVar)
    import GHC.Tc.Types
    import GHC.Tc.Utils.TcType (evVarPred)
    import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr)
    import GHC.HsToCore.Monad
    import GHC.Data.Bag
    import GHC.Data.IOEnv (updEnv, unsafeInterleaveM)
    import GHC.Data.OrdList
    import GHC.Utils.Monad (mapMaybeM)

    import Control.Monad (when, forM_)
    import qualified Data.Semigroup as Semi
    import Data.List.NonEmpty ( NonEmpty(..) )
    import qualified Data.List.NonEmpty as NE
    import Data.Coerce

    --
    -- * Exported entry points to the checker
    --

    -- | A non-empty delta that is initialised from the ambient refinement type
    -- capturing long-distance information, or the trivially habitable 'Nablas' if
    -- the former is uninhabited.
    -- See Note [Recovering from unsatisfiable pattern-matching constraints].
    getLdiNablas :: DsM Nablas
    getLdiNablas :: DsM Nablas
    getLdiNablas = do
      Nablas
    nablas <- DsM Nablas
    getPmNablas
      Nablas -> DsM Bool
    isInhabited Nablas
    nablas DsM Bool -> (Bool -> DsM Nablas) -> DsM Nablas
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
        Bool
    True  -> Nablas -> DsM Nablas
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Nablas
    nablas
        Bool
    False -> Nablas -> DsM Nablas
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Nablas
    initNablas

    -- | We need to call the Hs desugarer to get the Core of a let-binding or where
    -- clause. We don't want to run the coverage checker when doing so! Efficiency
    -- is one concern, but also a lack of properly set up long-distance information
    -- might trigger warnings that we normally wouldn't emit.
    noCheckDs :: DsM a -> DsM a
    noCheckDs :: forall a. DsM a -> DsM a
    noCheckDs DsM a
    k = do
      DynFlags
    dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
      let dflags' :: DynFlags
    dflags' = (DynFlags -> WarningFlag -> DynFlags)
    -> DynFlags -> [WarningFlag] -> DynFlags
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' DynFlags -> WarningFlag -> DynFlags
    wopt_unset DynFlags
    dflags [WarningFlag]
    allPmCheckWarnings
      (Env DsGblEnv DsLclEnv -> Env DsGblEnv DsLclEnv) -> DsM a -> DsM a
    forall env env' a. (env -> env') -> IOEnv env' a -> IOEnv env a
    updEnv (\Env DsGblEnv DsLclEnv
    env -> Env DsGblEnv DsLclEnv
    env{env_top :: HscEnv
    env_top = (Env DsGblEnv DsLclEnv -> HscEnv
    forall gbl lcl. Env gbl lcl -> HscEnv
    env_top Env DsGblEnv DsLclEnv
    env) {hsc_dflags :: DynFlags
    hsc_dflags = DynFlags
    dflags'} }) DsM a
    k

    -- | Check a pattern binding (let, where) for exhaustiveness.
    pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM ()
    -- See Note [pmcPatBind only checks PatBindRhs]
    pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM ()
    pmcPatBind ctxt :: DsMatchContext
    ctxt@(DsMatchContext HsMatchContext GhcRn
    PatBindRhs SrcSpan
    loc) Id
    var Pat GhcTc
    p = do
      !Nablas
    missing <- DsM Nablas
    getLdiNablas
      PmPatBind Pre
    pat_bind <- DsM (PmPatBind Pre) -> DsM (PmPatBind Pre)
    forall a. DsM a -> DsM a
    noCheckDs (DsM (PmPatBind Pre) -> DsM (PmPatBind Pre))
    -> DsM (PmPatBind Pre) -> DsM (PmPatBind Pre)
    forall a b. (a -> b) -> a -> b
    $ SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre)
    desugarPatBind SrcSpan
    loc Id
    var Pat GhcTc
    p
      String -> SDoc -> DsM ()
    tracePm String
    "pmcPatBind {" ([SDoc] -> SDoc
    vcat [DsMatchContext -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DsMatchContext
    ctxt, Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    var, Pat GhcTc -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Pat GhcTc
    p, PmPatBind Pre -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr PmPatBind Pre
    pat_bind, Nablas -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Nablas
    missing])
      CheckResult (PmPatBind Post)
    result <- CheckAction (PmPatBind Post)
    -> Nablas -> DsM (CheckResult (PmPatBind Post))
    forall a. CheckAction a -> Nablas -> DsM (CheckResult a)
    unCA (PmPatBind Pre -> CheckAction (PmPatBind Post)
    checkPatBind PmPatBind Pre
    pat_bind) Nablas
    missing
      String -> SDoc -> DsM ()
    tracePm String
    "}: " (Nablas -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CheckResult (PmPatBind Post) -> Nablas
    forall a. CheckResult a -> Nablas
    cr_uncov CheckResult (PmPatBind Post)
    result))
      (PmPatBind Post -> DsM CIRB)
    -> DsMatchContext -> [Id] -> CheckResult (PmPatBind Post) -> DsM ()
    forall ann.
    (ann -> DsM CIRB)
    -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
    formatReportWarnings PmPatBind Post -> DsM CIRB
    cirbsPatBind DsMatchContext
    ctxt [Id
    var] CheckResult (PmPatBind Post)
    result
    pmcPatBind DsMatchContext
    _ Id
    _ Pat GhcTc
    _ = () -> DsM ()
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()

    -- | Exhaustive for guard matches, is used for guards in pattern bindings and
    -- in @MultiIf@ expressions. Returns the 'Nablas' covered by the RHSs.
    pmcGRHSs
      :: HsMatchContext GhcRn         -- ^ Match context, for warning messages
      -> GRHSs GhcTc (LHsExpr GhcTc)  -- ^ The GRHSs to check
      -> DsM (NonEmpty Nablas)        -- ^ Covered 'Nablas' for each RHS, for long
                                      --   distance info
    pmcGRHSs :: HsMatchContext GhcRn
    -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty Nablas)
    pmcGRHSs HsMatchContext GhcRn
    hs_ctxt guards :: GRHSs GhcTc (LHsExpr GhcTc)
    guards@(GRHSs XCGRHSs GhcTc (LHsExpr GhcTc)
    _ [LGRHS GhcTc (LHsExpr GhcTc)]
    grhss HsLocalBinds GhcTc
    _) = do
      let combined_loc :: SrcSpan
    combined_loc = (SrcSpan -> SrcSpan -> SrcSpan) -> [SrcSpan] -> SrcSpan
    forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
    foldl1 SrcSpan -> SrcSpan -> SrcSpan
    combineSrcSpans ((GenLocated
       SrcSpan (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
     -> SrcSpan)
    -> [GenLocated
          SrcSpan (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
    -> [SrcSpan]
    forall a b. (a -> b) -> [a] -> [b]
    map GenLocated
      SrcSpan (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
    -> SrcSpan
    forall l e. GenLocated l e -> l
    getLoc [GenLocated
       SrcSpan (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
    [LGRHS GhcTc (LHsExpr GhcTc)]
    grhss)
          ctxt :: DsMatchContext
    ctxt = HsMatchContext GhcRn -> SrcSpan -> DsMatchContext
    DsMatchContext HsMatchContext GhcRn
    hs_ctxt SrcSpan
    combined_loc
      !Nablas
    missing <- DsM Nablas
    getLdiNablas
      PmGRHSs Pre
    matches  <- DsM (PmGRHSs Pre) -> DsM (PmGRHSs Pre)
    forall a. DsM a -> DsM a
    noCheckDs (DsM (PmGRHSs Pre) -> DsM (PmGRHSs Pre))
    -> DsM (PmGRHSs Pre) -> DsM (PmGRHSs Pre)
    forall a b. (a -> b) -> a -> b
    $ SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre)
    desugarGRHSs SrcSpan
    combined_loc SDoc
    empty GRHSs GhcTc (LHsExpr GhcTc)
    guards
      String -> SDoc -> DsM ()
    tracePm String
    "pmcGRHSs" (SDoc -> Int -> SDoc -> SDoc
    hang ([SDoc] -> SDoc
    vcat [DsMatchContext -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DsMatchContext
    ctxt
                                    , String -> SDoc
    text String
    "Guards:"])
                                    Int
    2
                                    (HsMatchContext GhcRn
    -> GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> SDoc
    forall (idR :: Pass) body passL.
    (OutputableBndrId idR, Outputable body) =>
    HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc
    pprGRHSs HsMatchContext GhcRn
    hs_ctxt GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
    GRHSs GhcTc (LHsExpr GhcTc)
    guards SDoc -> SDoc -> SDoc
    $$ Nablas -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Nablas
    missing))
      CheckResult (PmGRHSs Post)
    result <- CheckAction (PmGRHSs Post)
    -> Nablas -> DsM (CheckResult (PmGRHSs Post))
    forall a. CheckAction a -> Nablas -> DsM (CheckResult a)
    unCA (PmGRHSs Pre -> CheckAction (PmGRHSs Post)
    checkGRHSs PmGRHSs Pre
    matches) Nablas
    missing
      String -> SDoc -> DsM ()
    tracePm String
    "}: " (Nablas -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CheckResult (PmGRHSs Post) -> Nablas
    forall a. CheckResult a -> Nablas
    cr_uncov CheckResult (PmGRHSs Post)
    result))
      (PmGRHSs Post -> DsM CIRB)
    -> DsMatchContext -> [Id] -> CheckResult (PmGRHSs Post) -> DsM ()
    forall ann.
    (ann -> DsM CIRB)
    -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
    formatReportWarnings PmGRHSs Post -> DsM CIRB
    cirbsGRHSs DsMatchContext
    ctxt [] CheckResult (PmGRHSs Post)
    result
      NonEmpty Nablas -> DsM (NonEmpty Nablas)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (PmGRHSs Post -> NonEmpty Nablas
    ldiGRHSs (CheckResult (PmGRHSs Post) -> PmGRHSs Post
    forall a. CheckResult a -> a
    cr_ret CheckResult (PmGRHSs Post)
    result))

    -- | Check a list of syntactic 'Match'es (part of case, functions, etc.), each
    -- with a 'Pat' and one or more 'GRHSs':
    --
    -- @
    --   f x y | x == y    = 1   -- match on x and y with two guarded RHSs
    --         | otherwise = 2
    --   f _ _             = 3   -- clause with a single, un-guarded RHS
    -- @
    --
    -- Returns one non-empty 'Nablas' for 1.) each pattern of a 'Match' and 2.)
    -- each of a 'Match'es 'GRHS' for Note [Long-distance information].
    --
    -- Special case: When there are /no matches/, then the functionassumes it
    -- checks and @-XEmptyCase@ with only a single match variable.
    -- See Note [Checking EmptyCase].
    pmcMatches
      :: DsMatchContext                  -- ^ Match context, for warnings messages
      -> [Id]                            -- ^ Match variables, i.e. x and y above
      -> [LMatch GhcTc (LHsExpr GhcTc)]  -- ^ List of matches
      -> DsM [(Nablas, NonEmpty Nablas)] -- ^ One covered 'Nablas' per Match and
                                         --   GRHS, for long distance info.
    pmcMatches :: DsMatchContext
    -> [Id]
    -> [LMatch GhcTc (LHsExpr GhcTc)]
    -> DsM [(Nablas, NonEmpty Nablas)]
    pmcMatches DsMatchContext
    ctxt [Id]
    vars [LMatch GhcTc (LHsExpr GhcTc)]
    matches = do
      -- We have to force @missing@ before printing out the trace message,
      -- otherwise we get interleaved output from the solver. This function
      -- should be strict in @missing@ anyway!
      !Nablas
    missing <- DsM Nablas
    getLdiNablas
      String -> SDoc -> DsM ()
    tracePm String
    "pmcMatches {" (SDoc -> DsM ()) -> SDoc -> DsM ()
    forall a b. (a -> b) -> a -> b
    $
              SDoc -> Int -> SDoc -> SDoc
    hang ([SDoc] -> SDoc
    vcat [DsMatchContext -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DsMatchContext
    ctxt, [Id] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Id]
    vars, String -> SDoc
    text String
    "Matches:"])
                   Int
    2
                   ([SDoc] -> SDoc
    vcat ((GenLocated
       SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
     -> SDoc)
    -> [GenLocated
          SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
    -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map GenLocated
      SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
    -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [GenLocated
       SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
    [LMatch GhcTc (LHsExpr GhcTc)]
    matches) SDoc -> SDoc -> SDoc
    $$ Nablas -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Nablas
    missing)
      case [GenLocated
       SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
    -> Maybe
         (NonEmpty
            (GenLocated
               SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
    forall a. [a] -> Maybe (NonEmpty a)
    NE.nonEmpty [GenLocated
       SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
    [LMatch GhcTc (LHsExpr GhcTc)]
    matches of
        Maybe
      (NonEmpty
         (GenLocated
            SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
    Nothing -> do
          -- This must be an -XEmptyCase. See Note [Checking EmptyCase]
          let var :: Id
    var = [Id] -> Id
    forall a. [a] -> a
    only [Id]
    vars
          PmEmptyCase
    empty_case <- DsM PmEmptyCase -> DsM PmEmptyCase
    forall a. DsM a -> DsM a
    noCheckDs (DsM PmEmptyCase -> DsM PmEmptyCase)
    -> DsM PmEmptyCase -> DsM PmEmptyCase
    forall a b. (a -> b) -> a -> b
    $ Id -> DsM PmEmptyCase
    desugarEmptyCase Id
    var
          CheckResult PmEmptyCase
    result <- CheckAction PmEmptyCase -> Nablas -> DsM (CheckResult PmEmptyCase)
    forall a. CheckAction a -> Nablas -> DsM (CheckResult a)
    unCA (PmEmptyCase -> CheckAction PmEmptyCase
    checkEmptyCase PmEmptyCase
    empty_case) Nablas
    missing
          String -> SDoc -> DsM ()
    tracePm String
    "}: " (Nablas -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CheckResult PmEmptyCase -> Nablas
    forall a. CheckResult a -> Nablas
    cr_uncov CheckResult PmEmptyCase
    result))
          (PmEmptyCase -> DsM CIRB)
    -> DsMatchContext -> [Id] -> CheckResult PmEmptyCase -> DsM ()
    forall ann.
    (ann -> DsM CIRB)
    -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
    formatReportWarnings PmEmptyCase -> DsM CIRB
    cirbsEmptyCase DsMatchContext
    ctxt [Id]
    vars CheckResult PmEmptyCase
    result
          [(Nablas, NonEmpty Nablas)] -> DsM [(Nablas, NonEmpty Nablas)]
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
        Just NonEmpty
      (GenLocated
         SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
    matches -> do
          PmMatchGroup Pre
    matches <- DsM (PmMatchGroup Pre) -> DsM (PmMatchGroup Pre)
    forall a. DsM a -> DsM a
    noCheckDs (DsM (PmMatchGroup Pre) -> DsM (PmMatchGroup Pre))
    -> DsM (PmMatchGroup Pre) -> DsM (PmMatchGroup Pre)
    forall a b. (a -> b) -> a -> b
    $ [Id]
    -> NonEmpty (LMatch GhcTc (LHsExpr GhcTc))
    -> DsM (PmMatchGroup Pre)
    desugarMatches [Id]
    vars NonEmpty
      (GenLocated
         SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
    NonEmpty (LMatch GhcTc (LHsExpr GhcTc))
    matches
          CheckResult (PmMatchGroup Post)
    result <- CheckAction (PmMatchGroup Post)
    -> Nablas -> DsM (CheckResult (PmMatchGroup Post))
    forall a. CheckAction a -> Nablas -> DsM (CheckResult a)
    unCA (PmMatchGroup Pre -> CheckAction (PmMatchGroup Post)
    checkMatchGroup PmMatchGroup Pre
    matches) Nablas
    missing
          String -> SDoc -> DsM ()
    tracePm String
    "}: " (Nablas -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CheckResult (PmMatchGroup Post) -> Nablas
    forall a. CheckResult a -> Nablas
    cr_uncov CheckResult (PmMatchGroup Post)
    result))
          (PmMatchGroup Post -> DsM CIRB)
    -> DsMatchContext
    -> [Id]
    -> CheckResult (PmMatchGroup Post)
    -> DsM ()
    forall ann.
    (ann -> DsM CIRB)
    -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
    formatReportWarnings PmMatchGroup Post -> DsM CIRB
    cirbsMatchGroup DsMatchContext
    ctxt [Id]
    vars CheckResult (PmMatchGroup Post)
    result
          [(Nablas, NonEmpty Nablas)] -> DsM [(Nablas, NonEmpty Nablas)]
    forall (m :: * -> *) a. Monad m => a -> m a
    return (NonEmpty (Nablas, NonEmpty Nablas) -> [(Nablas, NonEmpty Nablas)]
    forall a. NonEmpty a -> [a]
    NE.toList (PmMatchGroup Post -> NonEmpty (Nablas, NonEmpty Nablas)
    ldiMatchGroup (CheckResult (PmMatchGroup Post) -> PmMatchGroup Post
    forall a. CheckResult a -> a
    cr_ret CheckResult (PmMatchGroup Post)
    result)))

    {- Note [pmcPatBind only checks PatBindRhs]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    @pmcPatBind@'s sole purpose is to check vanilla pattern bindings, like
    @x :: Int; Just x = e@, which is in a @PatBindRhs@ context.
    But its caller is also called for individual pattern guards in a @StmtCtxt@.
    For example, both pattern guards in @f x y | True <- x, False <- y = ...@ will
    go through this function. It makes no sense to do coverage checking there:
      * Pattern guards may well fail. Fall-through is not an unrecoverable panic,
        but rather behavior the programmer expects, so inexhaustivity should not be
        reported.
      * Redundancy is already reported for the whole GRHS via one of the other
        exported coverage checking functions. Also reporting individual redundant
        guards is... redundant. See #17646.
    Note that we can't just omit checking of @StmtCtxt@ altogether (by adjusting
    'isMatchContextPmChecked'), because that affects the other checking functions,
    too.
    -}

    --
    -- * Collecting long-distance information
    --

    ldiMatchGroup :: PmMatchGroup Post -> NonEmpty (Nablas, NonEmpty Nablas)
    ldiMatchGroup :: PmMatchGroup Post -> NonEmpty (Nablas, NonEmpty Nablas)
    ldiMatchGroup (PmMatchGroup NonEmpty (PmMatch Post)
    matches) = PmMatch Post -> (Nablas, NonEmpty Nablas)
    ldiMatch (PmMatch Post -> (Nablas, NonEmpty Nablas))
    -> NonEmpty (PmMatch Post) -> NonEmpty (Nablas, NonEmpty Nablas)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> NonEmpty (PmMatch Post)
    matches

    ldiMatch :: PmMatch Post -> (Nablas, NonEmpty Nablas)
    ldiMatch :: PmMatch Post -> (Nablas, NonEmpty Nablas)
    ldiMatch (PmMatch { pm_pats :: forall p. PmMatch p -> p
    pm_pats = Post
    red, pm_grhss :: forall p. PmMatch p -> PmGRHSs p
    pm_grhss = PmGRHSs Post
    grhss }) =
      (Post -> Nablas
    rs_cov Post
    red, PmGRHSs Post -> NonEmpty Nablas
    ldiGRHSs PmGRHSs Post
    grhss)

    ldiGRHSs :: PmGRHSs Post -> NonEmpty Nablas
    ldiGRHSs :: PmGRHSs Post -> NonEmpty Nablas
    ldiGRHSs (PmGRHSs { pgs_grhss :: forall p. PmGRHSs p -> NonEmpty (PmGRHS p)
    pgs_grhss = NonEmpty (PmGRHS Post)
    grhss }) = PmGRHS Post -> Nablas
    ldiGRHS (PmGRHS Post -> Nablas)
    -> NonEmpty (PmGRHS Post) -> NonEmpty Nablas
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> NonEmpty (PmGRHS Post)
    grhss

    ldiGRHS :: PmGRHS Post -> Nablas
    ldiGRHS :: PmGRHS Post -> Nablas
    ldiGRHS (PmGRHS { pg_grds :: forall p. PmGRHS p -> p
    pg_grds = Post
    red }) = Post -> Nablas
    rs_cov Post
    red

    --
    -- * Collecting redundancy information
    --

    -- | The result of redundancy checking:
    --    * RHSs classified as /C/overed, /I/naccessible and /R/edundant
    --    * And redundant /B/ang patterns. See Note [Dead bang patterns].
    data CIRB
      = CIRB
      { CIRB -> OrdList SrcInfo
    cirb_cov   :: !(OrdList SrcInfo) -- ^ Covered clauses
      , CIRB -> OrdList SrcInfo
    cirb_inacc :: !(OrdList SrcInfo) -- ^ Inaccessible clauses
      , CIRB -> OrdList SrcInfo
    cirb_red   :: !(OrdList SrcInfo) -- ^ Redundant clauses
      , CIRB -> OrdList SrcInfo
    cirb_bangs :: !(OrdList SrcInfo) -- ^ Redundant bang patterns
      }

    instance Semigroup CIRB where
      CIRB OrdList SrcInfo
    a OrdList SrcInfo
    b OrdList SrcInfo
    c OrdList SrcInfo
    d <> :: CIRB -> CIRB -> CIRB
    <> CIRB OrdList SrcInfo
    e OrdList SrcInfo
    f OrdList SrcInfo
    g OrdList SrcInfo
    h = OrdList SrcInfo
    -> OrdList SrcInfo -> OrdList SrcInfo -> OrdList SrcInfo -> CIRB
    CIRB (OrdList SrcInfo
    a OrdList SrcInfo -> OrdList SrcInfo -> OrdList SrcInfo
    <> OrdList SrcInfo
    e) (OrdList SrcInfo
    b OrdList SrcInfo -> OrdList SrcInfo -> OrdList SrcInfo
    <> OrdList SrcInfo
    f) (OrdList SrcInfo
    c OrdList SrcInfo -> OrdList SrcInfo -> OrdList SrcInfo
    <> OrdList SrcInfo
    g) (OrdList SrcInfo
    d OrdList SrcInfo -> OrdList SrcInfo -> OrdList SrcInfo
    <> OrdList SrcInfo
    h)
        where <> :: OrdList SrcInfo -> OrdList SrcInfo -> OrdList SrcInfo
    (<>) = OrdList SrcInfo -> OrdList SrcInfo -> OrdList SrcInfo
    forall a. Semigroup a => a -> a -> a
    (Semi.<>)

    instance Monoid CIRB where
      mempty :: CIRB
    mempty = OrdList SrcInfo
    -> OrdList SrcInfo -> OrdList SrcInfo -> OrdList SrcInfo -> CIRB
    CIRB OrdList SrcInfo
    forall a. Monoid a => a
    mempty OrdList SrcInfo
    forall a. Monoid a => a
    mempty OrdList SrcInfo
    forall a. Monoid a => a
    mempty OrdList SrcInfo
    forall a. Monoid a => a
    mempty

    -- See Note [Determining inaccessible clauses]
    ensureOneNotRedundant :: CIRB -> CIRB
    ensureOneNotRedundant :: CIRB -> CIRB
    ensureOneNotRedundant CIRB
    ci = case CIRB
    ci of
      CIRB { cirb_cov :: CIRB -> OrdList SrcInfo
    cirb_cov = OrdList SrcInfo
    NilOL, cirb_inacc :: CIRB -> OrdList SrcInfo
    cirb_inacc = OrdList SrcInfo
    NilOL, cirb_red :: CIRB -> OrdList SrcInfo
    cirb_red = ConsOL SrcInfo
    r OrdList SrcInfo
    rs }
        -> CIRB
    ci { cirb_inacc :: OrdList SrcInfo
    cirb_inacc = SrcInfo -> OrdList SrcInfo
    forall a. a -> OrdList a
    unitOL SrcInfo
    r, cirb_red :: OrdList SrcInfo
    cirb_red = OrdList SrcInfo
    rs }
      CIRB
    _ -> CIRB
    ci

    -- | Only adds the redundant bangs to the @CIRB@ if there is at least one
    -- non-redundant 'SrcInfo'. There is no point in remembering a redundant bang
    -- if the whole match is redundant!
    addRedundantBangs :: OrdList SrcInfo -> CIRB -> CIRB
    addRedundantBangs :: OrdList SrcInfo -> CIRB -> CIRB
    addRedundantBangs OrdList SrcInfo
    _red_bangs cirb :: CIRB
    cirb@CIRB { cirb_cov :: CIRB -> OrdList SrcInfo
    cirb_cov = OrdList SrcInfo
    NilOL, cirb_inacc :: CIRB -> OrdList SrcInfo
    cirb_inacc = OrdList SrcInfo
    NilOL } =
      CIRB
    cirb
    addRedundantBangs OrdList SrcInfo
    red_bangs  CIRB
    cirb =
      CIRB
    cirb { cirb_bangs :: OrdList SrcInfo
    cirb_bangs = CIRB -> OrdList SrcInfo
    cirb_bangs CIRB
    cirb OrdList SrcInfo -> OrdList SrcInfo -> OrdList SrcInfo
    forall a. Semigroup a => a -> a -> a
    Semi.<> OrdList SrcInfo
    red_bangs }

    -- | Checks the 'Nablas' in a 'RedSets' for inhabitants and returns
    --    1. Whether the Covered set was inhabited
    --    2. Whether the Diverging set was inhabited
    --    3. All source bangs whose 'Nablas' were empty, which means they are
    --       redundant.
    testRedSets :: RedSets -> DsM (Bool, Bool, OrdList SrcInfo)
    testRedSets :: Post -> DsM (Bool, Bool, OrdList SrcInfo)
    testRedSets RedSets { rs_cov :: Post -> Nablas
    rs_cov = Nablas
    cov, rs_div :: Post -> Nablas
    rs_div = Nablas
    div, rs_bangs :: Post -> OrdList (Nablas, SrcInfo)
    rs_bangs = OrdList (Nablas, SrcInfo)
    bangs } = do
      Bool
    is_covered  <- Nablas -> DsM Bool
    isInhabited Nablas
    cov
      Bool
    may_diverge <- Nablas -> DsM Bool
    isInhabited Nablas
    div
      [SrcInfo]
    red_bangs   <- (((Nablas, SrcInfo)
      -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo))
     -> [(Nablas, SrcInfo)] -> IOEnv (Env DsGblEnv DsLclEnv) [SrcInfo])
    -> [(Nablas, SrcInfo)]
    -> ((Nablas, SrcInfo)
        -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo))
    -> IOEnv (Env DsGblEnv DsLclEnv) [SrcInfo]
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip ((Nablas, SrcInfo)
     -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo))
    -> [(Nablas, SrcInfo)] -> IOEnv (Env DsGblEnv DsLclEnv) [SrcInfo]
    forall (m :: * -> *) a b.
    Applicative m =>
    (a -> m (Maybe b)) -> [a] -> m [b]
    mapMaybeM (OrdList (Nablas, SrcInfo) -> [(Nablas, SrcInfo)]
    forall a. OrdList a -> [a]
    fromOL OrdList (Nablas, SrcInfo)
    bangs) (((Nablas, SrcInfo)
      -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo))
     -> IOEnv (Env DsGblEnv DsLclEnv) [SrcInfo])
    -> ((Nablas, SrcInfo)
        -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo))
    -> IOEnv (Env DsGblEnv DsLclEnv) [SrcInfo]
    forall a b. (a -> b) -> a -> b
    $ \(Nablas
    nablas, SrcInfo
    bang) ->
        Nablas -> DsM Bool
    isInhabited Nablas
    nablas DsM Bool
    -> (Bool -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo))
    -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo)
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
          Bool
    True  -> Maybe SrcInfo -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Maybe SrcInfo
    forall a. Maybe a
    Nothing
          Bool
    False -> Maybe SrcInfo -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe SrcInfo)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (SrcInfo -> Maybe SrcInfo
    forall a. a -> Maybe a
    Just SrcInfo
    bang)
      (Bool, Bool, OrdList SrcInfo) -> DsM (Bool, Bool, OrdList SrcInfo)
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Bool
    is_covered, Bool
    may_diverge, [SrcInfo] -> OrdList SrcInfo
    forall a. [a] -> OrdList a
    toOL [SrcInfo]
    red_bangs)

    cirbsMatchGroup :: PmMatchGroup Post -> DsM CIRB
    cirbsMatchGroup :: PmMatchGroup Post -> DsM CIRB
    cirbsMatchGroup (PmMatchGroup NonEmpty (PmMatch Post)
    matches) =
      NonEmpty CIRB -> CIRB
    forall a. Semigroup a => NonEmpty a -> a
    Semi.sconcat (NonEmpty CIRB -> CIRB)
    -> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty CIRB) -> DsM CIRB
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (PmMatch Post -> DsM CIRB)
    -> NonEmpty (PmMatch Post)
    -> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty CIRB)
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    traverse PmMatch Post -> DsM CIRB
    cirbsMatch NonEmpty (PmMatch Post)
    matches

    cirbsMatch :: PmMatch Post -> DsM CIRB
    cirbsMatch :: PmMatch Post -> DsM CIRB
    cirbsMatch PmMatch { pm_pats :: forall p. PmMatch p -> p
    pm_pats = Post
    red, pm_grhss :: forall p. PmMatch p -> PmGRHSs p
    pm_grhss = PmGRHSs Post
    grhss } = do
      (Bool
    _is_covered, Bool
    may_diverge, OrdList SrcInfo
    red_bangs) <- Post -> DsM (Bool, Bool, OrdList SrcInfo)
    testRedSets Post
    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
    cirb <- PmGRHSs Post -> DsM CIRB
    cirbsGRHSs PmGRHSs Post
    grhss
      CIRB -> DsM CIRB
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (CIRB -> DsM CIRB) -> CIRB -> DsM CIRB
    forall a b. (a -> b) -> a -> b
    $ OrdList SrcInfo -> CIRB -> CIRB
    addRedundantBangs OrdList SrcInfo
    red_bangs
           -- See Note [Determining inaccessible clauses]
           (CIRB -> CIRB) -> CIRB -> CIRB
    forall a b. (a -> b) -> a -> b
    $ Bool -> (CIRB -> CIRB) -> CIRB -> CIRB
    forall a. Bool -> (a -> a) -> a -> a
    applyWhen Bool
    may_diverge CIRB -> CIRB
    ensureOneNotRedundant
           (CIRB -> CIRB) -> CIRB -> CIRB
    forall a b. (a -> b) -> a -> b
    $ CIRB
    cirb

    cirbsGRHSs :: PmGRHSs Post -> DsM CIRB
    cirbsGRHSs :: PmGRHSs Post -> DsM CIRB
    cirbsGRHSs (PmGRHSs { pgs_grhss :: forall p. PmGRHSs p -> NonEmpty (PmGRHS p)
    pgs_grhss = NonEmpty (PmGRHS Post)
    grhss }) = NonEmpty CIRB -> CIRB
    forall a. Semigroup a => NonEmpty a -> a
    Semi.sconcat (NonEmpty CIRB -> CIRB)
    -> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty CIRB) -> DsM CIRB
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (PmGRHS Post -> DsM CIRB)
    -> NonEmpty (PmGRHS Post)
    -> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty CIRB)
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    traverse PmGRHS Post -> DsM CIRB
    cirbsGRHS NonEmpty (PmGRHS Post)
    grhss

    cirbsGRHS :: PmGRHS Post -> DsM CIRB
    cirbsGRHS :: PmGRHS Post -> DsM CIRB
    cirbsGRHS PmGRHS { pg_grds :: forall p. PmGRHS p -> p
    pg_grds = Post
    red, pg_rhs :: forall p. PmGRHS p -> SrcInfo
    pg_rhs = SrcInfo
    info } = do
      (Bool
    is_covered, Bool
    may_diverge, OrdList SrcInfo
    red_bangs) <- Post -> DsM (Bool, Bool, OrdList SrcInfo)
    testRedSets Post
    red
      let cirb :: CIRB
    cirb | Bool
    is_covered  = CIRB
    forall a. Monoid a => a
    mempty { cirb_cov :: OrdList SrcInfo
    cirb_cov   = SrcInfo -> OrdList SrcInfo
    forall a. a -> OrdList a
    unitOL SrcInfo
    info }
               | Bool
    may_diverge = CIRB
    forall a. Monoid a => a
    mempty { cirb_inacc :: OrdList SrcInfo
    cirb_inacc = SrcInfo -> OrdList SrcInfo
    forall a. a -> OrdList a
    unitOL SrcInfo
    info }
               | Bool
    otherwise   = CIRB
    forall a. Monoid a => a
    mempty { cirb_red :: OrdList SrcInfo
    cirb_red   = SrcInfo -> OrdList SrcInfo
    forall a. a -> OrdList a
    unitOL SrcInfo
    info }
      CIRB -> DsM CIRB
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (OrdList SrcInfo -> CIRB -> CIRB
    addRedundantBangs OrdList SrcInfo
    red_bangs CIRB
    cirb)

    cirbsEmptyCase :: PmEmptyCase -> DsM CIRB
    cirbsEmptyCase :: PmEmptyCase -> DsM CIRB
    cirbsEmptyCase PmEmptyCase
    _ = CIRB -> DsM CIRB
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure CIRB
    forall a. Monoid a => a
    mempty

    cirbsPatBind :: PmPatBind Post -> DsM CIRB
    cirbsPatBind :: PmPatBind Post -> DsM CIRB
    cirbsPatBind = (PmGRHS Post -> DsM CIRB) -> PmPatBind Post -> DsM CIRB
    coerce PmGRHS Post -> DsM CIRB
    cirbsGRHS

    {- Note [Determining inaccessible clauses]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider
      f _  True = ()
      f () True = ()
      f _  _    = ()
    Is f's second clause redundant? The perhaps surprising answer is, no, it isn't!
    @f (error "boom") False@ will force the error with clause 2, but will return
    () if it was deleted, so clearly not redundant. Yet for now combination of
    arguments we can ever reach clause 2's RHS, so we say it has inaccessible RHS
    (as opposed to being completely redundant).

    We detect an inaccessible RHS simply by pretending it's redundant, until we see
    -}

    --
    -- * Formatting and reporting warnings
    --

    -- | Given a function that collects 'CIRB's, this function will emit warnings
    -- for a 'CheckResult'.
    formatReportWarnings :: (ann -> DsM CIRB) -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
    formatReportWarnings :: forall ann.
    (ann -> DsM CIRB)
    -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
    formatReportWarnings ann -> DsM CIRB
    collect DsMatchContext
    ctx [Id]
    vars cr :: CheckResult ann
    cr@CheckResult { cr_ret :: forall a. CheckResult a -> a
    cr_ret = ann
    ann } = do
      CIRB
    cov_info <- ann -> DsM CIRB
    collect ann
    ann
      DynFlags
    dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
      DynFlags -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM ()
    reportWarnings DynFlags
    dflags DsMatchContext
    ctx [Id]
    vars CheckResult ann
    cr{cr_ret :: CIRB
    cr_ret=CIRB
    cov_info}

    -- | Issue all the warnings
    -- (redundancy, inaccessibility, exhaustiveness, redundant bangs).
    reportWarnings :: DynFlags -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM ()
    reportWarnings :: DynFlags -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM ()
    reportWarnings DynFlags
    dflags ctx :: DsMatchContext
    ctx@(DsMatchContext HsMatchContext GhcRn
    kind SrcSpan
    loc) [Id]
    vars
      CheckResult { cr_ret :: forall a. CheckResult a -> a
    cr_ret    = CIRB { cirb_inacc :: CIRB -> OrdList SrcInfo
    cirb_inacc = OrdList SrcInfo
    inaccessible_rhss
                                     , cirb_red :: CIRB -> OrdList SrcInfo
    cirb_red   = OrdList SrcInfo
    redundant_rhss
                                     , cirb_bangs :: CIRB -> OrdList SrcInfo
    cirb_bangs = OrdList SrcInfo
    redundant_bangs }
                  , cr_uncov :: forall a. CheckResult a -> Nablas
    cr_uncov  = Nablas
    uncovered
                  , cr_approx :: forall a. CheckResult a -> Precision
    cr_approx = Precision
    precision }
      = Bool -> DsM () -> DsM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Bool
    flag_i Bool -> Bool -> Bool
    || Bool
    flag_u Bool -> Bool -> Bool
    || Bool
    flag_b) (DsM () -> DsM ()) -> DsM () -> DsM ()
    forall a b. (a -> b) -> a -> b
    $ do
          [Nabla]
    unc_examples <- [Id] -> Int -> Nablas -> DsM [Nabla]
    getNFirstUncovered [Id]
    vars (Int
    maxPatterns Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) Nablas
    uncovered
          let exists_r :: Bool
    exists_r = Bool
    flag_i Bool -> Bool -> Bool
    && OrdList SrcInfo -> Bool
    forall (f :: * -> *) a. Foldable f => f a -> Bool
    notNull OrdList SrcInfo
    redundant_rhss
              exists_i :: Bool
    exists_i = Bool
    flag_i Bool -> Bool -> Bool
    && OrdList SrcInfo -> Bool
    forall (f :: * -> *) a. Foldable f => f a -> Bool
    notNull OrdList SrcInfo
    inaccessible_rhss
              exists_u :: Bool
    exists_u = Bool
    flag_u Bool -> Bool -> Bool
    && [Nabla] -> Bool
    forall (f :: * -> *) a. Foldable f => f a -> Bool
    notNull [Nabla]
    unc_examples
              exists_b :: Bool
    exists_b = Bool
    flag_b Bool -> Bool -> Bool
    && OrdList SrcInfo -> Bool
    forall (f :: * -> *) a. Foldable f => f a -> Bool
    notNull OrdList SrcInfo
    redundant_bangs
              approx :: Bool
    approx   = Precision
    precision Precision -> Precision -> Bool
    forall a. Eq a => a -> a -> Bool
    == Precision
    Approximate

          Bool -> DsM () -> DsM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Bool
    approx Bool -> Bool -> Bool
    && (Bool
    exists_u Bool -> Bool -> Bool
    || Bool
    exists_i)) (DsM () -> DsM ()) -> DsM () -> DsM ()
    forall a b. (a -> b) -> a -> b
    $
            SrcSpan -> DsM () -> DsM ()
    forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs SrcSpan
    loc (WarnReason -> SDoc -> DsM ()
    warnDs WarnReason
    NoReason SDoc
    approx_msg)

          Bool -> DsM () -> DsM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    exists_b (DsM () -> DsM ()) -> DsM () -> DsM ()
    forall a b. (a -> b) -> a -> b
    $ OrdList SrcInfo -> (SrcInfo -> DsM ()) -> DsM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ OrdList SrcInfo
    redundant_bangs ((SrcInfo -> DsM ()) -> DsM ()) -> (SrcInfo -> DsM ()) -> DsM ()
    forall a b. (a -> b) -> a -> b
    $ \(SrcInfo (L SrcSpan
    l SDoc
    q)) ->
            SrcSpan -> DsM () -> DsM ()
    forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs SrcSpan
    l (WarnReason -> SDoc -> DsM ()
    warnDs (WarningFlag -> WarnReason
    Reason WarningFlag
    Opt_WarnRedundantBangPatterns)
                                   (SDoc -> String -> SDoc
    pprEqn SDoc
    q String
    "has redundant bang"))

          Bool -> DsM () -> DsM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    exists_r (DsM () -> DsM ()) -> DsM () -> DsM ()
    forall a b. (a -> b) -> a -> b
    $ OrdList SrcInfo -> (SrcInfo -> DsM ()) -> DsM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ OrdList SrcInfo
    redundant_rhss ((SrcInfo -> DsM ()) -> DsM ()) -> (SrcInfo -> DsM ()) -> DsM ()
    forall a b. (a -> b) -> a -> b
    $ \(SrcInfo (L SrcSpan
    l SDoc
    q)) ->
            SrcSpan -> DsM () -> DsM ()
    forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs SrcSpan
    l (WarnReason -> SDoc -> DsM ()
    warnDs (WarningFlag -> WarnReason
    Reason WarningFlag
    Opt_WarnOverlappingPatterns)
                                   (SDoc -> String -> SDoc
    pprEqn SDoc
    q String
    "is redundant"))
          Bool -> DsM () -> DsM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    exists_i (DsM () -> DsM ()) -> DsM () -> DsM ()
    forall a b. (a -> b) -> a -> b
    $ OrdList SrcInfo -> (SrcInfo -> DsM ()) -> DsM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ OrdList SrcInfo
    inaccessible_rhss ((SrcInfo -> DsM ()) -> DsM ()) -> (SrcInfo -> DsM ()) -> DsM ()
    forall a b. (a -> b) -> a -> b
    $ \(SrcInfo (L SrcSpan
    l SDoc
    q)) ->
            SrcSpan -> DsM () -> DsM ()
    forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs SrcSpan
    l (WarnReason -> SDoc -> DsM ()
    warnDs (WarningFlag -> WarnReason
    Reason WarningFlag
    Opt_WarnOverlappingPatterns)
                                   (SDoc -> String -> SDoc
    pprEqn SDoc
    q String
    "has inaccessible right hand side"))

          Bool -> DsM () -> DsM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    exists_u (DsM () -> DsM ()) -> DsM () -> DsM ()
    forall a b. (a -> b) -> a -> b
    $ SrcSpan -> DsM () -> DsM ()
    forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs SrcSpan
    loc (DsM () -> DsM ()) -> DsM () -> DsM ()
    forall a b. (a -> b) -> a -> b
    $ WarnReason -> SDoc -> DsM ()
    warnDs WarnReason
    flag_u_reason (SDoc -> DsM ()) -> SDoc -> DsM ()
    forall a b. (a -> b) -> a -> b
    $
            [Id] -> [Nabla] -> SDoc
    pprEqns [Id]
    vars [Nabla]
    unc_examples
      where
        flag_i :: Bool
    flag_i = DynFlags -> HsMatchContext GhcRn -> Bool
    forall id. DynFlags -> HsMatchContext id -> Bool
    overlapping DynFlags
    dflags HsMatchContext GhcRn
    kind
        flag_u :: Bool
    flag_u = DynFlags -> HsMatchContext GhcRn -> Bool
    forall id. DynFlags -> HsMatchContext id -> Bool
    exhaustive DynFlags
    dflags HsMatchContext GhcRn
    kind
        flag_b :: Bool
    flag_b = DynFlags -> Bool
    redundantBang DynFlags
    dflags
        flag_u_reason :: WarnReason
    flag_u_reason = WarnReason
    -> (WarningFlag -> WarnReason) -> Maybe WarningFlag -> WarnReason
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe WarnReason
    NoReason WarningFlag -> WarnReason
    Reason (HsMatchContext GhcRn -> Maybe WarningFlag
    forall id. HsMatchContext id -> Maybe WarningFlag
    exhaustiveWarningFlag HsMatchContext GhcRn
    kind)

        maxPatterns :: Int
    maxPatterns = DynFlags -> Int
    maxUncoveredPatterns DynFlags
    dflags

        -- Print a single clause (for redundant/with-inaccessible-rhs)
        pprEqn :: SDoc -> String -> SDoc
    pprEqn SDoc
    q String
    txt = Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
    pprContext Bool
    True DsMatchContext
    ctx (String -> SDoc
    text String
    txt) (((SDoc -> SDoc) -> SDoc) -> SDoc)
    -> ((SDoc -> SDoc) -> SDoc) -> SDoc
    forall a b. (a -> b) -> a -> b
    $ \SDoc -> SDoc
    f ->
          SDoc -> SDoc
    f (SDoc
    q SDoc -> SDoc -> SDoc
    <+> HsMatchContext GhcRn -> SDoc
    forall p. HsMatchContext p -> SDoc
    matchSeparator HsMatchContext GhcRn
    kind SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "...")

        -- Print several clauses (for uncovered clauses)
        pprEqns :: [Id] -> [Nabla] -> SDoc
    pprEqns [Id]
    vars [Nabla]
    nablas = Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
    pprContext Bool
    False DsMatchContext
    ctx (String -> SDoc
    text String
    "are non-exhaustive") (((SDoc -> SDoc) -> SDoc) -> SDoc)
    -> ((SDoc -> SDoc) -> SDoc) -> SDoc
    forall a b. (a -> b) -> a -> b
    $ \SDoc -> SDoc
    _ ->
          case [Id]
    vars of -- See #11245
               [] -> String -> SDoc
    text String
    "Guards do not cover entire pattern space"
               [Id]
    _  -> let us :: [SDoc]
    us = (Nabla -> SDoc) -> [Nabla] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Nabla
    nabla -> Nabla -> [Id] -> SDoc
    pprUncovered Nabla
    nabla [Id]
    vars) [Nabla]
    nablas
                         pp_tys :: SDoc
    pp_tys = [Kind] -> SDoc
    forall a. Outputable a => [a] -> SDoc
    pprQuotedList ([Kind] -> SDoc) -> [Kind] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ (Id -> Kind) -> [Id] -> [Kind]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> Kind
    idType [Id]
    vars
                     in  SDoc -> Int -> SDoc -> SDoc
    hang
                           (String -> SDoc
    text String
    "Patterns of type" SDoc -> SDoc -> SDoc
    <+> SDoc
    pp_tys SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "not matched:")
                           Int
    4
                           ([SDoc] -> SDoc
    vcat (Int -> [SDoc] -> [SDoc]
    forall a. Int -> [a] -> [a]
    take Int
    maxPatterns [SDoc]
    us) SDoc -> SDoc -> SDoc
    $$ Int -> [SDoc] -> SDoc
    forall a. Int -> [a] -> SDoc
    dots Int
    maxPatterns [SDoc]
    us)

        approx_msg :: SDoc
    approx_msg = [SDoc] -> SDoc
    vcat
          [ SDoc -> Int -> SDoc -> SDoc
    hang
              (String -> SDoc
    text String
    "Pattern match checker ran into -fmax-pmcheck-models="
                SDoc -> SDoc -> SDoc
    <> Int -> SDoc
    int (DynFlags -> Int
    maxPmCheckModels DynFlags
    dflags)
                SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    " limit, so")
              Int
    2
              (  SDoc
    bullet SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "Redundant clauses might not be reported at all"
              SDoc -> SDoc -> SDoc
    $$ SDoc
    bullet SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "Redundant clauses might be reported as inaccessible"
              SDoc -> SDoc -> SDoc
    $$ SDoc
    bullet SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "Patterns reported as unmatched might actually be matched")
          , String -> SDoc
    text String
    "Increase the limit or resolve the warnings to suppress this message." ]

    getNFirstUncovered :: [Id] -> Int -> Nablas -> DsM [Nabla]
    getNFirstUncovered :: [Id] -> Int -> Nablas -> DsM [Nabla]
    getNFirstUncovered [Id]
    vars Int
    n (MkNablas Bag Nabla
    nablas) = Int -> [Nabla] -> DsM [Nabla]
    go Int
    n (Bag Nabla -> [Nabla]
    forall a. Bag a -> [a]
    bagToList Bag Nabla
    nablas)
      where
        go :: Int -> [Nabla] -> DsM [Nabla]
    go Int
    0 [Nabla]
    _              = [Nabla] -> DsM [Nabla]
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure []
        go Int
    _ []             = [Nabla] -> DsM [Nabla]
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure []
        go Int
    n (Nabla
    nabla:[Nabla]
    nablas) = do
          [Nabla]
    front <- [Id] -> Int -> Nabla -> DsM [Nabla]
    generateInhabitingPatterns [Id]
    vars Int
    n Nabla
    nabla
          [Nabla]
    back <- Int -> [Nabla] -> DsM [Nabla]
    go (Int
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - [Nabla] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Nabla]
    front) [Nabla]
    nablas
          [Nabla] -> DsM [Nabla]
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ([Nabla]
    front [Nabla] -> [Nabla] -> [Nabla]
    forall a. [a] -> [a] -> [a]
    ++ [Nabla]
    back)

    dots :: Int -> [a] -> SDoc
    dots :: forall a. Int -> [a] -> SDoc
    dots Int
    maxPatterns [a]
    qs
        | [a]
    qs [a] -> Int -> Bool
    forall a. [a] -> Int -> Bool
    `lengthExceeds` Int
    maxPatterns = String -> SDoc
    text String
    "..."
        | Bool
    otherwise                      = SDoc
    empty

    pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
    pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
    pprContext Bool
    singular (DsMatchContext HsMatchContext GhcRn
    kind SrcSpan
    _loc) SDoc
    msg (SDoc -> SDoc) -> SDoc
    rest_of_msg_fun
      = [SDoc] -> SDoc
    vcat [String -> SDoc
    text String
    txt SDoc -> SDoc -> SDoc
    <+> SDoc
    msg,
              [SDoc] -> SDoc
    sep [ String -> SDoc
    text String
    "In" SDoc -> SDoc -> SDoc
    <+> SDoc
    ppr_match SDoc -> SDoc -> SDoc
    <> Char -> SDoc
    char Char
    ':'
                  , Int -> SDoc -> SDoc
    nest Int
    4 ((SDoc -> SDoc) -> SDoc
    rest_of_msg_fun SDoc -> SDoc
    pref)]]
      where
        txt :: String
    txt | Bool
    singular  = String
    "Pattern match"
            | Bool
    otherwise = String
    "Pattern match(es)"

        (SDoc
    ppr_match, SDoc -> SDoc
    pref)
            = case HsMatchContext GhcRn
    kind of
                 FunRhs { mc_fun :: forall p. HsMatchContext p -> LIdP p
    mc_fun = L SrcSpanAnnN
    _ Name
    fun }
                      -> (HsMatchContext GhcRn -> SDoc
    forall p.
    (Outputable (IdP p), UnXRec p) =>
    HsMatchContext p -> SDoc
    pprMatchContext HsMatchContext GhcRn
    kind, \ SDoc
    pp -> Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    fun SDoc -> SDoc -> SDoc
    <+> SDoc
    pp)
                 HsMatchContext GhcRn
    _    -> (HsMatchContext GhcRn -> SDoc
    forall p.
    (Outputable (IdP p), UnXRec p) =>
    HsMatchContext p -> SDoc
    pprMatchContext HsMatchContext GhcRn
    kind, \ SDoc
    pp -> SDoc
    pp)

    --
    -- * Adding external long-distance information
    --

    -- | Locally update 'dsl_nablas' with the given action, but defer evaluation
    -- with 'unsafeInterleaveM' in order not to do unnecessary work.
    locallyExtendPmNablas :: (Nablas -> DsM Nablas) -> DsM a -> DsM a
    locallyExtendPmNablas :: forall a. (Nablas -> DsM Nablas) -> DsM a -> DsM a
    locallyExtendPmNablas Nablas -> DsM Nablas
    ext DsM a
    k = do
      Nablas
    nablas <- DsM Nablas
    getLdiNablas
      Nablas
    nablas' <- DsM Nablas -> DsM Nablas
    forall env a. IOEnv env a -> IOEnv env a
    unsafeInterleaveM (DsM Nablas -> DsM Nablas) -> DsM Nablas -> DsM Nablas
    forall a b. (a -> b) -> a -> b
    $ Nablas -> DsM Nablas
    ext Nablas
    nablas
      Nablas -> DsM a -> DsM a
    forall a. Nablas -> DsM a -> DsM a
    updPmNablas Nablas
    nablas' DsM a
    k

    -- | Add in-scope type constraints if the coverage checker might run and then
    -- run the given action.
    addTyCs :: Origin -> Bag EvVar -> DsM a -> DsM a
    addTyCs :: forall a. Origin -> Bag Id -> DsM a -> DsM a
    addTyCs Origin
    origin Bag Id
    ev_vars DsM a
    m = do
      DynFlags
    dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
      Bool -> (DsM a -> DsM a) -> DsM a -> DsM a
    forall a. Bool -> (a -> a) -> a -> a
    applyWhen (DynFlags -> Origin -> Bool
    needToRunPmCheck DynFlags
    dflags Origin
    origin)
                ((Nablas -> DsM Nablas) -> DsM a -> DsM a
    forall a. (Nablas -> DsM Nablas) -> DsM a -> DsM a
    locallyExtendPmNablas ((Nablas -> DsM Nablas) -> DsM a -> DsM a)
    -> (Nablas -> DsM Nablas) -> DsM a -> DsM a
    forall a b. (a -> b) -> a -> b
    $ \Nablas
    nablas ->
                  Nablas -> PhiCts -> DsM Nablas
    addPhiCtsNablas Nablas
    nablas (Kind -> PhiCt
    PhiTyCt (Kind -> PhiCt) -> (Id -> Kind) -> Id -> PhiCt
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Id -> Kind
    evVarPred (Id -> PhiCt) -> Bag Id -> PhiCts
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Bag Id
    ev_vars))
                DsM a
    m

    -- | Add equalities for the 'CoreExpr' scrutinee to the local 'DsM' environment
    -- when checking a case expression:
    --     case e of x { matches }
    -- When checking matches we record that (x ~ e) where x is the initial
    -- uncovered. All matches will have to satisfy this equality.
    addCoreScrutTmCs :: Maybe CoreExpr -> [Id] -> DsM a -> DsM a
    addCoreScrutTmCs :: forall a. Maybe CoreExpr -> [Id] -> DsM a -> DsM a
    addCoreScrutTmCs Maybe CoreExpr
    Nothing    [Id]
    _   DsM a
    k = DsM a
    k
    addCoreScrutTmCs (Just CoreExpr
    scr) [Id
    x] DsM a
    k =
      ((Nablas -> DsM Nablas) -> DsM a -> DsM a)
    -> DsM a -> (Nablas -> DsM Nablas) -> DsM a
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (Nablas -> DsM Nablas) -> DsM a -> DsM a
    forall a. (Nablas -> DsM Nablas) -> DsM a -> DsM a
    locallyExtendPmNablas DsM a
    k ((Nablas -> DsM Nablas) -> DsM a)
    -> (Nablas -> DsM Nablas) -> DsM a
    forall a b. (a -> b) -> a -> b
    $ \Nablas
    nablas ->
        Nablas -> PhiCts -> DsM Nablas
    addPhiCtsNablas Nablas
    nablas (PhiCt -> PhiCts
    forall a. a -> Bag a
    unitBag (Id -> CoreExpr -> PhiCt
    PhiCoreCt Id
    x CoreExpr
    scr))
    addCoreScrutTmCs Maybe CoreExpr
    _   [Id]
    _   DsM a
    _ = String -> DsM a
    forall a. String -> a
    panic String
    "addCoreScrutTmCs: scrutinee, but more than one match id"

    -- | 'addCoreScrutTmCs', but desugars the 'LHsExpr' first.
    addHsScrutTmCs :: Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a
    addHsScrutTmCs :: forall a. Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a
    addHsScrutTmCs Maybe (LHsExpr GhcTc)
    Nothing    [Id]
    _    DsM a
    k = DsM a
    k
    addHsScrutTmCs (Just LHsExpr GhcTc
    scr) [Id]
    vars DsM a
    k = do
      CoreExpr
    scr_e <- LHsExpr GhcTc -> DsM CoreExpr
    dsLExpr LHsExpr GhcTc
    scr
      Maybe CoreExpr -> [Id] -> DsM a -> DsM a
    forall a. Maybe CoreExpr -> [Id] -> DsM a -> DsM a
    addCoreScrutTmCs (CoreExpr -> Maybe CoreExpr
    forall a. a -> Maybe a
    Just CoreExpr
    scr_e) [Id]
    vars DsM a
    k

    {- Note [Long-distance information]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider

      data Color = R | G | B
      f :: Color -> Int
      f R = …
      f c = … (case c of
              G -> True
              B -> False) …

    Humans can make the "long-distance connection" between the outer pattern match
    and the nested case pattern match to see that the inner pattern match is
    exhaustive: @c@ can't be @R@ anymore because it was matched in the first clause
    of @f@.

    To achieve similar reasoning in the coverage checker, we keep track of the set
    of values that can reach a particular program point (often loosely referred to
    as "Covered set") in 'GHC.HsToCore.Monad.dsl_nablas'.
    We fill that set with Covered Nablas returned by the exported checking
    functions, which the call sites put into place with
    'GHC.HsToCore.Monad.updPmNablas'.
    Call sites also extend this set with facts from type-constraint dictionaries,
    case scrutinees, etc. with the exported functions 'addTyCs', 'addCoreScrutTmCs'
    and 'addHsScrutTmCs'.

    Note [Recovering from unsatisfiable pattern-matching constraints]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider the following code (see #12957 and #15450):

      f :: Int ~ Bool => ()
      f = case True of { False -> () }

    We want to warn that the pattern-matching in `f` is non-exhaustive. But GHC
    used not to do this; in fact, it would warn that the match was /redundant/!
    This is because the constraint (Int ~ Bool) in `f` is unsatisfiable, and the
    coverage checker deems any matches with unsatisfiable constraint sets to be
    unreachable.

    We make sure to always start from an inhabited 'Nablas' by calling
    'getLdiNablas', which falls back to the trivially inhabited 'Nablas' if the
    long-distance info returned by 'GHC.HsToCore.Monad.getPmNablas' is empty.
    -}