    {-# LANGUAGE CPP                 #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE ScopedTypeVariables #-}

    -- | Utility module for the pattern-match coverage checker.
    module GHC.HsToCore.Pmc.Utils (

            tracePm, mkPmId,
            allPmCheckWarnings, overlapping, exhaustive, redundantBang,
            exhaustiveWarningFlag,
            isMatchContextPmChecked, needToRunPmCheck

        ) where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Types.Basic (Origin(..), isGenerated)
    import GHC.Driver.Session
    import GHC.Hs
    import GHC.Core.Type
    import GHC.Data.FastString
    import GHC.Data.IOEnv
    import GHC.Types.Id
    import GHC.Types.Name
    import GHC.Types.Unique.Supply
    import GHC.Types.SrcLoc
    import GHC.Utils.Misc
    import GHC.Utils.Outputable
    import GHC.Utils.Logger
    import GHC.HsToCore.Monad

    tracePm :: String -> SDoc -> DsM ()
    tracePm :: String -> SDoc -> DsM ()
    tracePm String
    herald SDoc
    doc = do
      DynFlags
    dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
      Logger
    logger <- forall (m :: * -> *). HasLogger m => m Logger
    getLogger
      PrintUnqualified
    printer <- DsM PrintUnqualified
    mkPrintUnqualifiedDs
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO forall a b. (a -> b) -> a -> b
    $ PrintUnqualified
    -> Logger
    -> DynFlags
    -> DumpFlag
    -> String
    -> DumpFormat
    -> SDoc
    -> IO ()
    dumpIfSet_dyn_printer PrintUnqualified
    printer Logger
    logger DynFlags
    dflags
                DumpFlag
    Opt_D_dump_ec_trace String
    "" DumpFormat
    FormatText (String -> SDoc
    text String
    herald SDoc -> SDoc -> SDoc
    $$ (Int -> SDoc -> SDoc
    nest Int
    2 SDoc
    doc))
    {-# INLINE tracePm #-}  -- see Note [INLINE conditional tracing utilities]

    -- | Generate a fresh `Id` of a given type
    mkPmId :: Type -> DsM Id
    mkPmId :: Type -> DsM Id
    mkPmId Type
    ty = forall (m :: * -> *). MonadUnique m => m Unique
    getUniqueM forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Unique
    unique ->
      let occname :: OccName
    occname = FastString -> OccName
    mkVarOccFS forall a b. (a -> b) -> a -> b
    $ String -> FastString
    fsLit String
    "pm"
          name :: Name
    name    = Unique -> OccName -> SrcSpan -> Name
    mkInternalName Unique
    unique OccName
    occname SrcSpan
    noSrcSpan
      in  forall (m :: * -> *) a. Monad m => a -> m a
    return (Name -> Type -> Type -> Id
    mkLocalIdOrCoVar Name
    name Type
    Many Type
    ty)

    -- | All warning flags that need to run the pattern match checker.
    allPmCheckWarnings :: [WarningFlag]
    allPmCheckWarnings :: [WarningFlag]
    allPmCheckWarnings =
      [ WarningFlag
    Opt_WarnIncompletePatterns
      , WarningFlag
    Opt_WarnIncompleteUniPatterns
      , WarningFlag
    Opt_WarnIncompletePatternsRecUpd
      , WarningFlag
    Opt_WarnOverlappingPatterns
      ]

    -- | Check whether the redundancy checker should run (redundancy only)
    overlapping :: DynFlags -> HsMatchContext id -> Bool
    -- See Note [Inaccessible warnings for record updates]
    overlapping :: forall id. DynFlags -> HsMatchContext id -> Bool
    overlapping DynFlags
    _      HsMatchContext id
    RecUpd = Bool
    False
    overlapping DynFlags
    dflags HsMatchContext id
    _      = WarningFlag -> DynFlags -> Bool
    wopt WarningFlag
    Opt_WarnOverlappingPatterns DynFlags
    dflags

    -- | Check whether the exhaustiveness checker should run (exhaustiveness only)
    exhaustive :: DynFlags -> HsMatchContext id -> Bool
    exhaustive :: forall id. DynFlags -> HsMatchContext id -> Bool
    exhaustive  DynFlags
    dflags = forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Bool
    False (WarningFlag -> DynFlags -> Bool
    `wopt` DynFlags
    dflags) forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall id. HsMatchContext id -> Maybe WarningFlag
    exhaustiveWarningFlag

    -- | Check whether unnecessary bangs should be warned about
    redundantBang :: DynFlags -> Bool
    redundantBang :: DynFlags -> Bool
    redundantBang DynFlags
    dflags = WarningFlag -> DynFlags -> Bool
    wopt WarningFlag
    Opt_WarnRedundantBangPatterns DynFlags
    dflags

    -- | Denotes whether an exhaustiveness check is supported, and if so,
    -- via which 'WarningFlag' it's controlled.
    -- Returns 'Nothing' if check is not supported.
    exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag
    exhaustiveWarningFlag :: forall id. HsMatchContext id -> Maybe WarningFlag
    exhaustiveWarningFlag (FunRhs {})   = forall a. a -> Maybe a
    Just WarningFlag
    Opt_WarnIncompletePatterns
    exhaustiveWarningFlag HsMatchContext id
    CaseAlt       = forall a. a -> Maybe a
    Just WarningFlag
    Opt_WarnIncompletePatterns
    exhaustiveWarningFlag HsMatchContext id
    IfAlt         = forall a. a -> Maybe a
    Just WarningFlag
    Opt_WarnIncompletePatterns
    exhaustiveWarningFlag HsMatchContext id
    LambdaExpr    = forall a. a -> Maybe a
    Just WarningFlag
    Opt_WarnIncompleteUniPatterns
    exhaustiveWarningFlag HsMatchContext id
    PatBindRhs    = forall a. a -> Maybe a
    Just WarningFlag
    Opt_WarnIncompleteUniPatterns
    exhaustiveWarningFlag HsMatchContext id
    PatBindGuards = forall a. a -> Maybe a
    Just WarningFlag
    Opt_WarnIncompletePatterns
    exhaustiveWarningFlag (ArrowMatchCtxt HsArrowMatchContext
    c) = HsArrowMatchContext -> Maybe WarningFlag
    arrowMatchContextExhaustiveWarningFlag HsArrowMatchContext
    c
    exhaustiveWarningFlag HsMatchContext id
    RecUpd        = forall a. a -> Maybe a
    Just WarningFlag
    Opt_WarnIncompletePatternsRecUpd
    exhaustiveWarningFlag HsMatchContext id
    ThPatSplice   = forall a. Maybe a
    Nothing
    exhaustiveWarningFlag HsMatchContext id
    PatSyn        = forall a. Maybe a
    Nothing
    exhaustiveWarningFlag HsMatchContext id
    ThPatQuote    = forall a. Maybe a
    Nothing
    -- Don't warn about incomplete patterns in list comprehensions, pattern guards
    -- etc. They are often *supposed* to be incomplete
    exhaustiveWarningFlag (StmtCtxt {}) = forall a. Maybe a
    Nothing

    arrowMatchContextExhaustiveWarningFlag :: HsArrowMatchContext -> Maybe WarningFlag
    arrowMatchContextExhaustiveWarningFlag :: HsArrowMatchContext -> Maybe WarningFlag
    arrowMatchContextExhaustiveWarningFlag = \ case
      HsArrowMatchContext
    ProcExpr     -> forall a. a -> Maybe a
    Just WarningFlag
    Opt_WarnIncompleteUniPatterns
      HsArrowMatchContext
    ArrowCaseAlt -> forall a. a -> Maybe a
    Just WarningFlag
    Opt_WarnIncompletePatterns
      HsArrowMatchContext
    KappaExpr    -> forall a. a -> Maybe a
    Just WarningFlag
    Opt_WarnIncompleteUniPatterns

    -- | Check whether any part of pattern match checking is enabled for this
    -- 'HsMatchContext' (does not matter whether it is the redundancy check or the
    -- exhaustiveness check).
    isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool
    isMatchContextPmChecked :: forall id. DynFlags -> Origin -> HsMatchContext id -> Bool
    isMatchContextPmChecked DynFlags
    dflags Origin
    origin HsMatchContext id
    kind
      | Origin -> Bool
    isGenerated Origin
    origin
      = Bool
    False
      | Bool
    otherwise
      = forall id. DynFlags -> HsMatchContext id -> Bool
    overlapping DynFlags
    dflags HsMatchContext id
    kind Bool -> Bool -> Bool
    || forall id. DynFlags -> HsMatchContext id -> Bool
    exhaustive DynFlags
    dflags HsMatchContext id
    kind

    -- | Return True when any of the pattern match warnings ('allPmCheckWarnings')
    -- are enabled, in which case we need to run the pattern match checker.
    needToRunPmCheck :: DynFlags -> Origin -> Bool
    needToRunPmCheck :: DynFlags -> Origin -> Bool
    needToRunPmCheck DynFlags
    dflags Origin
    origin
      | Origin -> Bool
    isGenerated Origin
    origin
      = Bool
    False
      | Bool
    otherwise
      = forall (f :: * -> *) a. Foldable f => f a -> Bool
    notNull (forall a. (a -> Bool) -> [a] -> [a]
    filter (WarningFlag -> DynFlags -> Bool
    `wopt` DynFlags
    dflags) [WarningFlag]
    allPmCheckWarnings)

    {- Note [Inaccessible warnings for record updates]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider (#12957)
      data T a where
        T1 :: { x :: Int } -> T Bool
        T2 :: { x :: Int } -> T a
        T3 :: T a

      f :: T Char -> T a
      f r = r { x = 3 }

    The desugarer will conservatively generate a case for T1 even though
    it's impossible:
      f r = case r of
              T1 x -> T1 3   -- Inaccessible branch
              T2 x -> T2 3
              _    -> error "Missing"

    We don't want to warn about the inaccessible branch because the programmer
    didn't put it there!  So we filter out the warning here.

    The same can happen for long distance term constraints instead of type
    constraints (#17783):

      data T = A { x :: Int } | B { x :: Int }
      f r@A{} = r { x = 3 }
      f _     = B 0

    Here, the long distance info from the FunRhs match (@r ~ A x@) will make the
    clause matching on @B@ of the desugaring to @case@ redundant. It's generated
    code that we don't want to warn about.
    -}