summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc/Utils
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc/Utils')
-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
3 files changed, 44 insertions, 41 deletions
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