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.

6 files changed, 19 insertions, 66 deletions

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