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 haskell#8114]
alt-romes · Jan 16, 2024 · 54228c3 · 54228c3
1 parent df5e188
commit 54228c3
Show file tree

Hide file tree

Showing 9 changed files with 170 additions and 131 deletions.
diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TupleSections #-}
 
@@ -81,7 +82,8 @@ module Distribution.Simple.GHC
 import Distribution.Compat.Prelude
 import Prelude ()
 
-import Control.Monad (forM_)
+import Control.Monad (forM_, msum)
+import Data.List (stripPrefix)
 import qualified Data.Map as Map
 import Distribution.CabalSpecVersion
 import Distribution.InstalledPackageInfo (InstalledPackageInfo)
@@ -236,10 +238,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

diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs
@@ -54,9 +54,6 @@ import Distribution.Client.TargetProblem (TargetProblem (..))
 import Distribution.Simple.Command
   ( CommandUI (..)
   )
-import Distribution.Simple.Compiler
-  ( Compiler (..)
-  )
 import Distribution.Simple.Flag
   ( Flag (..)
   , fromFlag
@@ -319,7 +316,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

diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs
@@ -523,8 +523,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
@@ -537,7 +536,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
@@ -846,7 +845,7 @@ prepareExeInstall
         mkUnitBinDir :: UnitId -> FilePath
         mkUnitBinDir =
           InstallDirs.bindir
-            . storePackageInstallDirs' storeDirLayout (compilerId compiler)
+            . storePackageInstallDirs' storeDirLayout compiler
 
         mkExeName :: UnqualComponentName -> FilePath
         mkExeName exe = unUnqualComponentName exe <.> exeExtension platform
@@ -1218,16 +1217,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,

diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/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 =

diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs
@@ -686,12 +686,12 @@ buildAndInstallUnpackedPackage
                 | otherwise = do
                     assert
                       ( elabRegisterPackageDBStack pkg
-                          == storePackageDBStack compid
+                          == storePackageDBStack compiler
                       )
                       (return ())
                     _ <-
                       runRegister
-                        (storePackageDBStack compid)
+                        (storePackageDBStack compiler)
                         Cabal.defaultRegisterOptions
                           { Cabal.registerMultiInstance = True
                           , Cabal.registerSuppressFilesCheck = True
@@ -703,7 +703,7 @@ buildAndInstallUnpackedPackage
             newStoreEntry
               verbosity
               storeDirLayout
-              compid
+              compiler
               uid
               (copyPkgFiles verbosity pkgshared pkg runCopy)
               registerPkg
@@ -740,7 +740,6 @@ buildAndInstallUnpackedPackage
     where
       uid = installedUnitId rpkg
       pkgid = packageId rpkg
-      compid = compilerId compiler
 
       dispname :: String
       dispname = case elabPkgOrComp pkg of

diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs
@@ -860,7 +860,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
@@ -872,7 +872,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.
@@ -2318,7 +2318,7 @@ elaborateInstallPlan
 
       corePackageDbs =
         applyPackageDbFlags
-          (storePackageDBStack (compilerId compiler))
+          (storePackageDBStack compiler)
           (projectConfigPackageDBs sharedPackageConfig)
 
       -- For this local build policy, every package that lives in a local source
@@ -3767,28 +3767,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 = ""
@@ -3838,7 +3838,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