Include the GHC "Project Unit Id" in the cabal store path

- This allows the use of several **API incompatible builds of the same
  version of GHC** without corrupting the cabal store.
- This relies on the "Project Unit Id" which is available since GHC
  9.8.1, older versions of GHC do not benefit from this change.

[fixes #8114]

Cabal/src/Distribution/Simple/GHC.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TupleSections #-}
 
@@ -83,6 +84,7 @@ import Prelude ()
 
 import Control.Monad (forM_, msum)
 import Data.Char (isLower)
+import Data.List (stripPrefix)
 import qualified Data.Map as Map
 import Distribution.CabalSpecVersion
 import Distribution.InstalledPackageInfo (InstalledPackageInfo)
@@ -246,10 +248,16 @@ configure verbosity hcPath hcPkgPath conf0 = do
 
  filterExt ext = filter ((/= EnableExtension ext) . fst)
 
+ compilerId :: CompilerId
+ compilerId = CompilerId GHC ghcVersion
+
+ compilerAbiTag :: AbiTag
+ compilerAbiTag = maybe NoAbiTag AbiTag (Map.lookup "Project Unit Id" ghcInfoMap >>= stripPrefix (prettyShow compilerId <> "-"))
+
  let comp =
  Compiler
- { compilerId = CompilerId GHC ghcVersion
- , compilerAbiTag = NoAbiTag
+ { compilerId
+ , compilerAbiTag
  , compilerCompat = []
  , compilerLanguages = languages
  , compilerExtensions = extensions

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

@@ -318,7 +318,7 @@ haddockProjectAction flags _extraArgs globalFlags = do
  packageDir =
  storePackageDirectory
  (cabalStoreDirLayout cabalLayout)
- (compilerId (pkgConfigCompiler sharedConfig'))
+ (pkgConfigCompiler sharedConfig')
  (elabUnitId package)
  docDir = packageDir </> "share" </> "doc" </> "html"
  destDir = outputDir </> packageName

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

@@ -484,8 +484,7 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt
 
  -- progDb is a program database with compiler tools configured properly
  ( compiler@Compiler
- { compilerId =
- compilerId@(CompilerId compilerFlavor compilerVersion)
+ { compilerId = CompilerId compilerFlavor compilerVersion
  }
  , platform
  , progDb
@@ -498,7 +497,7 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt
  envFile <- getEnvFile clientInstallFlags platform compilerVersion
  existingEnvEntries <-
  getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile
- packageDbs <- getPackageDbStack compilerId projectConfigStoreDir projectConfigLogsDir
+ packageDbs <- getPackageDbStack compiler projectConfigStoreDir projectConfigLogsDir
  installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb
 
  let
@@ -824,7 +823,7 @@ installExes
  mkUnitBinDir :: UnitId -> FilePath
  mkUnitBinDir =
  InstallDirs.bindir
- . storePackageInstallDirs' storeDirLayout (compilerId compiler)
+ . storePackageInstallDirs' storeDirLayout compiler
 
  mkExeName :: UnqualComponentName -> FilePath
  mkExeName exe = unUnqualComponentName exe <.> exeExtension platform
@@ -1204,16 +1203,16 @@ getLocalEnv dir platform compilerVersion =
  <> ghcPlatformAndVersionString platform compilerVersion
 
 getPackageDbStack
- :: CompilerId
+ :: Compiler
  -> Flag FilePath
  -> Flag FilePath
  -> IO PackageDBStack
-getPackageDbStack compilerId storeDirFlag logsDirFlag = do
+getPackageDbStack compiler storeDirFlag logsDirFlag = do
  mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag
  let
  mlogsDir = flagToMaybe logsDirFlag
  cabalLayout <- mkCabalDirLayout mstoreDir mlogsDir
- pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId
+ pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compiler
 
 -- | This defines what a 'TargetSelector' means for the @bench@ command.
 -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,

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

@@ -41,7 +41,8 @@ import Distribution.Package
  , UnitId
  )
 import Distribution.Simple.Compiler
- ( OptimisationLevel (..)
+ ( Compiler (..)
+ , OptimisationLevel (..)
  , PackageDB (..)
  , PackageDBStack
  )
@@ -116,13 +117,13 @@ data DistDirLayout = DistDirLayout
 
 -- | The layout of a cabal nix-style store.
 data StoreDirLayout = StoreDirLayout
- { storeDirectory :: CompilerId -> FilePath
- , storePackageDirectory :: CompilerId -> UnitId -> FilePath
- , storePackageDBPath :: CompilerId -> FilePath
- , storePackageDB :: CompilerId -> PackageDB
- , storePackageDBStack :: CompilerId -> PackageDBStack
- , storeIncomingDirectory :: CompilerId -> FilePath
- , storeIncomingLock :: CompilerId -> UnitId -> FilePath
+ { storeDirectory :: Compiler -> FilePath
+ , storePackageDirectory :: Compiler -> UnitId -> FilePath
+ , storePackageDBPath :: Compiler -> FilePath
+ , storePackageDB :: Compiler -> PackageDB
+ , storePackageDBStack :: Compiler -> PackageDBStack
+ , storeIncomingDirectory :: Compiler -> FilePath
+ , storeIncomingLock :: Compiler -> UnitId -> FilePath
  }
 
 -- TODO: move to another module, e.g. CabalDirLayout?
@@ -267,33 +268,35 @@ defaultStoreDirLayout :: FilePath -> StoreDirLayout
 defaultStoreDirLayout storeRoot =
  StoreDirLayout{..}
  where
- storeDirectory :: CompilerId -> FilePath
- storeDirectory compid =
- storeRoot </> prettyShow compid
-
- storePackageDirectory :: CompilerId -> UnitId -> FilePath
- storePackageDirectory compid ipkgid =
- storeDirectory compid </> prettyShow ipkgid
-
- storePackageDBPath :: CompilerId -> FilePath
- storePackageDBPath compid =
- storeDirectory compid </> "package.db"
-
- storePackageDB :: CompilerId -> PackageDB
- storePackageDB compid =
- SpecificPackageDB (storePackageDBPath compid)
-
- storePackageDBStack :: CompilerId -> PackageDBStack
- storePackageDBStack compid =
- [GlobalPackageDB, storePackageDB compid]
-
- storeIncomingDirectory :: CompilerId -> FilePath
- storeIncomingDirectory compid =
- storeDirectory compid </> "incoming"
-
- storeIncomingLock :: CompilerId -> UnitId -> FilePath
- storeIncomingLock compid unitid =
- storeIncomingDirectory compid </> prettyShow unitid <.> "lock"
+ storeDirectory :: Compiler -> FilePath
+ storeDirectory compiler =
+ storeRoot </> case compilerAbiTag compiler of
+ NoAbiTag -> prettyShow (compilerId compiler)
+ AbiTag tag -> prettyShow (compilerId compiler) <> "-" <> tag
+
+ storePackageDirectory :: Compiler -> UnitId -> FilePath
+ storePackageDirectory compiler ipkgid =
+ storeDirectory compiler </> prettyShow ipkgid
+
+ storePackageDBPath :: Compiler -> FilePath
+ storePackageDBPath compiler =
+ storeDirectory compiler </> "package.db"
+
+ storePackageDB :: Compiler -> PackageDB
+ storePackageDB compiler =
+ SpecificPackageDB (storePackageDBPath compiler)
+
+ storePackageDBStack :: Compiler -> PackageDBStack
+ storePackageDBStack compiler =
+ [GlobalPackageDB, storePackageDB compiler]
+
+ storeIncomingDirectory :: Compiler -> FilePath
+ storeIncomingDirectory compiler =
+ storeDirectory compiler </> "incoming"
+
+ storeIncomingLock :: Compiler -> UnitId -> FilePath
+ storeIncomingLock compiler unitid =
+ storeIncomingDirectory compiler </> prettyShow unitid <.> "lock"
 
 defaultCabalDirLayout :: IO CabalDirLayout
 defaultCabalDirLayout =

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

@@ -1280,15 +1280,15 @@ buildAndInstallUnpackedPackage
  let ipkg = ipkg0{Installed.installedUnitId = uid}
  assert
  ( elabRegisterPackageDBStack pkg
- == storePackageDBStack compid
+ == storePackageDBStack compiler
  )
  (return ())
  criticalSection registerLock $
  Cabal.registerPackage
  verbosity
  compiler
  progdb
- (storePackageDBStack compid)
+ (storePackageDBStack compiler)
  ipkg
  Cabal.defaultRegisterOptions
  { Cabal.registerMultiInstance = True
@@ -1300,7 +1300,7 @@ buildAndInstallUnpackedPackage
  newStoreEntry
  verbosity
  storeDirLayout
- compid
+ compiler
  uid
  copyPkgFiles
  registerPkg
@@ -1330,7 +1330,6 @@ buildAndInstallUnpackedPackage
  where
  pkgid = packageId rpkg
  uid = installedUnitId rpkg
- compid = compilerId compiler
 
  dispname :: String
  dispname = case elabPkgOrComp pkg of

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

@@ -897,7 +897,7 @@ rebuildInstallPlan
  -> Rebuild ElaboratedInstallPlan
  phaseImprovePlan elaboratedPlan elaboratedShared = do
  liftIO $ debug verbosity "Improving the install plan..."
- storePkgIdSet <- getStoreEntries cabalStoreDirLayout compid
+ storePkgIdSet <- getStoreEntries cabalStoreDirLayout compiler
  let improvedPlan =
  improveInstallPlanWithInstalledPackages
  storePkgIdSet
@@ -909,7 +909,7 @@ rebuildInstallPlan
  -- matches up as expected, e.g. no dangling deps, files deleted.
  return improvedPlan
  where
- compid = compilerId (pkgConfigCompiler elaboratedShared)
+ compiler = pkgConfigCompiler elaboratedShared
 
 -- | If a 'PackageSpecifier' refers to a single package, return Just that
 -- package.
@@ -2349,7 +2349,7 @@ elaborateInstallPlan
 
  corePackageDbs =
  applyPackageDbFlags
- (storePackageDBStack (compilerId compiler))
+ (storePackageDBStack compiler)
  (projectConfigPackageDBs sharedPackageConfig)
 
  -- For this local build policy, every package that lives in a local source
@@ -4026,28 +4026,28 @@ userInstallDirTemplates compiler = do
 
 storePackageInstallDirs
  :: StoreDirLayout
- -> CompilerId
+ -> Compiler
  -> InstalledPackageId
  -> InstallDirs.InstallDirs FilePath
-storePackageInstallDirs storeDirLayout compid ipkgid =
- storePackageInstallDirs' storeDirLayout compid $ newSimpleUnitId ipkgid
+storePackageInstallDirs storeDirLayout compiler ipkgid =
+ storePackageInstallDirs' storeDirLayout compiler $ newSimpleUnitId ipkgid
 
 storePackageInstallDirs'
  :: StoreDirLayout
- -> CompilerId
+ -> Compiler
  -> UnitId
  -> InstallDirs.InstallDirs FilePath
 storePackageInstallDirs'
  StoreDirLayout
  { storePackageDirectory
  , storeDirectory
  }
- compid
+ compiler
  unitid =
  InstallDirs.InstallDirs{..}
  where
- store = storeDirectory compid
- prefix = storePackageDirectory compid unitid
+ store = storeDirectory compiler
+ prefix = storePackageDirectory compiler unitid
  bindir = prefix </> "bin"
  libdir = prefix </> "lib"
  libsubdir = ""
@@ -4097,7 +4097,7 @@ computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab
  -- use special simplified install dirs
  storePackageInstallDirs'
  storeDirLayout
- (compilerId (pkgConfigCompiler elaboratedShared))
+ (pkgConfigCompiler elaboratedShared)
  (elabUnitId elab)
 
 -- TODO: [code cleanup] perhaps reorder this code