diff options
author | Matthew Pickering <matthewtpickering@gmail.com> | 2023-03-14 17:34:30 +0000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2023-04-18 10:31:02 -0400 |
commit | 5e1d33d7a428965c7024290cebb3d77b84230169 (patch) | |
tree | 8b9a35d5c0905ad7a67cd588b7fd991cb783b1a3 /compiler/GHC | |
parent | 1036481824fed7f8d5c9f70816b3dadd22098e42 (diff) | |
download | haskell-5e1d33d7a428965c7024290cebb3d77b84230169.tar.gz |
Convert interface file loading errors into proper diagnostics
This patch converts all the errors to do with loading interface files
into proper structured diagnostics.
* DriverMessage: Sometimes in the driver we attempt to load an interface
file so we embed the IfaceMessage into the DriverMessage.
* TcRnMessage: Most the time we are loading interface files during
typechecking, so we embed the IfaceMessage
This patch also removes the TcRnInterfaceLookupError constructor which
is superceded by the IfaceMessage, which is now structured compared to
just storing an SDoc before.
Diffstat (limited to 'compiler/GHC')
24 files changed, 730 insertions, 395 deletions
diff --git a/compiler/GHC/Driver/Config/Diagnostic.hs b/compiler/GHC/Driver/Config/Diagnostic.hs index f4b709301b..1e8b5a1e67 100644 --- a/compiler/GHC/Driver/Config/Diagnostic.hs +++ b/compiler/GHC/Driver/Config/Diagnostic.hs @@ -8,11 +8,13 @@ module GHC.Driver.Config.Diagnostic , initDsMessageOpts , initTcMessageOpts , initDriverMessageOpts + , initIfaceMessageOpts ) where import GHC.Driver.Flags import GHC.Driver.Session +import GHC.Prelude import GHC.Utils.Outputable import GHC.Utils.Error (DiagOpts (..)) @@ -22,6 +24,8 @@ import GHC.Tc.Errors.Types import GHC.HsToCore.Errors.Types import GHC.Types.Error import GHC.Tc.Errors.Ppr +import GHC.Iface.Errors.Types +import GHC.Iface.Errors.Ppr -- | Initialise the general configuration for printing diagnostic messages -- For example, this configuration controls things like whether warnings are @@ -50,11 +54,17 @@ initPsMessageOpts :: DynFlags -> DiagnosticOpts PsMessage initPsMessageOpts _ = NoDiagnosticOpts initTcMessageOpts :: DynFlags -> DiagnosticOpts TcRnMessage -initTcMessageOpts dflags = TcRnMessageOpts { tcOptsShowContext = gopt Opt_ShowErrorContext dflags } +initTcMessageOpts dflags = + TcRnMessageOpts { tcOptsShowContext = gopt Opt_ShowErrorContext dflags + , tcOptsIfaceOpts = initIfaceMessageOpts dflags } initDsMessageOpts :: DynFlags -> DiagnosticOpts DsMessage initDsMessageOpts _ = NoDiagnosticOpts +initIfaceMessageOpts :: DynFlags -> DiagnosticOpts IfaceMessage +initIfaceMessageOpts dflags = + IfaceMessageOpts { ifaceShowTriedFiles = verbosity dflags >= 3 } + initDriverMessageOpts :: DynFlags -> DiagnosticOpts DriverMessage -initDriverMessageOpts dflags = DriverMessageOpts (initPsMessageOpts dflags) +initDriverMessageOpts dflags = DriverMessageOpts (initPsMessageOpts dflags) (initIfaceMessageOpts dflags) diff --git a/compiler/GHC/Driver/Config/Tidy.hs b/compiler/GHC/Driver/Config/Tidy.hs index 89bdf31b2c..a02321ab78 100644 --- a/compiler/GHC/Driver/Config/Tidy.hs +++ b/compiler/GHC/Driver/Config/Tidy.hs @@ -17,11 +17,8 @@ import GHC.Driver.Env import GHC.Driver.Backend import GHC.Core.Make (getMkStringIds) -import GHC.Data.Maybe -import GHC.Utils.Panic -import GHC.Utils.Outputable import GHC.Builtin.Names -import GHC.Tc.Utils.Env (lookupGlobal_maybe) +import GHC.Tc.Utils.Env (lookupGlobal) import GHC.Types.TyThing import GHC.Platform.Ways @@ -49,13 +46,9 @@ initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts initStaticPtrOpts hsc_env = do let dflags = hsc_dflags hsc_env - let lookupM n = lookupGlobal_maybe hsc_env n >>= \case - Succeeded r -> pure r - Failed err -> pprPanic "initStaticPtrOpts: couldn't find" (ppr (err,n)) - - mk_string <- getMkStringIds (fmap tyThingId . lookupM) - static_ptr_info_datacon <- tyThingDataCon <$> lookupM staticPtrInfoDataConName - static_ptr_datacon <- tyThingDataCon <$> lookupM staticPtrDataConName + mk_string <- getMkStringIds (fmap tyThingId . lookupGlobal hsc_env ) + static_ptr_info_datacon <- tyThingDataCon <$> lookupGlobal hsc_env staticPtrInfoDataConName + static_ptr_datacon <- tyThingDataCon <$> lookupGlobal hsc_env staticPtrDataConName pure $ StaticPtrOpts { opt_platform = targetPlatform dflags diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs index dd6834046b..ab62682517 100644 --- a/compiler/GHC/Driver/Errors.hs +++ b/compiler/GHC/Driver/Errors.hs @@ -13,7 +13,7 @@ import GHC.Types.SrcLoc import GHC.Types.SourceError import GHC.Types.Error import GHC.Utils.Error -import GHC.Utils.Outputable (hang, ppr, ($$), SDocContext, text, withPprStyle, mkErrStyle, sdocStyle ) +import GHC.Utils.Outputable (hang, ppr, ($$), text, mkErrStyle, sdocStyle, updSDocContext ) import GHC.Utils.Logger import qualified GHC.Driver.CmdLine as CmdLine @@ -22,21 +22,21 @@ printMessages logger msg_opts opts msgs = sequence_ [ let style = mkErrStyle name_ppr_ctx ctx = (diag_ppr_ctx opts) { sdocStyle = style } in logMsg logger (MCDiagnostic sev (diagnosticReason dia) (diagnosticCode dia)) s $ - withPprStyle style (messageWithHints ctx dia) + updSDocContext (\_ -> ctx) (messageWithHints dia) | MsgEnvelope { errMsgSpan = s, errMsgDiagnostic = dia, errMsgSeverity = sev, errMsgContext = name_ppr_ctx } <- sortMsgBag (Just opts) (getMessages msgs) ] where - messageWithHints :: Diagnostic a => SDocContext -> a -> SDoc - messageWithHints ctx e = - let main_msg = formatBulleted ctx $ diagnosticMessage msg_opts e + messageWithHints :: Diagnostic a => a -> SDoc + messageWithHints e = + let main_msg = formatBulleted $ diagnosticMessage msg_opts e in case diagnosticHints e of [] -> main_msg [h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h) hs -> main_msg $$ hang (text "Suggested fixes:") 2 - (formatBulleted ctx . mkDecorated . map ppr $ hs) + (formatBulleted $ mkDecorated . map ppr $ hs) handleFlagWarnings :: Logger -> GhcMessageOpts -> DiagOpts -> [CmdLine.Warn] -> IO () handleFlagWarnings logger print_config opts warns = do diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs index 9e3822e460..a89e7992b1 100644 --- a/compiler/GHC/Driver/Errors/Ppr.hs +++ b/compiler/GHC/Driver/Errors/Ppr.hs @@ -16,7 +16,6 @@ import GHC.Driver.Flags import GHC.Driver.Session import GHC.HsToCore.Errors.Ppr () import GHC.Parser.Errors.Ppr () -import GHC.Tc.Errors.Ppr () import GHC.Types.Error import GHC.Types.Error.Codes ( constructorCode ) import GHC.Unit.Types @@ -30,6 +29,9 @@ import Data.Version import Language.Haskell.Syntax.Decls (RuleDecl(..)) import GHC.Tc.Errors.Types (TcRnMessage) import GHC.HsToCore.Errors.Types (DsMessage) +import GHC.Iface.Errors.Types +import GHC.Tc.Errors.Ppr () +import GHC.Iface.Errors.Ppr () -- -- Suggestions @@ -86,7 +88,7 @@ instance Diagnostic GhcMessage where instance Diagnostic DriverMessage where type DiagnosticOpts DriverMessage = DriverMessageOpts - defaultDiagnosticOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) + defaultDiagnosticOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @IfaceMessage) diagnosticMessage opts = \case DriverUnknownMessage (UnknownDiagnostic @e m) -> diagnosticMessage (defaultDiagnosticOpts @e) m @@ -218,6 +220,7 @@ instance Diagnostic DriverMessage where -> mkSimpleDecorated $ vcat ([text "Home units are not closed." , text "It is necessary to also load the following units:" ] ++ map (\uid -> text "-" <+> ppr uid) needed_unit_ids) + DriverInterfaceError reason -> diagnosticMessage (ifaceDiagnosticOpts opts) reason diagnosticReason = \case DriverUnknownMessage m @@ -272,6 +275,7 @@ instance Diagnostic DriverMessage where -> ErrorWithoutFlag DriverHomePackagesNotClosed {} -> ErrorWithoutFlag + DriverInterfaceError reason -> diagnosticReason reason diagnosticHints = \case DriverUnknownMessage m @@ -328,5 +332,6 @@ instance Diagnostic DriverMessage where -> noHints DriverHomePackagesNotClosed {} -> noHints + DriverInterfaceError reason -> diagnosticHints reason diagnosticCode = constructorCode diff --git a/compiler/GHC/Driver/Errors/Types.hs b/compiler/GHC/Driver/Errors/Types.hs index c2ec9cbb0c..cbf0622025 100644 --- a/compiler/GHC/Driver/Errors/Types.hs +++ b/compiler/GHC/Driver/Errors/Types.hs @@ -8,7 +8,6 @@ module GHC.Driver.Errors.Types ( , DriverMessage(..) , DriverMessageOpts(..) , DriverMessages, PsMessage(PsHeaderMessage) - , BuildingCabalPackage(..) , WarningMessages , ErrorMessages , WarnMsg @@ -32,7 +31,6 @@ import GHC.Unit.Module import GHC.Unit.State import GHC.Parser.Errors.Types ( PsMessage(PsHeaderMessage) ) -import GHC.Tc.Errors.Types ( TcRnMessage ) import GHC.HsToCore.Errors.Types ( DsMessage ) import GHC.Hs.Extension (GhcTc) @@ -40,6 +38,9 @@ import Language.Haskell.Syntax.Decls (RuleDecl) import GHC.Generics ( Generic ) +import GHC.Tc.Errors.Types +import GHC.Iface.Errors.Types + -- | A collection of warning messages. -- /INVARIANT/: Each 'GhcMessage' in the collection should have 'SevWarning' severity. type WarningMessages = Messages GhcMessage @@ -369,21 +370,18 @@ data DriverMessage where DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage + DriverInterfaceError :: !IfaceMessage -> DriverMessage + deriving instance Generic DriverMessage data DriverMessageOpts = - DriverMessageOpts { psDiagnosticOpts :: DiagnosticOpts PsMessage } + DriverMessageOpts { psDiagnosticOpts :: DiagnosticOpts PsMessage + , ifaceDiagnosticOpts :: DiagnosticOpts IfaceMessage } --- | Pass to a 'DriverMessage' the information whether or not the --- '-fbuilding-cabal-package' flag is set. -data BuildingCabalPackage - = YesBuildingCabalPackage - | NoBuildingCabalPackage - deriving Eq -- | Checks if we are building a cabal package by consulting the 'DynFlags'. checkBuildingCabalPackage :: DynFlags -> BuildingCabalPackage checkBuildingCabalPackage dflags = if gopt Opt_BuildingCabalPackage dflags then YesBuildingCabalPackage - else NoBuildingCabalPackage + else NoBuildingCabalPackage
\ No newline at end of file diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 7f60d5a8a0..d72b452d2e 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -153,6 +153,7 @@ import GHC.Utils.Constants import GHC.Types.Unique.DFM (udfmRestrictKeysSet) import qualified Data.IntSet as I import GHC.Types.Unique +import GHC.Iface.Errors.Types -- ----------------------------------------------------------------------------- @@ -2336,8 +2337,8 @@ noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMe -- ToDo: we don't have a proper line number for this error noModError hsc_env loc wanted_mod err = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ - DriverUnknownMessage $ UnknownDiagnostic $ mkPlainError noHints $ - cannotFindModule hsc_env wanted_mod err + DriverInterfaceError $ + (Can'tFindInterface (cannotFindModule hsc_env wanted_mod err) (LookingForModule wanted_mod NotBoot)) {- noHsFileErr :: SrcSpan -> String -> DriverMessages diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index a770637311..be20bfd89f 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -27,7 +27,6 @@ import GHC.Data.Graph.Directed ( SCC(..) ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Types.Error (UnknownDiagnostic(..)) import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Types.PkgQual @@ -53,6 +52,7 @@ import Control.Monad ( when, forM_ ) import Data.Maybe ( isJust ) import Data.IORef import qualified Data.Set as Set +import GHC.Iface.Errors.Types ----------------------------------------------------------------- -- @@ -307,9 +307,8 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do fail -> throwOneError $ mkPlainErrorMsgEnvelope srcloc $ - GhcDriverMessage $ DriverUnknownMessage $ - UnknownDiagnostic $ mkPlainError noHints $ - cannotFindModule hsc_env imp fail + GhcDriverMessage $ DriverInterfaceError $ + (Can'tFindInterface (cannotFindModule hsc_env imp fail) (LookingForModule imp is_boot)) ----------------------------- writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO () diff --git a/compiler/GHC/Iface/Errors.hs b/compiler/GHC/Iface/Errors.hs index 743ce9a33a..0fce13fd4a 100644 --- a/compiler/GHC/Iface/Errors.hs +++ b/compiler/GHC/Iface/Errors.hs @@ -3,14 +3,9 @@ module GHC.Iface.Errors ( badIfaceFile - , hiModuleNameMismatchWarn - , homeModError , cannotFindInterface , cantFindInstalledErr , cannotFindModule - , cantFindErr - -- * Utility functions - , mayShowLocations ) where import GHC.Platform.Profile @@ -25,73 +20,38 @@ import GHC.Unit import GHC.Unit.Env import GHC.Unit.Finder.Types import GHC.Utils.Outputable as Outputable +import GHC.Iface.Errors.Types +-- ----------------------------------------------------------------------------- +-- Error messages badIfaceFile :: String -> SDoc -> SDoc badIfaceFile file err = vcat [text "Bad interface file:" <+> text file, nest 4 err] -hiModuleNameMismatchWarn :: Module -> Module -> SDoc -hiModuleNameMismatchWarn requested_mod read_mod - | moduleUnit requested_mod == moduleUnit read_mod = - sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma, - text "but we were expecting module" <+> quotes (ppr requested_mod), - sep [text "Probable cause: the source code which generated interface file", - text "has an incompatible module name" - ] - ] - | otherwise = - -- ToDo: This will fail to have enough qualification when the package IDs - -- are the same - withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ - -- we want the Modules below to be qualified with package names, - -- so reset the NamePprCtx setting. - hsep [ text "Something is amiss; requested module " - , ppr requested_mod - , text "differs from name found in the interface file" - , ppr read_mod - , parens (text "if these names look the same, try again with -dppr-debug") - ] - -homeModError :: InstalledModule -> ModLocation -> SDoc --- See Note [Home module load error] -homeModError mod location - = text "attempting to use module " <> quotes (ppr mod) - <> (case ml_hs_file location of - Just file -> space <> parens (text file) - Nothing -> Outputable.empty) - <+> text "which is not loaded" - - --- ----------------------------------------------------------------------------- --- Error messages - -cannotFindInterface :: UnitState -> Maybe HomeUnit -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc -cannotFindInterface = cantFindInstalledErr (text "Failed to load interface for") - (text "Ambiguous interface for") +cannotFindInterface :: UnitState -> Maybe HomeUnit -> Profile + -> ModuleName -> InstalledFindResult -> MissingInterfaceError +cannotFindInterface us mhu p mn ifr = + CantFindErr us FindingInterface $ + cantFindInstalledErr us mhu p mn ifr cantFindInstalledErr - :: SDoc - -> SDoc - -> UnitState + :: UnitState -> Maybe HomeUnit -> Profile - -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult - -> SDoc -cantFindInstalledErr cannot_find _ unit_state mhome_unit profile tried_these mod_name find_result - = cannot_find <+> quotes (ppr mod_name) - $$ more_info + -> CantFindInstalled +cantFindInstalledErr unit_state mhome_unit profile mod_name find_result + = CantFindInstalled mod_name more_info where build_tag = waysBuildTag (profileWays profile) more_info = case find_result of InstalledNoPackage pkg - -> text "no unit id matching" <+> quotes (ppr pkg) <+> - text "was found" $$ looks_like_srcpkgid pkg + -> NoUnitIdMatching pkg (searchPackageId unit_state (PackageId (unitIdFS pkg))) InstalledNotFound files mb_pkg | Just pkg <- mb_pkg @@ -99,152 +59,83 @@ cantFindInstalledErr cannot_find _ unit_state mhome_unit profile tried_these mod -> not_found_in_package pkg files | null files - -> text "It is not a module in the current program, or in any known package." + -> NotAModule | otherwise - -> tried_these files + -> CouldntFindInFiles files _ -> panic "cantFindInstalledErr" - looks_like_srcpkgid :: UnitId -> SDoc - looks_like_srcpkgid pk - -- Unsafely coerce a unit id (i.e. an installed package component - -- identifier) into a PackageId and see if it means anything. - | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk)) - = parens (text "This unit ID looks like the source package ID;" $$ - text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$ - (if null pkgs then Outputable.empty - else text "and" <+> int (length pkgs) <+> text "other candidates")) - -- Todo: also check if it looks like a package name! - | otherwise = Outputable.empty - not_found_in_package pkg files | build_tag /= "" = let build = if build_tag == "p" then "profiling" else "\"" ++ build_tag ++ "\"" in - text "Perhaps you haven't installed the " <> text build <> - text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ - tried_these files - + MissingPackageWayFiles build pkg files | otherwise - = text "There are files missing in the " <> quotes (ppr pkg) <> - text " package," $$ - text "try running 'ghc-pkg check'." $$ - tried_these files + = MissingPackageFiles pkg files -mayShowLocations :: DynFlags -> [FilePath] -> SDoc -mayShowLocations dflags files - | null files = Outputable.empty - | verbosity dflags < 3 = - text "Use -v (or `:set -v` in ghci) " <> - text "to see a list of the files searched for." - | otherwise = - hang (text "Locations searched:") 2 $ vcat (map text files) -cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc + +cannotFindModule :: HscEnv -> ModuleName -> FindResult -> MissingInterfaceError cannotFindModule hsc_env = cannotFindModule' (hsc_dflags hsc_env) (hsc_unit_env hsc_env) (targetProfile (hsc_dflags hsc_env)) -cannotFindModule' :: DynFlags -> UnitEnv -> Profile -> ModuleName -> FindResult -> SDoc -cannotFindModule' dflags unit_env profile mod res = pprWithUnitState (ue_units unit_env) $ +cannotFindModule' :: DynFlags -> UnitEnv -> Profile -> ModuleName -> FindResult + -> MissingInterfaceError +cannotFindModule' dflags unit_env profile mod res = + CantFindErr (ue_units unit_env) FindingModule $ cantFindErr (checkBuildingCabalPackage dflags) - cannotFindMsg - (text "Ambiguous module name") unit_env profile - (mayShowLocations dflags) mod res - where - cannotFindMsg = - case res of - NotFound { fr_mods_hidden = hidden_mods - , fr_pkgs_hidden = hidden_pkgs - , fr_unusables = unusables } - | not (null hidden_mods && null hidden_pkgs && null unusables) - -> text "Could not load module" - _ -> text "Could not find module" cantFindErr :: BuildingCabalPackage -- ^ Using Cabal? - -> SDoc - -> SDoc -> UnitEnv -> Profile - -> ([FilePath] -> SDoc) -> ModuleName -> FindResult - -> SDoc -cantFindErr _ _ multiple_found _ _ _ mod_name (FoundMultiple mods) - | Just pkgs <- unambiguousPackages - = hang (multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( - sep [text "it was found in multiple packages:", - hsep (map ppr pkgs) ] - ) - | otherwise - = hang (multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( - vcat (map pprMod mods) - ) - where - unambiguousPackages = foldl' unambiguousPackage (Just []) mods - unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) - = Just (moduleUnit m : xs) - unambiguousPackage _ _ = Nothing + -> CantFindInstalled +cantFindErr _ _ _ mod_name (FoundMultiple mods) + = CantFindInstalled mod_name (MultiplePackages mods) - pprMod (m, o) = text "it is bound as" <+> ppr m <+> - text "by" <+> pprOrigin m o - pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" - pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" - pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( - if e == Just True - then [text "package" <+> ppr (moduleUnit m)] - else [] ++ - map ((text "a reexport in package" <+>) - .ppr.mkUnit) res ++ - if f then [text "a package flag"] else [] - ) - -cantFindErr using_cabal cannot_find _ unit_env profile tried_these mod_name find_result - = cannot_find <+> quotes (ppr mod_name) - $$ more_info +cantFindErr using_cabal unit_env profile mod_name find_result + = CantFindInstalled mod_name more_info where mhome_unit = ue_homeUnit unit_env more_info = case find_result of NoPackage pkg - -> text "no unit id matching" <+> quotes (ppr pkg) <+> - text "was found" - + -> NoUnitIdMatching (toUnitId pkg) [] NotFound { fr_paths = files, fr_pkg = mb_pkg , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens , fr_unusables = unusables, fr_suggestions = suggest } | Just pkg <- mb_pkg , Nothing <- mhome_unit -- no home-unit - -> not_found_in_package pkg files + -> not_found_in_package (toUnitId pkg) files | Just pkg <- mb_pkg , Just home_unit <- mhome_unit -- there is a home-unit but the , not (isHomeUnit home_unit pkg) -- module isn't from it - -> not_found_in_package pkg files + -> not_found_in_package (toUnitId pkg) files | not (null suggest) - -> pp_suggestions suggest $$ tried_these files + -> ModuleSuggestion suggest files | null files && null mod_hiddens && null pkg_hiddens && null unusables - -> text "It is not a module in the current program, or in any known package." + -> NotAModule | otherwise - -> vcat (map pkg_hidden pkg_hiddens) $$ - vcat (map mod_hidden mod_hiddens) $$ - vcat (map unusable unusables) $$ - tried_these files - + -> GenericMissing using_cabal + (map ((\uid -> (uid, lookupUnit (ue_units unit_env) uid))) pkg_hiddens) + mod_hiddens unusables files _ -> panic "cantFindErr" build_tag = waysBuildTag (profileWays profile) @@ -255,81 +146,7 @@ cantFindErr using_cabal cannot_find _ unit_env profile tried_these mod_name find build = if build_tag == "p" then "profiling" else "\"" ++ build_tag ++ "\"" in - text "Perhaps you haven't installed the " <> text build <> - text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ - tried_these files + MissingPackageWayFiles build pkg files | otherwise - = text "There are files missing in the " <> quotes (ppr pkg) <> - text " package," $$ - text "try running 'ghc-pkg check'." $$ - tried_these files - - pkg_hidden :: Unit -> SDoc - pkg_hidden uid = - text "It is a member of the hidden package" - <+> quotes (ppr uid) - --FIXME: we don't really want to show the unit id here we should - -- show the source package id or installed package id if it's ambiguous - <> dot $$ pkg_hidden_hint uid - - pkg_hidden_hint uid - | using_cabal == YesBuildingCabalPackage - = let pkg = expectJust "pkg_hidden" (lookupUnit (ue_units unit_env) uid) - in text "Perhaps you need to add" <+> - quotes (ppr (unitPackageName pkg)) <+> - text "to the build-depends in your .cabal file." - | Just pkg <- lookupUnit (ue_units unit_env) uid - = text "You can run" <+> - quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+> - text "to expose it." $$ - text "(Note: this unloads all the modules in the current scope.)" - | otherwise = Outputable.empty - - mod_hidden pkg = - text "it is a hidden module in the package" <+> quotes (ppr pkg) - - unusable (pkg, reason) - = text "It is a member of the package" - <+> quotes (ppr pkg) - $$ pprReason (text "which is") reason - - pp_suggestions :: [ModuleSuggestion] -> SDoc - pp_suggestions sugs - | null sugs = Outputable.empty - | otherwise = hang (text "Perhaps you meant") - 2 (vcat (map pp_sugg sugs)) - - -- NB: Prefer the *original* location, and then reexports, and then - -- package flags when making suggestions. ToDo: if the original package - -- also has a reexport, prefer that one - pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o - where provenance ModHidden = Outputable.empty - provenance (ModUnusable _) = Outputable.empty - provenance (ModOrigin{ fromOrigUnit = e, - fromExposedReexport = res, - fromPackageFlag = f }) - | Just True <- e - = parens (text "from" <+> ppr (moduleUnit mod)) - | f && moduleName mod == m - = parens (text "from" <+> ppr (moduleUnit mod)) - | (pkg:_) <- res - = parens (text "from" <+> ppr (mkUnit pkg) - <> comma <+> text "reexporting" <+> ppr mod) - | f - = parens (text "defined via package flags to be" - <+> ppr mod) - | otherwise = Outputable.empty - pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o - where provenance ModHidden = Outputable.empty - provenance (ModUnusable _) = Outputable.empty - provenance (ModOrigin{ fromOrigUnit = e, - fromHiddenReexport = rhs }) - | Just False <- e - = parens (text "needs flag -package-id" - <+> ppr (moduleUnit mod)) - | (pkg:_) <- rhs - = parens (text "needs flag -package-id" - <+> ppr (mkUnit pkg)) - | otherwise = Outputable.empty - + = MissingPackageFiles pkg files diff --git a/compiler/GHC/Iface/Errors/Ppr.hs b/compiler/GHC/Iface/Errors/Ppr.hs new file mode 100644 index 0000000000..031e4fd75c --- /dev/null +++ b/compiler/GHC/Iface/Errors/Ppr.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage +{-# LANGUAGE InstanceSigs #-} + +module GHC.Iface.Errors.Ppr + ( IfaceMessageOpts(..) + , interfaceErrorHints + , interfaceErrorReason + , interfaceErrorDiagnostic + , missingInterfaceErrorHints + , missingInterfaceErrorReason + , missingInterfaceErrorDiagnostic + , readInterfaceErrorDiagnostic + ) + where + +import GHC.Prelude + +import GHC.Types.Error +import GHC.Types.Hint.Ppr () -- Outputable GhcHint +import GHC.Types.Error.Codes ( constructorCode ) +import GHC.Types.Name +import GHC.Types.TyThing + +import GHC.Unit.State +import GHC.Unit.Module + +import GHC.Utils.Outputable +import GHC.Utils.Panic + + + +import GHC.Iface.Errors.Types + +data IfaceMessageOpts = IfaceMessageOpts { ifaceShowTriedFiles :: !Bool -- ^ Whether to show files we tried to look for or not when printing loader errors + } + +defaultIfaceMessageOpts :: IfaceMessageOpts +defaultIfaceMessageOpts = IfaceMessageOpts { ifaceShowTriedFiles = False } + + +instance Diagnostic IfaceMessage where + type DiagnosticOpts IfaceMessage = IfaceMessageOpts + defaultDiagnosticOpts = defaultIfaceMessageOpts + diagnosticMessage opts reason = mkSimpleDecorated $ + interfaceErrorDiagnostic opts reason + + diagnosticReason = interfaceErrorReason + + diagnosticHints = interfaceErrorHints + + diagnosticCode = constructorCode + +interfaceErrorHints :: IfaceMessage -> [GhcHint] +interfaceErrorHints = \ case + Can'tFindInterface err _looking_for -> + missingInterfaceErrorHints err + Can'tFindNameInInterface {} -> + noHints + +missingInterfaceErrorHints :: MissingInterfaceError -> [GhcHint] +missingInterfaceErrorHints = \case + BadSourceImport {} -> + noHints + HomeModError {} -> + noHints + DynamicHashMismatchError {} -> + noHints + CantFindErr {} -> + noHints + BadIfaceFile {} -> + noHints + FailedToLoadDynamicInterface {} -> + noHints + +interfaceErrorReason :: IfaceMessage -> DiagnosticReason +interfaceErrorReason (Can'tFindInterface err _) + = missingInterfaceErrorReason err +interfaceErrorReason (Can'tFindNameInInterface {}) + = ErrorWithoutFlag + +missingInterfaceErrorReason :: MissingInterfaceError -> DiagnosticReason +missingInterfaceErrorReason = \ case + BadSourceImport {} -> + ErrorWithoutFlag + HomeModError {} -> + ErrorWithoutFlag + DynamicHashMismatchError {} -> + ErrorWithoutFlag + CantFindErr {} -> + ErrorWithoutFlag + BadIfaceFile {} -> + ErrorWithoutFlag + FailedToLoadDynamicInterface {} -> + ErrorWithoutFlag + + +prettyCantFindWhat :: FindOrLoad -> FindingModuleOrInterface -> AmbiguousOrMissing -> SDoc +prettyCantFindWhat Find FindingModule AoM_Missing = text "Could not find module" +prettyCantFindWhat Load FindingModule AoM_Missing = text "Could not load module" +prettyCantFindWhat _ FindingInterface AoM_Missing = text "Failed to load interface for" +prettyCantFindWhat _ FindingModule AoM_Ambiguous = text "Ambiguous module name" +prettyCantFindWhat _ FindingInterface AoM_Ambiguous = text "Ambiguous interface for" + +isAmbiguousInstalledReason :: CantFindInstalledReason -> AmbiguousOrMissing +isAmbiguousInstalledReason (MultiplePackages {}) = AoM_Ambiguous +isAmbiguousInstalledReason _ = AoM_Missing + +isLoadOrFindReason :: CantFindInstalledReason -> FindOrLoad +isLoadOrFindReason NotAModule {} = Find +isLoadOrFindReason (GenericMissing _ a b c _) | null a && null b && null c = Find +isLoadOrFindReason (ModuleSuggestion {}) = Find +isLoadOrFindReason _ = Load + +data FindOrLoad = Find | Load + +data AmbiguousOrMissing = AoM_Ambiguous | AoM_Missing + +cantFindError :: IfaceMessageOpts -> FindingModuleOrInterface -> CantFindInstalled -> SDoc +cantFindError opts mod_or_interface (CantFindInstalled mod_name cfir) = + let ambig = isAmbiguousInstalledReason cfir + find_or_load = isLoadOrFindReason cfir + ppr_what = prettyCantFindWhat find_or_load mod_or_interface ambig + in + (ppr_what <+> quotes (ppr mod_name) <> dot) $$ + case cfir of + NoUnitIdMatching pkg cands -> + + let looks_like_srcpkgid :: SDoc + looks_like_srcpkgid = + -- Unsafely coerce a unit id (i.e. an installed package component + -- identifier) into a PackageId and see if it means anything. + case cands of + (pkg:pkgs) -> + parens (text "This unit ID looks like the source package ID;" $$ + text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$ + (if null pkgs then empty + else text "and" <+> int (length pkgs) <+> text "other candidate" <> plural pkgs)) + -- Todo: also check if it looks like a package name! + [] -> empty + + in hsep [ text "no unit id matching" <+> quotes (ppr pkg) + , text "was found"] $$ looks_like_srcpkgid + MissingPackageFiles pkg files -> + text "There are files missing in the " <> quotes (ppr pkg) <+> + text "package," $$ + text "try running 'ghc-pkg check'." $$ + mayShowLocations verbose files + MissingPackageWayFiles build pkg files -> + text "Perhaps you haven't installed the " <> text build <+> + text "libraries for package " <> quotes (ppr pkg) <> char '?' $$ + mayShowLocations verbose files + ModuleSuggestion ms fps -> + + let pp_suggestions :: [ModuleSuggestion] -> SDoc + pp_suggestions sugs + | null sugs = empty + | otherwise = hang (text "Perhaps you meant") + 2 (vcat (map pp_sugg sugs)) + + -- NB: Prefer the *original* location, and then reexports, and then + -- package flags when making suggestions. ToDo: if the original package + -- also has a reexport, prefer that one + pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o + where provenance ModHidden = empty + provenance (ModUnusable _) = empty + provenance (ModOrigin{ fromOrigUnit = e, + fromExposedReexport = res, + fromPackageFlag = f }) + | Just True <- e + = parens (text "from" <+> ppr (moduleUnit mod)) + | f && moduleName mod == m + = parens (text "from" <+> ppr (moduleUnit mod)) + | (pkg:_) <- res + = parens (text "from" <+> ppr (mkUnit pkg) + <> comma <+> text "reexporting" <+> ppr mod) + | f + = parens (text "defined via package flags to be" + <+> ppr mod) + | otherwise = empty + pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o + where provenance ModHidden = empty + provenance (ModUnusable _) = empty + provenance (ModOrigin{ fromOrigUnit = e, + fromHiddenReexport = rhs }) + | Just False <- e + = parens (text "needs flag -package-id" + <+> ppr (moduleUnit mod)) + | (pkg:_) <- rhs + = parens (text "needs flag -package-id" + <+> ppr (mkUnit pkg)) + | otherwise = empty + + in pp_suggestions ms $$ mayShowLocations verbose fps + NotAModule -> text "It is not a module in the current program, or in any known package." + CouldntFindInFiles fps -> vcat (map text fps) + MultiplePackages mods + | Just pkgs <- unambiguousPackages + -> sep [text "it was found in multiple packages:", + hsep (map ppr pkgs)] + | otherwise + -> vcat (map pprMod mods) + where + unambiguousPackages = foldl' unambiguousPackage (Just []) mods + unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) + = Just (moduleUnit m : xs) + unambiguousPackage _ _ = Nothing + GenericMissing using_cabal pkg_hiddens mod_hiddens unusables files -> + vcat (map (pkg_hidden using_cabal) pkg_hiddens) $$ + vcat (map mod_hidden mod_hiddens) $$ + vcat (map unusable unusables) $$ + mayShowLocations verbose files + where + verbose = ifaceShowTriedFiles opts + + pprMod (m, o) = text "it is bound as" <+> ppr m <+> + text "by" <+> pprOrigin m o + pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" + pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" + pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( + if e == Just True + then [text "package" <+> ppr (moduleUnit m)] + else [] ++ + map ((text "a reexport in package" <+>) + .ppr.mkUnit) res ++ + if f then [text "a package flag"] else [] + ) + pkg_hidden :: BuildingCabalPackage -> (Unit, Maybe UnitInfo) -> SDoc + pkg_hidden using_cabal (uid, uif) = + text "It is a member of the hidden package" + <+> quotes (ppr uid) + --FIXME: we don't really want to show the unit id here we should + -- show the source package id or installed package id if it's ambiguous + <> dot $$ pkg_hidden_hint using_cabal uif + + pkg_hidden_hint using_cabal (Just pkg) + | using_cabal == YesBuildingCabalPackage + = text "Perhaps you need to add" <+> + quotes (ppr (unitPackageName pkg)) <+> + text "to the build-depends in your .cabal file." + -- MP: This is ghci specific, remove + | otherwise + = text "You can run" <+> + quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+> + text "to expose it." $$ + text "(Note: this unloads all the modules in the current scope.)" + pkg_hidden_hint _ Nothing = empty + + mod_hidden pkg = + text "it is a hidden module in the package" <+> quotes (ppr pkg) + + unusable (pkg, reason) + = text "It is a member of the package" + <+> quotes (ppr pkg) + $$ pprReason (text "which is") reason + +mayShowLocations :: Bool -> [FilePath] -> SDoc +mayShowLocations verbose files + | null files = empty + | not verbose = + text "Use -v (or `:set -v` in ghci) " <> + text "to see a list of the files searched for." + | otherwise = + hang (text "Locations searched:") 2 $ vcat (map text files) + +interfaceErrorDiagnostic :: IfaceMessageOpts -> IfaceMessage -> SDoc +interfaceErrorDiagnostic opts = \ case + Can'tFindNameInInterface name relevant_tyThings -> + missingDeclInInterface name relevant_tyThings + Can'tFindInterface err looking_for -> + case looking_for of + LookingForName {} -> + missingInterfaceErrorDiagnostic opts err + LookingForModule {} -> + missingInterfaceErrorDiagnostic opts err + LookingForHiBoot mod -> + hang (text "Could not find hi-boot interface for" <+> quotes (ppr mod) <> colon) + 2 (missingInterfaceErrorDiagnostic opts err) + LookingForSig sig -> + hang (text "Could not find interface file for signature" <+> quotes (ppr sig) <> colon) + 2 (missingInterfaceErrorDiagnostic opts err) + +readInterfaceErrorDiagnostic :: ReadInterfaceError -> SDoc +readInterfaceErrorDiagnostic = \ case + ExceptionOccurred fp ex -> + hang (text "Exception when reading interface file " <+> text fp) + 2 (text (showException ex)) + HiModuleNameMismatchWarn _ m1 m2 -> + hiModuleNameMismatchWarn m1 m2 + +missingInterfaceErrorDiagnostic :: IfaceMessageOpts -> MissingInterfaceError -> SDoc +missingInterfaceErrorDiagnostic opts reason = + case reason of + BadSourceImport m -> badSourceImport m + HomeModError im ml -> homeModError im ml + DynamicHashMismatchError m ml -> dynamicHashMismatchError m ml + CantFindErr us module_or_interface cfi -> pprWithUnitState us $ cantFindError opts module_or_interface cfi + BadIfaceFile rie -> readInterfaceErrorDiagnostic rie + FailedToLoadDynamicInterface wanted_mod err -> + hang (text "Failed to load dynamic interface file for" <+> ppr wanted_mod <> colon) + 2 (readInterfaceErrorDiagnostic err) + +hiModuleNameMismatchWarn :: Module -> Module -> SDoc +hiModuleNameMismatchWarn requested_mod read_mod + | moduleUnit requested_mod == moduleUnit read_mod = + sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma, + text "but we were expecting module" <+> quotes (ppr requested_mod), + sep [text "Probable cause: the source code which generated interface file", + text "has an incompatible module name" + ] + ] + | otherwise = + -- ToDo: This will fail to have enough qualification when the package IDs + -- are the same + withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ + -- we want the Modules below to be qualified with package names, + -- so reset the NamePprCtx setting. + hsep [ text "Something is amiss; requested module " + , ppr requested_mod + , text "differs from name found in the interface file" + , ppr read_mod + , parens (text "if these names look the same, try again with -dppr-debug") + ] + +dynamicHashMismatchError :: Module -> ModLocation -> SDoc +dynamicHashMismatchError wanted_mod loc = + vcat [ text "Dynamic hash doesn't match for" <+> quotes (ppr wanted_mod) + , text "Normal interface file from" <+> text (ml_hi_file loc) + , text "Dynamic interface file from" <+> text (ml_dyn_hi_file loc) + , text "You probably need to recompile" <+> quotes (ppr wanted_mod) ] + +homeModError :: InstalledModule -> ModLocation -> SDoc +-- See Note [Home module load error] +homeModError mod location + = text "attempting to use module " <> quotes (ppr mod) + <> (case ml_hs_file location of + Just file -> space <> parens (text file) + Nothing -> empty) + <+> text "which is not loaded" + + +missingDeclInInterface :: Name -> [TyThing] -> SDoc +missingDeclInInterface name things = + whenPprDebug (found_things $$ empty) $$ + hang (text "Can't find interface-file declaration for" <+> + pprNameSpace (nameNameSpace name) <+> ppr name) + 2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file", + text "Use -ddump-if-trace to get an idea of which file caused the error"]) + where + found_things = + hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon) + 2 (vcat (map ppr things)) + +badSourceImport :: Module -> SDoc +badSourceImport mod + = hang (text "You cannot {-# SOURCE #-} import a module from another package") + 2 (text "but" <+> quotes (ppr mod) <+> text "is from package" + <+> quotes (ppr (moduleUnit mod))) diff --git a/compiler/GHC/Iface/Errors/Types.hs b/compiler/GHC/Iface/Errors/Types.hs new file mode 100644 index 0000000000..a421c2eeb7 --- /dev/null +++ b/compiler/GHC/Iface/Errors/Types.hs @@ -0,0 +1,90 @@ + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} + +module GHC.Iface.Errors.Types ( + + MissingInterfaceError(..) + , InterfaceLookingFor(..) + , IfaceMessage(..) + , ReadInterfaceError(..) + , CantFindInstalled(..) + , CantFindInstalledReason(..) + , FindingModuleOrInterface(..) + + , BuildingCabalPackage(..) + + ) where + +import GHC.Prelude + +import GHC.Hs +import GHC.Types.Name (Name) +import GHC.Types.TyThing (TyThing) +import GHC.Unit.Types (Module, InstalledModule, UnitId, Unit) +import GHC.Unit.State (UnitState, ModuleSuggestion, ModuleOrigin, UnusableUnitReason, UnitInfo) +import GHC.Exception.Type (SomeException) + + + +import GHC.Generics ( Generic ) +import GHC.Unit.Module.Location + +data InterfaceLookingFor + = LookingForName !Name + | LookingForHiBoot !Module + | LookingForModule !ModuleName !IsBootInterface + | LookingForSig !InstalledModule + +data IfaceMessage + = Can'tFindInterface + MissingInterfaceError + InterfaceLookingFor + | Can'tFindNameInInterface + Name + [TyThing] -- possibly relevant TyThings + deriving Generic + +data MissingInterfaceError + = BadSourceImport !Module + | HomeModError !InstalledModule !ModLocation + | DynamicHashMismatchError !Module !ModLocation + + | CantFindErr !UnitState FindingModuleOrInterface CantFindInstalled + + | BadIfaceFile ReadInterfaceError + | FailedToLoadDynamicInterface Module ReadInterfaceError + deriving Generic + +data ReadInterfaceError + = ExceptionOccurred FilePath SomeException + | HiModuleNameMismatchWarn FilePath Module Module + deriving Generic + +data CantFindInstalledReason + = NoUnitIdMatching UnitId [UnitInfo] + | MissingPackageFiles UnitId [FilePath] + | MissingPackageWayFiles String UnitId [FilePath] + | ModuleSuggestion [ModuleSuggestion] [FilePath] + | NotAModule + | CouldntFindInFiles [FilePath] + | GenericMissing BuildingCabalPackage + [(Unit, Maybe UnitInfo)] [Unit] + [(Unit, UnusableUnitReason)] [FilePath] + | MultiplePackages [(Module, ModuleOrigin)] + deriving Generic + +data CantFindInstalled = + CantFindInstalled ModuleName CantFindInstalledReason + deriving Generic +data FindingModuleOrInterface = FindingModule + | FindingInterface + +-- | Pass to a 'DriverMessage' the information whether or not the +-- '-fbuilding-cabal-package' flag is set. +data BuildingCabalPackage + = YesBuildingCabalPackage + | NoBuildingCabalPackage + deriving Eq diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index e794c7c6d2..5305a97623 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -116,6 +116,7 @@ import Data.Map ( toList ) import System.FilePath import System.Directory import GHC.Driver.Env.KnotVars +import GHC.Iface.Errors.Types {- ************************************************************************ @@ -143,7 +144,7 @@ where the code that e1 expands to might import some defns that also turn out to be needed by the code that e2 expands to. -} -tcLookupImported_maybe :: Name -> TcM (MaybeErr SDoc TyThing) +tcLookupImported_maybe :: Name -> TcM (MaybeErr IfaceMessage TyThing) -- Returns (Failed err) if we can't find the interface file for the thing tcLookupImported_maybe name = do { hsc_env <- getTopEnv @@ -152,7 +153,7 @@ tcLookupImported_maybe name Just thing -> return (Succeeded thing) Nothing -> tcImportDecl_maybe name } -tcImportDecl_maybe :: Name -> TcM (MaybeErr SDoc TyThing) +tcImportDecl_maybe :: Name -> TcM (MaybeErr IfaceMessage TyThing) -- Entry point for *source-code* uses of importDecl tcImportDecl_maybe name | Just thing <- wiredInNameTyThing_maybe name @@ -163,7 +164,7 @@ tcImportDecl_maybe name | otherwise = initIfaceTcRn (importDecl name) -importDecl :: Name -> IfM lcl (MaybeErr SDoc TyThing) +importDecl :: Name -> IfM lcl (MaybeErr IfaceMessage TyThing) -- Get the TyThing for this Name from an interface file -- It's not a wired-in thing -- the caller caught that importDecl name @@ -174,29 +175,22 @@ importDecl name -- Load the interface, which should populate the PTE ; mb_iface <- assertPpr (isExternalName name) (ppr name) $ loadInterface nd_doc (nameModule name) ImportBySystem - ; case mb_iface of { - Failed err_msg -> return (Failed err_msg) ; - Succeeded _ -> do + ; case mb_iface of + { Failed err_msg -> return $ Failed $ + Can'tFindInterface err_msg (LookingForName name) + ; Succeeded _ -> do -- Now look it up again; this time we should find it { eps <- getEps ; case lookupTypeEnv (eps_PTE eps) name of Just thing -> return $ Succeeded thing - Nothing -> let doc = whenPprDebug (found_things_msg eps $$ empty) - $$ not_found_msg - in return $ Failed doc + Nothing -> return $ Failed $ + Can'tFindNameInInterface name + (filter is_interesting $ nonDetNameEnvElts $ eps_PTE eps) }}} where nd_doc = text "Need decl for" <+> ppr name - not_found_msg = hang (text "Can't find interface-file declaration for" <+> - pprNameSpace (nameNameSpace name) <+> ppr name) - 2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file", - text "Use -ddump-if-trace to get an idea of which file caused the error"]) - found_things_msg eps = - hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon) - 2 (vcat (map ppr $ filter is_interesting $ nonDetNameEnvElts $ eps_PTE eps)) - where - is_interesting thing = nameModule name == nameModule (getName thing) + is_interesting thing = nameModule name == nameModule (getName thing) {- @@ -299,15 +293,21 @@ loadSrcInterface :: SDoc loadSrcInterface doc mod want_boot maybe_pkg = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg ; case res of - Failed err -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err) - Succeeded iface -> return iface } + Failed err -> + failWithTc $ + TcRnInterfaceError $ + Can'tFindInterface err $ + LookingForModule mod want_boot + Succeeded iface -> + return iface + } -- | Like 'loadSrcInterface', but returns a 'MaybeErr'. loadSrcInterface_maybe :: SDoc -> ModuleName -> IsBootInterface -- {-# SOURCE #-} ? -> PkgQual -- "package", if any - -> RnM (MaybeErr SDoc ModIface) + -> RnM (MaybeErr MissingInterfaceError ModIface) loadSrcInterface_maybe doc mod want_boot maybe_pkg -- We must first find which Module this import refers to. This involves @@ -403,11 +403,11 @@ loadInterfaceWithException doc mod_name where_from = do dflags <- getDynFlags let ctx = initSDocContext dflags defaultUserStyle - withException ctx (loadInterface doc mod_name where_from) + withIfaceErr ctx (loadInterface doc mod_name where_from) ------------------ loadInterface :: SDoc -> Module -> WhereFrom - -> IfM lcl (MaybeErr SDoc ModIface) + -> IfM lcl (MaybeErr MissingInterfaceError ModIface) -- loadInterface looks in both the HPT and PIT for the required interface -- If not found, it loads it, and puts it in the PIT (always). @@ -703,7 +703,7 @@ computeInterface -> SDoc -> IsBootInterface -> Module - -> IO (MaybeErr SDoc (ModIface, FilePath)) + -> IO (MaybeErr MissingInterfaceError (ModIface, FilePath)) computeInterface hsc_env doc_str hi_boot_file mod0 = do massert (not (isHoleModule mod0)) let mhome_unit = hsc_home_unit_maybe hsc_env @@ -732,7 +732,7 @@ computeInterface hsc_env doc_str hi_boot_file mod0 = do -- @p[A=\<A>,B=\<B>]:B@ never includes B. moduleFreeHolesPrecise :: SDoc -> Module - -> TcRnIf gbl lcl (MaybeErr SDoc (UniqDSet ModuleName)) + -> TcRnIf gbl lcl (MaybeErr MissingInterfaceError (UniqDSet ModuleName)) moduleFreeHolesPrecise doc_str mod | moduleIsDefinite mod = return (Succeeded emptyUniqDSet) | otherwise = @@ -769,13 +769,13 @@ moduleFreeHolesPrecise doc_str mod Failed err -> return (Failed err) wantHiBootFile :: Maybe HomeUnit -> ExternalPackageState -> Module -> WhereFrom - -> MaybeErr SDoc IsBootInterface + -> MaybeErr MissingInterfaceError IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot wantHiBootFile mhome_unit eps mod from = case from of ImportByUser usr_boot | usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod - -> Failed (badSourceImport mod) + -> Failed (BadSourceImport mod) | otherwise -> Succeeded usr_boot ImportByPlugin @@ -798,11 +798,6 @@ wantHiBootFile mhome_unit eps mod from -- The boot-ness of the requested interface, -- based on the dependencies in directly-imported modules -badSourceImport :: Module -> SDoc -badSourceImport mod - = hang (text "You cannot {-# SOURCE #-} import a module from another package") - 2 (text "but" <+> quotes (ppr mod) <+> text "is from package" - <+> quotes (ppr (moduleUnit mod))) ----------------------------------------------------- -- Loading type/class/value decls @@ -855,7 +850,7 @@ findAndReadIface -- this to check the consistency of the requirements of the -- module we read out. -> IsBootInterface -- ^ Looking for .hi-boot or .hi file - -> IO (MaybeErr SDoc (ModIface, FilePath)) + -> IO (MaybeErr MissingInterfaceError (ModIface, FilePath)) findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do let profile = targetProfile dflags @@ -897,12 +892,12 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do Just home_unit | isHomeInstalledModule home_unit mod , not (isOneShot (ghcMode dflags)) - -> return (Failed (homeModError mod loc)) + -> return (Failed (HomeModError mod loc)) _ -> do r <- read_file logger name_cache unit_state dflags wanted_mod (ml_hi_file loc) case r of - Failed _ - -> return r + Failed err + -> return (Failed $ BadIfaceFile err) Succeeded (iface,_fp) -> do r2 <- load_dynamic_too_maybe logger name_cache unit_state @@ -910,46 +905,47 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do iface loc case r2 of Failed sdoc -> return (Failed sdoc) - Succeeded {} -> return r + Succeeded {} -> return $ Succeeded (iface,_fp) err -> do trace_if logger (text "...not found") return $ Failed $ cannotFindInterface unit_state mhome_unit profile - (Iface_Errors.mayShowLocations dflags) (moduleName mod) err -- | Check if we need to try the dynamic interface for -dynamic-too -load_dynamic_too_maybe :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr SDoc ()) +load_dynamic_too_maybe :: Logger -> NameCache -> UnitState -> DynFlags + -> Module -> ModIface -> ModLocation + -> IO (MaybeErr MissingInterfaceError ()) load_dynamic_too_maybe logger name_cache unit_state dflags wanted_mod iface loc -- Indefinite interfaces are ALWAYS non-dynamic. | not (moduleIsDefinite (mi_module iface)) = return (Succeeded ()) | gopt Opt_BuildDynamicToo dflags = load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc | otherwise = return (Succeeded ()) -load_dynamic_too :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr SDoc ()) +load_dynamic_too :: Logger -> NameCache -> UnitState -> DynFlags + -> Module -> ModIface -> ModLocation + -> IO (MaybeErr MissingInterfaceError ()) load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc = do read_file logger name_cache unit_state dflags wanted_mod (ml_dyn_hi_file loc) >>= \case Succeeded (dynIface, _) | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) -> return (Succeeded ()) | otherwise -> - do return $ (Failed $ dynamicHashMismatchError wanted_mod loc) + do return $ (Failed $ DynamicHashMismatchError wanted_mod loc) Failed err -> - do return $ (Failed $ ((text "Failed to load dynamic interface file for" <+> ppr wanted_mod <> colon) $$ err)) + do return $ (Failed $ FailedToLoadDynamicInterface wanted_mod err) + --((text "Failed to load dynamic interface file for" <+> ppr wanted_mod <> colon) $$ err)) -dynamicHashMismatchError :: Module -> ModLocation -> SDoc -dynamicHashMismatchError wanted_mod loc = - vcat [ text "Dynamic hash doesn't match for" <+> quotes (ppr wanted_mod) - , text "Normal interface file from" <+> text (ml_hi_file loc) - , text "Dynamic interface file from" <+> text (ml_dyn_hi_file loc) - , text "You probably need to recompile" <+> quotes (ppr wanted_mod) ] -read_file :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> FilePath -> IO (MaybeErr SDoc (ModIface, FilePath)) + +read_file :: Logger -> NameCache -> UnitState -> DynFlags + -> Module -> FilePath + -> IO (MaybeErr ReadInterfaceError (ModIface, FilePath)) read_file logger name_cache unit_state dflags wanted_mod file_path = do trace_if logger (text "readIFace" <+> text file_path) @@ -964,7 +960,7 @@ read_file logger name_cache unit_state dflags wanted_mod file_path = do (uninstantiateInstantiatedModule indef_mod) read_result <- readIface dflags name_cache wanted_mod' file_path case read_result of - Failed err -> return (Failed (badIfaceFile file_path err)) + Failed err -> return (Failed err) Succeeded iface -> return (Succeeded (iface, file_path)) -- Don't forget to fill in the package name... @@ -985,7 +981,7 @@ readIface -> NameCache -> Module -> FilePath - -> IO (MaybeErr SDoc ModIface) + -> IO (MaybeErr ReadInterfaceError ModIface) readIface dflags name_cache wanted_mod file_path = do let profile = targetProfile dflags res <- tryMost $ readBinIface profile name_cache CheckHiWay QuietBinIFace file_path @@ -999,9 +995,9 @@ readIface dflags name_cache wanted_mod file_path = do | otherwise -> return (Failed err) where actual_mod = mi_module iface - err = hiModuleNameMismatchWarn wanted_mod actual_mod + err = HiModuleNameMismatchWarn file_path wanted_mod actual_mod - Left exn -> return (Failed (text (showException exn))) + Left exn -> return (Failed (ExceptionOccurred file_path exn)) {- ********************************************************* diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 2e1150910b..b0e668f0e6 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -83,6 +83,7 @@ import GHC.List (uncons) import Data.Ord import Data.Containers.ListUtils import Data.Bifunctor +import GHC.Iface.Errors.Ppr {- ----------------------------------------------- @@ -292,8 +293,13 @@ check_old_iface hsc_env mod_summary maybe_iface read_result <- readIface read_dflags ncu (ms_mod mod_summary) iface_path case read_result of Failed err -> do - trace_if logger (text "FYI: cannot read old interface file:" $$ nest 4 err) - trace_hi_diffs logger (text "Old interface file was invalid:" $$ nest 4 err) + let msg = readInterfaceErrorDiagnostic err + trace_if logger + $ vcat [ text "FYI: cannot read old interface file:" + , nest 4 msg ] + trace_hi_diffs logger $ + vcat [ text "Old interface file was invalid:" + , nest 4 msg ] return Nothing Succeeded iface -> do trace_if logger (text "Read the interface file" <+> text iface_path) @@ -1323,7 +1329,7 @@ getOrphanHashes hsc_env mods = do dflags = hsc_dflags hsc_env ctx = initSDocContext dflags defaultUserStyle get_orph_hash mod = do - iface <- initIfaceLoad hsc_env . withException ctx + iface <- initIfaceLoad hsc_env . withIfaceErr ctx $ loadInterface (text "getOrphanHashes") mod ImportBySystem return (mi_orphan_hash (mi_final_exts iface)) @@ -1618,7 +1624,7 @@ mkHashFun hsc_env eps name -- requirements; we didn't do any /real/ typechecking -- so there's no guarantee everything is loaded. -- Kind of a heinous hack. - initIfaceLoad hsc_env . withException ctx + initIfaceLoad hsc_env . withIfaceErr ctx $ withoutDynamicNow -- If you try and load interfaces when dynamic-too -- enabled then it attempts to load the dyn_hi and hi diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index aaacb86b7f..2a81b9c2a0 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -132,6 +132,7 @@ import GHC.Unit.Module.WholeCoreBindings import Data.IORef import Data.Foldable import GHC.Builtin.Names (ioTyConName, rOOT_MAIN) +import GHC.Iface.Errors.Types {- This module takes @@ -576,13 +577,14 @@ tcHiBootIface hsc_src mod -- to check consistency against, rather than just when we notice -- that an hi-boot is necessary due to a circular import. { hsc_env <- getTopEnv - ; read_result <- liftIO $ findAndReadIface hsc_env - need (fst (getModuleInstantiation mod)) mod - IsBoot -- Hi-boot file + ; read_result <- liftIO $ findAndReadIface hsc_env need + (fst (getModuleInstantiation mod)) mod + IsBoot -- Hi-boot file ; case read_result of { - Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface - ; mkSelfBootInfo iface tc_iface } ; + Succeeded (iface, _path) -> + do { tc_iface <- initIfaceTcRn $ typecheckIface iface + ; mkSelfBootInfo iface tc_iface } ; Failed err -> -- There was no hi-boot file. But if there is circularity in @@ -598,7 +600,10 @@ tcHiBootIface hsc_src mod Nothing -> return NoSelfBoot -- error cases Just (GWIB { gwib_isBoot = is_boot }) -> case is_boot of - IsBoot -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints (elaborate err)) + IsBoot -> + let diag = Can'tFindInterface err + (LookingForHiBoot mod) + in failWithTc (TcRnInterfaceError diag) -- The hi-boot file has mysteriously disappeared. NotBoot -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints moduleLoop) -- Someone below us imported us! @@ -611,8 +616,6 @@ tcHiBootIface hsc_src mod moduleLoop = text "Circular imports: module" <+> quotes (ppr mod) <+> text "depends on itself" - elaborate err = hang (text "Could not find hi-boot interface for" <+> - quotes (ppr mod) <> colon) 4 err mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo @@ -1968,7 +1971,7 @@ tcIfaceGlobal name { mb_thing <- importDecl name -- It's imported; go get it ; case mb_thing of - Failed err -> failIfM (ppr name <+> err) + Failed err -> failIfM (ppr name <+> pprDiagnostic err) Succeeded thing -> return thing }}} diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs index 7080bb0776..f6caa18a9d 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -119,6 +119,7 @@ import GHC.Iface.Load import GHC.Unit.Home import Data.Either import Control.Applicative +import GHC.Iface.Errors.Ppr uninitialised :: a uninitialised = panic "Loader not initialised" @@ -789,7 +790,10 @@ getLinkDeps hsc_env pls replace_osuf span mods mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $ loadInterface msg mod (ImportByUser NotBoot) iface <- case mb_iface of - Maybes.Failed err -> throwGhcExceptionIO (ProgramError (showSDoc dflags err)) + Maybes.Failed err -> + let opts = initIfaceMessageOpts dflags + err_txt = missingInterfaceErrorDiagnostic opts err + in throwGhcExceptionIO (ProgramError (showSDoc dflags err_txt)) Maybes.Succeeded iface -> return iface when (mi_boot iface == IsBoot) $ link_boot_mod_error mod diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index ebfa7875e5..cbe376b9cd 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -45,16 +45,20 @@ import GHC.Core.Type ( Type, mkTyConTy ) import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.TyCon ( TyCon ) + import GHC.Types.SrcLoc ( noSrcSpan ) import GHC.Types.Name ( Name, nameModule_maybe ) import GHC.Types.Id ( idType ) import GHC.Types.TyThing import GHC.Types.Name.Occurrence ( OccName, mkVarOccFS ) import GHC.Types.Name.Reader +import GHC.Types.Unique.DFM + import GHC.Unit.Finder ( findPluginModule, FindResult(..) ) import GHC.Driver.Config.Finder ( initFinderOpts ) +import GHC.Driver.Config.Diagnostic ( initIfaceMessageOpts ) import GHC.Unit.Module ( Module, ModuleName ) -import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModIface ( ModIface_(mi_exports), ModIface ) import GHC.Unit.Env import GHC.Utils.Panic @@ -68,8 +72,9 @@ import Control.Monad ( unless ) import Data.Maybe ( mapMaybe ) import Unsafe.Coerce ( unsafeCoerce ) import GHC.Linker.Types -import GHC.Types.Unique.DFM import Data.List (unzip4) +import GHC.Iface.Errors.Ppr + -- | Loads the plugins specified in the pluginModNames field of the dynamic -- flags. Should be called after command line arguments are parsed, but before @@ -329,7 +334,11 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do _ -> panic "lookupRdrNameInModule" Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name] - err -> throwCmdLineErrorS dflags $ cannotFindModule hsc_env mod_name err + err -> + let opts = initIfaceMessageOpts dflags + err_txt = missingInterfaceErrorDiagnostic opts + $ cannotFindModule hsc_env mod_name err + in throwCmdLineErrorS dflags err_txt where doc = text "contains a name used in an invocation of lookupRdrNameInModule" diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 0d253cbf6b..5cc8ab5f64 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -76,7 +76,7 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Fixity (defaultFixity) -import GHC.Unit.State (pprWithUnitState, UnitState) +import GHC.Unit.State import GHC.Unit.Module import GHC.Unit.Module.Warnings ( warningTxtCategory, pprWarningTxtForMsg ) @@ -101,13 +101,16 @@ import Data.Ord ( comparing ) import Data.Bifunctor import qualified Language.Haskell.TH as TH import {-# SOURCE #-} GHC.Tc.Types (pprTcTyThingCategory) +import GHC.Iface.Errors.Types +import GHC.Iface.Errors.Ppr data TcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext :: !Bool -- ^ Whether we show the error context or not + , tcOptsIfaceOpts :: !IfaceMessageOpts } defaultTcRnMessageOpts :: TcRnMessageOpts -defaultTcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext = True } - +defaultTcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext = True + , tcOptsIfaceOpts = defaultDiagnosticOpts @IfaceMessage } instance Diagnostic TcRnMessage where type DiagnosticOpts TcRnMessage = TcRnMessageOpts @@ -1245,7 +1248,6 @@ instance Diagnostic TcRnMessage where True -> text (show item) False -> text (TH.pprint item)) TcRnReportCustomQuasiError _ msg -> mkSimpleDecorated $ text msg - TcRnInterfaceLookupError _ sdoc -> mkSimpleDecorated sdoc TcRnUnsatisfiedMinimalDef mindef -> mkSimpleDecorated $ vcat [text "No explicit implementation for" @@ -1733,6 +1735,8 @@ instance Diagnostic TcRnMessage where ppr (frr_context frr) $$ text "cannot be assigned a fixed runtime representation," <+> text "not even by defaulting." + TcRnInterfaceError reason + -> diagnosticMessage (tcOptsIfaceOpts opts) reason diagnosticReason = \case TcRnUnknownMessage m @@ -2105,8 +2109,6 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnReportCustomQuasiError isError _ -> if isError then ErrorWithoutFlag else WarningWithoutFlag - TcRnInterfaceLookupError{} - -> ErrorWithoutFlag TcRnUnsatisfiedMinimalDef{} -> WarningWithFlag (Opt_WarnMissingMethods) TcRnMisplacedInstSig{} @@ -2307,6 +2309,9 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnCannotDefaultConcrete{} -> ErrorWithoutFlag + TcRnInterfaceError err + -> interfaceErrorReason err + diagnosticHints = \case TcRnUnknownMessage m @@ -2685,8 +2690,6 @@ instance Diagnostic TcRnMessage where -> noHints TcRnReportCustomQuasiError{} -> noHints - TcRnInterfaceLookupError{} - -> noHints TcRnUnsatisfiedMinimalDef{} -> noHints TcRnMisplacedInstSig{} @@ -2908,6 +2911,8 @@ instance Diagnostic TcRnMessage where -> noHints TcRnCannotDefaultConcrete{} -> [SuggestAddTypeSignatures UnnamedBinding] + TcRnInterfaceError reason + -> interfaceErrorHints reason diagnosticCode = constructorCode diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index a8d7c30846..38615d0f0d 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -124,6 +124,7 @@ import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol) import GHC.Tc.Types.Rank (Rank) import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType, TcSigmaType, TcPredType) import GHC.Types.Avail (AvailInfo) +import GHC.Types.Basic import GHC.Types.Error import GHC.Types.Hint (UntickedPromotedThing(..)) import GHC.Types.ForeignCall (CLabelString) @@ -151,7 +152,6 @@ import GHC.Core.TyCon (TyCon, Role) import GHC.Core.Type (Kind, Type, ThetaType, PredType) import GHC.Driver.Backend (Backend) import GHC.Unit.State (UnitState) -import GHC.Types.Basic import GHC.Utils.Misc (capitalise, filterOut) import qualified GHC.LanguageExtensions as LangExt import GHC.Data.FastString (FastString) @@ -166,6 +166,7 @@ import qualified Language.Haskell.TH.Syntax as TH import GHC.Generics ( Generic ) import GHC.Types.Name.Env (NameEnv) +import GHC.Iface.Errors.Types {- Note [Migrating TcM Messages] @@ -232,6 +233,11 @@ data TcRnMessage where -} TcRnUnknownMessage :: UnknownDiagnostic -> TcRnMessage + {-| Wrap an 'IfaceMessage' to a 'TcRnMessage' for when we attempt to load interface + files during typechecking but encounter an error. -} + + TcRnInterfaceError :: !IfaceMessage -> TcRnMessage + {-| TcRnMessageWithInfo is a constructor which is used when extra information is needed to be provided in order to qualify a diagnostic and where it was originated (and why). It carries an extra 'UnitState' which can be used to pretty-print some names @@ -2723,14 +2729,6 @@ data TcRnMessage where -> !String -- Error body -> TcRnMessage - {-| TcRnInterfaceLookupError is an error resulting from looking up a name in an interface file. - - Example(s): - - Test cases: - -} - TcRnInterfaceLookupError :: !Name -> !SDoc -> TcRnMessage - {- | TcRnUnsatisfiedMinimalDef is a warning that occurs when a class instance is missing methods that are required by the minimal definition. diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index fcfe39cb4d..e28ba6f24f 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -2029,7 +2029,7 @@ tcLookupTh name do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return (AGlobal thing) - Failed msg -> failWithTc (TcRnInterfaceLookupError name msg) + Failed msg -> failWithTc (TcRnInterfaceError msg) }}}} notInScope :: TH.Name -> TcRnMessage diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 20508c0fa4..5f76ba7e0c 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -87,6 +87,8 @@ import GHC.Data.Maybe import Control.Monad import Data.List (find) +import GHC.Iface.Errors.Types + checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn () checkHsigDeclM sig_iface sig_thing real_thing = do let name = getName real_thing @@ -152,7 +154,7 @@ checkHsigIface tcg_env gre_env sig_iface -- tcg_env (TODO: but maybe this isn't relevant anymore). r <- tcLookupImported_maybe name case r of - Failed err -> addErr (TcRnInterfaceLookupError name err) + Failed err -> addErr (TcRnInterfaceError err) Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing -- The hsig did NOT define this function; that means it must @@ -262,7 +264,7 @@ findExtraSigImports hsc_env HsigFile modname = do reqs = requirementMerges unit_state modname holes <- forM reqs $ \(Module iuid mod_name) -> do initIfaceLoad hsc_env - . withException ctx + . withIfaceErr ctx $ moduleFreeHolesPrecise (text "findExtraSigImports") (mkModule (VirtUnit iuid) mod_name) return (uniqDSetToList (unionManyUniqDSets holes)) @@ -547,9 +549,8 @@ mergeSignatures im = fst (getModuleInstantiation m) ctx = initSDocContext dflags defaultUserStyle fmap fst - . withException ctx - $ findAndReadIface hsc_env - (text "mergeSignatures") im m NotBoot + . withIfaceErr ctx + $ findAndReadIface hsc_env (text "mergeSignatures") im m NotBoot -- STEP 3: Get the unrenamed exports of all these interfaces, -- thin it according to the export list, and do shaping on them. @@ -980,9 +981,9 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do isig_mod sig_mod NotBoot isig_iface <- case mb_isig_iface of Succeeded (iface, _) -> return iface - Failed err -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Could not find hi interface for signature" <+> - quotes (ppr isig_mod) <> colon) 4 err + Failed err -> + failWithTc $ TcRnInterfaceError $ + Can'tFindInterface err (LookingForSig isig_mod) -- STEP 3: Check that the implementing interface exports everything -- we need. (Notice we IGNORE the Modules in the AvailInfos.) diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index 52bf245dc5..b8f9d83912 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -25,7 +25,7 @@ module GHC.Tc.Utils.Env( tcLookupRecSelParent, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, tcLookupLocatedClass, tcLookupAxiom, - lookupGlobal, lookupGlobal_maybe, ioLookupDataCon, + lookupGlobal, lookupGlobal_maybe, addTypecheckedBinds, -- Local environment @@ -136,11 +136,12 @@ import GHC.Types.Name.Reader import GHC.Types.TyThing import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) import qualified GHC.LanguageExtensions as LangExt -import GHC.Tc.Errors.Ppr (pprTyThingUsedWrong) import Data.IORef import Data.List ( intercalate ) import Control.Monad +import GHC.Iface.Errors.Types +import GHC.Types.Error {- ********************************************************************* * * @@ -156,10 +157,13 @@ lookupGlobal hsc_env name mb_thing <- lookupGlobal_maybe hsc_env name ; case mb_thing of Succeeded thing -> return thing - Failed msg -> pprPanic "lookupGlobal" msg + Failed err -> + let msg = case err of + Left name -> text "Could not find local name:" <+> ppr name + Right err -> pprDiagnostic err + in pprPanic "lookupGlobal" msg } - -lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) +lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr (Either Name IfaceMessage) TyThing) -- This may look up an Id that one has previously looked up. -- If so, we are going to read its interface file, and add its bindings -- to the ExternalPackageTable. @@ -170,24 +174,26 @@ lookupGlobal_maybe hsc_env name tcg_semantic_mod = homeModuleInstantiation mhome_unit mod ; if nameIsLocalOrFrom tcg_semantic_mod name - then (return - (Failed (text "Can't find local name: " <+> ppr name))) - -- Internal names can happen in GHCi - else - -- Try home package table and external package table - lookupImported_maybe hsc_env name + then return $ Failed $ Left name + -- Internal names can happen in GHCi + else do + res <- lookupImported_maybe hsc_env name + -- Try home package table and external package table + return $ case res of + Succeeded ok -> Succeeded ok + Failed err -> Failed (Right err) } -lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) +lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing) -- Returns (Failed err) if we can't find the interface file for the thing lookupImported_maybe hsc_env name = do { mb_thing <- lookupType hsc_env name ; case mb_thing of Just thing -> return (Succeeded thing) Nothing -> importDecl_maybe hsc_env name - } + } -importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) +importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing) importDecl_maybe hsc_env name | Just thing <- wiredInNameTyThing_maybe name = do { when (needWiredInHomeIface thing) @@ -197,23 +203,6 @@ importDecl_maybe hsc_env name | otherwise = initIfaceLoad hsc_env (importDecl name) --- | A 'TyThing'... except it's not the right sort. -type WrongTyThing = TyThing - -ioLookupDataCon :: HscEnv -> Name -> IO DataCon -ioLookupDataCon hsc_env name = do - mb_thing <- ioLookupDataCon_maybe hsc_env name - case mb_thing of - Succeeded thing -> return thing - Failed thing -> pprPanic "lookupDataConIO" (pprTyThingUsedWrong WrongThingDataCon (AGlobal thing) name) - -ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr WrongTyThing DataCon) -ioLookupDataCon_maybe hsc_env name = do - thing <- lookupGlobal hsc_env name - return $ case thing of - AConLike (RealDataCon con) -> Succeeded con - _ -> Failed thing - addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv addTypecheckedBinds tcg_env binds | isHsBootOrSig (tcg_src tcg_env) = tcg_env @@ -263,7 +252,7 @@ tcLookupGlobal name do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return thing - Failed msg -> failWithTc (TcRnInterfaceLookupError name msg) + Failed msg -> failWithTc (TcRnInterfaceError msg) }}} -- Look up only in this module's global env't. Don't look in imports, etc. diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index d713fce376..75b74cbb35 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -138,7 +139,7 @@ module GHC.Tc.Utils.Monad( forkM, setImplicitEnvM, - withException, + withException, withIfaceErr, -- * Stuff for cost centres. getCCIndexM, getCCIndexTcM, @@ -222,6 +223,8 @@ import qualified Data.Map as Map import GHC.Driver.Env.KnotVars import GHC.Linker.Types import GHC.Types.Unique.DFM +import GHC.Iface.Errors.Types +import GHC.Iface.Errors.Ppr {- ************************************************************************ @@ -661,6 +664,16 @@ withException ctx do_this = do Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx err)) Succeeded result -> return result +withIfaceErr :: MonadIO m => SDocContext -> m (MaybeErr MissingInterfaceError a) -> m a +withIfaceErr ctx do_this = do + r <- do_this + case r of + Failed err -> do + let opts = defaultDiagnosticOpts @IfaceMessage + msg = missingInterfaceErrorDiagnostic opts err + liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx msg)) + Succeeded result -> return result + {- ************************************************************************ * * diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index 0eccf085bb..b0454cac6b 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -35,6 +35,8 @@ module GHC.Types.Error , mkDecoratedDiagnostic , mkDecoratedError + , pprDiagnostic + , NoDiagnosticOpts(..) -- * Hints and refactoring actions diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs index b85e484ea2..e5d7a84bb6 100644 --- a/compiler/GHC/Types/Error/Codes.hs +++ b/compiler/GHC/Types/Error/Codes.hs @@ -38,6 +38,7 @@ import GHC.Generics import GHC.TypeLits ( Symbol, TypeError, ErrorMessage(..) ) import GHC.TypeNats ( Nat, KnownNat, natVal' ) import GHC.Core.InstEnv (LookupInstanceErrReason) +import GHC.Iface.Errors.Types {- Note [Diagnostic codes] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -663,6 +664,22 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "OneArgExpected" = 91490 GhcDiagnosticCode "AtLeastOneArgExpected" = 07641 + -- Interface errors + GhcDiagnosticCode "BadSourceImport" = 64852 + GhcDiagnosticCode "HomeModError" = 58427 + GhcDiagnosticCode "DynamicHashMismatchError" = 54709 + GhcDiagnosticCode "CouldntFindInFiles" = 94559 + GhcDiagnosticCode "GenericMissing" = 87110 + GhcDiagnosticCode "MissingPackageFiles" = 22211 + GhcDiagnosticCode "MissingPackageWayFiles" = 88719 + GhcDiagnosticCode "ModuleSuggestion" = 61948 + GhcDiagnosticCode "MultiplePackages" = 45102 + GhcDiagnosticCode "NoUnitIdMatching" = 51294 + GhcDiagnosticCode "NotAModule" = 35235 + GhcDiagnosticCode "Can'tFindNameInInterface" = 83249 + GhcDiagnosticCode "HiModuleNameMismatchWarn" = 53693 + GhcDiagnosticCode "ExceptionOccurred" = 47808 + -- Out of scope errors GhcDiagnosticCode "NotInScope" = 76037 GhcDiagnosticCode "NotARecordField" = 22385 @@ -757,6 +774,15 @@ type family ConRecursInto con where ConRecursInto "DriverUnknownMessage" = 'Just UnknownDiagnostic ConRecursInto "DriverPsHeaderMessage" = 'Just PsMessage + ConRecursInto "DriverInterfaceError" = 'Just IfaceMessage + + ConRecursInto "CantFindErr" = 'Just CantFindInstalled + ConRecursInto "CantFindInstalledErr" = 'Just CantFindInstalled + + ConRecursInto "CantFindInstalled" = 'Just CantFindInstalledReason + + ConRecursInto "BadIfaceFile" = 'Just ReadInterfaceError + ConRecursInto "FailedToLoadDynamicInterface" = 'Just ReadInterfaceError ---------------------------------- -- Constructors of PsMessage @@ -793,6 +819,11 @@ type family ConRecursInto con where ConRecursInto "TcRnRunSpliceFailure" = 'Just RunSpliceFailReason ConRecursInto "ConversionFail" = 'Just ConversionFailReason + -- Interface file errors + + ConRecursInto "TcRnInterfaceError" = 'Just IfaceMessage + ConRecursInto "Can'tFindInterface" = 'Just MissingInterfaceError + ------------------ -- FFI errors diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index 8ea61c6f39..bf80c5ed37 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -245,14 +245,14 @@ getInvalids vs = [d | NotValid d <- vs] ---------------- -- | Formats the input list of structured document, where each element of the list gets a bullet. -formatBulleted :: SDocContext -> DecoratedSDoc -> SDoc -formatBulleted ctx (unDecorated -> docs) - = case msgs of +formatBulleted :: DecoratedSDoc -> SDoc +formatBulleted (unDecorated -> docs) + = sdocWithContext $ \ctx -> case msgs ctx of [] -> Outputable.empty [msg] -> msg - _ -> vcat $ map starred msgs + xs -> vcat $ map starred xs where - msgs = filter (not . Outputable.isEmpty ctx) docs + msgs ctx = filter (not . Outputable.isEmpty ctx) docs starred = (bullet<+>) pprMessages :: Diagnostic e => DiagnosticOpts e -> Messages e -> SDoc @@ -274,12 +274,11 @@ pprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan = s , errMsgDiagnostic = e , errMsgSeverity = sev , errMsgContext = name_ppr_ctx }) - = sdocWithContext $ \ctx -> - withErrStyle name_ppr_ctx $ + = withErrStyle name_ppr_ctx $ mkLocMessage (MCDiagnostic sev (diagnosticReason e) (diagnosticCode e)) s - (formatBulleted ctx $ diagnosticMessage opts e) + (formatBulleted $ diagnosticMessage opts e) sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e] sortMsgBag mopts = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList |