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.

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