Refactor UnitId pretty-printing

When we pretty-print a UnitId for the user, we try to map it back to its
origin package name, version and component to print
"package-version:component" instead of some hash.

The UnitId type doesn't carry these information, so we have to look into
a UnitState to find them. This is why the Outputable instance of
UnitId used `sdocWithDynFlags` in order to access the `unitState` field
of DynFlags.

This is wrong for several reasons:

1. The DynFlags are accessed when the message is printed, not when it is
   generated. So we could imagine that the unitState may have changed
   in-between. Especially if we want to allow unit unloading.

2. We want GHC to support several independent sessions at once, hence
   several UnitState. The current approach supposes there is a unique
   UnitState as a UnitId doesn't indicate which UnitState to use.

See the Note [Pretty-printing UnitId] in GHC.Unit for the new approach
implemented by this patch.

One step closer to remove `sdocDynFlags` field from `SDocContext`
(#10143).

Fix #18124.

Also fix some Backpack code to use SDoc instead of String.

24 files changed, 202 insertions, 185 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 4c8864014f..bd3f0b6d9f 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -1682,7 +1682,7 @@ interpretPackageEnv dflags = do
         return dflags
       Just envfile -> do
         content <- readFile envfile
-        compilationProgressMsg dflags ("Loaded package environment from " ++ envfile)
+        compilationProgressMsg dflags (text "Loaded package environment from " <> text envfile)
         let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags
 
         return dflags'
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 1ae745ffe3..bfc58a3f42 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -88,7 +88,7 @@ doBackpack [src_filename] = do
             -- OK, so we have an LHsUnit PackageName, but we want an
             -- LHsUnit HsComponentId.  So let's rename it.
             let pkgstate = unitState dflags
-            let bkp = renameHsUnits pkgstate (bkpPackageNameMap pkgstate pkgname_bkp) pkgname_bkp
+            let bkp = renameHsUnits pkgstate (bkpPackageNameMap pkgname_bkp) pkgname_bkp
             initBkpM src_filename bkp $
                 forM_ (zip [1..] bkp) $ \(i, lunit) -> do
                     let comp_name = unLoc (hsunitName (unLoc lunit))
@@ -96,7 +96,7 @@ doBackpack [src_filename] = do
                     innerBkpM $ do
                         let (cid, insts) = computeUnitId lunit
                         if null insts
-                            then if cid == Indefinite (UnitId (fsLit "main")) Nothing
+                            then if cid == Indefinite (UnitId (fsLit "main"))
                                     then compileExe lunit
                                     else compileUnit cid []
                             else typecheckUnit cid insts
@@ -209,7 +209,7 @@ withBkpSession cid insts deps session_type do_this = do
 
 withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a
 withBkpExeSession deps do_this = do
-    withBkpSession (Indefinite (UnitId (fsLit "main")) Nothing) [] deps ExeSession do_this
+    withBkpSession (Indefinite (UnitId (fsLit "main"))) [] deps ExeSession do_this
 
 getSource :: IndefUnitId -> BkpM (LHsUnit HsComponentId)
 getSource cid = do
@@ -491,9 +491,10 @@ initBkpM file bkp m = do
 
 -- | Print a compilation progress message, but with indentation according
 -- to @level@ (for nested compilation).
-backpackProgressMsg :: Int -> DynFlags -> String -> IO ()
+backpackProgressMsg :: Int -> DynFlags -> SDoc -> IO ()
 backpackProgressMsg level dflags msg =
-    compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg
+    compilationProgressMsg dflags $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr
+                                      <> msg
 
 -- | Creates a 'Messager' for Backpack compilation; this is basically
 -- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which
@@ -503,17 +504,18 @@ mkBackpackMsg = do
     level <- getBkpLevel
     return $ \hsc_env mod_index recomp mod_summary ->
       let dflags = hsc_dflags hsc_env
+          state = unitState dflags
           showMsg msg reason =
-            backpackProgressMsg level dflags $
-                showModuleIndex mod_index ++
-                msg ++ showModMsg dflags (recompileRequired recomp) mod_summary
-                    ++ reason
+            backpackProgressMsg level dflags $ pprWithUnitState state $
+                showModuleIndex mod_index <>
+                msg <> showModMsg dflags (recompileRequired recomp) mod_summary
+                    <> reason
       in case recomp of
-            MustCompile -> showMsg "Compiling " ""
+            MustCompile -> showMsg (text "Compiling ") empty
             UpToDate
-                | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping  " ""
+                | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty
                 | otherwise -> return ()
-            RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
+            RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]")
 
 -- | 'PprStyle' for Backpack messages; here we usually want the module to
 -- be qualified (so we can tell how it was instantiated.) But we try not
@@ -531,27 +533,29 @@ msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do
     dflags <- getDynFlags
     level <- getBkpLevel
     liftIO . backpackProgressMsg level dflags
-        $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn
+        $ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn
 
 -- | Message when we instantiate a Backpack unit.
 msgUnitId :: Unit -> BkpM ()
 msgUnitId pk = do
     dflags <- getDynFlags
     level <- getBkpLevel
+    let state = unitState dflags
     liftIO . backpackProgressMsg level dflags
