summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc')
-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
6 files changed, 65 insertions, 59 deletions
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
+
{-
************************************************************************
* *
View Lorry Controller Status