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]
haskell · Oct 12, 2023 · 63c7fc3 · 63c7fc3
1 parent 2794dd8
commit 63c7fc3
Show file tree

Hide file tree

Showing 8 changed files with 129 additions and 107 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 #-}
 
@@ -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

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

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

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.hs b/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

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