diff options
Diffstat (limited to 'compiler/GHC/Iface')
| -rw-r--r-- | compiler/GHC/Iface/Errors.hs | 259 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Errors/Ppr.hs | 366 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Errors/Types.hs | 90 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Load.hs | 102 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Recomp.hs | 14 |
5 files changed, 553 insertions, 278 deletions
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 |