-        $ "Instantiating " ++ renderWithContext
-                                (initSDocContext dflags backpackStyle)
-                                (ppr pk)
+        $ pprWithUnitState state
+        $ text "Instantiating "
+           <> withPprStyle backpackStyle (ppr pk)
 
 -- | Message when we include a Backpack unit.
 msgInclude :: (Int,Int) -> Unit -> BkpM ()
 msgInclude (i,n) uid = do
     dflags <- getDynFlags
     level <- getBkpLevel
+    let state = unitState dflags
     liftIO . backpackProgressMsg level dflags
-        $ showModuleIndex (i, n) ++ "Including " ++
-          renderWithContext (initSDocContext dflags backpackStyle)
-            (ppr uid)
+        $ pprWithUnitState state
+        $ showModuleIndex (i, n) <> text "Including "
+            <> withPprStyle backpackStyle (ppr uid)
 
 -- ----------------------------------------------------------------------------
 -- Conversion from PackageName to HsComponentId
@@ -560,12 +564,12 @@ type PackageNameMap a = Map PackageName a
 
 -- For now, something really simple, since we're not actually going
 -- to use this for anything
-unitDefines :: UnitState -> LHsUnit PackageName -> (PackageName, HsComponentId)
-unitDefines pkgstate (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
-    = (pn, HsComponentId pn (mkIndefUnitId pkgstate (UnitId fs)))
+unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
+unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
+    = (pn, HsComponentId pn (Indefinite (UnitId fs)))
 
-bkpPackageNameMap :: UnitState -> [LHsUnit PackageName] -> PackageNameMap HsComponentId
-bkpPackageNameMap pkgstate units = Map.fromList (map (unitDefines pkgstate) units)
+bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
+bkpPackageNameMap units = Map.fromList (map unitDefines units)
 
 renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
 renameHsUnits pkgstate m units = map (fmap renameHsUnit) units
diff --git a/compiler/GHC/Driver/Finder.hs b/compiler/GHC/Driver/Finder.hs
index 0b9ad24371..c598e36791 100644
--- a/compiler/GHC/Driver/Finder.hs
+++ b/compiler/GHC/Driver/Finder.hs
@@ -620,11 +620,12 @@ findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])
 -- Error messages
 
 cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc
-cannotFindModule flags mod res =
+cannotFindModule dflags mod res = pprWithUnitState unit_state $
   cantFindErr (sLit cannotFindMsg)
               (sLit "Ambiguous module name")
-              flags mod res
+              dflags mod res
   where
+    unit_state = unitState dflags
     cannotFindMsg =
       case res of
         NotFound { fr_mods_hidden = hidden_mods
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index ab27efc832..a78df33e86 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -887,25 +887,25 @@ oneShotMsg hsc_env recomp =
     case recomp of
         UpToDate ->
             compilationProgressMsg (hsc_dflags hsc_env) $
-                   "compilation IS NOT required"
+                   text "compilation IS NOT required"
         _ ->
             return ()
 
 batchMsg :: Messager
 batchMsg hsc_env mod_index recomp mod_summary =
     case recomp of
-        MustCompile -> showMsg "Compiling " ""
+        MustCompile -> showMsg (text "Compiling ") empty
         UpToDate
-            | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping  " ""
+            | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty
             | otherwise -> return ()
-        RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
+        RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]")
     where
         dflags = hsc_dflags hsc_env
         showMsg msg reason =
             compilationProgressMsg dflags $
-            (showModuleIndex mod_index ++
-            msg ++ showModMsg dflags (recompileRequired recomp) mod_summary)
-                ++ reason
+            (showModuleIndex mod_index <>
+            msg <> showModMsg dflags (recompileRequired recomp) mod_summary)
+                <> reason
 
 --------------------------------------------------------------
 -- Safe Haskell
@@ -1174,7 +1174,8 @@ hscCheckSafe' m l = do
                     pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $
                         sep [ ppr (moduleName m)
                                 <> text ": Can't be safely imported!"
-                            , text "The package (" <> ppr (moduleUnit m)
+                            , text "The package ("
+                                <> (pprWithUnitState state $ ppr (moduleUnit m))
                                 <> text ") the module resides in isn't trusted."
                             ]
                     modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $
@@ -1225,8 +1226,10 @@ checkPkgTrust pkgs = do
             = acc
             | otherwise
             = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual state)
-                     $ text "The package (" <> ppr pkg <> text ") is required" <>
-                       text " to be trusted but it isn't!"
+                     $ pprWithUnitState state
+                     $ text "The package ("
+                        <> ppr pkg
+                        <> text ") is required to be trusted but it isn't!"
     case errors of
         [] -> return ()
         _  -> (liftIO . throwIO . mkSrcErr . listToBag) errors
@@ -1940,9 +1943,9 @@ dumpIfaceStats hsc_env = do
 %*                                                                      *
 %********************************************************************* -}
 
-showModuleIndex :: (Int, Int) -> String
-showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "
+showModuleIndex :: (Int, Int) -> SDoc
+showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] "
   where
-    n_str = show n
-    i_str = show i
-    padded = replicate (length n_str - length i_str) ' ' ++ i_str
+    -- compute the length of x > 0 in base 10
+    len x = ceiling (logBase 10 (fromIntegral x+1) :: Float)
+    pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index ca82e216d9..8386dd9c7e 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -474,7 +474,7 @@ link' dflags batch_attempt_linking hpt
                    return Succeeded
            else do
 
