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