never executed always true always false
1 {-# LANGUAGE LambdaCase #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage
3 {-# LANGUAGE RecordWildCards #-}
4
5 module GHC.Tc.Errors.Ppr ( pprTypeDoesNotHaveFixedRuntimeRep )
6 where
7
8 import GHC.Prelude
9
10 import Data.Maybe (isJust)
11
12 import GHC.Builtin.Names
13 import GHC.Core.Class (Class(..))
14 import GHC.Core.Coercion (pprCoAxBranchUser)
15 import GHC.Core.Coercion.Axiom (coAxiomTyCon, coAxiomSingleBranch)
16 import GHC.Core.DataCon (DataCon)
17 import GHC.Core.FamInstEnv (famInstAxiom)
18 import GHC.Core.InstEnv
19 import GHC.Core.TyCon (isNewTyCon)
20 import GHC.Core.TyCo.Ppr (pprKind, pprParendType, pprType,
21 pprWithExplicitKindsWhen, pprTheta, pprClassPred, pprTypeApp,
22 pprSourceTyCon)
23 import GHC.Core.Type
24 import GHC.Data.Bag
25 import GHC.Tc.Errors.Types
26 import GHC.Tc.Types.Rank (Rank(..))
27 import GHC.Tc.Utils.TcType (TcType, tcSplitForAllTyVars, mkClassPred)
28 import GHC.Types.Error
29 import GHC.Types.FieldLabel (FieldLabelString, flIsOverloaded, flSelector)
30 import GHC.Types.Id (isRecordSelector)
31 import GHC.Types.Name
32 import GHC.Types.Name.Reader (GreName(..), pprNameProvenance)
33 import GHC.Types.SrcLoc (GenLocated(..), unLoc)
34 import GHC.Types.TyThing
35 import GHC.Types.Var.Env (emptyTidyEnv)
36 import GHC.Types.Var.Set (pprVarSet, pluralVarSet)
37 import GHC.Driver.Flags
38 import GHC.Hs
39 import GHC.Utils.Misc (capitalise)
40 import GHC.Utils.Outputable
41 import GHC.Unit.State (pprWithUnitState, UnitState)
42 import qualified GHC.LanguageExtensions as LangExt
43 import qualified Data.List.NonEmpty as NE
44
45
46 instance Diagnostic TcRnMessage where
47 diagnosticMessage = \case
48 TcRnUnknownMessage m
49 -> diagnosticMessage m
50 TcRnTypeDoesNotHaveFixedRuntimeRep ty prov (ErrInfo extra supplementary)
51 -> mkDecorated [pprTypeDoesNotHaveFixedRuntimeRep ty prov, extra, supplementary]
52 TcRnMessageWithInfo unit_state msg_with_info
53 -> case msg_with_info of
54 TcRnMessageDetailed err_info msg
55 -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage msg)
56 TcRnImplicitLift id_or_name ErrInfo{..}
57 -> mkDecorated $
58 ( text "The variable" <+> quotes (ppr id_or_name) <+>
59 text "is implicitly lifted in the TH quotation"
60 ) : [errInfoContext, errInfoSupplementary]
61 TcRnUnusedPatternBinds bind
62 -> mkDecorated [hang (text "This pattern-binding binds no variables:") 2 (ppr bind)]
63 TcRnDodgyImports name
64 -> mkDecorated [dodgy_msg (text "import") name (dodgy_msg_insert name :: IE GhcPs)]
65 TcRnDodgyExports name
66 -> mkDecorated [dodgy_msg (text "export") name (dodgy_msg_insert name :: IE GhcRn)]
67 TcRnMissingImportList ie
68 -> mkDecorated [ text "The import item" <+> quotes (ppr ie) <+>
69 text "does not have an explicit import list"
70 ]
71 TcRnUnsafeDueToPlugin
72 -> mkDecorated [text "Use of plugins makes the module unsafe"]
73 TcRnModMissingRealSrcSpan mod
74 -> mkDecorated [text "Module does not have a RealSrcSpan:" <+> ppr mod]
75 TcRnIdNotExportedFromModuleSig name mod
76 -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+>
77 text "does not exist in the signature for" <+> ppr mod
78 ]
79 TcRnIdNotExportedFromLocalSig name
80 -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+>
81 text "does not exist in the local signature."
82 ]
83 TcRnShadowedName occ provenance
84 -> let shadowed_locs = case provenance of
85 ShadowedNameProvenanceLocal n -> [text "bound at" <+> ppr n]
86 ShadowedNameProvenanceGlobal gres -> map pprNameProvenance gres
87 in mkSimpleDecorated $
88 sep [text "This binding for" <+> quotes (ppr occ)
89 <+> text "shadows the existing binding" <> plural shadowed_locs,
90 nest 2 (vcat shadowed_locs)]
91 TcRnDuplicateWarningDecls d rdr_name
92 -> mkSimpleDecorated $
93 vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),
94 text "also at " <+> ppr (getLocA d)]
95 TcRnSimplifierTooManyIterations simples limit wc
96 -> mkSimpleDecorated $
97 hang (text "solveWanteds: too many iterations"
98 <+> parens (text "limit =" <+> ppr limit))
99 2 (vcat [ text "Unsolved:" <+> ppr wc
100 , text "Simples:" <+> ppr simples
101 ])
102 TcRnIllegalPatSynDecl rdrname
103 -> mkSimpleDecorated $
104 hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))
105 2 (text "Pattern synonym declarations are only valid at top level")
106 TcRnLinearPatSyn ty
107 -> mkSimpleDecorated $
108 hang (text "Pattern synonyms do not support linear fields (GHC #18806):") 2 (ppr ty)
109 TcRnEmptyRecordUpdate
110 -> mkSimpleDecorated $ text "Empty record update"
111 TcRnIllegalFieldPunning fld
112 -> mkSimpleDecorated $ text "Illegal use of punning for field" <+> quotes (ppr fld)
113 TcRnIllegalWildcardsInRecord fld_part
114 -> mkSimpleDecorated $ text "Illegal `..' in record" <+> pprRecordFieldPart fld_part
115 TcRnDuplicateFieldName fld_part dups
116 -> mkSimpleDecorated $
117 hsep [text "duplicate field name",
118 quotes (ppr (NE.head dups)),
119 text "in record", pprRecordFieldPart fld_part]
120 TcRnIllegalViewPattern pat
121 -> mkSimpleDecorated $ vcat [text "Illegal view pattern: " <+> ppr pat]
122 TcRnCharLiteralOutOfRange c
123 -> mkSimpleDecorated $ text "character literal out of range: '\\" <> char c <> char '\''
124 TcRnIllegalWildcardsInConstructor con
125 -> mkSimpleDecorated $
126 vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con)
127 , nest 2 (text "The constructor has no labelled fields") ]
128 TcRnIgnoringAnnotations anns
129 -> mkSimpleDecorated $
130 text "Ignoring ANN annotation" <> plural anns <> comma
131 <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi"
132 TcRnAnnotationInSafeHaskell
133 -> mkSimpleDecorated $
134 vcat [ text "Annotations are not compatible with Safe Haskell."
135 , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ]
136 TcRnInvalidTypeApplication fun_ty hs_ty
137 -> mkSimpleDecorated $
138 text "Cannot apply expression of type" <+> quotes (ppr fun_ty) $$
139 text "to a visible type argument" <+> quotes (ppr hs_ty)
140 TcRnTagToEnumMissingValArg
141 -> mkSimpleDecorated $
142 text "tagToEnum# must appear applied to one value argument"
143 TcRnTagToEnumUnspecifiedResTy ty
144 -> mkSimpleDecorated $
145 hang (text "Bad call to tagToEnum# at type" <+> ppr ty)
146 2 (vcat [ text "Specify the type by giving a type signature"
147 , text "e.g. (tagToEnum# x) :: Bool" ])
148 TcRnTagToEnumResTyNotAnEnum ty
149 -> mkSimpleDecorated $
150 hang (text "Bad call to tagToEnum# at type" <+> ppr ty)
151 2 (text "Result type must be an enumeration type")
152 TcRnArrowIfThenElsePredDependsOnResultTy
153 -> mkSimpleDecorated $
154 text "Predicate type of `ifThenElse' depends on result type"
155 TcRnArrowCommandExpected cmd
156 -> mkSimpleDecorated $
157 vcat [text "The expression", nest 2 (ppr cmd),
158 text "was found where an arrow command was expected"]
159 TcRnIllegalHsBootFileDecl
160 -> mkSimpleDecorated $
161 text "Illegal declarations in an hs-boot file"
162 TcRnRecursivePatternSynonym binds
163 -> mkSimpleDecorated $
164 hang (text "Recursive pattern synonym definition with following bindings:")
165 2 (vcat $ map pprLBind . bagToList $ binds)
166 where
167 pprLoc loc = parens (text "defined at" <+> ppr loc)
168 pprLBind :: GenLocated (SrcSpanAnn' a) (HsBindLR GhcRn idR) -> SDoc
169 pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind)
170 <+> pprLoc (locA loc)
171 TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty
172 -> mkSimpleDecorated $
173 hang (text "Couldn't match" <+> quotes (ppr n1)
174 <+> text "with" <+> quotes (ppr n2))
175 2 (hang (text "both bound by the partial type signature:")
176 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))
177 TcRnPartialTypeSigBadQuantifier n fn_name hs_ty
178 -> mkSimpleDecorated $
179 hang (text "Can't quantify over" <+> quotes (ppr n))
180 2 (hang (text "bound by the partial type signature:")
181 2 (ppr fn_name <+> dcolon <+> ppr hs_ty))
182 TcRnPolymorphicBinderMissingSig n ty
183 -> mkSimpleDecorated $
184 sep [ text "Polymorphic local binding with no type signature:"
185 , nest 2 $ pprPrefixName n <+> dcolon <+> ppr ty ]
186 TcRnOverloadedSig sig
187 -> mkSimpleDecorated $
188 hang (text "Overloaded signature conflicts with monomorphism restriction")
189 2 (ppr sig)
190 TcRnTupleConstraintInst _
191 -> mkSimpleDecorated $ text "You can't specify an instance for a tuple constraint"
192 TcRnAbstractClassInst clas
193 -> mkSimpleDecorated $
194 text "Cannot define instance for abstract class" <+>
195 quotes (ppr (className clas))
196 TcRnNoClassInstHead tau
197 -> mkSimpleDecorated $
198 hang (text "Instance head is not headed by a class:") 2 (pprType tau)
199 TcRnUserTypeError ty
200 -> mkSimpleDecorated (pprUserTypeErrorTy ty)
201 TcRnConstraintInKind ty
202 -> mkSimpleDecorated $
203 text "Illegal constraint in a kind:" <+> pprType ty
204 TcRnUnboxedTupleTypeFuncArg ty
205 -> mkSimpleDecorated $
206 sep [ text "Illegal unboxed tuple type as function argument:"
207 , pprType ty ]
208 TcRnLinearFuncInKind ty
209 -> mkSimpleDecorated $
210 text "Illegal linear function in a kind:" <+> pprType ty
211 TcRnForAllEscapeError ty kind
212 -> mkSimpleDecorated $ vcat
213 [ hang (text "Quantified type's kind mentions quantified type variable")
214 2 (text "type:" <+> quotes (ppr ty))
215 , hang (text "where the body of the forall has this kind:")
216 2 (quotes (pprKind kind)) ]
217 TcRnVDQInTermType ty
218 -> mkSimpleDecorated $ vcat
219 [ hang (text "Illegal visible, dependent quantification" <+>
220 text "in the type of a term:")
221 2 (pprType ty)
222 , text "(GHC does not yet support this)" ]
223 TcRnIllegalEqualConstraints ty
224 -> mkSimpleDecorated $
225 text "Illegal equational constraint" <+> pprType ty
226 TcRnBadQuantPredHead ty
227 -> mkSimpleDecorated $
228 hang (text "Quantified predicate must have a class or type variable head:")
229 2 (pprType ty)
230 TcRnIllegalTupleConstraint ty
231 -> mkSimpleDecorated $
232 text "Illegal tuple constraint:" <+> pprType ty
233 TcRnNonTypeVarArgInConstraint ty
234 -> mkSimpleDecorated $
235 hang (text "Non type-variable argument")
236 2 (text "in the constraint:" <+> pprType ty)
237 TcRnIllegalImplicitParam ty
238 -> mkSimpleDecorated $
239 text "Illegal implicit parameter" <+> quotes (pprType ty)
240 TcRnIllegalConstraintSynonymOfKind kind
241 -> mkSimpleDecorated $
242 text "Illegal constraint synonym of kind:" <+> quotes (pprKind kind)
243 TcRnIllegalClassInst tcf
244 -> mkSimpleDecorated $
245 vcat [ text "Illegal instance for a" <+> ppr tcf
246 , text "A class instance must be for a class" ]
247 TcRnOversaturatedVisibleKindArg ty
248 -> mkSimpleDecorated $
249 text "Illegal oversaturated visible kind argument:" <+>
250 quotes (char '@' <> pprParendType ty)
251 TcRnBadAssociatedType clas tc
252 -> mkSimpleDecorated $
253 hsep [ text "Class", quotes (ppr clas)
254 , text "does not have an associated type", quotes (ppr tc) ]
255 TcRnForAllRankErr rank ty
256 -> let herald = case tcSplitForAllTyVars ty of
257 ([], _) -> text "Illegal qualified type:"
258 _ -> text "Illegal polymorphic type:"
259 extra = case rank of
260 MonoTypeConstraint -> text "A constraint must be a monotype"
261 _ -> empty
262 in mkSimpleDecorated $ vcat [hang herald 2 (pprType ty), extra]
263 TcRnMonomorphicBindings bindings
264 -> let pp_bndrs = pprBindings bindings
265 in mkSimpleDecorated $
266 sep [ text "The Monomorphism Restriction applies to the binding"
267 <> plural bindings
268 , text "for" <+> pp_bndrs ]
269 TcRnOrphanInstance inst
270 -> mkSimpleDecorated $
271 hsep [ text "Orphan instance:"
272 , pprInstanceHdr inst
273 ]
274 TcRnFunDepConflict unit_state sorted
275 -> let herald = text "Functional dependencies conflict between instance declarations:"
276 in mkSimpleDecorated $
277 pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted))
278 TcRnDupInstanceDecls unit_state sorted
279 -> let herald = text "Duplicate instance declarations:"
280 in mkSimpleDecorated $
281 pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted))
282 TcRnConflictingFamInstDecls sortedNE
283 -> let sorted = NE.toList sortedNE
284 in mkSimpleDecorated $
285 hang (text "Conflicting family instance declarations:")
286 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)
287 | fi <- sorted
288 , let ax = famInstAxiom fi ])
289 TcRnFamInstNotInjective rea fam_tc (eqn1 NE.:| rest_eqns)
290 -> let (herald, show_kinds) = case rea of
291 InjErrRhsBareTyVar tys ->
292 (injectivityErrorHerald $$
293 text "RHS of injective type family equation is a bare" <+>
294 text "type variable" $$
295 text "but these LHS type and kind patterns are not bare" <+>
296 text "variables:" <+> pprQuotedList tys, False)
297 InjErrRhsCannotBeATypeFam ->
298 (injectivityErrorHerald $$
299 text "RHS of injective type family equation cannot" <+>
300 text "be a type family:", False)
301 InjErrRhsOverlap ->
302 (text "Type family equation right-hand sides overlap; this violates" $$
303 text "the family's injectivity annotation:", False)
304 InjErrCannotInferFromRhs tvs has_kinds _ ->
305 let show_kinds = has_kinds == YesHasKinds
306 what = if show_kinds then text "Type/kind" else text "Type"
307 body = sep [ what <+> text "variable" <>
308 pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort)
309 , text "cannot be inferred from the right-hand side." ]
310 in (injectivityErrorHerald $$ body $$ text "In the type family equation:", show_kinds)
311
312 in mkSimpleDecorated $ pprWithExplicitKindsWhen show_kinds $
313 hang herald
314 2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns)))
315 TcRnBangOnUnliftedType ty
316 -> mkSimpleDecorated $
317 text "Strictness flag has no effect on unlifted type" <+> quotes (ppr ty)
318 TcRnMultipleDefaultDeclarations dup_things
319 -> mkSimpleDecorated $
320 hang (text "Multiple default declarations")
321 2 (vcat (map pp dup_things))
322 where
323 pp :: LDefaultDecl GhcRn -> SDoc
324 pp (L locn (DefaultDecl _ _))
325 = text "here was another default declaration" <+> ppr (locA locn)
326 TcRnBadDefaultType ty deflt_clss
327 -> mkSimpleDecorated $
328 hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of")
329 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss))
330 TcRnPatSynBundledWithNonDataCon
331 -> mkSimpleDecorated $
332 text "Pattern synonyms can be bundled only with datatypes."
333 TcRnPatSynBundledWithWrongType expected_res_ty res_ty
334 -> mkSimpleDecorated $
335 text "Pattern synonyms can only be bundled with matching type constructors"
336 $$ text "Couldn't match expected type of"
337 <+> quotes (ppr expected_res_ty)
338 <+> text "with actual type of"
339 <+> quotes (ppr res_ty)
340 TcRnDupeModuleExport mod
341 -> mkSimpleDecorated $
342 hsep [ text "Duplicate"
343 , quotes (text "Module" <+> ppr mod)
344 , text "in export list" ]
345 TcRnExportedModNotImported mod
346 -> mkSimpleDecorated
347 $ formatExportItemError
348 (text "module" <+> ppr mod)
349 "is not imported"
350 TcRnNullExportedModule mod
351 -> mkSimpleDecorated
352 $ formatExportItemError
353 (text "module" <+> ppr mod)
354 "exports nothing"
355 TcRnMissingExportList mod
356 -> mkSimpleDecorated
357 $ formatExportItemError
358 (text "module" <+> ppr mod)
359 "is missing an export list"
360 TcRnExportHiddenComponents export_item
361 -> mkSimpleDecorated
362 $ formatExportItemError
363 (ppr export_item)
364 "attempts to export constructors or class methods that are not visible here"
365 TcRnDuplicateExport child ie1 ie2
366 -> mkSimpleDecorated $
367 hsep [ quotes (ppr child)
368 , text "is exported by", quotes (ppr ie1)
369 , text "and", quotes (ppr ie2) ]
370 TcRnExportedParentChildMismatch parent_name ty_thing child parent_names
371 -> mkSimpleDecorated $
372 text "The type constructor" <+> quotes (ppr parent_name)
373 <+> text "is not the parent of the" <+> text what_is
374 <+> quotes thing <> char '.'
375 $$ text (capitalise what_is)
376 <> text "s can only be exported with their parent type constructor."
377 $$ (case parents of
378 [] -> empty
379 [_] -> text "Parent:"
380 _ -> text "Parents:") <+> fsep (punctuate comma parents)
381 where
382 pp_category :: TyThing -> String
383 pp_category (AnId i)
384 | isRecordSelector i = "record selector"
385 pp_category i = tyThingCategory i
386 what_is = pp_category ty_thing
387 thing = ppr child
388 parents = map ppr parent_names
389 TcRnConflictingExports occ child1 gre1 ie1 child2 gre2 ie2
390 -> mkSimpleDecorated $
391 vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon
392 , ppr_export child1 gre1 ie1
393 , ppr_export child2 gre2 ie2
394 ]
395 where
396 ppr_export child gre ie = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>
397 quotes (ppr_name child))
398 2 (pprNameProvenance gre))
399
400 -- DuplicateRecordFields means that nameOccName might be a mangled
401 -- $sel-prefixed thing, in which case show the correct OccName alone
402 -- (but otherwise show the Name so it will have a module qualifier)
403 ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl
404 | otherwise = ppr (flSelector fl)
405 ppr_name (NormalGreName name) = ppr name
406 TcRnAmbiguousField rupd parent_type
407 -> mkSimpleDecorated $
408 vcat [ text "The record update" <+> ppr rupd
409 <+> text "with type" <+> ppr parent_type
410 <+> text "is ambiguous."
411 , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC."
412 ]
413 TcRnMissingFields con fields
414 -> mkSimpleDecorated $ vcat [header, nest 2 rest]
415 where
416 rest | null fields = empty
417 | otherwise = vcat (fmap pprField fields)
418 header = text "Fields of" <+> quotes (ppr con) <+>
419 text "not initialised" <>
420 if null fields then empty else colon
421 TcRnFieldUpdateInvalidType prs
422 -> mkSimpleDecorated $
423 hang (text "Record update for insufficiently polymorphic field"
424 <> plural prs <> colon)
425 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
426 TcRnNoConstructorHasAllFields conflictingFields
427 -> mkSimpleDecorated $
428 hang (text "No constructor has all these fields:")
429 2 (pprQuotedList conflictingFields)
430 TcRnMixedSelectors data_name data_sels pat_name pat_syn_sels
431 -> mkSimpleDecorated $
432 text "Cannot use a mixture of pattern synonym and record selectors" $$
433 text "Record selectors defined by"
434 <+> quotes (ppr data_name)
435 <> colon
436 <+> pprWithCommas ppr data_sels $$
437 text "Pattern synonym selectors defined by"
438 <+> quotes (ppr pat_name)
439 <> colon
440 <+> pprWithCommas ppr pat_syn_sels
441 TcRnMissingStrictFields con fields
442 -> mkSimpleDecorated $ vcat [header, nest 2 rest]
443 where
444 rest | null fields = empty -- Happens for non-record constructors
445 -- with strict fields
446 | otherwise = vcat (fmap pprField fields)
447
448 header = text "Constructor" <+> quotes (ppr con) <+>
449 text "does not have the required strict field(s)" <>
450 if null fields then empty else colon
451 TcRnNoPossibleParentForFields rbinds
452 -> mkSimpleDecorated $
453 hang (text "No type has all these fields:")
454 2 (pprQuotedList fields)
455 where fields = map (hfbLHS . unLoc) rbinds
456 TcRnBadOverloadedRecordUpdate _rbinds
457 -> mkSimpleDecorated $
458 text "Record update is ambiguous, and requires a type signature"
459 TcRnStaticFormNotClosed name reason
460 -> mkSimpleDecorated $
461 quotes (ppr name)
462 <+> text "is used in a static form but it is not closed"
463 <+> text "because it"
464 $$ sep (causes reason)
465 where
466 causes :: NotClosedReason -> [SDoc]
467 causes NotLetBoundReason = [text "is not let-bound."]
468 causes (NotTypeClosed vs) =
469 [ text "has a non-closed type because it contains the"
470 , text "type variables:" <+>
471 pprVarSet vs (hsep . punctuate comma . map (quotes . ppr))
472 ]
473 causes (NotClosed n reason) =
474 let msg = text "uses" <+> quotes (ppr n) <+> text "which"
475 in case reason of
476 NotClosed _ _ -> msg : causes reason
477 _ -> let (xs0, xs1) = splitAt 1 $ causes reason
478 in fmap (msg <+>) xs0 ++ xs1
479 TcRnUselessTypeable
480 -> mkSimpleDecorated $
481 text "Deriving" <+> quotes (ppr typeableClassName) <+>
482 text "has no effect: all types now auto-derive Typeable"
483 TcRnDerivingDefaults cls
484 -> mkSimpleDecorated $ sep
485 [ text "Both DeriveAnyClass and"
486 <+> text "GeneralizedNewtypeDeriving are enabled"
487 , text "Defaulting to the DeriveAnyClass strategy"
488 <+> text "for instantiating" <+> ppr cls
489 ]
490 TcRnNonUnaryTypeclassConstraint ct
491 -> mkSimpleDecorated $
492 quotes (ppr ct)
493 <+> text "is not a unary constraint, as expected by a deriving clause"
494 TcRnPartialTypeSignatures _ theta
495 -> mkSimpleDecorated $
496 text "Found type wildcard" <+> quotes (char '_')
497 <+> text "standing for" <+> quotes (pprTheta theta)
498 TcRnCannotDeriveInstance cls cls_tys mb_strat newtype_deriving reason
499 -> mkSimpleDecorated $
500 derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving True reason
501 TcRnLazyGADTPattern
502 -> mkSimpleDecorated $
503 hang (text "An existential or GADT data constructor cannot be used")
504 2 (text "inside a lazy (~) pattern")
505 TcRnArrowProcGADTPattern
506 -> mkSimpleDecorated $
507 text "Proc patterns cannot use existential or GADT data constructors"
508
509 TcRnSpecialClassInst cls because_safeHaskell
510 -> mkSimpleDecorated $
511 text "Class" <+> quotes (ppr $ className cls)
512 <+> text "does not support user-specified instances"
513 <> safeHaskell_msg
514 where
515 safeHaskell_msg
516 | because_safeHaskell
517 = text " when Safe Haskell is enabled."
518 | otherwise
519 = dot
520
521 diagnosticReason = \case
522 TcRnUnknownMessage m
523 -> diagnosticReason m
524 TcRnTypeDoesNotHaveFixedRuntimeRep{}
525 -> ErrorWithoutFlag
526 TcRnMessageWithInfo _ msg_with_info
527 -> case msg_with_info of
528 TcRnMessageDetailed _ m -> diagnosticReason m
529 TcRnImplicitLift{}
530 -> WarningWithFlag Opt_WarnImplicitLift
531 TcRnUnusedPatternBinds{}
532 -> WarningWithFlag Opt_WarnUnusedPatternBinds
533 TcRnDodgyImports{}
534 -> WarningWithFlag Opt_WarnDodgyImports
535 TcRnDodgyExports{}
536 -> WarningWithFlag Opt_WarnDodgyExports
537 TcRnMissingImportList{}
538 -> WarningWithFlag Opt_WarnMissingImportList
539 TcRnUnsafeDueToPlugin{}
540 -> WarningWithoutFlag
541 TcRnModMissingRealSrcSpan{}
542 -> ErrorWithoutFlag
543 TcRnIdNotExportedFromModuleSig{}
544 -> ErrorWithoutFlag
545 TcRnIdNotExportedFromLocalSig{}
546 -> ErrorWithoutFlag
547 TcRnShadowedName{}
548 -> WarningWithFlag Opt_WarnNameShadowing
549 TcRnDuplicateWarningDecls{}
550 -> ErrorWithoutFlag
551 TcRnSimplifierTooManyIterations{}
552 -> ErrorWithoutFlag
553 TcRnIllegalPatSynDecl{}
554 -> ErrorWithoutFlag
555 TcRnLinearPatSyn{}
556 -> ErrorWithoutFlag
557 TcRnEmptyRecordUpdate
558 -> ErrorWithoutFlag
559 TcRnIllegalFieldPunning{}
560 -> ErrorWithoutFlag
561 TcRnIllegalWildcardsInRecord{}
562 -> ErrorWithoutFlag
563 TcRnDuplicateFieldName{}
564 -> ErrorWithoutFlag
565 TcRnIllegalViewPattern{}
566 -> ErrorWithoutFlag
567 TcRnCharLiteralOutOfRange{}
568 -> ErrorWithoutFlag
569 TcRnIllegalWildcardsInConstructor{}
570 -> ErrorWithoutFlag
571 TcRnIgnoringAnnotations{}
572 -> WarningWithoutFlag
573 TcRnAnnotationInSafeHaskell
574 -> ErrorWithoutFlag
575 TcRnInvalidTypeApplication{}
576 -> ErrorWithoutFlag
577 TcRnTagToEnumMissingValArg
578 -> ErrorWithoutFlag
579 TcRnTagToEnumUnspecifiedResTy{}
580 -> ErrorWithoutFlag
581 TcRnTagToEnumResTyNotAnEnum{}
582 -> ErrorWithoutFlag
583 TcRnArrowIfThenElsePredDependsOnResultTy
584 -> ErrorWithoutFlag
585 TcRnArrowCommandExpected{}
586 -> ErrorWithoutFlag
587 TcRnIllegalHsBootFileDecl
588 -> ErrorWithoutFlag
589 TcRnRecursivePatternSynonym{}
590 -> ErrorWithoutFlag
591 TcRnPartialTypeSigTyVarMismatch{}
592 -> ErrorWithoutFlag
593 TcRnPartialTypeSigBadQuantifier{}
594 -> ErrorWithoutFlag
595 TcRnPolymorphicBinderMissingSig{}
596 -> WarningWithFlag Opt_WarnMissingLocalSignatures
597 TcRnOverloadedSig{}
598 -> ErrorWithoutFlag
599 TcRnTupleConstraintInst{}
600 -> ErrorWithoutFlag
601 TcRnAbstractClassInst{}
602 -> ErrorWithoutFlag
603 TcRnNoClassInstHead{}
604 -> ErrorWithoutFlag
605 TcRnUserTypeError{}
606 -> ErrorWithoutFlag
607 TcRnConstraintInKind{}
608 -> ErrorWithoutFlag
609 TcRnUnboxedTupleTypeFuncArg{}
610 -> ErrorWithoutFlag
611 TcRnLinearFuncInKind{}
612 -> ErrorWithoutFlag
613 TcRnForAllEscapeError{}
614 -> ErrorWithoutFlag
615 TcRnVDQInTermType{}
616 -> ErrorWithoutFlag
617 TcRnIllegalEqualConstraints{}
618 -> ErrorWithoutFlag
619 TcRnBadQuantPredHead{}
620 -> ErrorWithoutFlag
621 TcRnIllegalTupleConstraint{}
622 -> ErrorWithoutFlag
623 TcRnNonTypeVarArgInConstraint{}
624 -> ErrorWithoutFlag
625 TcRnIllegalImplicitParam{}
626 -> ErrorWithoutFlag
627 TcRnIllegalConstraintSynonymOfKind{}
628 -> ErrorWithoutFlag
629 TcRnIllegalClassInst{}
630 -> ErrorWithoutFlag
631 TcRnOversaturatedVisibleKindArg{}
632 -> ErrorWithoutFlag
633 TcRnBadAssociatedType{}
634 -> ErrorWithoutFlag
635 TcRnForAllRankErr{}
636 -> ErrorWithoutFlag
637 TcRnMonomorphicBindings{}
638 -> WarningWithFlag Opt_WarnMonomorphism
639 TcRnOrphanInstance{}
640 -> WarningWithFlag Opt_WarnOrphans
641 TcRnFunDepConflict{}
642 -> ErrorWithoutFlag
643 TcRnDupInstanceDecls{}
644 -> ErrorWithoutFlag
645 TcRnConflictingFamInstDecls{}
646 -> ErrorWithoutFlag
647 TcRnFamInstNotInjective{}
648 -> ErrorWithoutFlag
649 TcRnBangOnUnliftedType{}
650 -> WarningWithFlag Opt_WarnRedundantStrictnessFlags
651 TcRnMultipleDefaultDeclarations{}
652 -> ErrorWithoutFlag
653 TcRnBadDefaultType{}
654 -> ErrorWithoutFlag
655 TcRnPatSynBundledWithNonDataCon{}
656 -> ErrorWithoutFlag
657 TcRnPatSynBundledWithWrongType{}
658 -> ErrorWithoutFlag
659 TcRnDupeModuleExport{}
660 -> WarningWithFlag Opt_WarnDuplicateExports
661 TcRnExportedModNotImported{}
662 -> ErrorWithoutFlag
663 TcRnNullExportedModule{}
664 -> WarningWithFlag Opt_WarnDodgyExports
665 TcRnMissingExportList{}
666 -> WarningWithFlag Opt_WarnMissingExportList
667 TcRnExportHiddenComponents{}
668 -> ErrorWithoutFlag
669 TcRnDuplicateExport{}
670 -> WarningWithFlag Opt_WarnDuplicateExports
671 TcRnExportedParentChildMismatch{}
672 -> ErrorWithoutFlag
673 TcRnConflictingExports{}
674 -> ErrorWithoutFlag
675 TcRnAmbiguousField{}
676 -> WarningWithFlag Opt_WarnAmbiguousFields
677 TcRnMissingFields{}
678 -> WarningWithFlag Opt_WarnMissingFields
679 TcRnFieldUpdateInvalidType{}
680 -> ErrorWithoutFlag
681 TcRnNoConstructorHasAllFields{}
682 -> ErrorWithoutFlag
683 TcRnMixedSelectors{}
684 -> ErrorWithoutFlag
685 TcRnMissingStrictFields{}
686 -> ErrorWithoutFlag
687 TcRnNoPossibleParentForFields{}
688 -> ErrorWithoutFlag
689 TcRnBadOverloadedRecordUpdate{}
690 -> ErrorWithoutFlag
691 TcRnStaticFormNotClosed{}
692 -> ErrorWithoutFlag
693 TcRnUselessTypeable
694 -> WarningWithFlag Opt_WarnDerivingTypeable
695 TcRnDerivingDefaults{}
696 -> WarningWithFlag Opt_WarnDerivingDefaults
697 TcRnNonUnaryTypeclassConstraint{}
698 -> ErrorWithoutFlag
699 TcRnPartialTypeSignatures{}
700 -> WarningWithFlag Opt_WarnPartialTypeSignatures
701 TcRnCannotDeriveInstance _ _ _ _ rea
702 -> case rea of
703 DerivErrNotWellKinded{} -> ErrorWithoutFlag
704 DerivErrSafeHaskellGenericInst -> ErrorWithoutFlag
705 DerivErrDerivingViaWrongKind{} -> ErrorWithoutFlag
706 DerivErrNoEtaReduce{} -> ErrorWithoutFlag
707 DerivErrBootFileFound -> ErrorWithoutFlag
708 DerivErrDataConsNotAllInScope{} -> ErrorWithoutFlag
709 DerivErrGNDUsedOnData -> ErrorWithoutFlag
710 DerivErrNullaryClasses -> ErrorWithoutFlag
711 DerivErrLastArgMustBeApp -> ErrorWithoutFlag
712 DerivErrNoFamilyInstance{} -> ErrorWithoutFlag
713 DerivErrNotStockDeriveable{} -> ErrorWithoutFlag
714 DerivErrHasAssociatedDatatypes{} -> ErrorWithoutFlag
715 DerivErrNewtypeNonDeriveableClass -> ErrorWithoutFlag
716 DerivErrCannotEtaReduceEnough{} -> ErrorWithoutFlag
717 DerivErrOnlyAnyClassDeriveable{} -> ErrorWithoutFlag
718 DerivErrNotDeriveable{} -> ErrorWithoutFlag
719 DerivErrNotAClass{} -> ErrorWithoutFlag
720 DerivErrNoConstructors{} -> ErrorWithoutFlag
721 DerivErrLangExtRequired{} -> ErrorWithoutFlag
722 DerivErrDunnoHowToDeriveForType{} -> ErrorWithoutFlag
723 DerivErrMustBeEnumType{} -> ErrorWithoutFlag
724 DerivErrMustHaveExactlyOneConstructor{} -> ErrorWithoutFlag
725 DerivErrMustHaveSomeParameters{} -> ErrorWithoutFlag
726 DerivErrMustNotHaveClassContext{} -> ErrorWithoutFlag
727 DerivErrBadConstructor{} -> ErrorWithoutFlag
728 DerivErrGenerics{} -> ErrorWithoutFlag
729 DerivErrEnumOrProduct{} -> ErrorWithoutFlag
730 TcRnLazyGADTPattern
731 -> ErrorWithoutFlag
732 TcRnArrowProcGADTPattern
733 -> ErrorWithoutFlag
734 TcRnSpecialClassInst {}
735 -> ErrorWithoutFlag
736
737 diagnosticHints = \case
738 TcRnUnknownMessage m
739 -> diagnosticHints m
740 TcRnTypeDoesNotHaveFixedRuntimeRep{}
741 -> noHints
742 TcRnMessageWithInfo _ msg_with_info
743 -> case msg_with_info of
744 TcRnMessageDetailed _ m -> diagnosticHints m
745 TcRnImplicitLift{}
746 -> noHints
747 TcRnUnusedPatternBinds{}
748 -> noHints
749 TcRnDodgyImports{}
750 -> noHints
751 TcRnDodgyExports{}
752 -> noHints
753 TcRnMissingImportList{}
754 -> noHints
755 TcRnUnsafeDueToPlugin{}
756 -> noHints
757 TcRnModMissingRealSrcSpan{}
758 -> noHints
759 TcRnIdNotExportedFromModuleSig name mod
760 -> [SuggestAddToHSigExportList name $ Just mod]
761 TcRnIdNotExportedFromLocalSig name
762 -> [SuggestAddToHSigExportList name Nothing]
763 TcRnShadowedName{}
764 -> noHints
765 TcRnDuplicateWarningDecls{}
766 -> noHints
767 TcRnSimplifierTooManyIterations{}
768 -> [SuggestIncreaseSimplifierIterations]
769 TcRnIllegalPatSynDecl{}
770 -> noHints
771 TcRnLinearPatSyn{}
772 -> noHints
773 TcRnEmptyRecordUpdate{}
774 -> noHints
775 TcRnIllegalFieldPunning{}
776 -> [suggestExtension LangExt.NamedFieldPuns]
777 TcRnIllegalWildcardsInRecord{}
778 -> [suggestExtension LangExt.RecordWildCards]
779 TcRnDuplicateFieldName{}
780 -> noHints
781 TcRnIllegalViewPattern{}
782 -> [suggestExtension LangExt.ViewPatterns]
783 TcRnCharLiteralOutOfRange{}
784 -> noHints
785 TcRnIllegalWildcardsInConstructor{}
786 -> noHints
787 TcRnIgnoringAnnotations{}
788 -> noHints
789 TcRnAnnotationInSafeHaskell
790 -> noHints
791 TcRnInvalidTypeApplication{}
792 -> noHints
793 TcRnTagToEnumMissingValArg
794 -> noHints
795 TcRnTagToEnumUnspecifiedResTy{}
796 -> noHints
797 TcRnTagToEnumResTyNotAnEnum{}
798 -> noHints
799 TcRnArrowIfThenElsePredDependsOnResultTy
800 -> noHints
801 TcRnArrowCommandExpected{}
802 -> noHints
803 TcRnIllegalHsBootFileDecl
804 -> noHints
805 TcRnRecursivePatternSynonym{}
806 -> noHints
807 TcRnPartialTypeSigTyVarMismatch{}
808 -> noHints
809 TcRnPartialTypeSigBadQuantifier{}
810 -> noHints
811 TcRnPolymorphicBinderMissingSig{}
812 -> noHints
813 TcRnOverloadedSig{}
814 -> noHints
815 TcRnTupleConstraintInst{}
816 -> noHints
817 TcRnAbstractClassInst{}
818 -> noHints
819 TcRnNoClassInstHead{}
820 -> noHints
821 TcRnUserTypeError{}
822 -> noHints
823 TcRnConstraintInKind{}
824 -> noHints
825 TcRnUnboxedTupleTypeFuncArg{}
826 -> [suggestExtension LangExt.UnboxedTuples]
827 TcRnLinearFuncInKind{}
828 -> noHints
829 TcRnForAllEscapeError{}
830 -> noHints
831 TcRnVDQInTermType{}
832 -> noHints
833 TcRnIllegalEqualConstraints{}
834 -> [suggestAnyExtension [LangExt.GADTs, LangExt.TypeFamilies]]
835 TcRnBadQuantPredHead{}
836 -> noHints
837 TcRnIllegalTupleConstraint{}
838 -> [suggestExtension LangExt.ConstraintKinds]
839 TcRnNonTypeVarArgInConstraint{}
840 -> [suggestExtension LangExt.FlexibleContexts]
841 TcRnIllegalImplicitParam{}
842 -> noHints
843 TcRnIllegalConstraintSynonymOfKind{}
844 -> [suggestExtension LangExt.ConstraintKinds]
845 TcRnIllegalClassInst{}
846 -> noHints
847 TcRnOversaturatedVisibleKindArg{}
848 -> noHints
849 TcRnBadAssociatedType{}
850 -> noHints
851 TcRnForAllRankErr rank _
852 -> case rank of
853 LimitedRank{} -> [suggestExtension LangExt.RankNTypes]
854 MonoTypeRankZero -> [suggestExtension LangExt.RankNTypes]
855 MonoTypeTyConArg -> [suggestExtension LangExt.ImpredicativeTypes]
856 MonoTypeSynArg -> [suggestExtension LangExt.LiberalTypeSynonyms]
857 MonoTypeConstraint -> [suggestExtension LangExt.QuantifiedConstraints]
858 _ -> noHints
859 TcRnMonomorphicBindings bindings
860 -> case bindings of
861 [] -> noHints
862 (x:xs) -> [SuggestAddTypeSignatures $ NamedBindings (x NE.:| xs)]
863 TcRnOrphanInstance{}
864 -> [SuggestFixOrphanInstance]
865 TcRnFunDepConflict{}
866 -> noHints
867 TcRnDupInstanceDecls{}
868 -> noHints
869 TcRnConflictingFamInstDecls{}
870 -> noHints
871 TcRnFamInstNotInjective rea _ _
872 -> case rea of
873 InjErrRhsBareTyVar{} -> noHints
874 InjErrRhsCannotBeATypeFam -> noHints
875 InjErrRhsOverlap -> noHints
876 InjErrCannotInferFromRhs _ _ suggestUndInst
877 | YesSuggestUndecidableInstaces <- suggestUndInst
878 -> [suggestExtension LangExt.UndecidableInstances]
879 | otherwise
880 -> noHints
881 TcRnBangOnUnliftedType{}
882 -> noHints
883 TcRnMultipleDefaultDeclarations{}
884 -> noHints
885 TcRnBadDefaultType{}
886 -> noHints
887 TcRnPatSynBundledWithNonDataCon{}
888 -> noHints
889 TcRnPatSynBundledWithWrongType{}
890 -> noHints
891 TcRnDupeModuleExport{}
892 -> noHints
893 TcRnExportedModNotImported{}
894 -> noHints
895 TcRnNullExportedModule{}
896 -> noHints
897 TcRnMissingExportList{}
898 -> noHints
899 TcRnExportHiddenComponents{}
900 -> noHints
901 TcRnDuplicateExport{}
902 -> noHints
903 TcRnExportedParentChildMismatch{}
904 -> noHints
905 TcRnConflictingExports{}
906 -> noHints
907 TcRnAmbiguousField{}
908 -> noHints
909 TcRnMissingFields{}
910 -> noHints
911 TcRnFieldUpdateInvalidType{}
912 -> noHints
913 TcRnNoConstructorHasAllFields{}
914 -> noHints
915 TcRnMixedSelectors{}
916 -> noHints
917 TcRnMissingStrictFields{}
918 -> noHints
919 TcRnNoPossibleParentForFields{}
920 -> noHints
921 TcRnBadOverloadedRecordUpdate{}
922 -> noHints
923 TcRnStaticFormNotClosed{}
924 -> noHints
925 TcRnUselessTypeable
926 -> noHints
927 TcRnDerivingDefaults{}
928 -> [useDerivingStrategies]
929 TcRnNonUnaryTypeclassConstraint{}
930 -> noHints
931 TcRnPartialTypeSignatures suggestParSig _
932 -> case suggestParSig of
933 YesSuggestPartialTypeSignatures
934 -> let info = text "to use the inferred type"
935 in [suggestExtensionWithInfo info LangExt.PartialTypeSignatures]
936 NoSuggestPartialTypeSignatures
937 -> noHints
938 TcRnCannotDeriveInstance cls _ _ newtype_deriving rea
939 -> deriveInstanceErrReasonHints cls newtype_deriving rea
940 TcRnLazyGADTPattern
941 -> noHints
942 TcRnArrowProcGADTPattern
943 -> noHints
944 TcRnSpecialClassInst {}
945 -> noHints
946
947 deriveInstanceErrReasonHints :: Class
948 -> UsingGeneralizedNewtypeDeriving
949 -> DeriveInstanceErrReason
950 -> [GhcHint]
951 deriveInstanceErrReasonHints cls newtype_deriving = \case
952 DerivErrNotWellKinded _ _ n_args_to_keep
953 | cls `hasKey` gen1ClassKey && n_args_to_keep >= 0
954 -> [suggestExtension LangExt.PolyKinds]
955 | otherwise
956 -> noHints
957 DerivErrSafeHaskellGenericInst -> noHints
958 DerivErrDerivingViaWrongKind{} -> noHints
959 DerivErrNoEtaReduce{} -> noHints
960 DerivErrBootFileFound -> noHints
961 DerivErrDataConsNotAllInScope{} -> noHints
962 DerivErrGNDUsedOnData -> noHints
963 DerivErrNullaryClasses -> noHints
964 DerivErrLastArgMustBeApp -> noHints
965 DerivErrNoFamilyInstance{} -> noHints
966 DerivErrNotStockDeriveable deriveAnyClassEnabled
967 | deriveAnyClassEnabled == NoDeriveAnyClassEnabled
968 -> [suggestExtension LangExt.DeriveAnyClass]
969 | otherwise
970 -> noHints
971 DerivErrHasAssociatedDatatypes{}
972 -> noHints
973 DerivErrNewtypeNonDeriveableClass
974 | newtype_deriving == NoGeneralizedNewtypeDeriving
975 -> [useGND]
976 | otherwise
977 -> noHints
978 DerivErrCannotEtaReduceEnough{}
979 | newtype_deriving == NoGeneralizedNewtypeDeriving
980 -> [useGND]
981 | otherwise
982 -> noHints
983 DerivErrOnlyAnyClassDeriveable _ deriveAnyClassEnabled
984 | deriveAnyClassEnabled == NoDeriveAnyClassEnabled
985 -> [suggestExtension LangExt.DeriveAnyClass]
986 | otherwise
987 -> noHints
988 DerivErrNotDeriveable deriveAnyClassEnabled
989 | deriveAnyClassEnabled == NoDeriveAnyClassEnabled
990 -> [suggestExtension LangExt.DeriveAnyClass]
991 | otherwise
992 -> noHints
993 DerivErrNotAClass{}
994 -> noHints
995 DerivErrNoConstructors{}
996 -> let info = text "to enable deriving for empty data types"
997 in [useExtensionInOrderTo info LangExt.EmptyDataDeriving]
998 DerivErrLangExtRequired{}
999 -- This is a slightly weird corner case of GHC: we are failing
1000 -- to derive a typeclass instance because a particular 'Extension'
1001 -- is not enabled (and so we report in the main error), but here
1002 -- we don't want to /repeat/ to enable the extension in the hint.
1003 -> noHints
1004 DerivErrDunnoHowToDeriveForType{}
1005 -> noHints
1006 DerivErrMustBeEnumType rep_tc
1007 -- We want to suggest GND only if this /is/ a newtype.
1008 | newtype_deriving == NoGeneralizedNewtypeDeriving && isNewTyCon rep_tc
1009 -> [useGND]
1010 | otherwise
1011 -> noHints
1012 DerivErrMustHaveExactlyOneConstructor{}
1013 -> noHints
1014 DerivErrMustHaveSomeParameters{}
1015 -> noHints
1016 DerivErrMustNotHaveClassContext{}
1017 -> noHints
1018 DerivErrBadConstructor wcard _
1019 -> case wcard of
1020 Nothing -> noHints
1021 Just YesHasWildcard -> [SuggestFillInWildcardConstraint]
1022 Just NoHasWildcard -> [SuggestAddStandaloneDerivation]
1023 DerivErrGenerics{}
1024 -> noHints
1025 DerivErrEnumOrProduct{}
1026 -> noHints
1027
1028 messageWithInfoDiagnosticMessage :: UnitState
1029 -> ErrInfo
1030 -> DecoratedSDoc
1031 -> DecoratedSDoc
1032 messageWithInfoDiagnosticMessage unit_state ErrInfo{..} important =
1033 let err_info' = map (pprWithUnitState unit_state) [errInfoContext, errInfoSupplementary]
1034 in (mapDecoratedSDoc (pprWithUnitState unit_state) important) `unionDecoratedSDoc`
1035 mkDecorated err_info'
1036
1037 dodgy_msg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc
1038 dodgy_msg kind tc ie
1039 = sep [ text "The" <+> kind <+> text "item"
1040 <+> quotes (ppr ie)
1041 <+> text "suggests that",
1042 quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",
1043 text "but it has none" ]
1044
1045 dodgy_msg_insert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)
1046 dodgy_msg_insert tc = IEThingAll noAnn ii
1047 where
1048 ii :: LIEWrappedName (IdP (GhcPass p))
1049 ii = noLocA (IEName $ noLocA tc)
1050
1051 pprTypeDoesNotHaveFixedRuntimeRep :: Type -> FixedRuntimeRepProvenance -> SDoc
1052 pprTypeDoesNotHaveFixedRuntimeRep ty prov =
1053 let what = pprFixedRuntimeRepProvenance prov
1054 in text "The" <+> what <+> text "does not have a fixed runtime representation:"
1055 $$ format_frr_err ty
1056
1057 format_frr_err :: Type -- ^ the type which doesn't have a fixed runtime representation
1058 -> SDoc
1059 format_frr_err ty
1060 = (bullet <+> ppr tidy_ty <+> dcolon <+> ppr tidy_ki)
1061 where
1062 (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty
1063 tidy_ki = tidyType tidy_env (tcTypeKind ty)
1064
1065 pprField :: (FieldLabelString, TcType) -> SDoc
1066 pprField (f,ty) = ppr f <+> dcolon <+> ppr ty
1067
1068 pprRecordFieldPart :: RecordFieldPart -> SDoc
1069 pprRecordFieldPart = \case
1070 RecordFieldConstructor{} -> text "construction"
1071 RecordFieldPattern{} -> text "pattern"
1072 RecordFieldUpdate -> text "update"
1073
1074 pprBindings :: [Name] -> SDoc
1075 pprBindings = pprWithCommas (quotes . ppr)
1076
1077 injectivityErrorHerald :: SDoc
1078 injectivityErrorHerald =
1079 text "Type family equation violates the family's injectivity annotation."
1080
1081 formatExportItemError :: SDoc -> String -> SDoc
1082 formatExportItemError exportedThing reason =
1083 hsep [ text "The export item"
1084 , quotes exportedThing
1085 , text reason ]
1086
1087 useDerivingStrategies :: GhcHint
1088 useDerivingStrategies =
1089 useExtensionInOrderTo (text "to pick a different strategy") LangExt.DerivingStrategies
1090
1091 useGND :: GhcHint
1092 useGND = let info = text "for GHC's" <+> text "newtype-deriving extension"
1093 in suggestExtensionWithInfo info LangExt.GeneralizedNewtypeDeriving
1094
1095 cannotMakeDerivedInstanceHerald :: Class
1096 -> [Type]
1097 -> Maybe (DerivStrategy GhcTc)
1098 -> UsingGeneralizedNewtypeDeriving
1099 -> Bool -- ^ If False, only prints the why.
1100 -> SDoc
1101 -> SDoc
1102 cannotMakeDerivedInstanceHerald cls cls_args mb_strat newtype_deriving pprHerald why =
1103 if pprHerald
1104 then sep [(hang (text "Can't make a derived instance of")
1105 2 (quotes (ppr pred) <+> via_mechanism)
1106 $$ nest 2 extra) <> colon,
1107 nest 2 why]
1108 else why
1109 where
1110 strat_used = isJust mb_strat
1111 extra | not strat_used, (newtype_deriving == YesGeneralizedNewtypeDeriving)
1112 = text "(even with cunning GeneralizedNewtypeDeriving)"
1113 | otherwise = empty
1114 pred = mkClassPred cls cls_args
1115 via_mechanism | strat_used
1116 , Just strat <- mb_strat
1117 = text "with the" <+> (derivStrategyName strat) <+> text "strategy"
1118 | otherwise
1119 = empty
1120
1121 badCon :: DataCon -> SDoc -> SDoc
1122 badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg
1123
1124 derivErrDiagnosticMessage :: Class
1125 -> [Type]
1126 -> Maybe (DerivStrategy GhcTc)
1127 -> UsingGeneralizedNewtypeDeriving
1128 -> Bool -- If True, includes the herald \"can't make a derived..\"
1129 -> DeriveInstanceErrReason
1130 -> SDoc
1131 derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald = \case
1132 DerivErrNotWellKinded tc cls_kind _
1133 -> sep [ hang (text "Cannot derive well-kinded instance of form"
1134 <+> quotes (pprClassPred cls cls_tys
1135 <+> parens (ppr tc <+> text "...")))
1136 2 empty
1137 , nest 2 (text "Class" <+> quotes (ppr cls)
1138 <+> text "expects an argument of kind"
1139 <+> quotes (pprKind cls_kind))
1140 ]
1141 DerivErrSafeHaskellGenericInst
1142 -> text "Generic instances can only be derived in"
1143 <+> text "Safe Haskell using the stock strategy."
1144 DerivErrDerivingViaWrongKind cls_kind via_ty via_kind
1145 -> hang (text "Cannot derive instance via" <+> quotes (pprType via_ty))
1146 2 (text "Class" <+> quotes (ppr cls)
1147 <+> text "expects an argument of kind"
1148 <+> quotes (pprKind cls_kind) <> char ','
1149 $+$ text "but" <+> quotes (pprType via_ty)
1150 <+> text "has kind" <+> quotes (pprKind via_kind))
1151 DerivErrNoEtaReduce inst_ty
1152 -> sep [text "Cannot eta-reduce to an instance of form",
1153 nest 2 (text "instance (...) =>"
1154 <+> pprClassPred cls (cls_tys ++ [inst_ty]))]
1155 DerivErrBootFileFound
1156 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1157 (text "Cannot derive instances in hs-boot files"
1158 $+$ text "Write an instance declaration instead")
1159 DerivErrDataConsNotAllInScope tc
1160 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1161 (hang (text "The data constructors of" <+> quotes (ppr tc) <+> text "are not all in scope")
1162 2 (text "so you cannot derive an instance for it"))
1163 DerivErrGNDUsedOnData
1164 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1165 (text "GeneralizedNewtypeDeriving cannot be used on non-newtypes")
1166 DerivErrNullaryClasses
1167 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1168 (text "Cannot derive instances for nullary classes")
1169 DerivErrLastArgMustBeApp
1170 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1171 ( text "The last argument of the instance must be a"
1172 <+> text "data or newtype application")
1173 DerivErrNoFamilyInstance tc tc_args
1174 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1175 (text "No family instance for" <+> quotes (pprTypeApp tc tc_args))
1176 DerivErrNotStockDeriveable _
1177 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1178 (quotes (ppr cls) <+> text "is not a stock derivable class (Eq, Show, etc.)")
1179 DerivErrHasAssociatedDatatypes hasAdfs at_last_cls_tv_in_kinds at_without_last_cls_tv
1180 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1181 $ vcat [ ppWhen (hasAdfs == YesHasAdfs) adfs_msg
1182 , case at_without_last_cls_tv of
1183 YesAssociatedTyNotParamOverLastTyVar tc -> at_without_last_cls_tv_msg tc
1184 NoAssociatedTyNotParamOverLastTyVar -> empty
1185 , case at_last_cls_tv_in_kinds of
1186 YesAssocTyLastVarInKind tc -> at_last_cls_tv_in_kinds_msg tc
1187 NoAssocTyLastVarInKind -> empty
1188 ]
1189 where
1190
1191 adfs_msg = text "the class has associated data types"
1192
1193 at_without_last_cls_tv_msg at_tc = hang
1194 (text "the associated type" <+> quotes (ppr at_tc)
1195 <+> text "is not parameterized over the last type variable")
1196 2 (text "of the class" <+> quotes (ppr cls))
1197
1198 at_last_cls_tv_in_kinds_msg at_tc = hang
1199 (text "the associated type" <+> quotes (ppr at_tc)
1200 <+> text "contains the last type variable")
1201 2 (text "of the class" <+> quotes (ppr cls)
1202 <+> text "in a kind, which is not (yet) allowed")
1203 DerivErrNewtypeNonDeriveableClass
1204 -> derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald (DerivErrNotStockDeriveable NoDeriveAnyClassEnabled)
1205 DerivErrCannotEtaReduceEnough eta_ok
1206 -> let cant_derive_err = ppUnless eta_ok eta_msg
1207 eta_msg = text "cannot eta-reduce the representation type enough"
1208 in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1209 cant_derive_err
1210 DerivErrOnlyAnyClassDeriveable tc _
1211 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1212 (quotes (ppr tc) <+> text "is a type class,"
1213 <+> text "and can only have a derived instance"
1214 $+$ text "if DeriveAnyClass is enabled")
1215 DerivErrNotDeriveable _
1216 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald empty
1217 DerivErrNotAClass predType
1218 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1219 (quotes (ppr predType) <+> text "is not a class")
1220 DerivErrNoConstructors rep_tc
1221 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1222 (quotes (pprSourceTyCon rep_tc) <+> text "must have at least one data constructor")
1223 DerivErrLangExtRequired ext
1224 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1225 (text "You need " <> ppr ext
1226 <+> text "to derive an instance for this class")
1227 DerivErrDunnoHowToDeriveForType ty
1228 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1229 (hang (text "Don't know how to derive" <+> quotes (ppr cls))
1230 2 (text "for type" <+> quotes (ppr ty)))
1231 DerivErrMustBeEnumType rep_tc
1232 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1233 (sep [ quotes (pprSourceTyCon rep_tc) <+>
1234 text "must be an enumeration type"
1235 , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ])
1236
1237 DerivErrMustHaveExactlyOneConstructor rep_tc
1238 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1239 (quotes (pprSourceTyCon rep_tc) <+> text "must have precisely one constructor")
1240 DerivErrMustHaveSomeParameters rep_tc
1241 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1242 (text "Data type" <+> quotes (ppr rep_tc) <+> text "must have some type parameters")
1243 DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta
1244 -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1245 (text "Data type" <+> quotes (ppr rep_tc)
1246 <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta)
1247 DerivErrBadConstructor _ reasons
1248 -> let why = vcat $ map renderReason reasons
1249 in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why
1250 where
1251 renderReason = \case
1252 DerivErrBadConExistential con
1253 -> badCon con $ text "must be truly polymorphic in the last argument of the data type"
1254 DerivErrBadConCovariant con
1255 -> badCon con $ text "must not use the type variable in a function argument"
1256 DerivErrBadConFunTypes con
1257 -> badCon con $ text "must not contain function types"
1258 DerivErrBadConWrongArg con
1259 -> badCon con $ text "must use the type variable only as the last argument of a data type"
1260 DerivErrBadConIsGADT con
1261 -> badCon con $ text "is a GADT"
1262 DerivErrBadConHasExistentials con
1263 -> badCon con $ text "has existential type variables in its type"
1264 DerivErrBadConHasConstraints con
1265 -> badCon con $ text "has constraints in its type"
1266 DerivErrBadConHasHigherRankType con
1267 -> badCon con $ text "has a higher-rank type"
1268 DerivErrGenerics reasons
1269 -> let why = vcat $ map renderReason reasons
1270 in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why
1271 where
1272 renderReason = \case
1273 DerivErrGenericsMustNotHaveDatatypeContext tc_name
1274 -> ppr tc_name <+> text "must not have a datatype context"
1275 DerivErrGenericsMustNotHaveExoticArgs dc
1276 -> ppr dc <+> text "must not have exotic unlifted or polymorphic arguments"
1277 DerivErrGenericsMustBeVanillaDataCon dc
1278 -> ppr dc <+> text "must be a vanilla data constructor"
1279 DerivErrGenericsMustHaveSomeTypeParams rep_tc
1280 -> text "Data type" <+> quotes (ppr rep_tc)
1281 <+> text "must have some type parameters"
1282 DerivErrGenericsMustNotHaveExistentials con
1283 -> badCon con $ text "must not have existential arguments"
1284 DerivErrGenericsWrongArgKind con
1285 -> badCon con $
1286 text "applies a type to an argument involving the last parameter"
1287 $$ text "but the applied type is not of kind * -> *"
1288 DerivErrEnumOrProduct this that
1289 -> let ppr1 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False this
1290 ppr2 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False that
1291 in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
1292 (ppr1 $$ text " or" $$ ppr2)