Support getting nonreinstallable units from GHC

In short, this change allows reinstalling packages like `base` and
`template-haskell` with GHC >=9.14, and it doesn't modify the behaviour
of cabal-install with older versions of GHC for backwards-compatibility.

cabal-install includes a hardcoded list of non-reinstallable packages.
cabal-install will refuse to use a different version of these packages
in a build plan unless the --allow-boot-library-installs flag is set.

This list of packages is too pessimistic, and needlessly coupled to GHC.
For instance, as of GHC-9.12, `base` and `template-haskell` can be
"re-installed" without issue.

This patch allows compilers to specify exactly which packages are wired-in
and so should not be reinstalled.

In the case of GHC >=9.14, this amounts to ghc-internal and ghc itself.

If a compiler chooses to specify this information then it overrides the
hardcoded non-reinstallable package list. Otherwise, it is still used
for the sake of backwards compatibility.

Note that this information comes in the form of unit-ids rather than
package names. This patch extends the solver with constraints that force
the use of a precise unit-id.

The behaviour here is still somewhat pessimistic. In the future, we
could further relax this restriction and only ban reinstalling these
packafes when absolutely necessary, eg, only ban re-installing `ghc` if
we are using plugins, etc.

For the GHC change that added the interface to expose the unit-id of
ghc-internal, see: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/13297

Resolves #10087

Co-Authored-By: Matthew Pickering <[email protected]>

Author: TeofilC

Cabal-syntax/src/Distribution/Compiler.hs

@@ -56,8 +56,10 @@ import Language.Haskell.Extension
 import Distribution.Version (Version, mkVersion', nullVersion)
 
 import qualified Distribution.Compat.CharParsing as P
+import Distribution.Package (PackageName)
 import Distribution.Parsec (Parsec (..))
 import Distribution.Pretty (Pretty (..), prettyShow)
+import Distribution.Types.UnitId (UnitId)
 import qualified System.Info (compilerName, compilerVersion)
 import qualified Text.PrettyPrint as Disp
 
@@ -213,6 +215,12 @@ data CompilerInfo = CompilerInfo
   -- ^ Supported language standards, if known.
   , compilerInfoExtensions :: Maybe [Extension]
   -- ^ Supported extensions, if known.
+  , compilerInfoWiredInUnitIds :: Maybe [(PackageName, UnitId)]
+  -- ^ 'UnitId's that the compiler doesn't support reinstalling.
+  -- 'Nothing' indicates that the compiler hasn't supplied this
+  -- information and that we should act pessimistically.
+  -- For instance, when using GHC plugins, one wants to use the exact same
+  -- version of the `ghc` package as the one the compiler was linked against.
   }
   deriving (Generic, Show, Read)
 
@@ -245,4 +253,4 @@ abiTagString (AbiTag tag) = tag
 --   compiler id's.
 unknownCompilerInfo :: CompilerId -> AbiTag -> CompilerInfo
 unknownCompilerInfo compilerId abiTag =
-  CompilerInfo compilerId abiTag (Just []) Nothing Nothing
+  CompilerInfo compilerId abiTag (Just []) Nothing Nothing Nothing

Cabal-tests/tests/UnitTests/Distribution/Simple/Program/GHC.hs

@@ -54,6 +54,7 @@ tests = testGroup "Distribution.Simple.Program.GHC"
                       , compilerLanguages = []
                       , compilerExtensions = []
                       , compilerProperties = Map.singleton "Support parallel --make" "YES"
+                      , compilerWiredInUnitIds = Nothing
                       })
                   (Platform X86_64 Linux)
                   (mempty { ghcOptNumJobs = Flag (NumJobs (Just 4)) })

Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs

@@ -33,4 +33,4 @@ md5CheckGenericPackageDescription proxy = md5Check proxy
 
 md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion
 md5CheckLocalBuildInfo proxy = md5Check proxy
-    0xea86b170fa32ac289cbd1fb6174b5cbf
+    0xed69bb9372239b67b14b3e4dd3597c56

Cabal/src/Distribution/Simple/Compiler.hs

@@ -101,7 +101,9 @@ import Distribution.Pretty
 import Prelude ()
 
 import Distribution.Compiler
+import Distribution.Package (PackageName)
 import Distribution.Simple.Utils
+import Distribution.Types.UnitId (UnitId)
 import Distribution.Utils.Path
 import Distribution.Version
 
@@ -124,6 +126,12 @@ data Compiler = Compiler
   -- ^ Supported language standards.
   , compilerExtensions :: [(Extension, Maybe CompilerFlag)]
   -- ^ Supported extensions.
+  , compilerWiredInUnitIds :: Maybe [(PackageName, UnitId)]
+  -- ^ 'UnitId's that the compiler doesn't support reinstalling.
+  -- For instance, when using GHC plugins, one wants to use the exact same
+  -- version of the `ghc` package as the one the compiler was linked against.
+  -- 'Nothing' indicates that the compiler hasn't supplied this
+  -- information and that we should act pessimistically.
   , compilerProperties :: Map String String
   -- ^ A key-value map for properties not covered by the above fields.
   }