-        compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...")
+        compilationProgressMsg dflags (text "Linking " <> text exe_file <> text " ...")
 
         -- Don't showPass in Batch mode; doLink will do that for us.
         let link = case ghcLink dflags of
diff --git a/compiler/GHC/Driver/Ppr.hs b/compiler/GHC/Driver/Ppr.hs
index 6fe4ea91cc..5920acc959 100644
--- a/compiler/GHC/Driver/Ppr.hs
+++ b/compiler/GHC/Driver/Ppr.hs
@@ -30,6 +30,7 @@ import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Ppr       ( Mode(..) )
+import {-# SOURCE #-} GHC.Unit.State
 
 import System.IO ( Handle )
 import Control.Monad.IO.Class
@@ -46,7 +47,11 @@ showPprUnsafe a = showPpr unsafeGlobalDynFlags a
 
 -- | Allows caller to specify the PrintUnqualified to use
 showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
-showSDocForUser dflags unqual doc = renderWithContext (initSDocContext dflags (mkUserStyle unqual AllTheWay)) doc
+showSDocForUser dflags unqual doc = renderWithContext (initSDocContext dflags sty) doc'
+   where
+      sty        = mkUserStyle unqual AllTheWay
+      unit_state = unitState dflags
+      doc'       = pprWithUnitState unit_state doc
 
 showSDocDump :: DynFlags -> SDoc -> String
 showSDocDump dflags d = renderWithContext (initSDocContext dflags defaultDumpStyle) d
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 2c6c3affbd..041c7bc418 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -5080,6 +5080,7 @@ initSDocContext dflags style = SDC
   , sdocImpredicativeTypes          = xopt LangExt.ImpredicativeTypes dflags
   , sdocLinearTypes                 = xopt LangExt.LinearTypes dflags
   , sdocPrintTypeAbbreviations      = True
+  , sdocUnitIdForUser               = ftext
   , sdocDynFlags                    = dflags
   }
 
diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs
index 502ec07569..1cfd153523 100644
--- a/compiler/GHC/Driver/Types.hs
+++ b/compiler/GHC/Driver/Types.hs
@@ -2995,8 +2995,8 @@ instance Outputable ModSummary where
              char '}'
             ]
 
-showModMsg :: DynFlags -> Bool -> ModSummary -> String
-showModMsg dflags recomp mod_summary = showSDoc dflags $
+showModMsg :: DynFlags -> Bool -> ModSummary -> SDoc
+showModMsg dflags recomp mod_summary =
    if gopt Opt_HideSourcePaths dflags
       then text mod_str
       else hsep $
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index 508a6b8281..39e08c7eee 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -1121,6 +1121,7 @@ For some background on this choice see trac #15269.
 showIface :: HscEnv -> FilePath -> IO ()
 showIface hsc_env filename = do
    let dflags  = hsc_dflags hsc_env
+       unit_state = unitState dflags
        printer = putLogMsg dflags NoReason SevOutput noSrcSpan . withPprStyle defaultDumpStyle
 
    -- skip the hi way check; we don't want to worry about profiled vs.
@@ -1136,7 +1137,9 @@ showIface hsc_env filename = do
                                    neverQualifyModules
                                    neverQualifyPackages
    putLogMsg dflags NoReason SevDump noSrcSpan
-      $ withPprStyle (mkDumpStyle print_unqual) (pprModIface iface)
+      $ withPprStyle (mkDumpStyle print_unqual)
+      $ pprWithUnitState unit_state
+      $ pprModIface iface
 
 -- Show a ModIface but don't display details; suitable for ModIfaces stored in
 -- the EPT.
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index 575ef06a11..a179beff18 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -123,7 +123,9 @@ mkFullIface hsc_env partial_iface mb_cg_infos = do
       addFingerprints hsc_env partial_iface{ mi_decls = decls }
 
     -- Debug printing
-    dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface)
+    let unit_state = unitState (hsc_dflags hsc_env)
+    dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText
+      (pprWithUnitState unit_state $ pprModIface full_iface)
 
     return full_iface
 
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index 7197710cfb..0891da5808 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -1257,7 +1257,7 @@ showModule mod_summary =
     withSession $ \hsc_env -> do
         interpreted <- moduleIsBootOrNotObjectLinkable mod_summary
         let dflags = hsc_dflags hsc_env
-        return (showModMsg dflags interpreted mod_summary)
+        return (showSDoc dflags $ showModMsg dflags interpreted mod_summary)
 
 moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool
 moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 8231955063..311f87458f 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -2866,11 +2866,12 @@ rnDump rn = dumpOptTcRn Opt_D_dump_rn "Renamer" FormatHaskell (ppr rn)
 tcDump :: TcGblEnv -> TcRn ()
 tcDump env
  = do { dflags <- getDynFlags ;
+        unit_state <- unitState <$> getDynFlags ;
 
         -- Dump short output if -ddump-types or -ddump-tc
         when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
           (dumpTcRn True (dumpOptionsFromFlag Opt_D_dump_types)
-            "" FormatText short_dump) ;
+            "" FormatText (pprWithUnitState unit_state short_dump)) ;
 
         -- Dump bindings if -ddump-tc
         dumpOptTcRn Opt_D_dump_tc "Typechecker" FormatHaskell full_dump;
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index 5dbc90de86..b27002bec8 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -234,16 +234,15 @@ check_inst sig_inst = do
 -- | Return this list of requirement interfaces that need to be merged
 -- to form @mod_name@, or @[]@ if this is not a requirement.
 requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule]
