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

    -- | 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, getLdiNablas
        ) where

    import GHC.Prelude

    import GHC.HsToCore.Errors.Types
    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.Types.Basic (Origin(..))
    import GHC.Core (CoreExpr)
    import GHC.Driver.Session
    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.Utils.TcType (evVarPred)
    import GHC.Tc.Utils.Monad (updTopFlags)
    import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr)
    import GHC.HsToCore.Monad
    import GHC.Data.Bag
    import GHC.Data.IOEnv (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 a b.
    IOEnv (Env DsGblEnv DsLclEnv) a
    -> (a -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> IOEnv (Env DsGblEnv DsLclEnv) b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
        Bool
    True  -> Nablas -> DsM Nablas
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Nablas
    nablas
        Bool
    False -> Nablas -> DsM Nablas
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    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 = (DynFlags -> DynFlags)
    -> TcRnIf DsGblEnv DsLclEnv a -> TcRnIf DsGblEnv DsLclEnv a
    forall gbl lcl a.
    (DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
    updTopFlags (\DynFlags
    dflags -> (DynFlags -> WarningFlag -> DynFlags)
    -> DynFlags -> [WarningFlag] -> DynFlags
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' DynFlags -> WarningFlag -> DynFlags
    wopt_unset DynFlags
    dflags [WarningFlag]
    allPmCheckWarnings)

    -- | 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
    forall doc. IsDoc doc => [doc] -> doc
    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))
      FormatReportWarningsMode (PmPatBind Post)
    -> DsMatchContext -> [Id] -> CheckResult (PmPatBind Post) -> DsM ()
    forall ann.
    FormatReportWarningsMode ann
    -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
    formatReportWarnings FormatReportWarningsMode (PmPatBind Post)
    ReportPatBind DsMatchContext
    ctxt [Id
    var] CheckResult (PmPatBind Post)
    result
    pmcPatBind DsMatchContext
    _ Id
    _ Pat GhcTc
    _ = () -> DsM ()
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    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 a. (a -> a -> a) -> [a] -> a
    forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
    foldl1 SrcSpan -> SrcSpan -> SrcSpan
    combineSrcSpans ((GenLocated
       (SrcSpanAnn' (EpAnn NoEpAnns))
       (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
     -> SrcSpan)
    -> [GenLocated
          (SrcSpanAnn' (EpAnn NoEpAnns))
          (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
    -> [SrcSpan]
    forall a b. (a -> b) -> [a] -> [b]
    map GenLocated
      (SrcSpanAnn' (EpAnn NoEpAnns))
      (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
    -> SrcSpan
    forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
    getLocA [LGRHS GhcTc (LHsExpr GhcTc)]
    [GenLocated
       (SrcSpanAnn' (EpAnn NoEpAnns))
       (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr 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
    forall doc. IsOutput doc => doc
    empty GRHSs GhcTc (LHsExpr GhcTc)
    guards
      String -> SDoc -> DsM ()
    tracePm String
    "pmcGRHSs" (SDoc -> Int -> SDoc -> SDoc
    hang ([SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [DsMatchContext -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DsMatchContext
    ctxt
                                    , String -> SDoc
    forall doc. IsLine doc => String -> doc
    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 (LHsExpr GhcTc)
    GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
    guards SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ 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))
      FormatReportWarningsMode (PmGRHSs Post)
    -> DsMatchContext -> [Id] -> CheckResult (PmGRHSs Post) -> DsM ()
    forall ann.
    FormatReportWarningsMode ann
    -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
    formatReportWarnings FormatReportWarningsMode (PmGRHSs Post)
    ReportGRHSs DsMatchContext
    ctxt [] CheckResult (PmGRHSs Post)
    result
      NonEmpty Nablas -> DsM (NonEmpty Nablas)
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    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 function assumes it
    -- checks an @-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 = {-# SCC "pmcMatches" #-} 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
    forall doc. IsDoc doc => [doc] -> doc
    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
    forall doc. IsLine doc => String -> doc
    text String
    "Matches:"])
                   Int
    2
                   ([SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    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 [LMatch GhcTc (LHsExpr GhcTc)]
    [GenLocated
       SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
    matches) SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ 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 [LMatch GhcTc (LHsExpr GhcTc)]
    [GenLocated
       SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr 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))
          FormatReportWarningsMode PmEmptyCase
    -> DsMatchContext -> [Id] -> CheckResult PmEmptyCase -> DsM ()
    forall ann.
    FormatReportWarningsMode ann
    -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
    formatReportWarnings FormatReportWarningsMode PmEmptyCase
    ReportEmptyCase DsMatchContext
    ctxt [Id]
    vars CheckResult PmEmptyCase
    result
          [(Nablas, NonEmpty Nablas)] -> DsM [(Nablas, NonEmpty Nablas)]
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
        Just NonEmpty
      (GenLocated
         SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
    matches -> do
          PmMatchGroup Pre
    matches <- {-# SCC "desugarMatches" #-}
                     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 (LMatch GhcTc (LHsExpr GhcTc))
    NonEmpty
      (GenLocated
         SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
    matches
          CheckResult (PmMatchGroup Post)
    result  <- {-# SCC "checkMatchGroup" #-}
                     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))
          {-# SCC "formatReportWarnings" #-} FormatReportWarningsMode (PmMatchGroup Post)
    -> DsMatchContext
    -> [Id]
    -> CheckResult (PmMatchGroup Post)
    -> DsM ()
    forall ann.
    FormatReportWarningsMode ann
    -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
    formatReportWarnings FormatReportWarningsMode (PmMatchGroup Post)
    ReportMatchGroup DsMatchContext
    ctxt [Id]
    vars CheckResult (PmMatchGroup Post)
    result
          [(Nablas, NonEmpty Nablas)] -> DsM [(Nablas, NonEmpty Nablas)]
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    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 = unitOL r, cirb_red = 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 = cirb_bangs cirb Semi.<> 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 a b.
    IOEnv (Env DsGblEnv DsLclEnv) a
    -> (a -> IOEnv (Env DsGblEnv DsLclEnv) b)
    -> IOEnv (Env DsGblEnv DsLclEnv) b
    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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    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)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> NonEmpty a -> f (NonEmpty 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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    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)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> NonEmpty a -> f (NonEmpty 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   = unitOL info }
               | Bool
    may_diverge = CIRB
    forall a. Monoid a => a
    mempty { cirb_inacc = unitOL info }
               | Bool
    otherwise   = CIRB
    forall a. Monoid a => a
    mempty { cirb_red   = unitOL info }
      CIRB -> DsM CIRB
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    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
    forall a b. Coercible a b => a -> b
    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
    --

    -- | A datatype to accommodate the different call sites of
    -- 'formatReportWarnings'. Used for extracting 'CIRB's from a concrete 'ann'
    -- through 'collectInMode'. Since this is only possible for a couple of
    -- well-known 'ann's, this is a GADT.
    data FormatReportWarningsMode ann where
      ReportPatBind :: FormatReportWarningsMode (PmPatBind Post)
      ReportGRHSs   :: FormatReportWarningsMode (PmGRHSs Post)
      ReportMatchGroup:: FormatReportWarningsMode (PmMatchGroup Post)
      ReportEmptyCase:: FormatReportWarningsMode PmEmptyCase

    deriving instance Eq (FormatReportWarningsMode ann)

    -- | A function collecting 'CIRB's for each of the different
    -- 'FormatReportWarningsMode's.
    collectInMode :: FormatReportWarningsMode ann -> ann -> DsM CIRB
    collectInMode :: forall ann. FormatReportWarningsMode ann -> ann -> DsM CIRB
    collectInMode FormatReportWarningsMode ann
    ReportPatBind    = ann -> DsM CIRB
    PmPatBind Post -> DsM CIRB
    cirbsPatBind
    collectInMode FormatReportWarningsMode ann
    ReportGRHSs      = ann -> DsM CIRB
    PmGRHSs Post -> DsM CIRB
    cirbsGRHSs
    collectInMode FormatReportWarningsMode ann
    ReportMatchGroup = ann -> DsM CIRB
    PmMatchGroup Post -> DsM CIRB
    cirbsMatchGroup
    collectInMode FormatReportWarningsMode ann
    ReportEmptyCase  = ann -> DsM CIRB
    PmEmptyCase -> DsM CIRB
    cirbsEmptyCase

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

    -- | Issue all the warnings
    -- (redundancy, inaccessibility, exhaustiveness, redundant bangs).
    reportWarnings :: DynFlags -> FormatReportWarningsMode ann -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM ()
    reportWarnings :: forall ann.
    DynFlags
    -> FormatReportWarningsMode ann
    -> DsMatchContext
    -> [Id]
    -> CheckResult CIRB
    -> DsM ()
    reportWarnings DynFlags
    dflags FormatReportWarningsMode ann
    report_mode (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 <- GenerateInhabitingPatternsMode
    -> [Id] -> Int -> Nablas -> DsM [Nabla]
    getNFirstUncovered GenerateInhabitingPatternsMode
    gen_mode [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 (DsMessage -> DsM ()
    diagnosticDs (Int -> DsMessage
    DsMaxPmCheckModelsReached (DynFlags -> Int
    maxPmCheckModels DynFlags
    dflags)))

          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 (DsMessage -> DsM ()
    diagnosticDs (HsMatchContext GhcRn -> SDoc -> DsMessage
    DsRedundantBangPatterns HsMatchContext GhcRn
    kind SDoc
    q))

          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 (DsMessage -> DsM ()
    diagnosticDs (HsMatchContext GhcRn -> SDoc -> DsMessage
    DsOverlappingPatterns HsMatchContext GhcRn
    kind SDoc
    q))
          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 (DsMessage -> DsM ()
    diagnosticDs (HsMatchContext GhcRn -> SDoc -> DsMessage
    DsInaccessibleRhs HsMatchContext GhcRn
    kind SDoc
    q))

          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 (DsMessage -> DsM ()
    diagnosticDs (HsMatchContext GhcRn
    -> ExhaustivityCheckType -> Int -> [Id] -> [Nabla] -> DsMessage
    DsNonExhaustivePatterns HsMatchContext GhcRn
    kind ExhaustivityCheckType
    check_type Int
    maxPatterns [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
        check_type :: ExhaustivityCheckType
    check_type = Maybe WarningFlag -> ExhaustivityCheckType
    ExhaustivityCheckType (HsMatchContext GhcRn -> Maybe WarningFlag
    forall id. HsMatchContext id -> Maybe WarningFlag
    exhaustiveWarningFlag HsMatchContext GhcRn
    kind)
        gen_mode :: GenerateInhabitingPatternsMode
    gen_mode = case FormatReportWarningsMode ann
    report_mode of -- See Note [Case split inhabiting patterns]
          FormatReportWarningsMode ann
    ReportEmptyCase -> GenerateInhabitingPatternsMode
    CaseSplitTopLevel
          FormatReportWarningsMode ann
    _               -> GenerateInhabitingPatternsMode
    MinimalCover

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

    getNFirstUncovered :: GenerateInhabitingPatternsMode -> [Id] -> Int -> Nablas -> DsM [Nabla]
    getNFirstUncovered :: GenerateInhabitingPatternsMode
    -> [Id] -> Int -> Nablas -> DsM [Nabla]
    getNFirstUncovered GenerateInhabitingPatternsMode
    mode [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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure []
        go Int
    _ []             = [Nabla] -> DsM [Nabla]
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure []
        go Int
    n (Nabla
    nabla:[Nabla]
    nablas) = do
          [Nabla]
    front <- GenerateInhabitingPatternsMode
    -> [Id] -> Int -> Nabla -> DsM [Nabla]
    generateInhabitingPatterns GenerateInhabitingPatternsMode
    mode [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 a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Nabla]
    front) [Nabla]
    nablas
          [Nabla] -> DsM [Nabla]
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ([Nabla]
    front [Nabla] -> [Nabla] -> [Nabla]
    forall a. [a] -> [a] -> [a]
    ++ [Nabla]
    back)

    --
    -- * 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 (PredType -> PhiCt
    PhiTyCt (PredType -> PhiCt) -> (Id -> PredType) -> Id -> PhiCt
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Id -> PredType
    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' scrutinees to the local 'DsM' environment,
    -- e.g. 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.
    -- This is also used for the Arrows \cases command, where these equalities have
    -- to be added for multiple scrutinees rather than just one.
    addCoreScrutTmCs :: [CoreExpr] -> [Id] -> DsM a -> DsM a
    addCoreScrutTmCs :: forall a. [CoreExpr] -> [Id] -> DsM a -> DsM a
    addCoreScrutTmCs []         [Id]
    _      DsM a
    k = DsM a
    k
    addCoreScrutTmCs (CoreExpr
    scr:[CoreExpr]
    scrs) (Id
    x:[Id]
    xs) 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 ([CoreExpr] -> [Id] -> DsM a -> DsM a
    forall a. [CoreExpr] -> [Id] -> DsM a -> DsM a
    addCoreScrutTmCs [CoreExpr]
    scrs [Id]
    xs 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 [CoreExpr]
    _   [Id]
    _   DsM a
    _ = String -> DsM a
    forall a. HasCallStack => String -> a
    panic String
    "addCoreScrutTmCs: numbers of scrutinees and match ids differ"

    -- | 'addCoreScrutTmCs', but desugars the 'LHsExpr's first.
    addHsScrutTmCs :: [LHsExpr GhcTc] -> [Id] -> DsM a -> DsM a
    addHsScrutTmCs :: forall a. [LHsExpr GhcTc] -> [Id] -> DsM a -> DsM a
    addHsScrutTmCs [LHsExpr GhcTc]
    scrs [Id]
    vars DsM a
    k = do
      [CoreExpr]
    scr_es <- (GenLocated SrcSpanAnnA (HsExpr GhcTc)
     -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr)
    -> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
    -> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> [a] -> f [b]
    traverse LHsExpr GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
    GenLocated SrcSpanAnnA (HsExpr GhcTc)
    -> IOEnv (Env DsGblEnv DsLclEnv) CoreExpr
    dsLExpr [LHsExpr GhcTc]
    [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
    scrs
      [CoreExpr] -> [Id] -> DsM a -> DsM a
    forall a. [CoreExpr] -> [Id] -> DsM a -> DsM a
    addCoreScrutTmCs [CoreExpr]
    scr_es [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.
    -}