@@ -183,6 +191,7 @@ compilerInfo c =
     (Just . compilerCompat $ c)
     (Just . map fst . compilerLanguages $ c)
     (Just . map fst . compilerExtensions $ c)
+    (compilerWiredInUnitIds c)
 
 -- ------------------------------------------------------------
 

Cabal/src/Distribution/Simple/GHC.hs

@@ -229,6 +229,9 @@ configureCompiler verbosity hcPath conf0 = do
       compilerId :: CompilerId
       compilerId = CompilerId GHC ghcVersion
 
+      projectUnitId :: Maybe String
+      projectUnitId = Map.lookup "Project Unit Id" ghcInfoMap
+
       -- The @AbiTag@ is the @Project Unit Id@ but with redundant information from the compiler version removed.
       -- For development versions of the compiler these look like:
       -- @Project Unit Id@: "ghc-9.13-inplace"
@@ -241,9 +244,17 @@ configureCompiler verbosity hcPath conf0 = do
           NoAbiTag
           AbiTag
           ( dropWhile (== '-') . stripCommonPrefix (prettyShow compilerId)
-              <$> Map.lookup "Project Unit Id" ghcInfoMap
+              <$> projectUnitId
           )
 
+      wiredInUnitIds = do
+        ghcInternalUnitId <- Map.lookup "ghc-internal Unit Id" ghcInfoMap
+        ghcUnitId <- projectUnitId
+        pure
+          [ (mkPackageName "ghc", mkUnitId ghcUnitId)
+          , (mkPackageName "ghc-internal", mkUnitId ghcInternalUnitId)
+          ]
+
   let comp =
         Compiler
           { compilerId
@@ -252,6 +263,7 @@ configureCompiler verbosity hcPath conf0 = do
           , compilerLanguages = languages
           , compilerExtensions = extensions
           , compilerProperties = ghcInfoMap
+          , compilerWiredInUnitIds = wiredInUnitIds
           }
       compPlatform = Internal.targetPlatform ghcInfo
   return (comp, compPlatform, progdb1)

Cabal/src/Distribution/Simple/GHCJS.hs

@@ -170,6 +170,7 @@ configureCompiler verbosity hcPath conf0 = do
           , compilerLanguages = languages
           , compilerExtensions = extensions
           , compilerProperties = ghcInfoMap
+          , compilerWiredInUnitIds = Nothing
           }
       compPlatform = Internal.targetPlatform ghcjsInfo
   return (comp, compPlatform, progdb1)

Cabal/src/Distribution/Simple/UHC.hs

@@ -77,6 +77,7 @@ configure verbosity hcPath progdb = do
           , compilerLanguages = uhcLanguages
           , compilerExtensions = uhcLanguageExtensions
           , compilerProperties = Map.empty
+          , compilerWiredInUnitIds = Nothing
           }
       compPlatform = Nothing
   return (comp, compPlatform, progdb')

cabal-install-solver/src/Distribution/Solver/Modular/Message.hs

@@ -318,6 +318,7 @@ showFR _ UnknownPackage                   = " (unknown package)"
 showFR _ (GlobalConstraintVersion vr (ConstraintSourceProjectConfig pc)) = '\n' : (render . nest 6 $ docProjectConfigPathFailReason vr pc)
 showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")"
 showFR _ (GlobalConstraintInstalled src)  = " (" ++ constraintSource src ++ " requires installed instance)"
+showFR _ (GlobalConstraintInstalledSpecificUnitId unitId src)  = " (" ++ constraintSource src ++ " requires installed instance with unit id " ++ prettyShow unitId ++ ")"
 showFR _ (GlobalConstraintSource src)     = " (" ++ constraintSource src ++ " requires source instance)"
 showFR _ (GlobalConstraintFlag src)       = " (" ++ constraintSource src ++ " requires opposite flag selection)"
 showFR _ ManualFlag                       = " (manual flag can only be changed explicitly)"

cabal-install-solver/src/Distribution/Solver/Modular/Package.hs

@@ -10,6 +10,7 @@ module Distribution.Solver.Modular.Package
   , PN
   , QPV
   , instI
+  , instUid
   , makeIndependent
   , primaryPP
   , setupPP
@@ -77,6 +78,10 @@ instI :: I -> Bool
 instI (I _ (Inst _)) = True
 instI _              = False
 
+instUid :: UnitId -> I -> Bool
+instUid uid (I _ (Inst uid')) = uid == uid'
+instUid _ _ = False
+
 -- | Is the package in the primary group of packages.  This is used to
 -- determine (1) if we should try to establish stanza preferences
 -- for this goal, and (2) whether or not a user specified @--constraint@

cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs

@@ -190,6 +190,9 @@ processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint s
     go _       PackagePropertyInstalled
         | instI i       = r
         | otherwise     = Fail c (GlobalConstraintInstalled src)
+    go _       (PackagePropertyInstalledSpecificUnitId unitId)
+        | instUid unitId i       = r
+        | otherwise     = Fail c (GlobalConstraintInstalledSpecificUnitId unitId src)
     go _       PackagePropertySource
         | not (instI i) = r
         | otherwise     = Fail c (GlobalConstraintSource src)