[Git][ghc/ghc][wip/interface-loading-errs] 3 commits: Convert interface file loading errors into proper diagnostics
sheaf (@sheaf)
gitlab at gitlab.haskell.org
Thu Mar 16 11:39:59 UTC 2023
sheaf pushed to branch wip/interface-loading-errs at Glasgow Haskell Compiler / GHC
Commits:
65e873fe by Matthew Pickering at 2023-03-16T12:39:17+01:00
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 MissingInterfaceErrors into the DriverMessage.
* TcRnMessage: Most the time we are loading interface files during
typechecking, so we embed the MissingInterfaceError
This patch also removes the TcRnInterfaceLookupError constructor which
is superceded by the TcR
- - - - -
a2c01839 by Matthew Pickering at 2023-03-16T12:39:17+01:00
wip
- - - - -
53cb7758 by sheaf at 2023-03-16T12:39:17+01:00
refactor interface error datatypes
- - - - -
26 changed files:
- compiler/GHC/Driver/Config/Diagnostic.hs
- compiler/GHC/Driver/Config/Tidy.hs
- compiler/GHC/Driver/Errors.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Driver/Errors/Types.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Iface/Errors.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Utils/Error.hs
- ghc/GHCi/UI.hs
- + ghc/GHCi/UI/Exception.hs
- ghc/Main.hs
- ghc/ghc-bin.cabal.in
Changes:
=====================================
compiler/GHC/Driver/Config/Diagnostic.hs
=====================================
@@ -13,6 +13,7 @@ where
import GHC.Driver.Flags
import GHC.Driver.Session
+import GHC.Prelude
import GHC.Utils.Outputable
import GHC.Utils.Error (DiagOpts (..))
@@ -48,7 +49,9 @@ 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
+ , tcOptsShowTriedFiles = verbosity dflags >= 3 }
initDsMessageOpts :: DynFlags -> DiagnosticOpts DsMessage
initDsMessageOpts _ = NoDiagnosticOpts
=====================================
compiler/GHC/Driver/Config/Tidy.hs
=====================================
@@ -26,6 +26,9 @@ import GHC.Types.TyThing
import GHC.Platform.Ways
import qualified GHC.LanguageExtensions as LangExt
+import GHC.Types.Error
+import GHC.Utils.Error
+import GHC.Driver.Config.Diagnostic (initTcMessageOpts)
initTidyOpts :: HscEnv -> IO TidyOpts
initTidyOpts hsc_env = do
@@ -51,7 +54,10 @@ initStaticPtrOpts hsc_env = do
let lookupM n = lookupGlobal_maybe hsc_env n >>= \case
Succeeded r -> pure r
- Failed err -> pprPanic "initStaticPtrOpts: couldn't find" (ppr (err,n))
+ Failed err ->
+ let txt = formatBulleted $ diagnosticMessage (initTcMessageOpts dflags) err
+ in pprPanic "initStaticPtrOpts: couldn't find" (ppr (txt, n))
+
mk_string <- getMkStringIds (fmap tyThingId . lookupM)
static_ptr_info_datacon <- tyThingDataCon <$> lookupM staticPtrInfoDataConName
=====================================
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
=====================================
compiler/GHC/Driver/Errors/Ppr.hs
=====================================
@@ -16,7 +16,7 @@ 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.Tc.Errors.Ppr
import GHC.Types.Error
import GHC.Types.Error.Codes ( constructorCode )
import GHC.Unit.Types
@@ -28,7 +28,7 @@ import GHC.Types.SrcLoc
import Data.Version
import Language.Haskell.Syntax.Decls (RuleDecl(..))
-import GHC.Tc.Errors.Types (TcRnMessage)
+import GHC.Tc.Errors.Types (TcRnMessage, BuildingCabalPackage (..))
import GHC.HsToCore.Errors.Types (DsMessage)
--
@@ -218,6 +218,8 @@ 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 ->
+ mkSimpleDecorated $ missingInterfaceErrorDiagnostic False reason
diagnosticReason = \case
DriverUnknownMessage m
@@ -272,6 +274,7 @@ instance Diagnostic DriverMessage where
-> ErrorWithoutFlag
DriverHomePackagesNotClosed {}
-> ErrorWithoutFlag
+ DriverInterfaceError reason -> missingInterfaceErrorReason reason
diagnosticHints = \case
DriverUnknownMessage m
@@ -328,5 +331,6 @@ instance Diagnostic DriverMessage where
-> noHints
DriverHomePackagesNotClosed {}
-> noHints
+ DriverInterfaceError reason -> missingInterfaceErrorHints reason
diagnosticCode = constructorCode
=====================================
compiler/GHC/Driver/Errors/Types.hs
=====================================
@@ -8,7 +8,6 @@ module GHC.Driver.Errors.Types (
, DriverMessage(..)
, DriverMessageOpts(..)
, DriverMessages, PsMessage(PsHeaderMessage)
- , BuildingCabalPackage(..)
, WarningMessages
, ErrorMessages
, WarnMsg
@@ -31,7 +30,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)
@@ -39,6 +37,8 @@ import Language.Haskell.Syntax.Decls (RuleDecl)
import GHC.Generics ( Generic )
+import GHC.Tc.Errors.Types
+
-- | A collection of warning messages.
-- /INVARIANT/: Each 'GhcMessage' in the collection should have 'SevWarning' severity.
type WarningMessages = Messages GhcMessage
@@ -368,21 +368,17 @@ data DriverMessage where
DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage
+ DriverInterfaceError :: MissingInterfaceError -> DriverMessage
+
deriving instance Generic DriverMessage
data DriverMessageOpts =
DriverMessageOpts { psDiagnosticOpts :: DiagnosticOpts PsMessage }
--- | 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
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -2330,7 +2330,7 @@ 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 $
+ DriverInterfaceError $
cannotFindModule hsc_env wanted_mod err
{-
=====================================
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
@@ -307,8 +306,7 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do
fail ->
throwOneError $
mkPlainErrorMsgEnvelope srcloc $
- GhcDriverMessage $ DriverUnknownMessage $
- UnknownDiagnostic $ mkPlainError noHints $
+ GhcDriverMessage $ DriverInterfaceError $
cannotFindModule hsc_env imp fail
-----------------------------
=====================================
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
@@ -21,77 +16,45 @@ import GHC.Driver.Env
import GHC.Driver.Errors.Types
import GHC.Data.Maybe
import GHC.Prelude
+import GHC.Tc.Errors.Types
import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.Finder.Types
import GHC.Utils.Outputable as Outputable
+-- -----------------------------------------------------------------------------
+-- 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 =
+ CantFindInstalledErr $
+ cantFindInstalledErr CantLoadInterface
+ AmbiguousInterface us mhu p mn ifr
cantFindInstalledErr
- :: SDoc
- -> SDoc
+ :: CantFindWhat
+ -> CantFindWhat
-> 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 cannot_find _ unit_state mhome_unit profile mod_name find_result
+ = CantFindInstalled mod_name cannot_find 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,65 +62,41 @@ 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) $
cantFindErr (checkBuildingCabalPackage dflags)
cannotFindMsg
- (text "Ambiguous module name")
+ AmbiguousModule
unit_env
profile
- (mayShowLocations dflags)
mod
res
where
@@ -167,84 +106,52 @@ cannotFindModule' dflags unit_env profile mod res = pprWithUnitState (ue_units u
, 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"
+ -> CantLoadModule
+ _ -> CantFindModule
cantFindErr
:: BuildingCabalPackage -- ^ Using Cabal?
- -> SDoc
- -> SDoc
+ -> CantFindWhat
+ -> CantFindWhat
-> 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 _ _ multiple_found _ _ mod_name (FoundMultiple mods)
+ = CantFindInstalled mod_name multiple_found (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 cannot_find _ unit_env profile mod_name find_result
+ = CantFindInstalled mod_name cannot_find 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 +162,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
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -143,7 +143,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 InterfaceError TyThing)
-- Returns (Failed err) if we can't find the interface file for the thing
tcLookupImported_maybe name
= do { hsc_env <- getTopEnv
@@ -152,7 +152,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 InterfaceError TyThing)
-- Entry point for *source-code* uses of importDecl
tcImportDecl_maybe name
| Just thing <- wiredInNameTyThing_maybe name
@@ -163,7 +163,7 @@ tcImportDecl_maybe name
| otherwise
= initIfaceTcRn (importDecl name)
-importDecl :: Name -> IfM lcl (MaybeErr SDoc TyThing)
+importDecl :: Name -> IfM lcl (MaybeErr InterfaceError 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 +174,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 +292,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 +402,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 +702,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 +731,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 +768,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 +797,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 +849,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 +891,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 +904,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 +959,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 +980,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 +994,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))
{-
*********************************************************
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Iface.Recomp.Flags
import GHC.Iface.Env
import GHC.Core
+import GHC.Tc.Errors.Ppr
import GHC.Tc.Utils.Monad
import GHC.Hs
@@ -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)
@@ -1319,7 +1325,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))
@@ -1614,7 +1620,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
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -50,6 +50,7 @@ import GHC.StgToCmm.Types
import GHC.Runtime.Heap.Layout
import GHC.Tc.Errors.Types
+import GHC.Tc.Errors.Ppr
import GHC.Tc.TyCl.Build
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
@@ -574,13 +575,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
@@ -596,7 +598,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!
@@ -609,8 +614,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
@@ -1961,7 +1964,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 <+> interfaceErrorDiagnostic False err)
Succeeded thing -> return thing
}}}
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -48,6 +48,7 @@ import GHC.Driver.Config.Diagnostic
import GHC.Driver.Config.Finder
import GHC.Tc.Utils.Monad
+import GHC.Tc.Errors.Ppr
import GHC.Runtime.Interpreter
import GHCi.RemoteTypes
@@ -791,7 +792,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 tries = tcOptsShowTriedFiles $ initTcMessageOpts dflags
+ err_txt = missingInterfaceErrorDiagnostic tries err
+ in throwGhcExceptionIO (ProgramError (showSDoc dflags err_txt))
Maybes.Succeeded iface -> return iface
when (mi_boot iface == IsBoot) $ link_boot_mod_error mod
=====================================
compiler/GHC/Runtime/Loader.hs
=====================================
@@ -44,6 +44,8 @@ import GHC.Core.Type ( Type, mkTyConTy )
import GHC.Core.TyCo.Compare( eqType )
import GHC.Core.TyCon ( TyCon )
+import GHC.Tc.Errors.Ppr
+
import GHC.Types.SrcLoc ( noSrcSpan )
import GHC.Types.Name ( Name, nameModule_maybe )
import GHC.Types.Id ( idType )
@@ -52,11 +54,13 @@ import GHC.Types.Name.Occurrence ( OccName, mkVarOccFS )
import GHC.Types.Name.Reader ( RdrName, ImportSpec(..), ImpDeclSpec(..)
, ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName
, greMangledName, mkRdrQual )
+import GHC.Types.Unique.DFM
import GHC.Unit.Finder ( findPluginModule, FindResult(..) )
import GHC.Driver.Config.Finder ( initFinderOpts )
+import GHC.Driver.Config.Diagnostic ( initTcMessageOpts )
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
@@ -69,9 +73,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)
+
-- | Loads the plugins specified in the pluginModNames field of the dynamic
-- flags. Should be called after command line arguments are parsed, but before
-- actual compilation starts. Idempotent operation. Should be re-called if
@@ -328,7 +332,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 tries = tcOptsShowTriedFiles $ initTcMessageOpts dflags
+ err_txt = missingInterfaceErrorDiagnostic tries
+ $ cannotFindModule hsc_env mod_name err
+ in throwCmdLineErrorS dflags err_txt
where
doc = text "contains a name used in an invocation of lookupRdrNameInModule"
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -20,6 +20,14 @@ module GHC.Tc.Errors.Ppr
, pprHsDocContext
, inHsDocContext
, TcRnMessageOpts(..)
+
+ , interfaceErrorHints
+ , interfaceErrorReason
+ , interfaceErrorDiagnostic
+ , missingInterfaceErrorHints
+ , missingInterfaceErrorReason
+ , missingInterfaceErrorDiagnostic
+ , readInterfaceErrorDiagnostic
)
where
@@ -74,7 +82,7 @@ import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Var.Env
-import GHC.Unit.State (pprWithUnitState, UnitState)
+import GHC.Unit.State
import GHC.Unit.Module
import GHC.Unit.Module.Warnings ( pprWarningTxtForMsg )
@@ -101,10 +109,12 @@ import GHC.Types.Name.Env
import qualified Language.Haskell.TH as TH
data TcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext :: !Bool -- ^ Whether we show the error context or not
+ , tcOptsShowTriedFiles :: !Bool -- ^ Whether to show files we tried to look for or not when printing loader errors
}
defaultTcRnMessageOpts :: TcRnMessageOpts
-defaultTcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext = True }
+defaultTcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext = True
+ , tcOptsShowTriedFiles = False }
instance Diagnostic TcRnMessage where
@@ -1162,7 +1172,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"
@@ -1406,6 +1415,12 @@ instance Diagnostic TcRnMessage where
hsep [ text "Unknown type variable" <> plural errorVars
, text "on the RHS of injectivity condition:"
, interpp'SP errorVars ]
+ TcRnCan'tFindLocalName name
+ -> mkSimpleDecorated $ text "Can't find local name: " <+> ppr name
+ TcRnInterfaceError reason
+ -> mkSimpleDecorated $
+ interfaceErrorDiagnostic (tcOptsShowTriedFiles opts) reason
+
diagnosticReason = \case
TcRnUnknownMessage m
@@ -1772,8 +1787,6 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnReportCustomQuasiError isError _
-> if isError then ErrorWithoutFlag else WarningWithoutFlag
- TcRnInterfaceLookupError{}
- -> ErrorWithoutFlag
TcRnUnsatisfiedMinimalDef{}
-> WarningWithFlag (Opt_WarnMissingMethods)
TcRnMisplacedInstSig{}
@@ -1870,6 +1883,11 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnUnknownTyVarsOnRhsOfInjCond{}
-> ErrorWithoutFlag
+ TcRnCan'tFindLocalName {}
+ -> ErrorWithoutFlag
+ TcRnInterfaceError err
+ -> interfaceErrorReason err
+
diagnosticHints = \case
TcRnUnknownMessage m
@@ -2242,8 +2260,6 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnReportCustomQuasiError{}
-> noHints
- TcRnInterfaceLookupError{}
- -> noHints
TcRnUnsatisfiedMinimalDef{}
-> noHints
TcRnMisplacedInstSig{}
@@ -2352,6 +2368,10 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnUnknownTyVarsOnRhsOfInjCond{}
-> noHints
+ TcRnCan'tFindLocalName {}
+ -> noHints
+ TcRnInterfaceError reason
+ -> interfaceErrorHints reason
diagnosticCode = constructorCode
@@ -2366,6 +2386,297 @@ commafyWith conjunction xs = addConjunction $ punctuate comma xs
addConjunction (x : xs) = x : addConjunction xs
addConjunction _ = panic "commafyWith expected 2 or more elements"
+interfaceErrorHints :: InterfaceError -> [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
+ CantFindInstalledErr {} ->
+ noHints
+ BadIfaceFile {} ->
+ noHints
+ FailedToLoadDynamicInterface {} ->
+ noHints
+
+interfaceErrorReason :: InterfaceError -> DiagnosticReason
+interfaceErrorReason (Can'tFindInterface err _)
+ = missingInterfaceErrorReason err
+interfaceErrorReason (Can'tFindNameInInterface {})
+ = ErrorWithoutFlag
+
+missingInterfaceErrorReason :: MissingInterfaceError -> DiagnosticReason
+missingInterfaceErrorReason = \ case
+ BadSourceImport {} ->
+ ErrorWithoutFlag
+ HomeModError {} ->
+ ErrorWithoutFlag
+ DynamicHashMismatchError {} ->
+ ErrorWithoutFlag
+ CantFindErr {} ->
+ ErrorWithoutFlag
+ CantFindInstalledErr {} ->
+ ErrorWithoutFlag
+ BadIfaceFile {} ->
+ ErrorWithoutFlag
+ FailedToLoadDynamicInterface {} ->
+ ErrorWithoutFlag
+
+prettyCantFindWhat :: CantFindWhat -> (SDoc, SDoc)
+prettyCantFindWhat CantFindModule = (text "Could not find module", dot)
+prettyCantFindWhat CantLoadModule = (text "Could not load module", dot)
+prettyCantFindWhat CantLoadInterface = (text "Failed to load interface for", colon)
+prettyCantFindWhat AmbiguousModule = (text "Ambiguous module name", colon)
+prettyCantFindWhat AmbiguousInterface= (text "Ambiguous interface for", colon)
+
+cantFindError :: Bool -> CantFindInstalled -> SDoc
+cantFindError verbose (CantFindInstalled mod_name what cfir) =
+ let (ppr_what, punct) = prettyCantFindWhat what in
+ hang (ppr_what <+> quotes (ppr mod_name) <> punct) 4 $
+ 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 candidates"))
+ -- 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
+ 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 :: Bool -> InterfaceError -> SDoc
+interfaceErrorDiagnostic verbose_files = \ case
+ Can'tFindNameInInterface name relevant_tyThings ->
+ missingDeclInInterface name relevant_tyThings
+ Can'tFindInterface err looking_for ->
+ case looking_for of
+ LookingForName {} ->
+ missingInterfaceErrorDiagnostic verbose_files err
+ LookingForModule {} ->
+ missingInterfaceErrorDiagnostic verbose_files err
+ LookingForHiBoot mod ->
+ hang (text "Could not find hi-boot interface for" <+> quotes (ppr mod) <> colon)
+ 2 (missingInterfaceErrorDiagnostic verbose_files err)
+ LookingForSig sig ->
+ hang (text "Could not find interface file for signature" <+> quotes (ppr sig) <> colon)
+ 2 (missingInterfaceErrorDiagnostic verbose_files 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 :: Bool -> MissingInterfaceError -> SDoc
+missingInterfaceErrorDiagnostic verbose_files reason =
+ case reason of
+ BadSourceImport m -> badSourceImport m
+ HomeModError im ml -> homeModError im ml
+ DynamicHashMismatchError m ml -> dynamicHashMismatchError m ml
+ CantFindErr us cfi -> pprWithUnitState us $ cantFindError verbose_files cfi
+ CantFindInstalledErr cfi -> cantFindError verbose_files 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)))
+
deriveInstanceErrReasonHints :: Class
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -48,6 +48,16 @@ module GHC.Tc.Errors.Types (
, HsDocContext(..)
, FixedRuntimeRepErrorInfo(..)
+ , MissingInterfaceError(..)
+ , InterfaceLookingFor(..)
+ , InterfaceError(..)
+ , ReadInterfaceError(..)
+ , CantFindInstalled(..)
+ , CantFindInstalledReason(..)
+ , CantFindWhat(..)
+
+ , BuildingCabalPackage(..)
+
, ErrorItem(..), errorItemOrigin, errorItemEqRel, errorItemPred, errorItemCtLoc
, SolverReport(..), SolverReportSupplementary(..)
@@ -105,6 +115,7 @@ import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol)
, FixedRuntimeRepOrigin(..) )
import GHC.Tc.Types.Rank (Rank)
import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType)
+import GHC.Types.Basic
import GHC.Types.Error
import GHC.Types.Hint (UntickedPromotedThing(..))
import GHC.Types.ForeignCall (CLabelString)
@@ -116,7 +127,7 @@ import GHC.Types.TyThing (TyThing)
import GHC.Types.Var (Id, TyCoVar, TyVar, TcTyVar)
import GHC.Types.Var.Env (TidyEnv)
import GHC.Types.Var.Set (TyVarSet, VarSet)
-import GHC.Unit.Types (Module)
+import GHC.Unit.Types (Module, InstalledModule, UnitId, Unit)
import GHC.Utils.Outputable
import GHC.Core.Class (Class, ClassMinimalDef)
import GHC.Core.Coercion.Axiom (CoAxBranch)
@@ -129,8 +140,7 @@ import GHC.Core.Predicate (EqRel, predTypeEqRel)
import GHC.Core.TyCon (TyCon, TyConFlavour)
import GHC.Core.Type (Kind, Type, ThetaType, PredType)
import GHC.Driver.Backend (Backend)
-import GHC.Unit.State (UnitState)
-import GHC.Types.Basic
+import GHC.Unit.State (UnitState, ModuleSuggestion, ModuleOrigin, UnusableUnitReason, UnitInfo)
import GHC.Utils.Misc (capitalise, filterOut)
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.FastString (FastString)
@@ -144,6 +154,7 @@ import GHC.Unit.Module.Warnings (WarningTxt)
import qualified Language.Haskell.TH.Syntax as TH
import GHC.Generics ( Generic )
+import GHC.Unit.Module.Location
{-
Note [Migrating TcM Messages]
@@ -2546,14 +2557,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.
@@ -3178,6 +3181,10 @@ data TcRnMessage where
-}
TcRnUnknownTyVarsOnRhsOfInjCond :: [Name] -> TcRnMessage
+ TcRnCan'tFindLocalName :: !Name -> TcRnMessage
+
+ TcRnInterfaceError :: !InterfaceError -> TcRnMessage
+
deriving Generic
-- | Things forbidden in @type data@ declarations.
@@ -3596,6 +3603,61 @@ instance Outputable Exported where
ppr IsNotExported = text "IsNotExported"
ppr IsExported = text "IsExported"
+data InterfaceLookingFor
+ = LookingForName !Name
+ | LookingForHiBoot !Module
+ | LookingForModule !ModuleName !IsBootInterface
+ | LookingForSig !InstalledModule
+
+data InterfaceError
+ = Can'tFindInterface
+ MissingInterfaceError
+ InterfaceLookingFor
+ | Can'tFindNameInInterface
+ Name
+ [TyThing] -- possibly relevant TyThings
+ deriving Generic
+
+data MissingInterfaceError
+ = BadSourceImport !Module
+ | HomeModError !InstalledModule !ModLocation
+ | DynamicHashMismatchError !Module !ModLocation
+
+ -- TODO: common up these two
+ | CantFindErr !UnitState CantFindInstalled
+ | CantFindInstalledErr 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 CantFindWhat CantFindInstalledReason
+ deriving Generic
+
+data CantFindWhat
+ = CantFindModule | CantLoadModule | CantLoadInterface
+ | AmbiguousInterface | AmbiguousModule
+ -- TODO?
+
--------------------------------------------------------------------------------
--
-- Errors used in GHC.Tc.Errors
@@ -4419,3 +4481,11 @@ data NonStandardGuards where
data RuleLhsErrReason
= UnboundVariable RdrName NotInScopeError
| IllegalExpression
+
+-- | Pass to a 'DriverMessage' the information whether or not the
+-- '-fbuilding-cabal-package' flag is set.
+data BuildingCabalPackage
+ = YesBuildingCabalPackage
+ | NoBuildingCabalPackage
+ deriving Eq
+
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -2024,7 +2024,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
=====================================
compiler/GHC/Tc/Utils/Backpack.hs
=====================================
@@ -168,7 +168,7 @@ checkHsigIface tcg_env gr 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
@@ -278,7 +278,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))
@@ -563,9 +563,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.
@@ -996,9 +995,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.)
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -24,7 +24,7 @@ module GHC.Tc.Utils.Env(
tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
tcLookupLocatedClass, tcLookupAxiom,
- lookupGlobal, lookupGlobal_maybe, ioLookupDataCon,
+ lookupGlobal, lookupGlobal_maybe,
addTypecheckedBinds,
-- Local environment
@@ -136,6 +136,8 @@ import Data.IORef
import Data.List (intercalate)
import Control.Monad
import GHC.Driver.Env.KnotVars
+import GHC.Utils.Error (formatBulleted)
+import GHC.Driver.Config.Diagnostic (initTcMessageOpts)
{- *********************************************************************
* *
@@ -151,10 +153,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 err_txt = formatBulleted
+ $ diagnosticMessage (initTcMessageOpts (hsc_dflags hsc_env))
+ err
+ in pprPanic "lookupGlobal" err_txt
}
-
-lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
+lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr TcRnMessage 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.
@@ -165,24 +170,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 $ TcRnCan'tFindLocalName 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 (TcRnInterfaceError err)
}
-lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
+lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr InterfaceError 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 InterfaceError TyThing)
importDecl_maybe hsc_env name
| Just thing <- wiredInNameTyThing_maybe name
= do { when (needWiredInHomeIface thing)
@@ -192,22 +199,6 @@ importDecl_maybe hsc_env name
| otherwise
= initIfaceLoad hsc_env (importDecl name)
-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 msg -> pprPanic "lookupDataConIO" msg
-
-ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc DataCon)
-ioLookupDataCon_maybe hsc_env name = do
- thing <- lookupGlobal hsc_env name
- return $ case thing of
- AConLike (RealDataCon con) -> Succeeded con
- _ -> Failed $
- pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+>
- text "used as a data constructor"
-
addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
addTypecheckedBinds tcg_env binds
| isHsBootOrSig (tcg_src tcg_env) = tcg_env
@@ -257,7 +248,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.
=====================================
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,
@@ -217,6 +218,7 @@ import Data.IORef
import Control.Monad
import GHC.Tc.Errors.Types
+import GHC.Tc.Errors.Ppr
import {-# SOURCE #-} GHC.Tc.Utils.Env ( tcInitTidyEnv )
import qualified Data.Map as Map
@@ -663,6 +665,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 tries = tcOptsShowTriedFiles $ defaultDiagnosticOpts @TcRnMessage
+ msg = missingInterfaceErrorDiagnostic tries err
+ liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx msg))
+ Succeeded result -> return result
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -35,6 +35,8 @@ module GHC.Types.Error
, mkDecoratedDiagnostic
, mkDecoratedError
+ , pprDiagnostic
+
, NoDiagnosticOpts(..)
-- * Hints and refactoring actions
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -530,6 +530,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnShadowedTyVarNameInFamResult" = 99412
GhcDiagnosticCode "TcRnIncorrectTyVarOnLhsOfInjCond" = 88333
GhcDiagnosticCode "TcRnUnknownTyVarsOnRhsOfInjCond" = 48254
+ GhcDiagnosticCode "TcRnCan'tFindLocalName" = 11111 -- SLD TODO
-- IllegalNewtypeReason
GhcDiagnosticCode "DoesNotHaveSingleField" = 23517
@@ -583,6 +584,28 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "OneArgExpected" = 91490
GhcDiagnosticCode "AtLeastOneArgExpected" = 07641
+ -- Interface errors
+ GhcDiagnosticCode "BadSourceImport" = 00001
+ GhcDiagnosticCode "MissingDeclInInterface" = 00002
+ GhcDiagnosticCode "MissingInterfaceError" = 00003
+ GhcDiagnosticCode "HomeModError" = 00004
+ GhcDiagnosticCode "DynamicHashMismatchError" = 00005
+ GhcDiagnosticCode "BadIfaceFile" = 00006
+ GhcDiagnosticCode "FailedToLoadDynamicInterface" = 00010
+ GhcDiagnosticCode "UsedAsDataConstructor" = 00014
+ GhcDiagnosticCode "CouldntFindInFiles" = 00016
+ GhcDiagnosticCode "GenericMissing" = 00017
+ GhcDiagnosticCode "MissingPackageFiles" = 00018
+ GhcDiagnosticCode "MissingPackageWayFiles" = 00019
+ GhcDiagnosticCode "ModuleSuggestion" = 00020
+ GhcDiagnosticCode "MultiplePackages" = 00022
+ GhcDiagnosticCode "NoUnitIdMatching" = 00023
+ GhcDiagnosticCode "NotAModule" = 00024
+ GhcDiagnosticCode "Can'tFindNameInInterface" = 00026
+
+ GhcDiagnosticCode "HiModuleNameMismatchWarn" = 00012
+ GhcDiagnosticCode "ExceptionOccurred" = 00011
+
-- Out of scope errors
GhcDiagnosticCode "NotInScope" = 76037
GhcDiagnosticCode "NoExactName" = 97784
@@ -670,6 +693,15 @@ type family ConRecursInto con where
ConRecursInto "DriverUnknownMessage" = 'Just UnknownDiagnostic
ConRecursInto "DriverPsHeaderMessage" = 'Just PsMessage
+ ConRecursInto "DriverInterfaceError" = 'Just MissingInterfaceError
+
+ ConRecursInto "CantFindErr" = 'Just CantFindInstalled
+ ConRecursInto "CantFindInstalledErr" = 'Just CantFindInstalled
+
+ ConRecursInto "CantFindInstalled" = 'Just CantFindInstalledReason
+
+ ConRecursInto "BadIfaceFile" = 'Just ReadInterfaceError
+ ConRecursInto "FailedToLoadDynamicInterface" = 'Just ReadInterfaceError
----------------------------------
-- Constructors of PsMessage
@@ -698,6 +730,11 @@ type family ConRecursInto con where
ConRecursInto "TcRnRunSpliceFailure" = 'Just RunSpliceFailReason
ConRecursInto "ConversionFail" = 'Just ConversionFailReason
+ -- Interface file errors
+
+ ConRecursInto "TcRnInterfaceError" = 'Just InterfaceError
+ ConRecursInto "Can'tFindInterface" = 'Just MissingInterfaceError
+
------------------
-- FFI errors
=====================================
compiler/GHC/Utils/Error.hs
=====================================
@@ -219,14 +219,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
@@ -248,12 +248,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
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -35,6 +35,7 @@ import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' )
import GHCi.UI.Monad hiding ( args, runStmt )
import GHCi.UI.Tags
import GHCi.UI.Info
+import GHCi.UI.Exception
import GHC.Runtime.Debugger
-- The GHC interface
@@ -1115,7 +1116,7 @@ runOneCommand eh gCmd = do
-- is the handler necessary here?
where
printErrorAndFail err = do
- GHC.printException err
+ printGhciException err
return $ Just False -- Exit ghc -e, but not GHCi
noSpace q = q >>= maybe (return Nothing)
@@ -1588,7 +1589,7 @@ help _ = do
info :: GHC.GhcMonad m => Bool -> String -> m ()
info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
-info allInfo s = handleSourceError GHC.printException $ do
+info allInfo s = handleSourceError printGhciException $ do
forM_ (words s) $ \thing -> do
sdoc <- infoThing allInfo thing
rendered <- showSDocForUser' sdoc
@@ -2002,7 +2003,7 @@ instancesCmd :: String -> InputT GHCi ()
instancesCmd "" =
throwGhcException (CmdLineError "syntax: ':instances <type-you-want-instances-for>'")
instancesCmd s = do
- handleSourceError GHC.printException $ do
+ handleSourceError printGhciException $ do
ty <- GHC.parseInstanceHead s
res <- GHC.getInstancesForType ty
@@ -2309,7 +2310,7 @@ modulesLoadedMsg ok mods = do
-- and printing 'throwE' strings to 'stderr'. If in expression
-- evaluation mode - throw GhcException and exit.
runExceptGhciMonad :: GhciMonad m => ExceptT SDoc m () -> m ()
-runExceptGhciMonad act = handleSourceError GHC.printException $
+runExceptGhciMonad act = handleSourceError printGhciException $
either handleErr pure =<<
runExceptT act
where
@@ -4543,7 +4544,7 @@ failIfExprEvalMode = do
-- | When in expression evaluation mode (ghc -e), we want to exit immediately.
-- Otherwis, just print out the message.
printErrAndMaybeExit :: (GhciMonad m, MonadIO m, HasLogger m) => SourceError -> m ()
-printErrAndMaybeExit = (>> failIfExprEvalMode) . GHC.printException
+printErrAndMaybeExit = (>> failIfExprEvalMode) . printGhciException
-----------------------------------------------------------------------------
-- recursive exception handlers
@@ -4641,7 +4642,7 @@ wantNameFromInterpretedModule :: GHC.GhcMonad m
-> (Name -> m ())
-> m ()
wantNameFromInterpretedModule noCanDo str and_then =
- handleSourceError GHC.printException $ do
+ handleSourceError printGhciException $ do
n NE.:| _ <- GHC.parseName str
let modl = assert (isExternalName n) $ GHC.nameModule n
if not (GHC.isExternalName n)
=====================================
ghc/GHCi/UI/Exception.hs
=====================================
@@ -0,0 +1,42 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module GHCi.UI.Exception(printGhciException) where
+
+import GHC.Prelude
+import GHC.Utils.Logger
+import Control.Monad.IO.Class
+import GHC.Driver.Session
+import GHC.Types.SourceError
+import GHC.Driver.Errors.Types
+import GHC.Types.Error
+import GHC.Driver.Config.Diagnostic
+import GHC.Driver.Errors
+
+-- | Print the all diagnostics in a 'SourceError'. Specialised for GHCi error reporting
+-- for some error messages.
+printGhciException :: (HasLogger m, MonadIO m, HasDynFlags m) => SourceError -> m ()
+printGhciException err = do
+ dflags <- getDynFlags
+ logger <- getLogger
+ let !diag_opts = initDiagOpts dflags
+ !print_config = initPrintConfig dflags
+ liftIO $ printMessages logger print_config diag_opts (GHCiMessage <$> (srcErrorMessages err))
+
+
+newtype GHCiMessage = GHCiMessage { getGhciMessage :: GhcMessage }
+
+instance Diagnostic GHCiMessage where
+ type DiagnosticOpts GHCiMessage = DiagnosticOpts GhcMessage
+
+ defaultDiagnosticOpts = defaultDiagnosticOpts @GhcMessage
+
+ diagnosticMessage opts (GHCiMessage msg) = diagnosticMessage opts msg
+
+ diagnosticReason (GHCiMessage msg) = diagnosticReason msg
+
+ diagnosticHints (GHCiMessage msg) = diagnosticHints msg
+
+ diagnosticCode (GHCiMessage msg) = diagnosticCode msg
+
+
=====================================
ghc/Main.hs
=====================================
@@ -79,12 +79,13 @@ import GHC.Iface.Load
import GHC.Iface.Recomp.Binary ( fingerprintBinMem )
import GHC.Tc.Utils.Monad ( initIfaceCheck )
-import System.FilePath
+import GHC.Tc.Errors.Ppr
-- Standard Haskell libraries
import System.IO
import System.Environment
import System.Exit
+import System.FilePath
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except (throwE, runExceptT)
@@ -1100,8 +1101,11 @@ abiHash strs = do
r <- findImportedModule hsc_env modname NoPkgQual
case r of
Found _ m -> return m
- _error -> throwGhcException $ CmdLineError $ showSDoc dflags $
- cannotFindModule hsc_env modname r
+ _error ->
+ let tries = tcOptsShowTriedFiles $ initTcMessageOpts dflags
+ err_txt = missingInterfaceErrorDiagnostic tries
+ $ cannotFindModule hsc_env modname r
+ in throwGhcException . CmdLineError $ showSDoc dflags err_txt
mods <- mapM find_it strs
=====================================
ghc/ghc-bin.cabal.in
=====================================
@@ -69,6 +69,7 @@ Executable ghc
GHCi.UI.Info
GHCi.UI.Monad
GHCi.UI.Tags
+ GHCi.UI.Exception
GHCi.Util
Other-Extensions:
FlexibleInstances
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/abac1c81d6428294878df0a35a42ebfea5c03a8e...53cb7758762332ae300df5191f633e2ab1fb05f4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/abac1c81d6428294878df0a35a42ebfea5c03a8e...53cb7758762332ae300df5191f633e2ab1fb05f4
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230316/582f18a8/attachment-0001.html>
More information about the ghc-commits
mailing list