-requirementMerges pkgstate mod_name =
-    fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate))
+requirementMerges unit_state mod_name =
+    fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext unit_state))
     where
       -- update IndefUnitId ppr info as they may have changed since the
       -- time the IndefUnitId was created
       fixupModule (Module iud name) = Module iud' name
          where
-            iud' = iud { instUnitInstanceOf = cid' }
+            iud' = iud { instUnitInstanceOf = cid }
             cid  = instUnitInstanceOf iud
-            cid' = updateIndefUnitId pkgstate cid
 
 -- | For a module @modname@ of type 'HscSource', determine the list
 -- of extra "imports" of other requirements which should be considered part of
@@ -276,8 +275,8 @@ findExtraSigImports' hsc_env HsigFile modname =
             $ moduleFreeHolesPrecise (text "findExtraSigImports")
                 (mkModule (VirtUnit iuid) mod_name)))
   where
-    pkgstate = unitState (hsc_dflags hsc_env)
-    reqs = requirementMerges pkgstate modname
+    unit_state = unitState (hsc_dflags hsc_env)
+    reqs = requirementMerges unit_state modname
 
 findExtraSigImports' _ _ _ = return emptyUniqDSet
 
@@ -535,17 +534,17 @@ mergeSignatures
        }) $ do
     tcg_env <- getGblEnv
 
-    let outer_mod = tcg_mod tcg_env
-        inner_mod = tcg_semantic_mod tcg_env
-        mod_name = moduleName (tcg_mod tcg_env)
-        pkgstate = unitState dflags
-        home_unit = mkHomeUnitFromFlags dflags
+    let outer_mod  = tcg_mod tcg_env
+        inner_mod  = tcg_semantic_mod tcg_env
+        mod_name   = moduleName (tcg_mod tcg_env)
+        unit_state = unitState dflags
+        home_unit  = mkHomeUnitFromFlags dflags
 
     -- STEP 1: Figure out all of the external signature interfaces
     -- we are going to merge in.
-    let reqs = requirementMerges pkgstate mod_name
+    let reqs = requirementMerges unit_state mod_name
 
-    addErrCtxt (merge_msg mod_name reqs) $ do
+    addErrCtxt (pprWithUnitState unit_state $ merge_msg mod_name reqs) $ do
 
     -- STEP 2: Read in the RAW forms of all of these interfaces
     ireq_ifaces0 <- forM reqs $ \(Module iuid mod_name) ->
@@ -572,7 +571,7 @@ mergeSignatures
             let insts = instUnitInsts iuid
                 isFromSignaturePackage =
                     let inst_uid = instUnitInstanceOf iuid
-                        pkg = unsafeLookupUnitId pkgstate (indefUnit inst_uid)
+                        pkg = unsafeLookupUnitId unit_state (indefUnit inst_uid)
                     in null (unitExposedModules pkg)
             -- 3(a). Rename the exports according to how the dependency
             -- was instantiated.  The resulting export list will be accurate
@@ -900,18 +899,21 @@ tcRnInstantiateSignature hsc_env this_mod real_loc =
 exportOccs :: [AvailInfo] -> [OccName]
 exportOccs = concatMap (map occName . availNames)
 
-impl_msg :: Module -> InstantiatedModule -> SDoc
-impl_msg impl_mod (Module req_uid req_mod_name) =
-  text "while checking that" <+> ppr impl_mod <+>
-  text "implements signature" <+> ppr req_mod_name <+>
-  text "in" <+> ppr req_uid
+impl_msg :: UnitState -> Module -> InstantiatedModule -> SDoc
+impl_msg unit_state impl_mod (Module req_uid req_mod_name)
+   = pprWithUnitState unit_state $
+      text "while checking that" <+> ppr impl_mod <+>
+      text "implements signature" <+> ppr req_mod_name <+>
+      text "in" <+> ppr req_uid
 
 -- | Check if module implements a signature.  (The signature is
 -- always un-hashed, which is why its components are specified
 -- explicitly.)
 checkImplements :: Module -> InstantiatedModule -> TcRn TcGblEnv
-checkImplements impl_mod req_mod@(Module uid mod_name) =
-  addErrCtxt (impl_msg impl_mod req_mod) $ do
+checkImplements impl_mod req_mod@(Module uid mod_name) = do
+  dflags <- getDynFlags
+  let unit_state = unitState dflags
+  addErrCtxt (impl_msg unit_state impl_mod req_mod) $ do
     let insts = instUnitInsts uid
 
     -- STEP 1: Load the implementing interface, and make a RdrEnv
@@ -931,7 +933,6 @@ checkImplements impl_mod req_mod@(Module uid mod_name) =
     loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)")
                          (dep_orphs (mi_deps impl_iface))
 
-    dflags <- getDynFlags
     let avails = calculateAvails dflags
                     impl_iface False{- safe -} NotBoot ImportedBySystem
         fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
