never executed always true always false
    1 
    2 {-# LANGUAGE LambdaCase #-}
    3 {-# LANGUAGE ScopedTypeVariables #-}
    4 
    5 -- | Utility module for the pattern-match coverage checker.
    6 module GHC.HsToCore.Pmc.Utils (
    7 
    8         tracePm, traceWhenFailPm, mkPmId,
    9         allPmCheckWarnings, overlapping, exhaustive, redundantBang,
   10         exhaustiveWarningFlag,
   11         isMatchContextPmChecked, needToRunPmCheck
   12 
   13     ) where
   14 
   15 import GHC.Prelude
   16 
   17 import GHC.Types.Basic (Origin(..), isGenerated)
   18 import GHC.Driver.Session
   19 import GHC.Hs
   20 import GHC.Core.Type
   21 import GHC.Data.FastString
   22 import GHC.Data.IOEnv
   23 import GHC.Data.Maybe
   24 import GHC.Types.Id
   25 import GHC.Types.Name
   26 import GHC.Types.Unique.Supply
   27 import GHC.Types.SrcLoc
   28 import GHC.Utils.Misc
   29 import GHC.Utils.Outputable
   30 import GHC.Utils.Logger
   31 import GHC.HsToCore.Monad
   32 
   33 import Control.Monad
   34 
   35 tracePm :: String -> SDoc -> DsM ()
   36 tracePm herald doc = do
   37   logger  <- getLogger
   38   printer <- mkPrintUnqualifiedDs
   39   liftIO $ putDumpFileMaybe' logger printer
   40             Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc))
   41 {-# INLINE tracePm #-}  -- see Note [INLINE conditional tracing utilities]
   42 
   43 traceWhenFailPm :: String -> SDoc -> MaybeT DsM a -> MaybeT DsM a
   44 traceWhenFailPm herald doc act = MaybeT $ do
   45   mb_a <- runMaybeT act
   46   when (isNothing mb_a) $ tracePm herald doc
   47   pure mb_a
   48 {-# INLINE traceWhenFailPm #-}  -- see Note [INLINE conditional tracing utilities]
   49 
   50 -- | Generate a fresh `Id` of a given type
   51 mkPmId :: Type -> DsM Id
   52 mkPmId ty = getUniqueM >>= \unique ->
   53   let occname = mkVarOccFS $ fsLit "pm"
   54       name    = mkInternalName unique occname noSrcSpan
   55   in  return (mkLocalIdOrCoVar name Many ty)
   56 {-# NOINLINE mkPmId #-} -- We'll CPR deeply, that should be enough
   57 
   58 -- | All warning flags that need to run the pattern match checker.
   59 allPmCheckWarnings :: [WarningFlag]
   60 allPmCheckWarnings =
   61   [ Opt_WarnIncompletePatterns
   62   , Opt_WarnIncompleteUniPatterns
   63   , Opt_WarnIncompletePatternsRecUpd
   64   , Opt_WarnOverlappingPatterns
   65   ]
   66 
   67 -- | Check whether the redundancy checker should run (redundancy only)
   68 overlapping :: DynFlags -> HsMatchContext id -> Bool
   69 -- See Note [Inaccessible warnings for record updates]
   70 overlapping _      RecUpd = False
   71 overlapping dflags _      = wopt Opt_WarnOverlappingPatterns dflags
   72 
   73 -- | Check whether the exhaustiveness checker should run (exhaustiveness only)
   74 exhaustive :: DynFlags -> HsMatchContext id -> Bool
   75 exhaustive  dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag
   76 
   77 -- | Check whether unnecessary bangs should be warned about
   78 redundantBang :: DynFlags -> Bool
   79 redundantBang dflags = wopt Opt_WarnRedundantBangPatterns dflags
   80 
   81 -- | Denotes whether an exhaustiveness check is supported, and if so,
   82 -- via which 'WarningFlag' it's controlled.
   83 -- Returns 'Nothing' if check is not supported.
   84 exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag
   85 exhaustiveWarningFlag (FunRhs {})   = Just Opt_WarnIncompletePatterns
   86 exhaustiveWarningFlag CaseAlt       = Just Opt_WarnIncompletePatterns
   87 exhaustiveWarningFlag IfAlt         = Just Opt_WarnIncompletePatterns
   88 exhaustiveWarningFlag LambdaExpr    = Just Opt_WarnIncompleteUniPatterns
   89 exhaustiveWarningFlag PatBindRhs    = Just Opt_WarnIncompleteUniPatterns
   90 exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns
   91 exhaustiveWarningFlag (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFlag c
   92 exhaustiveWarningFlag RecUpd        = Just Opt_WarnIncompletePatternsRecUpd
   93 exhaustiveWarningFlag ThPatSplice   = Nothing
   94 exhaustiveWarningFlag PatSyn        = Nothing
   95 exhaustiveWarningFlag ThPatQuote    = Nothing
   96 -- Don't warn about incomplete patterns in list comprehensions, pattern guards
   97 -- etc. They are often *supposed* to be incomplete
   98 exhaustiveWarningFlag (StmtCtxt {}) = Nothing
   99 
  100 arrowMatchContextExhaustiveWarningFlag :: HsArrowMatchContext -> Maybe WarningFlag
  101 arrowMatchContextExhaustiveWarningFlag = \ case
  102   ProcExpr     -> Just Opt_WarnIncompleteUniPatterns
  103   ArrowCaseAlt -> Just Opt_WarnIncompletePatterns
  104   KappaExpr    -> Just Opt_WarnIncompleteUniPatterns
  105 
  106 -- | Check whether any part of pattern match checking is enabled for this
  107 -- 'HsMatchContext' (does not matter whether it is the redundancy check or the
  108 -- exhaustiveness check).
  109 isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool
  110 isMatchContextPmChecked dflags origin kind
  111   | isGenerated origin
  112   = False
  113   | otherwise
  114   = overlapping dflags kind || exhaustive dflags kind
  115 
  116 -- | Return True when any of the pattern match warnings ('allPmCheckWarnings')
  117 -- are enabled, in which case we need to run the pattern match checker.
  118 needToRunPmCheck :: DynFlags -> Origin -> Bool
  119 needToRunPmCheck dflags origin
  120   | isGenerated origin
  121   = False
  122   | otherwise
  123   = notNull (filter (`wopt` dflags) allPmCheckWarnings)
  124 
  125 {- Note [Inaccessible warnings for record updates]
  126 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  127 Consider (#12957)
  128   data T a where
  129     T1 :: { x :: Int } -> T Bool
  130     T2 :: { x :: Int } -> T a
  131     T3 :: T a
  132 
  133   f :: T Char -> T a
  134   f r = r { x = 3 }
  135 
  136 The desugarer will conservatively generate a case for T1 even though
  137 it's impossible:
  138   f r = case r of
  139           T1 x -> T1 3   -- Inaccessible branch
  140           T2 x -> T2 3
  141           _    -> error "Missing"
  142 
  143 We don't want to warn about the inaccessible branch because the programmer
  144 didn't put it there!  So we filter out the warning here.
  145 
  146 The same can happen for long distance term constraints instead of type
  147 constraints (#17783):
  148 
  149   data T = A { x :: Int } | B { x :: Int }
  150   f r@A{} = r { x = 3 }
  151   f _     = B 0
  152 
  153 Here, the long distance info from the FunRhs match (@r ~ A x@) will make the
  154 clause matching on @B@ of the desugaring to @case@ redundant. It's generated
  155 code that we don't want to warn about.
  156 -}