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,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)

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]
@@ -102,6 +103,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)  =
@@ -139,6 +141,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

@@ -443,6 +443,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
@@ -849,8 +859,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
 
     formatProgress :: Progress SummarizedMessage String a -> Progress String String a

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-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs

@@ -96,6 +96,7 @@ import Distribution.Solver.Types.Settings
 import Distribution.Solver.Types.SolverPackage
 import Distribution.Solver.Types.SourcePackage
 import Distribution.Solver.Types.Variable
+import Distribution.Types.UnitId (UnitId)
 
 {-------------------------------------------------------------------------------
   Example package database DSL
@@ -783,6 +784,8 @@ exResolve
   -> Maybe [Extension]
   -- List of languages supported by the compiler, or Nothing if unknown.
   -> Maybe [Language]
+  -> Maybe [(C.PackageName, UnitId)]
+  -- ^ List of units that are wired in to the compiler
   -> Maybe PC.PkgConfigDb
   -> [ExamplePkgName]
   -> Maybe Int
@@ -806,6 +809,7 @@ exResolve
   db
   exts
   langs
+  wiredInUnitIds
   pkgConfigDb
   targets
   mbj
@@ -831,6 +835,7 @@ exResolve
         defaultCompiler
           { C.compilerInfoExtensions = exts
           , C.compilerInfoLanguages = langs
+          , C.compilerInfoWiredInUnitIds = wiredInUnitIds
           }
       (inst, avai) = partitionEithers db
       instIdx = exInstIdx inst

cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs

@@ -18,6 +18,7 @@ module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils
   , preferences
   , setVerbose
   , enableAllTests
+  , wiredInUnitIds
   , solverSuccess
   , solverFailure
   , anySolverFailure
@@ -50,6 +51,7 @@ import qualified Distribution.Solver.Types.PackagePath as P
 import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb (..), pkgConfigDbFromList)
 import Distribution.Solver.Types.Settings
 import Distribution.Solver.Types.Variable
+import Distribution.Types.UnitId (UnitId, mkUnitId)
 import UnitTests.Distribution.Solver.Modular.DSL
 import UnitTests.Options
 
@@ -106,6 +108,16 @@ setVerbose test = test{testVerbosity = verbose}
 enableAllTests :: SolverTest -> SolverTest
 enableAllTests test = test{testEnableAllTests = EnableAllTests True}
 
+wiredInUnitIds :: SolverTest -> SolverTest
+wiredInUnitIds test =
+  test
+    { testWiredInUnitIds =
+        Just
+          [ (C.mkPackageName "ghc-internal", mkUnitId "ghc-internal-1")
+          , (C.mkPackageName "ghc", mkUnitId "ghc-1")
+          ]
+    }
+
 {-------------------------------------------------------------------------------
   Solver tests
 -------------------------------------------------------------------------------}
@@ -130,6 +142,7 @@ data SolverTest = SolverTest
   , testDb :: ExampleDb
   , testSupportedExts :: Maybe [Extension]
   , testSupportedLangs :: Maybe [Language]
+  , testWiredInUnitIds :: Maybe [(C.PackageName, UnitId)]
   , testPkgConfigDb :: Maybe PkgConfigDb
   , testEnableAllTests :: EnableAllTests
   }
@@ -233,6 +246,7 @@ mkTestExtLangPC exts langs mPkgConfigDb db label targets result =
     , testDb = db
     , testSupportedExts = exts
     , testSupportedLangs = langs
+    , testWiredInUnitIds = Nothing
     , testPkgConfigDb = pkgConfigDbFromList <$> mPkgConfigDb
     , testEnableAllTests = EnableAllTests False
     }
@@ -245,6 +259,7 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
             testDb
             testSupportedExts
             testSupportedLangs
+            testWiredInUnitIds
             testPkgConfigDb
             testTargets
             testMaxBackjumps

cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs

@@ -242,6 +242,7 @@ solve enableBj fineGrainedConflicts reorder countConflicts indep prefOldest goal
             (unTestDb (testDb test))
             Nothing
             Nothing
+            Nothing
             (Just $ pkgConfigDbFromList [])
             (map unPN (testTargets test))
             -- The backjump limit prevents individual tests from using