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

    -- | Coverage checking step of the
    -- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989).
    --
    -- Coverage check guard trees (like @'PmMatch' 'Pre'@) to get a
    -- 'CheckResult', containing
    --
    --   1. The set of uncovered values, 'cr_uncov'
    --   2. And an annotated tree variant (like @'PmMatch' 'Post'@) that captures
    --      redundancy and inaccessibility information as 'RedSets' annotations
    --
    -- Basically the UA function from Section 5.1, which is an optimised
    -- interleaving of U and A from Section 3.2 (Figure 5).
    -- The Normalised Refinement Types 'Nablas' are maintained in
    -- "GHC.HsToCore.Pmc.Solver".
    module GHC.HsToCore.Pmc.Check (
            CheckAction(..),
            checkMatchGroup, checkGRHSs, checkPatBind, checkEmptyCase
        ) where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Builtin.Names ( hasKey, considerAccessibleIdKey, trueDataConKey )
    import GHC.HsToCore.Monad ( DsM )
    import GHC.HsToCore.Pmc.Types
    import GHC.HsToCore.Pmc.Utils
    import GHC.HsToCore.Pmc.Solver
    import GHC.Driver.Session
    import GHC.Utils.Outputable
    import GHC.Tc.Utils.TcType (evVarPred)
    import GHC.Data.OrdList

    import qualified Data.Semigroup as Semi
    import Data.List.NonEmpty ( NonEmpty(..) )
    import qualified Data.List.NonEmpty as NE
    import Data.Coerce

    -- | Coverage checking action. Can be composed 'leftToRight' or 'topToBottom'.
    newtype CheckAction a = CA { forall a. CheckAction a -> Nablas -> DsM (CheckResult a)
    unCA :: Nablas -> DsM (CheckResult a) }
      deriving forall a b. a -> CheckAction b -> CheckAction a
    forall a b. (a -> b) -> CheckAction a -> CheckAction b
    forall (f :: * -> *).
    (forall a b. (a -> b) -> f a -> f b)
    -> (forall a b. a -> f b -> f a) -> Functor f
    <$ :: forall a b. a -> CheckAction b -> CheckAction a
    $c<$ :: forall a b. a -> CheckAction b -> CheckAction a
    fmap :: forall a b. (a -> b) -> CheckAction a -> CheckAction b
    $cfmap :: forall a b. (a -> b) -> CheckAction a -> CheckAction b
    Functor

    -- | Composes 'CheckAction's top-to-bottom:
    -- If a value falls through the resulting action, then it must fall through the
    -- first action and then through the second action.
    -- If a value matches the resulting action, then it either matches the
    -- first action or matches the second action.
    -- Basically the semantics of the LYG branching construct.
    topToBottom :: (top -> bot -> ret)
                -> CheckAction top
                -> CheckAction bot
                -> CheckAction ret
    topToBottom :: forall top bot ret.
    (top -> bot -> ret)
    -> CheckAction top -> CheckAction bot -> CheckAction ret
    topToBottom top -> bot -> ret
    f (CA Nablas -> DsM (CheckResult top)
    top) (CA Nablas -> DsM (CheckResult bot)
    bot) = forall a. (Nablas -> DsM (CheckResult a)) -> CheckAction a
    CA forall a b. (a -> b) -> a -> b
    $ \Nablas
    inc -> do
      CheckResult top
    t <- Nablas -> DsM (CheckResult top)
    top Nablas
    inc
      CheckResult bot
    b <- Nablas -> DsM (CheckResult bot)
    bot (forall a. CheckResult a -> Nablas
    cr_uncov CheckResult top
    t)
      forall (f :: * -> *) a. Applicative f => a -> f a
    pure CheckResult { cr_ret :: ret
    cr_ret = top -> bot -> ret
    f (forall a. CheckResult a -> a
    cr_ret CheckResult top
    t) (forall a. CheckResult a -> a
    cr_ret CheckResult bot
    b)
                       , cr_uncov :: Nablas
    cr_uncov = forall a. CheckResult a -> Nablas
    cr_uncov CheckResult bot
    b
                       , cr_approx :: Precision
    cr_approx = forall a. CheckResult a -> Precision
    cr_approx CheckResult top
    t forall a. Semigroup a => a -> a -> a
    Semi.<> forall a. CheckResult a -> Precision
    cr_approx CheckResult bot
    b }

    -- | Composes 'CheckAction's left-to-right:
    -- If a value falls through the resulting action, then it either falls through the
    -- first action or through the second action.
    -- If a value matches the resulting action, then it must match the first action
    -- and then match the second action.
    -- Basically the semantics of the LYG guard construct.
    leftToRight :: (RedSets -> right -> ret)
                -> CheckAction RedSets
                -> CheckAction right
                -> CheckAction ret
    leftToRight :: forall right ret.
    (Post -> right -> ret)
    -> CheckAction Post -> CheckAction right -> CheckAction ret
    leftToRight Post -> right -> ret
    f (CA Nablas -> DsM (CheckResult Post)
    left) (CA Nablas -> DsM (CheckResult right)
    right) = forall a. (Nablas -> DsM (CheckResult a)) -> CheckAction a
    CA forall a b. (a -> b) -> a -> b
    $ \Nablas
    inc -> do
      CheckResult Post
    l <- Nablas -> DsM (CheckResult Post)
    left Nablas
    inc
      CheckResult right
    r <- Nablas -> DsM (CheckResult right)
    right (Post -> Nablas
    rs_cov (forall a. CheckResult a -> a
    cr_ret CheckResult Post
    l))
      Int
    limit <- DynFlags -> Int
    maxPmCheckModels forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
      let uncov :: Nablas
    uncov = forall a. CheckResult a -> Nablas
    cr_uncov CheckResult Post
    l forall a. Semigroup a => a -> a -> a
    Semi.<> forall a. CheckResult a -> Nablas
    cr_uncov CheckResult right
    r
      -- See Note [Countering exponential blowup]
      let (Precision
    prec', Nablas
    uncov') = Int -> Nablas -> Nablas -> (Precision, Nablas)
    throttle Int
    limit Nablas
    inc Nablas
    uncov
      forall (f :: * -> *) a. Applicative f => a -> f a
    pure CheckResult { cr_ret :: ret
    cr_ret = Post -> right -> ret
    f (forall a. CheckResult a -> a
    cr_ret CheckResult Post
    l) (forall a. CheckResult a -> a
    cr_ret CheckResult right
    r)
                       , cr_uncov :: Nablas
    cr_uncov = Nablas
    uncov'
                       , cr_approx :: Precision
    cr_approx = Precision
    prec' forall a. Semigroup a => a -> a -> a
    Semi.<> forall a. CheckResult a -> Precision
    cr_approx CheckResult Post
    l forall a. Semigroup a => a -> a -> a
    Semi.<> forall a. CheckResult a -> Precision
    cr_approx CheckResult right
    r }

    -- | @throttle limit old new@ returns @old@ if the number of 'Nabla's in @new@
    -- is exceeding the given @limit@ and the @old@ number of 'Nabla's.
    -- See Note [Countering exponential blowup].
    throttle :: Int -> Nablas -> Nablas -> (Precision, Nablas)
    throttle :: Int -> Nablas -> Nablas -> (Precision, Nablas)
    throttle Int
    limit old :: Nablas
    old@(MkNablas Bag Nabla
    old_ds) new :: Nablas
    new@(MkNablas Bag Nabla
    new_ds)
      --- | pprTrace "PmCheck:throttle" (ppr (length old_ds) <+> ppr (length new_ds) <+> ppr limit) False = undefined
      | forall (t :: * -> *) a. Foldable t => t a -> Int
    length Bag Nabla
    new_ds forall a. Ord a => a -> a -> Bool
    > forall a. Ord a => a -> a -> a
    max Int
    limit (forall (t :: * -> *) a. Foldable t => t a -> Int
    length Bag Nabla
    old_ds) = (Precision
    Approximate, Nablas
    old)
      | Bool
    otherwise                                 = (Precision
    Precise,     Nablas
    new)

    checkSequence :: (grdtree -> CheckAction anntree) -> NonEmpty grdtree -> CheckAction (NonEmpty anntree)
    -- The implementation is pretty similar to
    -- @traverse1 :: Apply f => (a -> f b) -> NonEmpty a -> f (NonEmpty b)@
    checkSequence :: forall grdtree anntree.
    (grdtree -> CheckAction anntree)
    -> NonEmpty grdtree -> CheckAction (NonEmpty anntree)
    checkSequence grdtree -> CheckAction anntree
    act (grdtree
    t :| [])       = (forall a. a -> [a] -> NonEmpty a
    :| []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> grdtree -> CheckAction anntree
    act grdtree
    t
    checkSequence grdtree -> CheckAction anntree
    act (grdtree
    t1 :| (grdtree
    t2:[grdtree]
    ts)) =
      forall top bot ret.
    (top -> bot -> ret)
    -> CheckAction top -> CheckAction bot -> CheckAction ret
    topToBottom forall a. a -> NonEmpty a -> NonEmpty a
    (NE.<|) (grdtree -> CheckAction anntree
    act grdtree
    t1) (forall grdtree anntree.
    (grdtree -> CheckAction anntree)
    -> NonEmpty grdtree -> CheckAction (NonEmpty anntree)
    checkSequence grdtree -> CheckAction anntree
    act (grdtree
    t2forall a. a -> [a] -> NonEmpty a
    :|[grdtree]
    ts))

    emptyRedSets :: RedSets
    -- Semigroup instance would be misleading!
    emptyRedSets :: Post
    emptyRedSets = Nablas -> Nablas -> OrdList (Nablas, SrcInfo) -> Post
    RedSets forall a. Monoid a => a
    mempty forall a. Monoid a => a
    mempty forall a. Monoid a => a
    mempty

    checkGrd :: PmGrd -> CheckAction RedSets
    checkGrd :: PmGrd -> CheckAction Post
    checkGrd PmGrd
    grd = forall a. (Nablas -> DsM (CheckResult a)) -> CheckAction a
    CA forall a b. (a -> b) -> a -> b
    $ \Nablas
    inc -> case PmGrd
    grd of
      -- let x = e: Refine with x ~ e
      PmLet Id
    x CoreExpr
    e -> do
        Nablas
    matched <- Nablas -> PhiCt -> DsM Nablas
    addPhiCtNablas Nablas
    inc (Id -> CoreExpr -> PhiCt
    PhiCoreCt Id
    x CoreExpr
    e)
        String -> SDoc -> DsM ()
    tracePm String
    "check:Let" (forall a. Outputable a => a -> SDoc
    ppr Id
    x SDoc -> SDoc -> SDoc
    <+> Char -> SDoc
    char Char
    '=' SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr CoreExpr
    e)
        forall (f :: * -> *) a. Applicative f => a -> f a
    pure CheckResult { cr_ret :: Post
    cr_ret = Post
    emptyRedSets { rs_cov :: Nablas
    rs_cov = Nablas
    matched }
                         , cr_uncov :: Nablas
    cr_uncov = forall a. Monoid a => a
    mempty
                         , cr_approx :: Precision
    cr_approx = Precision
    Precise }
      -- Bang x _: Diverge on x ~ ⊥, refine with x ≁ ⊥
      PmBang Id
    x Maybe SrcInfo
    mb_info -> do
        Nablas
    div <- Nablas -> PhiCt -> DsM Nablas
    addPhiCtNablas Nablas
    inc (Id -> PhiCt
    PhiBotCt Id
    x)
        Nablas
    matched <- Nablas -> PhiCt -> DsM Nablas
    addPhiCtNablas Nablas
    inc (Id -> PhiCt
    PhiNotBotCt Id
    x)
        -- See Note [Dead bang patterns]
        -- mb_info = Just info <==> PmBang originates from bang pattern in source
        let bangs :: OrdList (Nablas, SrcInfo)
    bangs | Just SrcInfo
    info <- Maybe SrcInfo
    mb_info = forall a. a -> OrdList a
    unitOL (Nablas
    div, SrcInfo
    info)
                  | Bool
    otherwise            = forall a. OrdList a
    NilOL
        String -> SDoc -> DsM ()
    tracePm String
    "check:Bang" (forall a. Outputable a => a -> SDoc
    ppr Id
    x SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr Nablas
    div)
        forall (f :: * -> *) a. Applicative f => a -> f a
    pure CheckResult { cr_ret :: Post
    cr_ret = RedSets { rs_cov :: Nablas
    rs_cov = Nablas
    matched, rs_div :: Nablas
    rs_div = Nablas
    div, rs_bangs :: OrdList (Nablas, SrcInfo)
    rs_bangs = OrdList (Nablas, SrcInfo)
    bangs }
                         , cr_uncov :: Nablas
    cr_uncov = forall a. Monoid a => a
    mempty
                         , cr_approx :: Precision
    cr_approx = Precision
    Precise }
      -- See point (3) of Note [considerAccessible]
      PmCon Id
    x (PmAltConLike ConLike
    con) [Id]
    _ [Id]
    _ [Id]
    _
        | Id
    x forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    considerAccessibleIdKey
        , ConLike
    con forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    trueDataConKey
        -> forall (f :: * -> *) a. Applicative f => a -> f a
    pure CheckResult { cr_ret :: Post
    cr_ret = Post
    emptyRedSets { rs_cov :: Nablas
    rs_cov = Nablas
    initNablas }
                            , cr_uncov :: Nablas
    cr_uncov = forall a. Monoid a => a
    mempty
                            , cr_approx :: Precision
    cr_approx = Precision
    Precise }
      -- Con: Fall through on x ≁ K and refine with x ~ K ys and type info
      PmCon Id
    x PmAltCon
    con [Id]
    tvs [Id]
    dicts [Id]
    args -> do
        !Nablas
    div <- if PmAltCon -> Bool
    isPmAltConMatchStrict PmAltCon
    con
          then Nablas -> PhiCt -> DsM Nablas
    addPhiCtNablas Nablas
    inc (Id -> PhiCt
    PhiBotCt Id
    x)
          else forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a. Monoid a => a
    mempty
        !Nablas
    matched <- Nablas -> PhiCt -> DsM Nablas
    addPhiCtNablas Nablas
    inc (Id -> PmAltCon -> [Id] -> [PredType] -> [Id] -> PhiCt
    PhiConCt Id
    x PmAltCon
    con [Id]
    tvs (forall a b. (a -> b) -> [a] -> [b]
    map Id -> PredType
    evVarPred [Id]
    dicts) [Id]
    args)
        !Nablas
    uncov   <- Nablas -> PhiCt -> DsM Nablas
    addPhiCtNablas Nablas
    inc (Id -> PmAltCon -> PhiCt
    PhiNotConCt Id
    x PmAltCon
    con)
        String -> SDoc -> DsM ()
    tracePm String
    "check:Con" forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    vcat
          [ forall a. Outputable a => a -> SDoc
    ppr PmGrd
    grd
          , forall a. Outputable a => a -> SDoc
    ppr Nablas
    inc
          , SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "div") Int
    2 (forall a. Outputable a => a -> SDoc
    ppr Nablas
    div)
          , SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "matched") Int
    2 (forall a. Outputable a => a -> SDoc
    ppr Nablas
    matched)
          , SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "uncov") Int
    2 (forall a. Outputable a => a -> SDoc
    ppr Nablas
    uncov)
          ]
        forall (f :: * -> *) a. Applicative f => a -> f a
    pure CheckResult { cr_ret :: Post
    cr_ret = Post
    emptyRedSets { rs_cov :: Nablas
    rs_cov = Nablas
    matched, rs_div :: Nablas
    rs_div = Nablas
    div }
                         , cr_uncov :: Nablas
    cr_uncov = Nablas
    uncov
                         , cr_approx :: Precision
    cr_approx = Precision
    Precise }

    checkGrds :: [PmGrd] -> CheckAction RedSets
    checkGrds :: [PmGrd] -> CheckAction Post
    checkGrds [] = forall a. (Nablas -> DsM (CheckResult a)) -> CheckAction a
    CA forall a b. (a -> b) -> a -> b
    $ \Nablas
    inc ->
      forall (f :: * -> *) a. Applicative f => a -> f a
    pure CheckResult { cr_ret :: Post
    cr_ret = Post
    emptyRedSets { rs_cov :: Nablas
    rs_cov = Nablas
    inc }
                       , cr_uncov :: Nablas
    cr_uncov = forall a. Monoid a => a
    mempty
                       , cr_approx :: Precision
    cr_approx = Precision
    Precise }
    checkGrds (PmGrd
    g:[PmGrd]
    grds) = forall right ret.
    (Post -> right -> ret)
    -> CheckAction Post -> CheckAction right -> CheckAction ret
    leftToRight Post -> Post -> Post
    merge (PmGrd -> CheckAction Post
    checkGrd PmGrd
    g) ([PmGrd] -> CheckAction Post
    checkGrds [PmGrd]
    grds)
      where
        merge :: Post -> Post -> Post
    merge Post
    ri_g Post
    ri_grds = -- This operation would /not/ form a Semigroup!
          RedSets { rs_cov :: Nablas
    rs_cov   = Post -> Nablas
    rs_cov Post
    ri_grds
                  , rs_div :: Nablas
    rs_div   = Post -> Nablas
    rs_div Post
    ri_g   forall a. Semigroup a => a -> a -> a
    Semi.<> Post -> Nablas
    rs_div Post
    ri_grds
                  , rs_bangs :: OrdList (Nablas, SrcInfo)
    rs_bangs = Post -> OrdList (Nablas, SrcInfo)
    rs_bangs Post
    ri_g forall a. Semigroup a => a -> a -> a
    Semi.<> Post -> OrdList (Nablas, SrcInfo)
    rs_bangs Post
    ri_grds }

    checkMatchGroup :: PmMatchGroup Pre -> CheckAction (PmMatchGroup Post)
    checkMatchGroup :: PmMatchGroup Pre -> CheckAction (PmMatchGroup Post)
    checkMatchGroup (PmMatchGroup NonEmpty (PmMatch Pre)
    matches) =
      forall p. NonEmpty (PmMatch p) -> PmMatchGroup p
    PmMatchGroup forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall grdtree anntree.
    (grdtree -> CheckAction anntree)
    -> NonEmpty grdtree -> CheckAction (NonEmpty anntree)
    checkSequence PmMatch Pre -> CheckAction (PmMatch Post)
    checkMatch NonEmpty (PmMatch Pre)
    matches

    checkMatch :: PmMatch Pre -> CheckAction (PmMatch Post)
    checkMatch :: PmMatch Pre -> CheckAction (PmMatch Post)
    checkMatch (PmMatch { pm_pats :: forall p. PmMatch p -> p
    pm_pats = GrdVec [PmGrd]
    grds, pm_grhss :: forall p. PmMatch p -> PmGRHSs p
    pm_grhss = PmGRHSs Pre
    grhss }) =
      forall right ret.
    (Post -> right -> ret)
    -> CheckAction Post -> CheckAction right -> CheckAction ret
    leftToRight forall p. p -> PmGRHSs p -> PmMatch p
    PmMatch ([PmGrd] -> CheckAction Post
    checkGrds [PmGrd]
    grds) (PmGRHSs Pre -> CheckAction (PmGRHSs Post)
    checkGRHSs PmGRHSs Pre
    grhss)

    checkGRHSs :: PmGRHSs Pre -> CheckAction (PmGRHSs Post)
    checkGRHSs :: PmGRHSs Pre -> CheckAction (PmGRHSs Post)
    checkGRHSs (PmGRHSs { pgs_lcls :: forall p. PmGRHSs p -> p
    pgs_lcls = GrdVec [PmGrd]
    lcls, pgs_grhss :: forall p. PmGRHSs p -> NonEmpty (PmGRHS p)
    pgs_grhss = NonEmpty (PmGRHS Pre)
    grhss }) =
      forall right ret.
    (Post -> right -> ret)
    -> CheckAction Post -> CheckAction right -> CheckAction ret
    leftToRight forall p. p -> NonEmpty (PmGRHS p) -> PmGRHSs p
    PmGRHSs ([PmGrd] -> CheckAction Post
    checkGrds [PmGrd]
    lcls) (forall grdtree anntree.
    (grdtree -> CheckAction anntree)
    -> NonEmpty grdtree -> CheckAction (NonEmpty anntree)
    checkSequence PmGRHS Pre -> CheckAction (PmGRHS Post)
    checkGRHS NonEmpty (PmGRHS Pre)
    grhss)

    checkGRHS :: PmGRHS Pre -> CheckAction (PmGRHS Post)
    checkGRHS :: PmGRHS Pre -> CheckAction (PmGRHS Post)
    checkGRHS (PmGRHS { pg_grds :: forall p. PmGRHS p -> p
    pg_grds = GrdVec [PmGrd]
    grds, pg_rhs :: forall p. PmGRHS p -> SrcInfo
    pg_rhs = SrcInfo
    rhs_info }) =
      forall a b c. (a -> b -> c) -> b -> a -> c
    flip forall p. p -> SrcInfo -> PmGRHS p
    PmGRHS SrcInfo
    rhs_info forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [PmGrd] -> CheckAction Post
    checkGrds [PmGrd]
    grds

    checkEmptyCase :: PmEmptyCase -> CheckAction PmEmptyCase
    -- See Note [Checking EmptyCase]
    checkEmptyCase :: PmEmptyCase -> CheckAction PmEmptyCase
    checkEmptyCase pe :: PmEmptyCase
    pe@(PmEmptyCase { pe_var :: PmEmptyCase -> Id
    pe_var = Id
    var }) = forall a. (Nablas -> DsM (CheckResult a)) -> CheckAction a
    CA forall a b. (a -> b) -> a -> b
    $ \Nablas
    inc -> do
      Nablas
    unc <- Nablas -> PhiCt -> DsM Nablas
    addPhiCtNablas Nablas
    inc (Id -> PhiCt
    PhiNotBotCt Id
    var)
      forall (f :: * -> *) a. Applicative f => a -> f a
    pure CheckResult { cr_ret :: PmEmptyCase
    cr_ret = PmEmptyCase
    pe, cr_uncov :: Nablas
    cr_uncov = Nablas
    unc, cr_approx :: Precision
    cr_approx = forall a. Monoid a => a
    mempty }

    checkPatBind :: (PmPatBind Pre) -> CheckAction (PmPatBind Post)
    checkPatBind :: PmPatBind Pre -> CheckAction (PmPatBind Post)
    checkPatBind = coerce :: forall a b. Coercible a b => a -> b
    coerce PmGRHS Pre -> CheckAction (PmGRHS Post)
    checkGRHS

    {- Note [Checking EmptyCase]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -XEmptyCase is useful for matching on empty data types like 'Void'. For example,
    the following is a complete match:

        f :: Void -> ()
        f x = case x of {}

    Really, -XEmptyCase is the only way to write a program that at the same time is
    safe (@f _ = error "boom"@ is not because of ⊥), doesn't trigger a warning
    (@f !_ = error "inaccessible" has inaccessible RHS) and doesn't turn an
    exception into divergence (@f x = f x@).

    Semantically, unlike every other case expression, -XEmptyCase is strict in its
    match var x, which rules out ⊥ as an inhabitant. So we add x ≁ ⊥ to the
    initial Nabla and check if there are any values left to match on.

    Note [Dead bang patterns]
    ~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider

      f :: Bool -> Int
      f True = 1
      f !x   = 2

    Whenever we fall through to the second equation, we will already have evaluated
    the argument. Thus, the bang pattern serves no purpose and should be warned
    about. We call this kind of bang patterns "dead". Dead bangs are the ones
    that under no circumstances can force a thunk that wasn't already forced.
    Dead bangs are a form of redundant bangs; see below.

    We can detect dead bang patterns by checking whether @x ~ ⊥@ is satisfiable
    where the PmBang appears in 'checkGrd'. If not, then clearly the bang is
    dead. So for a source bang, we add the refined Nabla and the source info to
    the 'RedSet's 'rs_bangs'. When collecting stuff to warn, we test that Nabla for
    inhabitants. If it's empty, we'll warn that it's redundant.

    Note that we don't want to warn for a dead bang that appears on a redundant
    clause. That is because in that case, we recommend to delete the clause wholly,
    including its leading pattern match.

    Dead bang patterns are redundant. But there are bang patterns which are
    redundant that aren't dead, for example

      f !() = 0

    the bang still forces the match variable, before we attempt to match on (). But
    it is redundant with the forcing done by the () match. We currently don't
    detect redundant bangs that aren't dead.

    Note [Countering exponential blowup]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Precise pattern match exhaustiveness checking is necessarily exponential in
    the size of some input programs. We implement a counter-measure in the form of
    the -fmax-pmcheck-models flag, limiting the number of Nablas we check against
    each pattern by a constant.

    How do we do that? Consider

      f True True = ()
      f True True = ()

    And imagine we set our limit to 1 for the sake of the example. The first clause
    will be checked against the initial Nabla, {}. Doing so will produce an
    Uncovered set of size 2, containing the models {x≁True} and {x~True,y≁True}.
    Also we find the first clause to cover the model {x~True,y~True}.

    But the Uncovered set we get out of the match is too huge! We somehow have to
    ensure not to make things worse as they are already, so we continue checking
    with a singleton Uncovered set of the initial Nabla {}. Why is this
    sound (wrt. the notion in GADTs Meet Their Match)? Well, it basically amounts
    to forgetting that we matched against the first clause. The values represented
    by {} are a superset of those represented by its two refinements {x≁True} and
    {x~True,y≁True}.

    This forgetfulness becomes very apparent in the example above: By continuing
    with {} we don't detect the second clause as redundant, as it again covers the
    same non-empty subset of {}. So we don't flag everything as redundant anymore,
    but still will never flag something as redundant that isn't.

    For exhaustivity, the converse applies: We will report @f@ as non-exhaustive
    and report @f _ _@ as missing, which is a superset of the actual missing
    matches. But soundness means we will never fail to report a missing match.

    This mechanism is implemented in 'throttle'.

    Guards are an extreme example in this regard, with #11195 being a particularly
    dreadful example: Since their RHS are often pretty much unique, we split on a
    variable (the one representing the RHS) that doesn't occur anywhere else in the
    program, so we don't actually get useful information out of that split!

    Note [considerAccessible]
    ~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider (T18610)

      f :: Bool -> Int
      f x = case (x, x) of
        (True,  True)  -> 1
        (False, False) -> 2
        (True,  False) -> 3 -- Warning: Redundant

    The third case is detected as redundant. But it may be the intent of the
    programmer to keep the dead code, in order for it not to bitrot or to support
    debugging scenarios. But there is no way to communicate that to the
    pattern-match checker! The only way is to deactivate pattern-match checking
    whole-sale, which is quite annoying. Hence, we define in "GHC.Exts":

      considerAccessible = True

    'considerAccessible' is treated specially by the pattern-match checker in that a
    guard with it as the scrutinee expression will keep its parent clause alive:

      g :: Bool -> Int
      g x = case (x, x) of
        (True,  True)  -> 1
        (False, False) -> 2
        (True,  False) | GHC.Exts.considerAccessible -> 3 -- No warning

    The key bits of the implementation are:

      1. Its definition is recognised as known-key (see "GHC.Builtin.Names").
      2. After "GHC.HsToCore.Pmc.Desugar", the guard will end up as a 'PmCon', where
         the match var is the known-key 'considerAccessible' and the constructor
         against which it matches is 'True'.
      3. We recognise the 'PmCon' in 'GHC.HsToCore.Check.checkGrd' and inflate the
         incoming set of values for all guards downstream to the unconstrained
         'initNablas' set, e.g. /all/ values.
         (The set of values that falls through that particular guard is empty, as
         matching 'considerAccessible' against 'True' can't fail.)

    Note that 'considerAccessible' breaks the invariant that incoming sets of values
    reaching syntactic children are subsets of that of the syntactic ancestor:
    A whole match, like that of the third clause of the example, might have no
    incoming value, but its single RHS has incoming values because of (3).

    That means the 'is_covered' flag computed in 'GHC.HsToCore.Pmc.cirbsMatch'
    is irrelevant and should not be used to flag all children as redundant (which is
    what we used to do).

    We achieve great benefits with a very simple implementation.
    There are caveats, though:

      (A) Putting potentially failing guards /after/ the
          'considerAccessible' guard might lead to weird check results, e.g.,

            h :: Bool -> Int
            h x = case (x, x) of
              (True,  True)  -> 1
              (False, False) -> 2
              (True,  False) | GHC.Exts.considerAccessible, False <- x -> 3
              -- Warning: Not matched: (_, _)

          That *is* fixable, although we would pay with a much more complicated
          implementation.
      (B) If the programmer puts a 'considerAccessible' marker on an accessible
          clause, the checker doesn't warn about it. E.g.,

            f :: Bool -> Int
            f True | considerAccessible = 0
            f False = 1

          will not emit any warning whatsoever. We could implement code that warns
          here, but it wouldn't be as simple as it is now.
    -}