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