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