never executed always true always false
1 {-# LANGUAGE LambdaCase #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage
3
4 module GHC.HsToCore.Errors.Ppr where
5
6 import GHC.Builtin.Names (withDictName)
7 import GHC.Core.Predicate (isEvVar)
8 import GHC.Core.Type
9 import GHC.Driver.Flags
10 import GHC.Hs
11 import GHC.HsToCore.Errors.Types
12 import GHC.Prelude
13 import GHC.Types.Basic (pprRuleName)
14 import GHC.Types.Error
15 import GHC.Types.Id (idType)
16 import GHC.Types.SrcLoc
17 import GHC.Utils.Misc
18 import GHC.Utils.Outputable
19 import qualified GHC.LanguageExtensions as LangExt
20 import GHC.HsToCore.Pmc.Ppr
21
22
23 instance Diagnostic DsMessage where
24 diagnosticMessage = \case
25 DsUnknownMessage m
26 -> diagnosticMessage m
27 DsEmptyEnumeration
28 -> mkSimpleDecorated $ text "Enumeration is empty"
29 DsIdentitiesFound conv_fn type_of_conv
30 -> mkSimpleDecorated $
31 vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv
32 , nest 2 $ text "can probably be omitted"
33 ]
34 DsOverflowedLiterals i tc bounds _possiblyUsingNegativeLiterals
35 -> let msg = case bounds of
36 Nothing
37 -> vcat [ text "Literal" <+> integer i
38 <+> text "is negative but" <+> ppr tc
39 <+> text "only supports positive numbers"
40 ]
41 Just (MinBound minB, MaxBound maxB)
42 -> vcat [ text "Literal" <+> integer i
43 <+> text "is out of the" <+> ppr tc <+> text "range"
44 <+> integer minB <> text ".." <> integer maxB
45 ]
46 in mkSimpleDecorated msg
47 DsRedundantBangPatterns ctx q
48 -> mkSimpleDecorated $ pprEqn ctx q "has redundant bang"
49 DsOverlappingPatterns ctx q
50 -> mkSimpleDecorated $ pprEqn ctx q "is redundant"
51 DsInaccessibleRhs ctx q
52 -> mkSimpleDecorated $ pprEqn ctx q "has inaccessible right hand side"
53 DsMaxPmCheckModelsReached limit
54 -> mkSimpleDecorated $ vcat
55 [ hang
56 (text "Pattern match checker ran into -fmax-pmcheck-models="
57 <> int limit
58 <> text " limit, so")
59 2
60 ( bullet <+> text "Redundant clauses might not be reported at all"
61 $$ bullet <+> text "Redundant clauses might be reported as inaccessible"
62 $$ bullet <+> text "Patterns reported as unmatched might actually be matched")
63 ]
64 DsNonExhaustivePatterns kind _flag maxPatterns vars nablas
65 -> mkSimpleDecorated $
66 pprContext False kind (text "are non-exhaustive") $ \_ ->
67 case vars of -- See #11245
68 [] -> text "Guards do not cover entire pattern space"
69 _ -> let us = map (\nabla -> pprUncovered nabla vars) nablas
70 pp_tys = pprQuotedList $ map idType vars
71 in hang
72 (text "Patterns of type" <+> pp_tys <+> text "not matched:")
73 4
74 (vcat (take maxPatterns us) $$ dots maxPatterns us)
75 DsTopLevelBindsNotAllowed bindsType bind
76 -> let desc = case bindsType of
77 UnliftedTypeBinds -> "bindings for unlifted types"
78 StrictBinds -> "strict bindings"
79 in mkSimpleDecorated $
80 hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind)
81 DsUselessSpecialiseForClassMethodSelector poly_id
82 -> mkSimpleDecorated $
83 text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id)
84 DsUselessSpecialiseForNoInlineFunction poly_id
85 -> mkSimpleDecorated $
86 text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id)
87 DsMultiplicityCoercionsNotSupported
88 -> mkSimpleDecorated $ text "GHC bug #19517: GHC currently does not support programs using GADTs or type families to witness equality of multiplicities"
89 DsOrphanRule rule
90 -> mkSimpleDecorated $ text "Orphan rule:" <+> ppr rule
91 DsRuleLhsTooComplicated orig_lhs lhs2
92 -> mkSimpleDecorated $
93 hang (text "RULE left-hand side too complicated to desugar")
94 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2
95 , text "Orig lhs:" <+> ppr orig_lhs])
96 DsRuleIgnoredDueToConstructor con
97 -> mkSimpleDecorated $ vcat
98 [ text "A constructor," <+> ppr con <>
99 text ", appears as outermost match in RULE lhs."
100 , text "This rule will be ignored." ]
101 DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2
102 -> mkSimpleDecorated $ vcat (map pp_dead unbound)
103 where
104 pp_dead bndr =
105 hang (sep [ text "Forall'd" <+> pp_bndr bndr
106 , text "is not bound in RULE lhs"])
107 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
108 , text "Orig lhs:" <+> ppr orig_lhs
109 , text "optimised lhs:" <+> ppr lhs2 ])
110
111 pp_bndr b
112 | isTyVar b = text "type variable" <+> quotes (ppr b)
113 | isEvVar b = text "constraint" <+> quotes (ppr (varType b))
114 | otherwise = text "variable" <+> quotes (ppr b)
115 DsMultipleConForNewtype names
116 -> mkSimpleDecorated $ text "Multiple constructors for newtype:" <+> pprQuotedList names
117 DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs
118 -> mkSimpleDecorated $
119 hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$
120 text "Unlifted variables:")
121 2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id)) unlifted_bndrs))
122 DsNotYetHandledByTH reason
123 -> case reason of
124 ThAmbiguousRecordUpdates fld
125 -> mkMsg "Ambiguous record updates" (ppr fld)
126 ThAbstractClosedTypeFamily decl
127 -> mkMsg "abstract closed type family" (ppr decl)
128 ThForeignLabel cls
129 -> mkMsg "Foreign label" (doubleQuotes (ppr cls))
130 ThForeignExport decl
131 -> mkMsg "Foreign export" (ppr decl)
132 ThMinimalPragmas
133 -> mkMsg "MINIMAL pragmas" empty
134 ThSCCPragmas
135 -> mkMsg "SCC pragmas" empty
136 ThNoUserInline
137 -> mkMsg "NOUSERINLINE" empty
138 ThExoticFormOfType ty
139 -> mkMsg "Exotic form of type" (ppr ty)
140 ThAmbiguousRecordSelectors e
141 -> mkMsg "Ambiguous record selectors" (ppr e)
142 ThMonadComprehensionSyntax e
143 -> mkMsg "monad comprehension and [: :]" (ppr e)
144 ThCostCentres e
145 -> mkMsg "Cost centres" (ppr e)
146 ThExpressionForm e
147 -> mkMsg "Expression form" (ppr e)
148 ThExoticStatement other
149 -> mkMsg "Exotic statement" (ppr other)
150 ThExoticLiteral lit
151 -> mkMsg "Exotic literal" (ppr lit)
152 ThExoticPattern pat
153 -> mkMsg "Exotic pattern" (ppr pat)
154 ThGuardedLambdas m
155 -> mkMsg "Guarded lambdas" (pprMatch m)
156 ThNegativeOverloadedPatterns pat
157 -> mkMsg "Negative overloaded patterns" (ppr pat)
158 ThHaddockDocumentation
159 -> mkMsg "Haddock documentation" empty
160 ThWarningAndDeprecationPragmas decl
161 -> mkMsg "WARNING and DEPRECATION pragmas" $
162 text "Pragma for declaration of" <+> ppr decl
163 ThSplicesWithinDeclBrackets
164 -> mkMsg "Splices within declaration brackets" empty
165 ThNonLinearDataCon
166 -> mkMsg "Non-linear fields in data constructors" empty
167 where
168 mkMsg what doc =
169 mkSimpleDecorated $
170 hang (text what <+> text "not (yet) handled by Template Haskell") 2 doc
171 DsAggregatedViewExpressions views
172 -> mkSimpleDecorated (vcat msgs)
173 where
174 msgs = map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) views
175 DsUnbangedStrictPatterns bind
176 -> mkSimpleDecorated $
177 hang (text "Pattern bindings containing unlifted types should use" $$
178 text "an outermost bang pattern:")
179 2 (ppr bind)
180 DsCannotMixPolyAndUnliftedBindings bind
181 -> mkSimpleDecorated $
182 hang (text "You can't mix polymorphic and unlifted bindings:")
183 2 (ppr bind)
184 DsInvalidInstantiationDictAtType wrapped_ty
185 -> mkSimpleDecorated $
186 hang (text "Invalid instantiation of" <+>
187 quotes (ppr withDictName) <+> text "at type:")
188 4 (ppr wrapped_ty)
189 DsWrongDoBind _rhs elt_ty
190 -> mkSimpleDecorated $ badMonadBind elt_ty
191 DsUnusedDoBind _rhs elt_ty
192 -> mkSimpleDecorated $ badMonadBind elt_ty
193 DsRecBindsNotAllowedForUnliftedTys binds
194 -> mkSimpleDecorated $
195 hang (text "Recursive bindings for unlifted types aren't allowed:")
196 2 (vcat (map ppr binds))
197 DsRuleMightInlineFirst rule_name lhs_id _
198 -> mkSimpleDecorated $
199 vcat [ hang (text "Rule" <+> pprRuleName rule_name
200 <+> text "may never fire")
201 2 (text "because" <+> quotes (ppr lhs_id)
202 <+> text "might inline first")
203 ]
204 DsAnotherRuleMightFireFirst rule_name bad_rule lhs_id
205 -> mkSimpleDecorated $
206 vcat [ hang (text "Rule" <+> pprRuleName rule_name
207 <+> text "may never fire")
208 2 (text "because rule" <+> pprRuleName bad_rule
209 <+> text "for"<+> quotes (ppr lhs_id)
210 <+> text "might fire first")
211 ]
212
213 diagnosticReason = \case
214 DsUnknownMessage m -> diagnosticReason m
215 DsEmptyEnumeration -> WarningWithFlag Opt_WarnEmptyEnumerations
216 DsIdentitiesFound{} -> WarningWithFlag Opt_WarnIdentities
217 DsOverflowedLiterals{} -> WarningWithFlag Opt_WarnOverflowedLiterals
218 DsRedundantBangPatterns{} -> WarningWithFlag Opt_WarnRedundantBangPatterns
219 DsOverlappingPatterns{} -> WarningWithFlag Opt_WarnOverlappingPatterns
220 DsInaccessibleRhs{} -> WarningWithFlag Opt_WarnOverlappingPatterns
221 DsMaxPmCheckModelsReached{} -> WarningWithoutFlag
222 DsNonExhaustivePatterns _ (ExhaustivityCheckType mb_flag) _ _ _
223 -> maybe WarningWithoutFlag WarningWithFlag mb_flag
224 DsTopLevelBindsNotAllowed{} -> ErrorWithoutFlag
225 DsUselessSpecialiseForClassMethodSelector{} -> WarningWithoutFlag
226 DsUselessSpecialiseForNoInlineFunction{} -> WarningWithoutFlag
227 DsMultiplicityCoercionsNotSupported{} -> ErrorWithoutFlag
228 DsOrphanRule{} -> WarningWithFlag Opt_WarnOrphans
229 DsRuleLhsTooComplicated{} -> WarningWithoutFlag
230 DsRuleIgnoredDueToConstructor{} -> WarningWithoutFlag
231 DsRuleBindersNotBound{} -> WarningWithoutFlag
232 DsMultipleConForNewtype{} -> ErrorWithoutFlag
233 DsLazyPatCantBindVarsOfUnliftedType{} -> ErrorWithoutFlag
234 DsNotYetHandledByTH{} -> ErrorWithoutFlag
235 DsAggregatedViewExpressions{} -> WarningWithoutFlag
236 DsUnbangedStrictPatterns{} -> WarningWithFlag Opt_WarnUnbangedStrictPatterns
237 DsCannotMixPolyAndUnliftedBindings{} -> ErrorWithoutFlag
238 DsInvalidInstantiationDictAtType{} -> ErrorWithoutFlag
239 DsWrongDoBind{} -> WarningWithFlag Opt_WarnWrongDoBind
240 DsUnusedDoBind{} -> WarningWithFlag Opt_WarnUnusedDoBind
241 DsRecBindsNotAllowedForUnliftedTys{} -> ErrorWithoutFlag
242 DsRuleMightInlineFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing
243 DsAnotherRuleMightFireFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing
244
245 diagnosticHints = \case
246 DsUnknownMessage m -> diagnosticHints m
247 DsEmptyEnumeration -> noHints
248 DsIdentitiesFound{} -> noHints
249 DsOverflowedLiterals i _tc bounds usingNegLiterals
250 -> case (bounds, usingNegLiterals) of
251 (Just (MinBound minB, MaxBound _), NotUsingNegLiterals)
252 | minB == -i -- Note [Suggest NegativeLiterals]
253 , i > 0
254 -> [ suggestExtensionWithInfo (text "If you are trying to write a large negative literal")
255 LangExt.NegativeLiterals ]
256 _ -> noHints
257 DsRedundantBangPatterns{} -> noHints
258 DsOverlappingPatterns{} -> noHints
259 DsInaccessibleRhs{} -> noHints
260 DsMaxPmCheckModelsReached{} -> [SuggestIncreaseMaxPmCheckModels]
261 DsNonExhaustivePatterns{} -> noHints
262 DsTopLevelBindsNotAllowed{} -> noHints
263 DsUselessSpecialiseForClassMethodSelector{} -> noHints
264 DsUselessSpecialiseForNoInlineFunction{} -> noHints
265 DsMultiplicityCoercionsNotSupported -> noHints
266 DsOrphanRule{} -> noHints
267 DsRuleLhsTooComplicated{} -> noHints
268 DsRuleIgnoredDueToConstructor{} -> noHints
269 DsRuleBindersNotBound{} -> noHints
270 DsMultipleConForNewtype{} -> noHints
271 DsLazyPatCantBindVarsOfUnliftedType{} -> noHints
272 DsNotYetHandledByTH{} -> noHints
273 DsAggregatedViewExpressions{} -> noHints
274 DsUnbangedStrictPatterns{} -> noHints
275 DsCannotMixPolyAndUnliftedBindings{} -> [SuggestAddTypeSignatures UnnamedBinding]
276 DsWrongDoBind rhs _ -> [SuggestBindToWildcard rhs]
277 DsUnusedDoBind rhs _ -> [SuggestBindToWildcard rhs]
278 DsRecBindsNotAllowedForUnliftedTys{} -> noHints
279 DsInvalidInstantiationDictAtType{} -> noHints
280 DsRuleMightInlineFirst _ lhs_id rule_act -> [SuggestAddInlineOrNoInlinePragma lhs_id rule_act]
281 DsAnotherRuleMightFireFirst _ bad_rule _ -> [SuggestAddPhaseToCompetingRule bad_rule]
282
283 {-
284 Note [Suggest NegativeLiterals]
285 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
286 If you write
287 x :: Int8
288 x = -128
289 it'll parse as (negate 128), and overflow. In this case, suggest NegativeLiterals.
290 We get an erroneous suggestion for
291 x = 128
292 but perhaps that does not matter too much.
293 -}
294
295 --
296 -- Helper functions
297 --
298
299 badMonadBind :: Type -> SDoc
300 badMonadBind elt_ty
301 = hang (text "A do-notation statement discarded a result of type")
302 2 (quotes (ppr elt_ty))
303
304 -- Print a single clause (for redundant/with-inaccessible-rhs)
305 pprEqn :: HsMatchContext GhcRn -> SDoc -> String -> SDoc
306 pprEqn ctx q txt = pprContext True ctx (text txt) $ \f ->
307 f (q <+> matchSeparator ctx <+> text "...")
308
309 pprContext :: Bool -> HsMatchContext GhcRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
310 pprContext singular kind msg rest_of_msg_fun
311 = vcat [text txt <+> msg,
312 sep [ text "In" <+> ppr_match <> char ':'
313 , nest 4 (rest_of_msg_fun pref)]]
314 where
315 txt | singular = "Pattern match"
316 | otherwise = "Pattern match(es)"
317
318 (ppr_match, pref)
319 = case kind of
320 FunRhs { mc_fun = L _ fun }
321 -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
322 _ -> (pprMatchContext kind, \ pp -> pp)
323
324 dots :: Int -> [a] -> SDoc
325 dots maxPatterns qs
326 | qs `lengthExceeds` maxPatterns = text "..."
327 | otherwise = empty