@@ -969,9 +970,8 @@ checkImplements impl_mod req_mod@(Module uid mod_name) =
     forM_ (exportOccs (mi_exports isig_iface)) $ \occ ->
         case lookupGlobalRdrEnv impl_gr occ of
             [] -> addErr $ quotes (ppr occ)
-                    <+> text "is exported by the hsig file, but not"
-                    <+> text "exported by the implementing module"
-                    <+> quotes (ppr impl_mod)
+                    <+> text "is exported by the hsig file, but not exported by the implementing module"
+                    <+> quotes (pprWithUnitState unit_state $ ppr impl_mod)
             _ -> return ()
     failIfErrsM
 
@@ -1002,15 +1002,12 @@ instantiateSignature = do
     let outer_mod = tcg_mod tcg_env
         inner_mod = tcg_semantic_mod tcg_env
         home_unit = mkHomeUnitFromFlags dflags
-        unit_state = unitState dflags
     -- TODO: setup the local RdrEnv so the error messages look a little better.
     -- But this information isn't stored anywhere. Should we RETYPECHECK
     -- the local one just to get the information?  Hmm...
     MASSERT( isHomeModule home_unit outer_mod )
     MASSERT( isHomeUnitInstantiating home_unit)
-        -- we need to fetch the most recent ppr infos from the unit
-        -- database because we might have modified it
-    let uid = mkIndefUnitId unit_state (homeUnitInstanceOf home_unit)
+    let uid = Indefinite (homeUnitInstanceOf home_unit)
     inner_mod `checkImplements`
         Module
             (mkInstantiatedUnit uid (homeUnitInstantiations home_unit))
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
index 8a9c791da3..d93e8fc84f 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -80,6 +80,7 @@ import GHC.Utils.Panic
 import GHC.Utils.Outputable
 import GHC.Types.Basic ( TypeOrKind(..) )
 import qualified GHC.LanguageExtensions as LangExt
+import GHC.Unit.State
 
 import Data.List ( sortBy, mapAccumL )
 import Control.Monad( unless )
@@ -972,9 +973,10 @@ dupInstErr ispec dup_ispec
                     [ispec, dup_ispec]
 
 addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
-addClsInstsErr herald ispecs
-  = setSrcSpan (getSrcSpan (head sorted)) $
-    addErr (hang herald 2 (pprInstances sorted))
+addClsInstsErr herald ispecs = do
+   unit_state <- unitState <$> getDynFlags
+   setSrcSpan (getSrcSpan (head sorted)) $
+      addErr $ pprWithUnitState unit_state $ (hang herald 2 (pprInstances sorted))
  where
    sorted = sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs
    -- The sortBy just arranges that instances are displayed in order
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 9f7d0b2ec1..b2c987794b 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -977,13 +977,19 @@ mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
 mkLongErrAt loc msg extra
   = do { dflags <- getDynFlags ;
          printer <- getPrintUnqualified dflags ;
-         return $ mkLongErrMsg dflags loc printer msg extra }
+         unit_state <- unitState <$> getDynFlags ;
+         let msg' = pprWithUnitState unit_state msg in
+         return $ mkLongErrMsg dflags loc printer msg' extra }
 
 mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg
 mkErrDocAt loc errDoc
   = do { dflags <- getDynFlags ;
          printer <- getPrintUnqualified dflags ;
-         return $ mkErrDoc dflags loc printer errDoc }
+         unit_state <- unitState <$> getDynFlags ;
+         let f = pprWithUnitState unit_state
+             errDoc' = mapErrDoc f errDoc
+         in
+         return $ mkErrDoc dflags loc printer errDoc' }
 
 addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
 addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
