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.

2 files changed, 23 insertions, 3 deletions

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"
   }