Convert interface file loading errors into proper diagnosticswip/interface-loading-errs

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.

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
+
 {-
 ************************************************************************
 *                                                                      *