[Git][ghc/ghc][wip/interface-loading-errs] 2 commits: Convert interface file loading errors into proper diagnostics
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Wed Mar 15 12:09:36 UTC 2023
Matthew Pickering pushed to branch wip/interface-loading-errs at Glasgow Haskell Compiler / GHC
Commits:
0798e5cb by Matthew Pickering at 2023-03-15T11:21:32+00: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
- - - - -
4c2bf582 by Matthew Pickering at 2023-03-15T12:09:08+00:00
wip
- - - - -
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,8 @@ 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,10 @@ import GHC.Types.TyThing
import GHC.Platform.Ways
import qualified GHC.LanguageExtensions as LangExt
+import GHC.Types.Error
+import GHC.Utils.Error
+import GHC.Tc.Errors.Types (TcRnMessage(..))
+import GHC.Driver.Config.Diagnostic (initTcMessageOpts)
initTidyOpts :: HscEnv -> IO TidyOpts
initTidyOpts hsc_env = do
@@ -51,7 +55,11 @@ 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) (TcRnMissingInterfaceError 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 (missingInterfaceErrorHints, missingInterfaceErrorReason, missingInterfaceErrorDiagnostic)
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,7 @@ instance Diagnostic DriverMessage where
-> mkSimpleDecorated $ vcat ([text "Home units are not closed."
, text "It is necessary to also load the following units:" ]
++ map (\uid -> text "-" <+> ppr uid) needed_unit_ids)
+ DriverInterfaceError reason -> missingInterfaceErrorDiagnostic False reason
diagnosticReason = \case
DriverUnknownMessage m
@@ -272,6 +273,7 @@ instance Diagnostic DriverMessage where
-> ErrorWithoutFlag
DriverHomePackagesNotClosed {}
-> ErrorWithoutFlag
+ DriverInterfaceError reason -> missingInterfaceErrorReason reason
diagnosticHints = \case
DriverUnknownMessage m
@@ -328,5 +330,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
@@ -25,6 +20,7 @@ import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.Finder.Types
import GHC.Utils.Outputable as Outputable
+import GHC.Tc.Errors.Types (MissingInterfaceError (..), CantFindInstalled(..), CantFindInstalledReason(..), CantFindWhat(..), BuildingCabalPackage)
badIfaceFile :: String -> SDoc -> SDoc
@@ -32,66 +28,35 @@ 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 +64,45 @@ 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
+ MissingPackageWayFiles build pkg files
+ {-
text "Perhaps you haven't installed the " <> text build <>
text " libraries for package " <> quotes (ppr pkg) <> char '?' $$
tried_these 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")
+ AmbigiousModule
unit_env
profile
- (mayShowLocations dflags)
mod
res
where
@@ -167,84 +112,58 @@ 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)
+ -> CantFindInstalled
+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) ]
- )
+ = CantFindInstalled mod_name multiple_found (MultiplePackages pkgs)
| otherwise
- = hang (multiple_found <+> quotes (ppr mod_name) <> colon) 2 (
- vcat (map pprMod mods)
- )
+ = CantFindInstalled mod_name multiple_found (MultiplePackages2 mods)
where
unambiguousPackages = foldl' unambiguousPackage (Just []) mods
unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)
= Just (moduleUnit m : xs)
unambiguousPackage _ _ = Nothing
- 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 +174,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
\ No newline at end of file
=====================================
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 MissingInterfaceError 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 MissingInterfaceError 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 MissingInterfaceError TyThing)
-- Get the TyThing for this Name from an interface file
-- It's not a wired-in thing -- the caller caught that
importDecl name
@@ -182,21 +182,11 @@ importDecl name
{ 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 (MissingDeclInInterface 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,7 +289,7 @@ 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)
+ Failed err -> failWithTc (TcRnMissingInterfaceError err)
Succeeded iface -> return iface }
-- | Like 'loadSrcInterface', but returns a 'MaybeErr'.
@@ -307,7 +297,7 @@ 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 +393,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 +693,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 +722,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 +759,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 +788,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 +840,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,7 +882,7 @@ 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
@@ -917,39 +902,34 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
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 MissingInterfaceError (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 +944,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 (BadIfaceFile file_path err))
Succeeded iface -> return (Succeeded (iface, file_path))
-- Don't forget to fill in the package name...
@@ -985,7 +965,7 @@ readIface
-> NameCache
-> Module
-> FilePath
- -> IO (MaybeErr SDoc ModIface)
+ -> IO (MaybeErr MissingInterfaceError 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 +979,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 wanted_mod actual_mod
- Left exn -> return (Failed (text (showException exn)))
+ Left exn -> return (Failed (GenericException exn))
{-
*********************************************************
=====================================
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.Tc.Errors.Ppr (missingInterfaceErrorDiagnostic)
{-
-----------------------------------------------
@@ -292,8 +293,8 @@ 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)
+ trace_if logger (text "FYI: cannot read old interface file:" $$ nest 4 (formatBulleted $ missingInterfaceErrorDiagnostic False err))
+ trace_hi_diffs logger (text "Old interface file was invalid:" $$ nest 4 (formatBulleted $ missingInterfaceErrorDiagnostic False err))
return Nothing
Succeeded iface -> do
trace_if logger (text "Read the interface file" <+> text iface_path)
@@ -1319,7 +1320,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 +1615,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
=====================================
@@ -130,6 +130,8 @@ import GHC.Unit.Module.WholeCoreBindings
import Data.IORef
import Data.Foldable
import GHC.Builtin.Names (ioTyConName, rOOT_MAIN)
+import GHC.Tc.Errors.Ppr (missingInterfaceErrorDiagnostic)
+import GHC.Utils.Error
{-
This module takes
@@ -596,7 +598,7 @@ 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 -> failWithTc (TcRnMissingInterfaceError (CantFindHiBoot mod err))
-- The hi-boot file has mysteriously disappeared.
NotBoot -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints moduleLoop)
-- Someone below us imported us!
@@ -609,8 +611,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 +1961,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 <+> (formatBulleted $ missingInterfaceErrorDiagnostic False err))
Succeeded thing -> return thing
}}}
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -120,6 +120,7 @@ import GHC.Iface.Load
import GHC.Unit.Home
import Data.Either
import Control.Applicative
+import GHC.Tc.Errors.Types (TcRnMessage(..))
uninitialised :: a
uninitialised = panic "Loader not initialised"
@@ -791,7 +792,9 @@ 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 err_txt = formatBulleted $ diagnosticMessage (initTcMessageOpts dflags) (TcRnMissingInterfaceError 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
=====================================
@@ -71,6 +71,8 @@ import Unsafe.Coerce ( unsafeCoerce )
import GHC.Linker.Types
import GHC.Types.Unique.DFM
import Data.List (unzip4)
+import GHC.Tc.Errors.Types (TcRnMessage(..))
+import GHC.Driver.Config.Diagnostic (initTcMessageOpts)
-- | Loads the plugins specified in the pluginModNames field of the dynamic
-- flags. Should be called after command line arguments are parsed, but before
@@ -328,7 +330,9 @@ 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 err_txt = formatBulleted $ diagnosticMessage (initTcMessageOpts dflags) (TcRnMissingInterfaceError (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,10 @@ module GHC.Tc.Errors.Ppr
, pprHsDocContext
, inHsDocContext
, TcRnMessageOpts(..)
+
+ , missingInterfaceErrorHints
+ , missingInterfaceErrorReason
+ , missingInterfaceErrorDiagnostic
)
where
@@ -74,7 +78,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 +105,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 +1168,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"
@@ -1407,6 +1412,10 @@ instance Diagnostic TcRnMessage where
, text "on the RHS of injectivity condition:"
, interpp'SP errorVars ]
+ TcRnMissingInterfaceError reason
+ -> missingInterfaceErrorDiagnostic (tcOptsShowTriedFiles opts) reason
+
+
diagnosticReason = \case
TcRnUnknownMessage m
-> diagnosticReason m
@@ -1772,8 +1781,6 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnReportCustomQuasiError isError _
-> if isError then ErrorWithoutFlag else WarningWithoutFlag
- TcRnInterfaceLookupError{}
- -> ErrorWithoutFlag
TcRnUnsatisfiedMinimalDef{}
-> WarningWithFlag (Opt_WarnMissingMethods)
TcRnMisplacedInstSig{}
@@ -1870,6 +1877,23 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnUnknownTyVarsOnRhsOfInjCond{}
-> ErrorWithoutFlag
+ TcRnMissingInterfaceError reason
+ -> case reason of
+ BadSourceImport {} -> ErrorWithoutFlag
+ MissingDeclInInterface {} -> ErrorWithoutFlag
+ HomeModError {} -> ErrorWithoutFlag
+ DynamicHashMismatchError {} -> ErrorWithoutFlag
+ CantFindErr {} -> ErrorWithoutFlag
+ CantFindInstalledErr {} -> ErrorWithoutFlag
+ HiModuleNameMismatchWarn {} -> ErrorWithoutFlag
+ BadIfaceFile {} -> ErrorWithoutFlag
+ FailedToLoadDynamicInterface {} -> ErrorWithoutFlag
+ GenericException {} -> ErrorWithoutFlag
+ CantFindLocalName {} -> ErrorWithoutFlag
+ CantFindHiInterfaceForSig {} -> ErrorWithoutFlag
+ CantFindHiBoot {} -> ErrorWithoutFlag
+ InterfaceLookupError {} -> ErrorWithoutFlag
+
diagnosticHints = \case
TcRnUnknownMessage m
@@ -2242,8 +2266,6 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnReportCustomQuasiError{}
-> noHints
- TcRnInterfaceLookupError{}
- -> noHints
TcRnUnsatisfiedMinimalDef{}
-> noHints
TcRnMisplacedInstSig{}
@@ -2352,6 +2374,8 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnUnknownTyVarsOnRhsOfInjCond{}
-> noHints
+ TcRnMissingInterfaceError reason
+ -> missingInterfaceErrorHints reason
diagnosticCode = constructorCode
@@ -2366,6 +2390,256 @@ commafyWith conjunction xs = addConjunction $ punctuate comma xs
addConjunction (x : xs) = x : addConjunction xs
addConjunction _ = panic "commafyWith expected 2 or more elements"
+missingInterfaceErrorHints :: MissingInterfaceError -> [GhcHint]
+missingInterfaceErrorHints reason =
+ case reason of
+ BadSourceImport {} -> noHints
+ MissingDeclInInterface {} -> noHints
+ HomeModError {} -> noHints
+ DynamicHashMismatchError {} -> noHints
+ CantFindErr {} -> noHints
+ CantFindInstalledErr {} -> noHints
+ HiModuleNameMismatchWarn {} -> noHints
+ BadIfaceFile {} -> noHints
+ FailedToLoadDynamicInterface {} -> noHints
+ GenericException {} -> noHints
+ CantFindLocalName {} -> noHints
+ CantFindHiInterfaceForSig {} -> noHints
+ CantFindHiBoot {} -> noHints
+ InterfaceLookupError {} -> noHints
+
+missingInterfaceErrorReason :: MissingInterfaceError -> DiagnosticReason
+missingInterfaceErrorReason _reason = ErrorWithoutFlag
+
+prettyCantFindWhat :: CantFindWhat -> SDoc
+prettyCantFindWhat CantFindModule = text "Could not find module"
+prettyCantFindWhat CantLoadModule = text "Could not load module"
+prettyCantFindWhat CantLoadInterface = text "Failed to load interface for"
+prettyCantFindWhat AmbigiousModule = text "Ambiguous module name"
+prettyCantFindWhat AmbiguousInterface = text "Ambigious interface for"
+
+cantFindError :: Bool -> CantFindInstalled -> DecoratedSDoc
+cantFindError verbose (CantFindInstalled mod_name what cfir) =
+ mkSimpleDecorated (prettyCantFindWhat what <+> quotes (ppr mod_name)) `unionDecoratedSDoc`
+ 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 mkSimpleDecorated (text "no unit id matching" <+> quotes (ppr pkg) <+>
+ text "was found" $$ looks_like_srcpkgid)
+ MissingPackageFiles pkg files ->
+ mkSimpleDecorated $
+ 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 ->
+ mkSimpleDecorated $
+ 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 mkSimpleDecorated $ pp_suggestions ms $$ mayShowLocations verbose fps
+ NotAModule -> mkSimpleDecorated $ text "It is not a module in the current program, or in any known package."
+ CouldntFindInFiles fps -> mkSimpleDecorated (vcat (map text fps))
+ MultiplePackages pkgs -> mkSimpleDecorated $
+ sep [text "it was found in multiple packages:",
+ hsep (map ppr pkgs)]
+ MultiplePackages2 mods -> mkSimpleDecorated $
+ vcat (map pprMod mods)
+ GenericMissing using_cabal pkg_hiddens mod_hiddens unusables files -> mkSimpleDecorated $
+ 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)
+
+missingInterfaceErrorDiagnostic :: Bool -> MissingInterfaceError -> DecoratedSDoc
+missingInterfaceErrorDiagnostic verbose_files reason =
+ case reason of
+ BadSourceImport m -> mkSimpleDecorated $ badSourceImport m
+ MissingDeclInInterface name things -> mkSimpleDecorated $ missingDeclInInterface name things
+ HomeModError im ml -> mkSimpleDecorated $ homeModError im ml
+ DynamicHashMismatchError m ml -> mkSimpleDecorated $ dynamicHashMismatchError m ml
+ CantFindErr us cfi -> mkDecorated . map (pprWithUnitState us) . unDecorated $ cantFindError verbose_files cfi
+ CantFindInstalledErr cfi -> cantFindError verbose_files cfi
+ HiModuleNameMismatchWarn m1 m2 -> mkSimpleDecorated $ hiModuleNameMismatchWarn m1 m2
+ BadIfaceFile fp mie ->
+ -- TODO
+ mkSimpleDecorated (text fp)
+ `unionDecoratedSDoc` missingInterfaceErrorDiagnostic verbose_files mie
+ FailedToLoadDynamicInterface wanted_mod err ->
+ mkSimpleDecorated (text "Failed to load dynamic interface file for" <+> ppr wanted_mod)
+ `unionDecoratedSDoc` missingInterfaceErrorDiagnostic verbose_files err
+ GenericException se ->
+-- mkSimpleDecorated $ text "Exception when reading interface file for" <+> ppr mod
+ mkSimpleDecorated $ text (showException se)
+ CantFindLocalName name -> mkSimpleDecorated (text "Can't find local name: " <+> ppr name)
+ CantFindHiInterfaceForSig isig_mod mie ->
+ mkSimpleDecorated (text "Could not find hi interface for signature" <+> quotes (ppr isig_mod))
+ `unionDecoratedSDoc` missingInterfaceErrorDiagnostic verbose_files mie
+ CantFindHiBoot m mie ->
+ mkSimpleDecorated (text "Could not find hi-boot interface for" <+> quotes (ppr m))
+ `unionDecoratedSDoc` missingInterfaceErrorDiagnostic verbose_files mie
+ InterfaceLookupError _ mie -> missingInterfaceErrorDiagnostic verbose_files mie
+
+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,13 @@ module GHC.Tc.Errors.Types (
, HsDocContext(..)
, FixedRuntimeRepErrorInfo(..)
+ , MissingInterfaceError(..)
+ , CantFindInstalled(..)
+ , CantFindInstalledReason(..)
+ , CantFindWhat(..)
+
+ , BuildingCabalPackage(..)
+
, ErrorItem(..), errorItemOrigin, errorItemEqRel, errorItemPred, errorItemCtLoc
, SolverReport(..), SolverReportSupplementary(..)
@@ -116,7 +123,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,7 +136,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.Unit.State (UnitState, ModuleSuggestion, ModuleOrigin, UnusableUnitReason, UnitInfo)
import GHC.Types.Basic
import GHC.Utils.Misc (capitalise, filterOut)
import qualified GHC.LanguageExtensions as LangExt
@@ -144,6 +151,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 +2554,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 +3178,8 @@ data TcRnMessage where
-}
TcRnUnknownTyVarsOnRhsOfInjCond :: [Name] -> TcRnMessage
+ TcRnMissingInterfaceError :: !MissingInterfaceError -> TcRnMessage
+
deriving Generic
-- | Things forbidden in @type data@ declarations.
@@ -3596,6 +3598,41 @@ instance Outputable Exported where
ppr IsNotExported = text "IsNotExported"
ppr IsExported = text "IsExported"
+data MissingInterfaceError =
+ BadSourceImport !Module
+ | MissingDeclInInterface !Name [TyThing]
+ | HomeModError !InstalledModule !ModLocation
+ | DynamicHashMismatchError !Module !ModLocation
+ | HiModuleNameMismatchWarn Module Module
+ | CantFindLocalName Name
+ -- dodgy?
+ | GenericException SomeException
+ -- Can't find errors
+ | CantFindErr !UnitState CantFindInstalled
+ | CantFindInstalledErr CantFindInstalled
+ -- Adding context
+ | BadIfaceFile FilePath MissingInterfaceError
+ | FailedToLoadDynamicInterface Module MissingInterfaceError
+ | CantFindHiInterfaceForSig InstalledModule MissingInterfaceError
+ | CantFindHiBoot Module MissingInterfaceError
+ | InterfaceLookupError Name MissingInterfaceError
+ 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]
+ -- Ambiguous
+ | MultiplePackages [Unit]
+ | MultiplePackages2 [(Module, ModuleOrigin)]
+ deriving Generic
+
+data CantFindInstalled = CantFindInstalled ModuleName CantFindWhat CantFindInstalledReason deriving Generic
+
+data CantFindWhat = CantFindModule | CantLoadModule | CantLoadInterface | AmbiguousInterface | AmbigiousModule
--------------------------------------------------------------------------------
--
-- Errors used in GHC.Tc.Errors
@@ -4419,3 +4456,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 (TcRnMissingInterfaceError (InterfaceLookupError name 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 (TcRnMissingInterfaceError (InterfaceLookupError name 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,7 +563,7 @@ mergeSignatures
im = fst (getModuleInstantiation m)
ctx = initSDocContext dflags defaultUserStyle
fmap fst
- . withException ctx
+ . withIfaceErr ctx
$ findAndReadIface hsc_env
(text "mergeSignatures") im m NotBoot
@@ -996,9 +996,11 @@ 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 $
+ Failed err -> failWithTc $ TcRnMissingInterfaceError $ CantFindHiInterfaceForSig isig_mod err
+ {-
hang (text "Could not find hi interface for signature" <+>
quotes (ppr isig_mod) <> colon) 4 err
+ -}
-- 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,12 @@ 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 msg ->
+ let err_txt = formatBulleted $ diagnosticMessage (initTcMessageOpts (hsc_dflags hsc_env)) (TcRnMissingInterfaceError msg)
+ in pprPanic "lookupGlobal" err_txt
}
-lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
+lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MissingInterfaceError 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.
@@ -166,14 +170,14 @@ lookupGlobal_maybe hsc_env name
; if nameIsLocalOrFrom tcg_semantic_mod name
then (return
- (Failed (text "Can't find local name: " <+> ppr name)))
+ (Failed (CantFindLocalName name)))
-- Internal names can happen in GHCi
else
-- Try home package table and external package table
lookupImported_maybe hsc_env name
}
-lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
+lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MissingInterfaceError 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
@@ -182,7 +186,7 @@ lookupImported_maybe hsc_env name
Nothing -> importDecl_maybe hsc_env name
}
-importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
+importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MissingInterfaceError TyThing)
importDecl_maybe hsc_env name
| Just thing <- wiredInNameTyThing_maybe name
= do { when (needWiredInHomeIface thing)
@@ -192,22 +196,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 +245,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 (TcRnMissingInterfaceError (InterfaceLookupError name msg))
}}}
-- Look up only in this module's global env't. Don't look in imports, etc.
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -138,7 +138,7 @@ module GHC.Tc.Utils.Monad(
forkM,
setImplicitEnvM,
- withException,
+ withException, withIfaceErr,
-- * Stuff for cost centres.
getCCIndexM, getCCIndexTcM,
@@ -663,6 +663,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 diag = TcRnMissingInterfaceError err
+ msg = pprDiagnostic diag
+ 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
=====================================
@@ -583,6 +583,33 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "OneArgExpected" = 91490
GhcDiagnosticCode "AtLeastOneArgExpected" = 07641
+ -- Missing interface errors
+ GhcDiagnosticCode "BadSourceImport" = 00001
+ GhcDiagnosticCode "MissingDeclInInterface" = 00002
+ GhcDiagnosticCode "MissingInterfaceError" = 00003
+ GhcDiagnosticCode "HomeModError" = 00004
+ GhcDiagnosticCode "DynamicHashMismatchError" = 00005
+ GhcDiagnosticCode "BadIfaceFile" = 00006
+ GhcDiagnosticCode "CantFindLocalName" = 00009
+ GhcDiagnosticCode "FailedToLoadDynamicInterface" = 00010
+ GhcDiagnosticCode "GenericException" = 00011
+ GhcDiagnosticCode "HiModuleNameMismatch" = 00012
+ GhcDiagnosticCode "HiModuleNameMismatchWarn" = 00013
+ GhcDiagnosticCode "UsedAsDataConstructor" = 00014
+ GhcDiagnosticCode "CantFindHiInterfaceForSig" = 00015
+
+ GhcDiagnosticCode "CouldntFindInFiles" = 00016
+ GhcDiagnosticCode "GenericMissing" = 00017
+ GhcDiagnosticCode "MissingPackageFiles" = 00018
+ GhcDiagnosticCode "MissingPackageWayFiles" = 00019
+ GhcDiagnosticCode "ModuleSuggestion" = 00020
+ GhcDiagnosticCode "MultiplePackages" = 00021
+ GhcDiagnosticCode "MultiplePackages2" = 00022
+ GhcDiagnosticCode "NoUnitIdMatching" = 00023
+ GhcDiagnosticCode "NotAModule" = 00024
+ GhcDiagnosticCode "CantFindHiBoot" = 00025
+
+
-- Out of scope errors
GhcDiagnosticCode "NotInScope" = 76037
GhcDiagnosticCode "NoExactName" = 97784
@@ -670,6 +697,18 @@ 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 MissingInterfaceError
+ ConRecursInto "FailedToLoadDynamicInterface" = 'Just MissingInterfaceError
+ ConRecursInto "CantFindHiInterfaceForSig" = 'Just MissingInterfaceError
+ ConRecursInto "CantFindHiBoot" = 'Just MissingInterfaceError
+ ConRecursInto "InterfaceLookupError" = 'Just MissingInterfaceError
----------------------------------
-- Constructors of PsMessage
@@ -698,6 +737,8 @@ type family ConRecursInto con where
ConRecursInto "TcRnRunSpliceFailure" = 'Just RunSpliceFailReason
ConRecursInto "ConversionFail" = 'Just ConversionFailReason
+ ConRecursInto "TcRnMissingInterfaceError" = '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
=====================================
@@ -98,6 +98,8 @@ import GHC.ResponseFile (expandResponse)
import Data.Bifunctor
import GHC.Data.Graph.Directed
import qualified Data.List.NonEmpty as NE
+import GHC.Types.Error
+import GHC.Tc.Errors.Types (TcRnMessage(..))
-----------------------------------------------------------------------------
-- ToDo:
@@ -1100,8 +1102,9 @@ 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 err_txt = formatBulleted $ diagnosticMessage (initTcMessageOpts dflags) (TcRnMissingInterfaceError (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/93c56386f13072bb7e58c5981e807426e6eb4f8e...4c2bf582af0931c41c86e8210bbfcccdf785f951
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/93c56386f13072bb7e58c5981e807426e6eb4f8e...4c2bf582af0931c41c86e8210bbfcccdf785f951
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/20230315/46b9d6fb/attachment-0001.html>
More information about the ghc-commits
mailing list