diff --git a/compiler/GHC/Unit.hs b/compiler/GHC/Unit.hs
index 3c167762f4..0de384f52c 100644
--- a/compiler/GHC/Unit.hs
+++ b/compiler/GHC/Unit.hs
@@ -272,39 +272,58 @@ themselves.  It is a reminiscence of previous terminology (when "instanceOf" was
 TODO: We should probably have `instanceOf :: Maybe IndefUnitId` instead.
 
 
-Pretty-printing UnitId
-----------------------
+Note [Pretty-printing UnitId]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When we pretty-print a UnitId for the user, we try to map it back to its origin
+package name, version and component to print "package-version:component" instead
+of some hash. How to retrieve these information from a UnitId?
+
+Solution 0: ask for a UnitState to be passed each time we want to pretty-print a
+SDoc so that the Outputable instance for UnitId could retrieve the information
+from it. That what we used in the past: a DynFlags was passed and the UnitState
+was retrieved from it. This is wrong for several reasons:
+
+    1. The UnitState is accessed when the message is printed, not when it is
+       generated. So we could imagine that the UnitState could have changed
+       in-between. Especially if we want to allow unit unloading.
+
+    2. We want GHC to support several independent sessions at once, hence
+       several UnitState. This approach supposes there is a unique UnitState
+       (the one given at printing-time), moreover a UnitId doesn't indicate
+       which UnitState it comes from (think about statically defined UnitId for
+       wired-in units).
+
+Solution 1: an obvious approach would be to store the required information in
+the UnitId itself. However it doesn't work because some UnitId are defined
+statically for wired-in units and the same UnitId can map to different units in
+different contexts. This solution would make wired-in units harder to deal with.
+
+Solution 2: another approach would be to thread the UnitState to all places
+where a UnitId is pretty-printed and to retrieve the information from the
+UnitState only when needed. It would mean that UnitId couldn't have an
+Outputable instance as it would need an additional UnitState parameter to be
+printed. It means that many other types couldn't have an Outputable instance
+either: Unit, Module, Name, InstEnv, etc. Too many to make this solution
+feasible.
+
+Solution 3: the approach we use is a compromise between solutions 0 and 2: the
+appropriate UnitState has to be threaded close enough to the function generating
+the SDoc so that the latter can use `pprWithUnitState` to set the UnitState to
+fetch information from. However the UnitState doesn't have to be threaded
+explicitly all the way down to the point where the UnitId itself is printed:
+instead the Outputable instance of UnitId fetches the "sdocUnitIdForUser"
+field in the SDocContext to pretty-print.
+
+   1. We can still have Outputable instances for common types (Module, Unit,
+      Name, etc.)
+
+   2. End-users don't have to pass a UnitState (via a DynFlags) to print a SDoc.
+
+   3. By default "sdocUnitIdForUser" prints the UnitId hash. In case of a bug
+      (i.e. GHC doesn't correctly call `pprWithUnitState` before pretty-printing a
+      UnitId), that's what will be shown to the user so it's no big deal.
 
-GHC mostly deals with UnitIds which are some opaque strings. We could display
-them when we pretty-print a module origin, a name, etc. But it wouldn't be
-very friendly to the user because of the hash they usually contain. E.g.
-
-   foo-4.18.1:thelib-XYZsomeUglyHashABC
-
-Instead when we want to pretty-print a 'UnitId' we query the database to
-get the 'UnitInfo' and print something nicer to the user:
-
-   foo-4.18.1:thelib
-
-We do the same for wired-in units.
-
-Currently (2020-04-06), we don't thread the database into every function that
-pretty-prints a Name/Module/Unit. Instead querying the database is delayed
-until the `SDoc` is transformed into a `Doc` using the database that is
-active at this point in time. This is an issue because we want to be able to
-unload units from the database and we also want to support several
-independent databases loaded at the same time (see #14335). The alternatives
-we have are:
-
-   * threading the database into every function that pretty-prints a UnitId
-   for the user (directly or indirectly).
-
-   * storing enough info to correctly display a UnitId into the UnitId
-   datatype itself. This is done in the IndefUnitId wrapper (see
-   'UnitPprInfo' datatype) but not for every 'UnitId'. Statically defined
-   'UnitId' for wired-in units would have empty UnitPprInfo so we need to
-   find some places to update them if we want to display wired-in UnitId
-   correctly. This leads to a solution similar to the first one above.
 
 Note [VirtUnit to RealUnit improvement]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Unit/Home.hs b/compiler/GHC/Unit/Home.hs
index eceebd81d0..6baa8bf5fb 100644
--- a/compiler/GHC/Unit/Home.hs
+++ b/compiler/GHC/Unit/Home.hs
@@ -105,7 +105,7 @@ homeUnitInstanceOfMaybe _                                   = Nothing
 --    produce any code object that rely on the unit id of this virtual unit.
 homeUnitAsUnit :: HomeUnit -> Unit
 homeUnitAsUnit (DefiniteHomeUnit u _)    = RealUnit (Definite u)
-homeUnitAsUnit (IndefiniteHomeUnit u is) = mkVirtUnit (Indefinite u Nothing) is
+homeUnitAsUnit (IndefiniteHomeUnit u is) = mkVirtUnit (Indefinite u) is
 
 -- | Map over the unit identifier for instantiating units
 homeUnitMap :: IsUnitId v => (u -> v) -> GenHomeUnit u -> GenHomeUnit v
diff --git a/compiler/GHC/Unit/Info.hs b/compiler/GHC/Unit/Info.hs
index 839344804c..034b61e145 100644
--- a/compiler/GHC/Unit/Info.hs
+++ b/compiler/GHC/Unit/Info.hs
@@ -68,7 +68,7 @@ mkUnitKeyInfo = mapGenericUnitInfo
      mkPackageName'       = PackageName    . mkFastStringByteString
      mkUnitKey'           = UnitKey        . mkFastStringByteString
      mkModuleName'        = mkModuleNameFS . mkFastStringByteString
-     mkIndefUnitKey' cid  = Indefinite (mkUnitKey' cid) Nothing
+     mkIndefUnitKey' cid  = Indefinite (mkUnitKey' cid)
      mkVirtUnitKey' i = case i of
       DbInstUnitId cid insts -> mkVirtUnit (mkIndefUnitKey' cid) (fmap (bimap mkModuleName' mkModule') insts)
       DbUnitId uid           -> RealUnit (Definite (mkUnitKey' uid))
diff --git a/compiler/GHC/Unit/Parser.hs b/compiler/GHC/Unit/Parser.hs
index 6ae38259af..fddd594e8e 100644
--- a/compiler/GHC/Unit/Parser.hs
+++ b/compiler/GHC/Unit/Parser.hs
@@ -36,7 +36,7 @@ parseUnitId = do
 parseIndefUnitId :: ReadP IndefUnitId
 parseIndefUnitId = do
    uid <- parseUnitId
-   return (Indefinite uid Nothing)
+   return (Indefinite uid)
 
 parseHoleyModule :: ReadP Module
 parseHoleyModule = parseModuleVar <++ parseModule
diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs
index f35437be11..ec8cafe170 100644
--- a/compiler/GHC/Unit/State.hs
+++ b/compiler/GHC/Unit/State.hs
@@ -68,10 +68,9 @@ module GHC.Unit.State (
         pprUnitIdForUser,
         pprUnitInfoForUser,
         pprModuleMap,
+        pprWithUnitState,
 
         -- * Utils
-        mkIndefUnitId,
-        updateIndefUnitId,
         unwireUnit
     )
 where
@@ -2128,15 +2127,6 @@ pprUnitInfoForUser info = ppr (mkUnitPprInfo unitIdFS info)
 lookupUnitPprInfo :: UnitState -> UnitId -> Maybe UnitPprInfo
 lookupUnitPprInfo state uid = fmap (mkUnitPprInfo unitIdFS) (lookupUnitId state uid)
 
--- | Create a IndefUnitId.
-mkIndefUnitId :: UnitState -> UnitId -> IndefUnitId
-mkIndefUnitId state uid = Indefinite uid $! lookupUnitPprInfo state uid
-
--- | Update component ID details from the database
-updateIndefUnitId :: UnitState -> IndefUnitId -> IndefUnitId
-updateIndefUnitId pkgstate uid = mkIndefUnitId pkgstate (indefUnit uid)
-
-
 -- -----------------------------------------------------------------------------
 -- Displaying packages
 
@@ -2270,3 +2260,8 @@ instModuleToModule :: UnitState -> InstantiatedModule -> Module
 instModuleToModule pkgstate (Module iuid mod_name) =
     mkModule (instUnitToUnit pkgstate iuid) mod_name
 
+-- | Print unit-ids with UnitInfo found in the given UnitState
+pprWithUnitState :: UnitState -> SDoc -> SDoc
+pprWithUnitState state = updSDocContext (\ctx -> ctx
+   { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs)
+   })
diff --git a/compiler/GHC/Unit/State.hs-boot b/compiler/GHC/Unit/State.hs-boot
index 4107962941..7c906165df 100644
--- a/compiler/GHC/Unit/State.hs-boot
+++ b/compiler/GHC/Unit/State.hs-boot
@@ -1,12 +1,11 @@
 module GHC.Unit.State where
 
 import {-# SOURCE #-} GHC.Utils.Outputable
-import {-# SOURCE #-} GHC.Unit.Types (IndefUnitId, UnitId)
+import {-# SOURCE #-} GHC.Unit.Types (UnitId)
 
 data UnitState
 data UnitDatabase unit
 
 emptyUnitState :: UnitState
-mkIndefUnitId :: UnitState -> UnitId -> IndefUnitId
 pprUnitIdForUser :: UnitState -> UnitId -> SDoc
-updateIndefUnitId :: UnitState -> IndefUnitId -> IndefUnitId
+pprWithUnitState :: UnitState -> SDoc -> SDoc
diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs
index c402461630..f80a3b5b9d 100644
--- a/compiler/GHC/Unit/Types.hs
+++ b/compiler/GHC/Unit/Types.hs
@@ -2,6 +2,8 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 -- | Unit & Module types
 --
@@ -87,7 +89,6 @@ where
 import GHC.Prelude
 import GHC.Types.Unique
 import GHC.Types.Unique.DSet
-import GHC.Unit.Ppr
 import GHC.Unit.Module.Name
 import GHC.Utils.Binary
 import GHC.Utils.Outputable
@@ -104,9 +105,6 @@ import Data.Bifunctor
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BS.Char8
 
-import {-# SOURCE #-} GHC.Unit.State (pprUnitIdForUser)
-import {-# SOURCE #-} GHC.Driver.Session (unitState)
-
 ---------------------------------------------------------------------
 -- MODULES
 ---------------------------------------------------------------------
@@ -186,12 +184,6 @@ instance IsUnitId u => IsUnitId (GenUnit u) where
    unitFS (RealUnit (Definite x)) = unitFS x
    unitFS HoleUnit                = holeFS
 
-instance IsUnitId u => IsUnitId (Definite u) where
-   unitFS (Definite x) = unitFS x
-
-instance IsUnitId u => IsUnitId (Indefinite u) where
-   unitFS (Indefinite x _) = unitFS x
-
 pprModule :: Module -> SDoc
 pprModule mod@(Module p n)  = getPprStyle doc
  where
@@ -365,12 +357,6 @@ instance Binary Unit where
                 1 -> fmap VirtUnit (get bh)
                 _ -> pure HoleUnit
 
-instance Binary unit => Binary (Indefinite unit) where
-  put_ bh (Indefinite fs _) = put_ bh fs
-  get bh = do { fs <- get bh; return (Indefinite fs Nothing) }
-
-
-
 -- | Retrieve the set of free module holes of a 'Unit'.
 unitFreeModuleHoles :: GenUnit u -> UniqDSet ModuleName
 unitFreeModuleHoles (VirtUnit x) = instUnitHoles x
@@ -524,7 +510,8 @@ instance Uniquable UnitId where
     getUnique = getUnique . unitIdFS
 
 instance Outputable UnitId where
-    ppr uid = sdocWithDynFlags $ \dflags -> pprUnitIdForUser (unitState dflags) uid
+    ppr (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs) -- see Note [Pretty-printing UnitId]
+                                                          -- in "GHC.Unit"
 
 -- | A 'DefUnitId' is an 'UnitId' with the invariant that
 -- it only refers to a definite library; i.e., one we have generated
@@ -543,44 +530,16 @@ stringToUnitId = UnitId . mkFastString
 
 -- | A definite unit (i.e. without any free module hole)
 newtype Definite unit = Definite { unDefinite :: unit }
-    deriving (Eq, Ord, Functor)
-
-instance Outputable unit => Outputable (Definite unit) where
-    ppr (Definite uid) = ppr uid
-
-instance Binary unit => Binary (Definite unit) where
-    put_ bh (Definite uid) = put_ bh uid
-    get bh = do uid <- get bh; return (Definite uid)
-
+   deriving (Functor)
+   deriving newtype (Eq, Ord, Outputable, Binary, Uniquable, IsUnitId)
 
 -- | An 'IndefUnitId' is an 'UnitId' with the invariant that it only
 -- refers to an indefinite library; i.e., one that can be instantiated.
 type IndefUnitId = Indefinite UnitId
 
-data Indefinite unit = Indefinite
-   { indefUnit        :: !unit             -- ^ Unit identifier
-   , indefUnitPprInfo :: Maybe UnitPprInfo -- ^ Cache for some unit info retrieved from the DB
-   }
+newtype Indefinite unit = Indefinite { indefUnit :: unit }
    deriving (Functor)
-
-instance Eq unit => Eq (Indefinite unit) where
-   a == b = indefUnit a == indefUnit b
-
-instance Ord unit => Ord (Indefinite unit) where
-   compare a b = compare (indefUnit a) (indefUnit b)
-
-
-instance Uniquable unit => Uniquable (Indefinite unit) where
-  getUnique (Indefinite n _) = getUnique n
-
-instance Outputable unit => Outputable (Indefinite unit) where
-  ppr (Indefinite uid Nothing)        = ppr uid
-  ppr (Indefinite uid (Just pprinfo)) =
-    getPprDebug $ \debug ->
-      if debug
-         then ppr uid
-         else ppr pprinfo
-
+   deriving newtype (Eq, Ord, Outputable, Binary, Uniquable, IsUnitId)
 
 ---------------------------------------------------------------------
 -- WIRED-IN UNITS
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index e3d3cde2f7..654c4b91a9 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -18,6 +18,7 @@ module GHC.Utils.Error (
         -- * Messages
         ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason,
         ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary,
+        mapErrDoc,
         WarnMsg, MsgDoc,
         Messages, ErrorMessages, WarningMessages,
         unionMessages,
@@ -162,6 +163,9 @@ data ErrDoc = ErrDoc {
 errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
 errDoc = ErrDoc
 
+mapErrDoc :: (MsgDoc -> MsgDoc) -> ErrDoc -> ErrDoc
+mapErrDoc f (ErrDoc a b c) = ErrDoc (map f a) (map f b) (map f c)
+
 type WarnMsg = ErrMsg
 
 data Severity
@@ -635,11 +639,12 @@ fatalErrorMsg dflags msg =
 fatalErrorMsg'' :: FatalMessager -> String -> IO ()
 fatalErrorMsg'' fm msg = fm msg
 
-compilationProgressMsg :: DynFlags -> String -> IO ()
+compilationProgressMsg :: DynFlags -> SDoc -> IO ()
 compilationProgressMsg dflags msg = do
-    traceEventIO $ "GHC progress: " ++ msg
+    let str = showSDoc dflags msg
+    traceEventIO $ "GHC progress: " ++ str
     ifVerbose dflags 1 $
-        logOutput dflags $ withPprStyle defaultUserStyle (text msg)
+        logOutput dflags $ withPprStyle defaultUserStyle msg
 
 showPass :: DynFlags -> String -> IO ()
 showPass dflags what
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index 736d609def..af146ed72a 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -357,6 +357,20 @@ data SDocContext = SDC
   , sdocLinearTypes                 :: !Bool
   , sdocImpredicativeTypes          :: !Bool
   , sdocPrintTypeAbbreviations      :: !Bool
+  , sdocUnitIdForUser               :: !(FastString -> SDoc)
+      -- ^ Used to map UnitIds to more friendly "package-version:component"
+      -- strings while pretty-printing.
+      --
+      -- Use `GHC.Unit.State.pprWithUnitState` to set it. Users should never
+      -- have to set it to pretty-print SDocs emitted by GHC, otherwise it's a
+      -- bug. It's an internal field used to thread the UnitState so that the
+      -- Outputable instance of UnitId can use it.
+      --
+      -- See Note [Pretty-printing UnitId] in "GHC.Unit" for more details.
+      --
+      -- Note that we use `FastString` instead of `UnitId` to avoid boring
+      -- module inter-dependency issues.
+
   , sdocDynFlags                    :: DynFlags -- TODO: remove
   }
 
@@ -404,6 +418,7 @@ defaultSDocContext = SDC
   , sdocImpredicativeTypes          = False
   , sdocLinearTypes                 = False
   , sdocPrintTypeAbbreviations      = True
+  , sdocUnitIdForUser               = ftext
   , sdocDynFlags                    = error "defaultSDocContext: DynFlags not available"
   }