diff options
author | Aaron Allen <aaron@flipstone.com> | 2021-08-05 21:13:43 -0500 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-09-22 08:23:45 -0400 |
commit | bb37026e3547af569db6dce021b59f4d0ac70910 (patch) | |
tree | 472633d4623fa91244f5104b15d78bb696c8146c /compiler | |
parent | 104bf6bfa0d52f6b51992df98dcc17232fc7b75d (diff) | |
download | haskell-bb37026e3547af569db6dce021b59f4d0ac70910.tar.gz |
Convert Diagnostics in GHC.Tc.Gen.* (Part 2)
Converts diagnostics in: (#20116)
- GHC.Tc.Gen.Default
- GHC.Tc.Gen.Export
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 148 | ||||
-rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 170 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Default.hs | 16 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Export.hs | 110 |
4 files changed, 330 insertions, 114 deletions
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 027c888972..841f0aa713 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -21,14 +21,18 @@ import GHC.Tc.Errors.Types import GHC.Tc.Types.Rank (Rank(..)) import GHC.Tc.Utils.TcType (tcSplitForAllTyVars) import GHC.Types.Error +import GHC.Types.FieldLabel (flIsOverloaded, flSelector) +import GHC.Types.Id (isRecordSelector) import GHC.Types.Name -import GHC.Types.Name.Reader (pprNameProvenance) +import GHC.Types.Name.Reader (GreName(..), pprNameProvenance) import GHC.Types.SrcLoc (GenLocated(..)) +import GHC.Types.TyThing import GHC.Types.Var.Env (emptyTidyEnv) import GHC.Types.Var.Set (pprVarSet, pluralVarSet) import GHC.Driver.Flags import GHC.Hs import GHC.Utils.Outputable +import GHC.Utils.Misc (capitalise) import GHC.Unit.State (pprWithUnitState, UnitState) import qualified GHC.LanguageExtensions as LangExt import qualified Data.List.NonEmpty as NE @@ -306,6 +310,94 @@ instance Diagnostic TcRnMessage where TcRnBangOnUnliftedType ty -> mkSimpleDecorated $ text "Strictness flag has no effect on unlifted type" <+> quotes (ppr ty) + TcRnMultipleDefaultDeclarations dup_things + -> mkSimpleDecorated $ + hang (text "Multiple default declarations") + 2 (vcat (map pp dup_things)) + where + pp :: LDefaultDecl GhcRn -> SDoc + pp (L locn (DefaultDecl _ _)) + = text "here was another default declaration" <+> ppr (locA locn) + TcRnBadDefaultType ty deflt_clss + -> mkSimpleDecorated $ + hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of") + 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss)) + TcRnPatSynBundledWithNonDataCon + -> mkSimpleDecorated $ + text "Pattern synonyms can be bundled only with datatypes." + TcRnPatSynBundledWithWrongType expected_res_ty res_ty + -> mkSimpleDecorated $ + text "Pattern synonyms can only be bundled with matching type constructors" + $$ text "Couldn't match expected type of" + <+> quotes (ppr expected_res_ty) + <+> text "with actual type of" + <+> quotes (ppr res_ty) + TcRnDupeModuleExport mod + -> mkSimpleDecorated $ + hsep [ text "Duplicate" + , quotes (text "Module" <+> ppr mod) + , text "in export list" ] + TcRnExportedModNotImported mod + -> mkSimpleDecorated + $ formatExportItemError + (text "module" <+> ppr mod) + "is not imported" + TcRnNullExportedModule mod + -> mkSimpleDecorated + $ formatExportItemError + (text "module" <+> ppr mod) + "exports nothing" + TcRnMissingExportList mod + -> mkSimpleDecorated + $ formatExportItemError + (text "module" <+> ppr mod) + "is missing an export list" + TcRnExportHiddenComponents export_item + -> mkSimpleDecorated + $ formatExportItemError + (ppr export_item) + "attempts to export constructors or class methods that are not visible here" + TcRnDuplicateExport child ie1 ie2 + -> mkSimpleDecorated $ + hsep [ quotes (ppr child) + , text "is exported by", quotes (ppr ie1) + , text "and", quotes (ppr ie2) ] + TcRnExportedParentChildMismatch parent_name ty_thing child parent_names + -> mkSimpleDecorated $ + text "The type constructor" <+> quotes (ppr parent_name) + <+> text "is not the parent of the" <+> text what_is + <+> quotes thing <> char '.' + $$ text (capitalise what_is) + <> text "s can only be exported with their parent type constructor." + $$ (case parents of + [] -> empty + [_] -> text "Parent:" + _ -> text "Parents:") <+> fsep (punctuate comma parents) + where + pp_category :: TyThing -> String + pp_category (AnId i) + | isRecordSelector i = "record selector" + pp_category i = tyThingCategory i + what_is = pp_category ty_thing + thing = ppr child + parents = map ppr parent_names + TcRnConflictingExports occ child1 gre1 ie1 child2 gre2 ie2 + -> mkSimpleDecorated $ + vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon + , ppr_export child1 gre1 ie1 + , ppr_export child2 gre2 ie2 + ] + where + ppr_export child gre ie = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+> + quotes (ppr_name child)) + 2 (pprNameProvenance gre)) + + -- DuplicateRecordFields means that nameOccName might be a mangled + -- $sel-prefixed thing, in which case show the correct OccName alone + -- (but otherwise show the Name so it will have a module qualifier) + ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl + | otherwise = ppr (flSelector fl) + ppr_name (NormalGreName name) = ppr name diagnosticReason = \case TcRnUnknownMessage m @@ -437,6 +529,30 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnBangOnUnliftedType{} -> WarningWithFlag Opt_WarnRedundantStrictnessFlags + TcRnMultipleDefaultDeclarations{} + -> ErrorWithoutFlag + TcRnBadDefaultType{} + -> ErrorWithoutFlag + TcRnPatSynBundledWithNonDataCon{} + -> ErrorWithoutFlag + TcRnPatSynBundledWithWrongType{} + -> ErrorWithoutFlag + TcRnDupeModuleExport{} + -> WarningWithFlag Opt_WarnDuplicateExports + TcRnExportedModNotImported{} + -> ErrorWithoutFlag + TcRnNullExportedModule{} + -> WarningWithFlag Opt_WarnDodgyExports + TcRnMissingExportList{} + -> WarningWithFlag Opt_WarnMissingExportList + TcRnExportHiddenComponents{} + -> ErrorWithoutFlag + TcRnDuplicateExport{} + -> WarningWithFlag Opt_WarnDuplicateExports + TcRnExportedParentChildMismatch{} + -> ErrorWithoutFlag + TcRnConflictingExports{} + -> ErrorWithoutFlag diagnosticHints = \case TcRnUnknownMessage m @@ -584,6 +700,30 @@ instance Diagnostic TcRnMessage where -> noHints TcRnBangOnUnliftedType{} -> noHints + TcRnMultipleDefaultDeclarations{} + -> noHints + TcRnBadDefaultType{} + -> noHints + TcRnPatSynBundledWithNonDataCon{} + -> noHints + TcRnPatSynBundledWithWrongType{} + -> noHints + TcRnDupeModuleExport{} + -> noHints + TcRnExportedModNotImported{} + -> noHints + TcRnNullExportedModule{} + -> noHints + TcRnMissingExportList{} + -> noHints + TcRnExportHiddenComponents{} + -> noHints + TcRnDuplicateExport{} + -> noHints + TcRnExportedParentChildMismatch{} + -> noHints + TcRnConflictingExports{} + -> noHints messageWithInfoDiagnosticMessage :: UnitState -> ErrInfo @@ -662,3 +802,9 @@ pprBindings = pprWithCommas (quotes . ppr) injectivityErrorHerald :: SDoc injectivityErrorHerald = text "Type family equation violates the family's injectivity annotation." + +formatExportItemError :: SDoc -> String -> SDoc +formatExportItemError exportedThing reason = + hsep [ text "The export item" + , quotes exportedThing + , text reason ] diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 2ce13ae06f..4272ac9a4a 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -24,6 +24,7 @@ import GHC.Types.Error import GHC.Types.Name (Name, OccName) import GHC.Types.Name.Reader import GHC.Types.SrcLoc +import GHC.Types.TyThing (TyThing) import GHC.Unit.Types (Module) import GHC.Utils.Outputable import GHC.Core.Class (Class) @@ -33,6 +34,7 @@ import GHC.Core.InstEnv (ClsInst) import GHC.Core.TyCon (TyCon, TyConFlavour) import GHC.Core.Type (Kind, Type, Var) import GHC.Unit.State (UnitState) +import GHC.Unit.Module.Name (ModuleName) import GHC.Types.Basic import GHC.Types.Var.Set (TyVarSet) @@ -927,6 +929,174 @@ data TcRnMessage where -} TcRnBangOnUnliftedType :: !Type -> TcRnMessage + {-| TcRnMultipleDefaultDeclarations is an error that occurs when a module has + more than one default declaration. + + Example: + default (Integer, Int) + default (Double, Float) -- 2nd default declaration not allowed + + Text cases: module/mod58 + -} + TcRnMultipleDefaultDeclarations :: [LDefaultDecl GhcRn] -> TcRnMessage + + {-| TcRnBadDefaultType is an error that occurs when a type used in a default + declaration does not have an instance for any of the applicable classes. + + Example(s): + data Foo + default (Foo) + + Test cases: typecheck/should_fail/T11974b + -} + TcRnBadDefaultType :: Type -> [Class] -> TcRnMessage + + {-| TcRnPatSynBundledWithNonDataCon is an error that occurs when a module's + export list bundles a pattern synonym with a type that is not a proper + `data` or `newtype` construction. + + Example(s): + module Foo (MyClass(.., P)) where + pattern P = Nothing + class MyClass a where + foo :: a -> Int + + Test cases: patsyn/should_fail/export-class + -} + TcRnPatSynBundledWithNonDataCon :: TcRnMessage + + {-| TcRnPatSynBundledWithWrongType is an error that occurs when the export list + of a module has a pattern synonym bundled with a type that does not match + the type of the pattern synonym. + + Example(s): + module Foo (R(P,x)) where + data Q = Q Int + data R = R + pattern P{x} = Q x + + Text cases: patsyn/should_fail/export-ps-rec-sel + patsyn/should_fail/export-type-synonym + patsyn/should_fail/export-type + -} + TcRnPatSynBundledWithWrongType :: Type -> Type -> TcRnMessage + + {-| TcRnDupeModuleExport is a warning controlled by @-Wduplicate-exports@ that + occurs when a module appears more than once in an export list. + + Example(s): + module Foo (module Bar, module Bar) + import Bar + + Text cases: None + -} + TcRnDupeModuleExport :: ModuleName -> TcRnMessage + + {-| TcRnExportedModNotImported is an error that occurs when an export list + contains a module that is not imported. + + Example(s): None + + Text cases: module/mod135 + module/mod8 + rename/should_fail/rnfail028 + backpack/should_fail/bkpfail48 + -} + TcRnExportedModNotImported :: ModuleName -> TcRnMessage + + {-| TcRnNullExportedModule is a warning controlled by -Wdodgy-exports that occurs + when an export list contains a module that has no exports. + + Example(s): + module Foo (module Bar) where + import Bar () + + Test cases: None + -} + TcRnNullExportedModule :: ModuleName -> TcRnMessage + + {-| TcRnMissingExportList is a warning controlled by -Wmissing-export-lists that + occurs when a module does not have an explicit export list. + + Example(s): None + + Test cases: typecheck/should_fail/MissingExportList03 + -} + TcRnMissingExportList :: ModuleName -> TcRnMessage + + {-| TcRnExportHiddenComponents is an error that occurs when an export contains + constructor or class methods that are not visible. + + Example(s): None + + Test cases: None + -} + TcRnExportHiddenComponents :: IE GhcPs -> TcRnMessage + + {-| TcRnDuplicateExport is a warning (controlled by -Wduplicate-exports) that occurs + when an identifier appears in an export list more than once. + + Example(s): None + + Test cases: module/MultiExport + module/mod128 + module/mod14 + module/mod5 + overloadedrecflds/should_fail/DuplicateExports + patsyn/should_compile/T11959 + -} + TcRnDuplicateExport :: GreName -> IE GhcPs -> IE GhcPs -> TcRnMessage + + {-| TcRnExportedParentChildMismatch is an error that occurs when an export is + bundled with a parent that it does not belong to + + Example(s): + module Foo (T(a)) where + data T + a = True + + Test cases: module/T11970 + module/T11970B + module/mod17 + module/mod3 + overloadedrecflds/should_fail/NoParent + -} + TcRnExportedParentChildMismatch :: Name -> TyThing -> GreName -> [Name] -> TcRnMessage + + {-| TcRnConflictingExports is an error that occurs when different identifiers that + have the same name are being exported by a module. + + Example(s): + module Foo (Bar.f, module Baz) where + import qualified Bar (f) + import Baz (f) + + Test cases: module/mod131 + module/mod142 + module/mod143 + module/mod144 + module/mod145 + module/mod146 + module/mod150 + module/mod155 + overloadedrecflds/should_fail/T14953 + overloadedrecflds/should_fail/overloadedrecfldsfail10 + rename/should_fail/rnfail029 + rename/should_fail/rnfail040 + typecheck/should_fail/T16453E2 + typecheck/should_fail/tcfail025 + typecheck/should_fail/tcfail026 + -} + TcRnConflictingExports + :: OccName -- ^ Occurrence name shared by both exports + -> GreName -- ^ Name of first export + -> GlobalRdrElt -- ^ Provenance for definition site of first export + -> IE GhcPs -- ^ Export decl of first export + -> GreName -- ^ Name of second export + -> GlobalRdrElt -- ^ Provenance for definition site of second export + -> IE GhcPs -- ^ Export decl of second export + -> TcRnMessage + -- | Which parts of a record field are affected by a particular error or warning. data RecordFieldPart = RecordFieldConstructor !Name diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs index 1390c2bdad..15f2bdd440 100644 --- a/compiler/GHC/Tc/Gen/Default.hs +++ b/compiler/GHC/Tc/Gen/Default.hs @@ -81,7 +81,7 @@ tc_default_ty deflt_clss hs_ty -- Check that the type is an instance of at least one of the deflt_clss ; oks <- mapM (check_instance ty) deflt_clss - ; checkTc (or oks) (badDefaultTy ty deflt_clss) + ; checkTc (or oks) (TcRnBadDefaultType ty deflt_clss) ; return ty } check_instance :: Type -> Class -> TcM Bool @@ -105,17 +105,5 @@ defaultDeclCtxt = text "When checking the types in a default declaration" dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> TcRnMessage dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things) - = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Multiple default declarations") - 2 (vcat (map pp dup_things)) - where - pp :: LDefaultDecl GhcRn -> SDoc - pp (L locn (DefaultDecl _ _)) - = text "here was another default declaration" <+> ppr (locA locn) + = TcRnMultipleDefaultDeclarations dup_things dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" - -badDefaultTy :: Type -> [Class] -> TcRnMessage -badDefaultTy ty deflt_clss - = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of") - 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss)) diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index e7fb4384f5..acf5a9da3f 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -26,11 +26,9 @@ import GHC.Utils.Panic import GHC.Core.ConLike import GHC.Core.PatSyn import GHC.Data.Maybe -import GHC.Utils.Misc (capitalise) import GHC.Data.FastString (fsLit) import GHC.Driver.Env -import GHC.Types.TyThing( tyThingCategory ) import GHC.Types.Unique.Set import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name @@ -238,7 +236,7 @@ exports_from_avail Nothing rdr_env _imports _this_mod -- when a data instance is exported. = do { ; addDiagnostic - (missingModuleExportWarn $ moduleName _this_mod) + (TcRnMissingExportList $ moduleName _this_mod) ; let avails = map fix_faminst . gresToAvailInfo . filter isLocalGRE . globalRdrEnvElts $ rdr_env @@ -283,7 +281,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod exports_from_item (ExportAccum occs earlier_mods) (L loc ie@(IEModuleContents _ lmod@(L _ mod))) | mod `elementOfUniqSet` earlier_mods -- Duplicate export of M - = do { addDiagnostic (dupModuleExport mod) ; + = do { addDiagnostic (TcRnDupeModuleExport mod) ; return Nothing } | otherwise @@ -297,8 +295,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod ; mods = addOneToUniqSet earlier_mods mod } - ; checkErr exportValid (moduleNotImported mod) - ; warnIf (exportValid && null gre_prs) (nullModuleExport mod) + ; checkErr exportValid (TcRnExportedModNotImported mod) + ; warnIf (exportValid && null gre_prs) (TcRnNullExportedModule mod) ; traceRn "efa" (ppr mod $$ ppr all_gres) ; addUsedGREs all_gres @@ -394,7 +392,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod then addTcRnDiagnostic (TcRnDodgyExports name) else -- This occurs when you export T(..), but -- only import T abstractly, or T is a synonym. - addErr (exportItemErr ie) + addErr (TcRnExportHiddenComponents ie) return (L (locA l) name, non_flds, flds) ------------- @@ -607,10 +605,6 @@ checkPatSynParent parent NoParent gname psErr = exportErrCtxt "pattern synonym" selErr = exportErrCtxt "pattern synonym record selector" - assocClassErr :: TcRnMessage - assocClassErr = TcRnUnknownMessage $ mkPlainError noHints $ - text "Pattern synonyms can be bundled only with datatypes." - handle_pat_syn :: SDoc -> TyCon -- ^ Parent TyCon -> PatSyn -- ^ Corresponding bundled PatSyn @@ -620,7 +614,7 @@ checkPatSynParent parent NoParent gname -- 2. See note [Types of TyCon] | not $ isTyConWithSrcDataCons ty_con - = addErrCtxt doc $ failWithTc assocClassErr + = addErrCtxt doc $ failWithTc TcRnPatSynBundledWithNonDataCon -- 3. Is the head a type variable? | Nothing <- mtycon @@ -628,7 +622,8 @@ checkPatSynParent parent NoParent gname -- 4. Ok. Check they are actually the same type constructor. | Just p_ty_con <- mtycon, p_ty_con /= ty_con - = addErrCtxt doc $ failWithTc typeMismatchError + = addErrCtxt doc $ failWithTc + (TcRnPatSynBundledWithWrongType expected_res_ty res_ty) -- 5. We passed! | otherwise @@ -638,13 +633,6 @@ checkPatSynParent parent NoParent gname expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con)) (_, _, _, _, _, res_ty) = patSynSig pat_syn mtycon = fst <$> tcSplitTyConApp_maybe res_ty - typeMismatchError :: TcRnMessage - typeMismatchError = TcRnUnknownMessage $ mkPlainError noHints $ - text "Pattern synonyms can only be bundled with matching type constructors" - $$ text "Couldn't match expected type of" - <+> quotes (ppr expected_res_ty) - <+> text "with actual type of" - <+> quotes (ppr res_ty) {-===========================================================================-} @@ -667,7 +655,7 @@ check_occs ie occs avails | greNameMangledName child == greNameMangledName child' -- Duplicate export -- But we don't want to warn if the same thing is exported -- by two different module exports. See ticket #4478. - -> do { warnIf (not (dupExport_ok child ie ie')) (dupExportWarn child ie ie') + -> do { warnIf (not (dupExport_ok child ie ie')) (TcRnDuplicateExport child ie ie') ; return occs } | otherwise -- Same occ name but different names: an error @@ -729,35 +717,6 @@ dupExport_ok child ie1 ie2 single _ = False -dupModuleExport :: ModuleName -> TcRnMessage -dupModuleExport mod - = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDuplicateExports) noHints $ - hsep [text "Duplicate", - quotes (text "Module" <+> ppr mod), - text "in export list"] - -moduleNotImported :: ModuleName -> TcRnMessage -moduleNotImported mod - = TcRnUnknownMessage $ mkPlainError noHints $ - hsep [text "The export item", - quotes (text "module" <+> ppr mod), - text "is not imported"] - -nullModuleExport :: ModuleName -> TcRnMessage -nullModuleExport mod - = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyExports) noHints $ - hsep [text "The export item", - quotes (text "module" <+> ppr mod), - text "exports nothing"] - -missingModuleExportWarn :: ModuleName -> TcRnMessage -missingModuleExportWarn mod - = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingExportList) noHints $ - hsep [text "The export item", - quotes (text "module" <+> ppr mod), - text "is missing an export list"] - - exportErrCtxt :: Outputable o => String -> o -> SDoc exportErrCtxt herald exp = text "In the" <+> text (herald ++ ":") <+> ppr exp @@ -769,42 +728,11 @@ addExportErrCtxt ie = addErrCtxt exportCtxt where exportCtxt = text "In the export:" <+> ppr ie -exportItemErr :: IE GhcPs -> TcRnMessage -exportItemErr export_item - = TcRnUnknownMessage $ mkPlainError noHints $ - sep [ text "The export item" <+> quotes (ppr export_item), - text "attempts to export constructors or class methods that are not visible here" ] - - -dupExportWarn :: GreName -> IE GhcPs -> IE GhcPs -> TcRnMessage -dupExportWarn child ie1 ie2 - = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDuplicateExports) noHints $ - hsep [quotes (ppr child), - text "is exported by", quotes (ppr ie1), - text "and", quotes (ppr ie2)] - -dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> TcRnMessage -dcErrMsg ty_con what_is thing parents = TcRnUnknownMessage $ mkPlainError noHints $ - text "The type constructor" <+> quotes (ppr ty_con) - <+> text "is not the parent of the" <+> text what_is - <+> quotes thing <> char '.' - $$ text (capitalise what_is) - <> text "s can only be exported with their parent type constructor." - $$ (case parents of - [] -> empty - [_] -> text "Parent:" - _ -> text "Parents:") <+> fsep (punctuate comma parents) failWithDcErr :: Name -> GreName -> [Name] -> TcM a failWithDcErr parent child parents = do ty_thing <- tcLookupGlobal (greNameMangledName child) - failWithTc $ dcErrMsg parent (pp_category ty_thing) - (ppr child) (map ppr parents) - where - pp_category :: TyThing -> String - pp_category (AnId i) - | isRecordSelector i = "record selector" - pp_category i = tyThingCategory i + failWithTc $ TcRnExportedParentChildMismatch parent ty_thing child parents exportClashErr :: GlobalRdrEnv @@ -812,25 +740,9 @@ exportClashErr :: GlobalRdrEnv -> IE GhcPs -> IE GhcPs -> TcRnMessage exportClashErr global_env child1 child2 ie1 ie2 - = TcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon - , ppr_export child1' gre1' ie1' - , ppr_export child2' gre2' ie2' - ] + = TcRnConflictingExports occ child1' gre1' ie1' child2' gre2' ie2' where occ = occName child1 - - ppr_export child gre ie = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+> - quotes (ppr_name child)) - 2 (pprNameProvenance gre)) - - -- DuplicateRecordFields means that nameOccName might be a mangled - -- $sel-prefixed thing, in which case show the correct OccName alone - -- (but otherwise show the Name so it will have a module qualifier) - ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl - | otherwise = ppr (flSelector fl) - ppr_name (NormalGreName name) = ppr name - -- get_gre finds a GRE for the Name, so that we can show its provenance gre1 = get_gre child1 gre2 = get_gre child2 |