Support reinstalling more packages (including base and template-haskell) with GHC >=9.14

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,11 @@ 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.
+  -- 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)
 
@@ -244,4 +251,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

@@ -98,7 +98,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
 
@@ -120,6 +122,11 @@ 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.
   , compilerProperties :: Map String String
   -- ^ A key-value map for properties not covered by the above fields.
   }
@@ -178,6 +185,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

@@ -168,6 +168,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

@@ -295,6 +295,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)

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

@@ -118,6 +118,7 @@ data FailReason = UnsupportedExtension Extension
                 | UnknownPackage
                 | GlobalConstraintVersion VR ConstraintSource
                 | GlobalConstraintInstalled ConstraintSource
+                | GlobalConstraintInstalledSpecificUnitId UnitId ConstraintSource
                 | GlobalConstraintSource ConstraintSource
                 | GlobalConstraintFlag ConstraintSource
                 | ManualFlag

cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs

@@ -19,7 +19,7 @@ module Distribution.Solver.Types.PackageConstraint (
 import Distribution.Solver.Compat.Prelude
 import Prelude ()
 
-import Distribution.Package                        (PackageName)
+import Distribution.Package                        (PackageName, UnitId)
 import Distribution.PackageDescription             (FlagAssignment, dispFlagAssignment)
 import Distribution.Pretty                         (flatStyle, Pretty(pretty))
 import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..))
@@ -90,6 +90,7 @@ instance Pretty ConstraintScope where
 data PackageProperty
    = PackagePropertyVersion   VersionRange
    | PackagePropertyInstalled
+   | PackagePropertyInstalledSpecificUnitId UnitId
    | PackagePropertySource
    | PackagePropertyFlags     FlagAssignment
    | PackagePropertyStanzas   [OptionalStanza]
@@ -101,6 +102,7 @@ instance Structured PackageProperty
 instance Pretty PackageProperty where
   pretty (PackagePropertyVersion verrange) = pretty verrange
   pretty PackagePropertyInstalled          = Disp.text "installed"
+  pretty (PackagePropertyInstalledSpecificUnitId unitId) = Disp.text "installed(" <> pretty unitId <> Disp.text ")"
   pretty PackagePropertySource             = Disp.text "source"
   pretty (PackagePropertyFlags flags)      = dispFlagAssignment flags
   pretty (PackagePropertyStanzas stanzas)  =
@@ -138,6 +140,7 @@ packageConstraintToDependency (PackageConstraint scope prop) = toDep prop
   where
     toDep (PackagePropertyVersion vr) = Just $ PackageVersionConstraint (scopeToPackageName scope) vr
     toDep (PackagePropertyInstalled)  = Nothing
+    toDep (PackagePropertyInstalledSpecificUnitId {}) = Nothing
     toDep (PackagePropertySource)     = Nothing
     toDep (PackagePropertyFlags _)    = Nothing
     toDep (PackagePropertyStanzas _)  = Nothing

cabal-install/src/Distribution/Client/Dependency.hs

@@ -435,6 +435,16 @@ setSolverVerbosity verbosity params =
     { depResolverVerbosity = verbosity
     }
 
+dependOnWiredIns :: CompilerInfo -> DepResolverParams -> DepResolverParams
+dependOnWiredIns compiler params = addConstraints extraConstraints params
+  where
+    extraConstraints =
+      [ LabeledPackageConstraint
+        (PackageConstraint (ScopeAnyQualifier pkgName) (PackagePropertyInstalledSpecificUnitId unitId))
+        ConstraintSourceNonReinstallablePackage
+      | (pkgName, unitId) <- fromMaybe [] $ compilerInfoWiredInUnitIds compiler
+      ]
+
 -- | Some packages are specific to a given compiler version and should never be
 -- reinstalled.
 dontInstallNonReinstallablePackages :: DepResolverParams -> DepResolverParams
@@ -840,8 +850,8 @@ resolveDependencies platform comp pkgConfigDB params =
                     order
                     verbosity
                   ) =
-        if asBool (depResolverAllowBootLibInstalls params)
-          then params
+        if isJust (compilerInfoWiredInUnitIds comp) || asBool (depResolverAllowBootLibInstalls params)
+          then dependOnWiredIns comp params
           else dontInstallNonReinstallablePackages params
 
     preferences :: PackageName -> PackagePreferences

cabal-install/tests/UnitTests/Distribution/Client/Store.hs

@@ -46,6 +46,7 @@ testListEmpty =
         , compilerLanguages = []
         , compilerExtensions = []
         , compilerProperties = mempty
+        , compilerWiredInUnitIds = Nothing
         }
 
     unitid = mkUnitId "foo-1.0-xyz"
@@ -102,6 +103,7 @@ testInstallSerial =
         , compilerLanguages = []
         , compilerExtensions = []
         , compilerProperties = mempty
+        , compilerWiredInUnitIds = Nothing
         }
 
     unitid1 = mkUnitId "foo-1.0-xyz"

cabal-testsuite/Setup.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE Haskell2010 #-}
+{-# LANGUAGE CPP #-}
 module Main (main) where
 
 import Distribution.Backpack
@@ -51,7 +52,14 @@ generateScriptEnvModule lbi verbosity = do
       , "lbiPlatform = " ++ show (hostPlatform lbi)
       , ""
       , "lbiCompiler :: Compiler"
+      -- We added a new field to compiler so we need to be careful
+      -- to make sure that it is always defined,
+      -- even if the test suite is being built with an older Cabal
+#if MIN_VERSION_Cabal(3,15,0)
       , "lbiCompiler = " ++ show (compiler lbi)
+#else
+      , "lbiCompiler = " ++ init (show (compiler lbi)) ++ ", compilerWiredInUnitIds = Nothing}"
+#endif
       , ""
       , "lbiPackages :: [(OpenUnitId, ModuleRenaming)]"
       , "lbiPackages = read " ++ show (show (cabalTestsPackages lbi))

changelog.d/pr-10982

@@ -0,0 +1,14 @@
+synopsis: Allow reinstalling packages like base and template-haskell for GHC>9.14
+packages: cabal-install
+prs: #10982
+issues: #10087
+significance: significant
+
+description: {
+
+Historically cabal-install disallowed reinstalling packages like `base` and `template-haskell`.
+As of GHC-9.12, the reasons for this have been lifted.
+We update cabal-install to become aware of this and allow reinstalling more packages.
+Certain packages like `ghc` and `ghc-internal` still cannot be reinstalled.
+
+}