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

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

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

    ) where

import GHC.Prelude

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

import Control.Monad

tracePm :: String -> SDoc -> DsM ()
tracePm :: String -> SDoc -> DsM ()
tracePm String
herald SDoc
doc = do
  logger  <- IOEnv (Env DsGblEnv DsLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  name_ppr_ctx <- mkNamePprCtxDs
  liftIO $ putDumpFileMaybe' logger name_ppr_ctx
            Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc))
{-# INLINE tracePm #-}  -- see Note [INLINE conditional tracing utilities]

traceWhenFailPm :: String -> SDoc -> MaybeT DsM a -> MaybeT DsM a
traceWhenFailPm :: forall a.
String
-> SDoc
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
-> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
traceWhenFailPm String
herald SDoc
doc MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
act = DsM (Maybe a) -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (DsM (Maybe a) -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a)
-> DsM (Maybe a) -> MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
forall a b. (a -> b) -> a -> b
$ do
  mb_a <- MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a -> DsM (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT (IOEnv (Env DsGblEnv DsLclEnv)) a
act
  when (isNothing mb_a) $ tracePm herald doc
  pure mb_a
{-# INLINE traceWhenFailPm #-}  -- 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 = IOEnv (Env DsGblEnv DsLclEnv) Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM IOEnv (Env DsGblEnv DsLclEnv) Unique
-> (Unique -> DsM Id) -> DsM Id
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
>>= \Unique
unique ->
  let occname :: OccName
occname = FastString -> OccName
mkVarOccFS (FastString -> OccName) -> FastString -> OccName
forall a b. (a -> b) -> a -> b
$ String -> FastString
fsLit String
"pm"
  in  Id -> DsM Id
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (OccName -> Unique -> Type -> Type -> SrcSpan -> Id
mkUserLocalOrCoVar OccName
occname Unique
unique Type
ManyTy Type
ty SrcSpan
noSrcSpan)
{-# NOINLINE mkPmId #-} -- We'll CPR deeply, that should be enough

-- | 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
  , WarningFlag
Opt_WarnIncompleteRecordSelectors
  ]

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

-- | Check whether the exhaustiveness checker should run (exhaustiveness only)
exhaustive :: DynFlags -> HsMatchContext fn -> Bool
exhaustive :: forall fn. DynFlags -> HsMatchContext fn -> Bool
exhaustive  DynFlags
dflags = Bool -> (WarningFlag -> Bool) -> Maybe WarningFlag -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (WarningFlag -> DynFlags -> Bool
`wopt` DynFlags
dflags) (Maybe WarningFlag -> Bool)
-> (HsMatchContext fn -> Maybe WarningFlag)
-> HsMatchContext fn
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsMatchContext fn -> Maybe WarningFlag
forall fn. HsMatchContext fn -> 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 fn -> Maybe WarningFlag
exhaustiveWarningFlag :: forall fn. HsMatchContext fn -> Maybe WarningFlag
exhaustiveWarningFlag FunRhs{}           = WarningFlag -> Maybe WarningFlag
forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompletePatterns
exhaustiveWarningFlag HsMatchContext fn
CaseAlt            = WarningFlag -> Maybe WarningFlag
forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompletePatterns
exhaustiveWarningFlag HsMatchContext fn
IfAlt              = WarningFlag -> Maybe WarningFlag
forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompletePatterns
exhaustiveWarningFlag (LamAlt HsLamVariant
LamSingle) = WarningFlag -> Maybe WarningFlag
forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompleteUniPatterns
exhaustiveWarningFlag (LamAlt HsLamVariant
_case)     = WarningFlag -> Maybe WarningFlag
forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompletePatterns
exhaustiveWarningFlag HsMatchContext fn
PatBindRhs         = WarningFlag -> Maybe WarningFlag
forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompleteUniPatterns
exhaustiveWarningFlag HsMatchContext fn
PatBindGuards      = WarningFlag -> Maybe WarningFlag
forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompletePatterns
exhaustiveWarningFlag (ArrowMatchCtxt HsArrowMatchContext
c) = HsArrowMatchContext -> Maybe WarningFlag
arrowMatchContextExhaustiveWarningFlag HsArrowMatchContext
c
exhaustiveWarningFlag HsMatchContext fn
RecUpd             = WarningFlag -> Maybe WarningFlag
forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompletePatternsRecUpd
exhaustiveWarningFlag HsMatchContext fn
LazyPatCtx         = WarningFlag -> Maybe WarningFlag
forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompleteUniPatterns
exhaustiveWarningFlag HsMatchContext fn
ThPatSplice        = Maybe WarningFlag
forall a. Maybe a
Nothing
exhaustiveWarningFlag HsMatchContext fn
PatSyn             = Maybe WarningFlag
forall a. Maybe a
Nothing
exhaustiveWarningFlag HsMatchContext fn
ThPatQuote         = Maybe WarningFlag
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{}         = Maybe WarningFlag
forall a. Maybe a
Nothing

arrowMatchContextExhaustiveWarningFlag :: HsArrowMatchContext -> Maybe WarningFlag
arrowMatchContextExhaustiveWarningFlag :: HsArrowMatchContext -> Maybe WarningFlag
arrowMatchContextExhaustiveWarningFlag = \ case
  HsArrowMatchContext
ProcExpr              -> WarningFlag -> Maybe WarningFlag
forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompleteUniPatterns
  HsArrowMatchContext
ArrowCaseAlt          -> WarningFlag -> Maybe WarningFlag
forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompletePatterns
  ArrowLamAlt HsLamVariant
LamSingle -> WarningFlag -> Maybe WarningFlag
forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompleteUniPatterns
  ArrowLamAlt HsLamVariant
_         -> WarningFlag -> Maybe WarningFlag
forall a. a -> Maybe a
Just WarningFlag
Opt_WarnIncompletePatterns

-- | 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 fn -> Bool
isMatchContextPmChecked :: forall fn. DynFlags -> Origin -> HsMatchContext fn -> Bool
isMatchContextPmChecked DynFlags
dflags Origin
origin HsMatchContext fn
ctxt
  =  Origin -> Bool
requiresPMC Origin
origin
  Bool -> Bool -> Bool
&& (DynFlags -> HsMatchContext fn -> Bool
forall fn. DynFlags -> HsMatchContext fn -> Bool
overlapping DynFlags
dflags HsMatchContext fn
ctxt Bool -> Bool -> Bool
|| DynFlags -> HsMatchContext fn -> Bool
forall fn. DynFlags -> HsMatchContext fn -> Bool
exhaustive DynFlags
dflags HsMatchContext fn
ctxt)

-- | Check whether exhaustivity checks are enabled for this 'HsMatchContext',
-- when dealing with a single pattern (using the 'matchSinglePatVar' function).
isMatchContextPmChecked_SinglePat :: DynFlags -> Origin -> HsMatchContext fn -> LPat GhcTc -> Bool
isMatchContextPmChecked_SinglePat :: forall fn.
DynFlags -> Origin -> HsMatchContext fn -> LPat GhcTc -> Bool
isMatchContextPmChecked_SinglePat DynFlags
dflags Origin
origin HsMatchContext fn
ctxt LPat GhcTc
pat
  | Bool -> Bool
not (DynFlags -> Origin -> Bool
needToRunPmCheck DynFlags
dflags Origin
origin)
  = Bool
False
  | StmtCtxt {} <- HsMatchContext fn
ctxt
  -- For @StmtCtxt@, we are interested in propagating pattern-match information
  -- but not in the actual outcome of pattern-match checking, so we skip
  -- if the pattern is "boring" (gives rise to no long-distance information).
  -- (This is done purely for runtime performance.)
  = Bool -> Bool
not (LPat GhcTc -> Bool
forall (p :: Pass). OutputableBndrId p => LPat (GhcPass p) -> Bool
isBoringHsPat LPat GhcTc
pat) -- See Note [Boring patterns] in GHC.Hs.Pat.
  | Bool
otherwise
  = DynFlags -> HsMatchContext fn -> Bool
forall fn. DynFlags -> HsMatchContext fn -> Bool
overlapping DynFlags
dflags HsMatchContext fn
ctxt Bool -> Bool -> Bool
|| DynFlags -> HsMatchContext fn -> Bool
forall fn. DynFlags -> HsMatchContext fn -> Bool
exhaustive DynFlags
dflags HsMatchContext fn
ctxt

-- | 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
requiresPMC Origin
origin
  Bool -> Bool -> Bool
&& (WarningFlag -> Bool) -> [WarningFlag] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (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 }

In GHC.Tc.Gen.Expr.desugarRecordUpd, we 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 test case T12957a checks this.

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

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

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.
-}