Merge pull request haskell#9683 from mpickering/wip/package-db-fix

cabal-install: Clarify the semantics of package-db flag
alt-romes · Feb 25, 2024 · 9025af5 · 9025af5
2 parents fb3f4d4 + d626ef8
commit 9025af5
Show file tree

Hide file tree

Showing 18 changed files with 147 additions and 35 deletions.
diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs
@@ -412,6 +412,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project
           , projectConfigHcPkg
           , projectConfigStoreDir
           , projectConfigProgPathExtra
+          , projectConfigPackageDBs
           }
       , projectConfigLocalPackages =
         PackageConfig
@@ -443,7 +444,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project
   envFile <- getEnvFile clientInstallFlags platform compilerVersion
   existingEnvEntries <-
     getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile
-  packageDbs <- getPackageDbStack compiler projectConfigStoreDir projectConfigLogsDir
+  packageDbs <- getPackageDbStack compiler projectConfigStoreDir projectConfigLogsDir projectConfigPackageDBs
   installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb
 
   let
@@ -1281,13 +1282,14 @@ getPackageDbStack
   :: Compiler
   -> Flag FilePath
   -> Flag FilePath
+  -> [Maybe PackageDB]
   -> IO PackageDBStack
-getPackageDbStack compiler storeDirFlag logsDirFlag = do
+getPackageDbStack compiler storeDirFlag logsDirFlag packageDbs = do
   mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag
   let
     mlogsDir = flagToMaybe logsDirFlag
   cabalLayout <- mkCabalDirLayout mstoreDir mlogsDir
-  pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compiler
+  pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compiler packageDbs
 
 -- | 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
@@ -46,6 +46,7 @@ import Distribution.Simple.Compiler
   , PackageDB (..)
   , PackageDBStack
   )
+import Distribution.Simple.Configure (interpretPackageDbFlags)
 import Distribution.System
 import Distribution.Types.ComponentName
 import Distribution.Types.LibraryName
@@ -121,7 +122,7 @@ data StoreDirLayout = StoreDirLayout
   , storePackageDirectory :: Compiler -> UnitId -> FilePath
   , storePackageDBPath :: Compiler -> FilePath
   , storePackageDB :: Compiler -> PackageDB
-  , storePackageDBStack :: Compiler -> PackageDBStack
+  , storePackageDBStack :: Compiler -> [Maybe PackageDB] -> PackageDBStack
   , storeIncomingDirectory :: Compiler -> FilePath
   , storeIncomingLock :: Compiler -> UnitId -> FilePath
   }
@@ -286,9 +287,10 @@ defaultStoreDirLayout storeRoot =
     storePackageDB compiler =
       SpecificPackageDB (storePackageDBPath compiler)
 
-    storePackageDBStack :: Compiler -> PackageDBStack
-    storePackageDBStack compiler =
-      [GlobalPackageDB, storePackageDB compiler]
+    storePackageDBStack :: Compiler -> [Maybe PackageDB] -> PackageDBStack
+    storePackageDBStack compiler extraPackageDB =
+      (interpretPackageDbFlags False extraPackageDB)
+        ++ [storePackageDB compiler]
 
     storeIncomingDirectory :: Compiler -> FilePath
     storeIncomingDirectory compiler =

diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs
@@ -683,12 +683,12 @@ buildAndInstallUnpackedPackage
                 | otherwise = do
                     assert
                       ( elabRegisterPackageDBStack pkg
-                          == storePackageDBStack compiler
+                          == storePackageDBStack compiler (elabPackageDbs pkg)
                       )
                       (return ())
                     _ <-
                       runRegister
-                        (storePackageDBStack compiler)
+                        (elabRegisterPackageDBStack pkg)
                         Cabal.defaultRegisterOptions
                           { Cabal.registerMultiInstance = True
                           , Cabal.registerSuppressFilesCheck = True

diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs
@@ -295,6 +295,7 @@ establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentComma
     sequenceA $
       makeAbsolute
         <$> Setup.flagToMaybe projectConfigStoreDir
+
   cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir
 
   let buildSettings =

diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs
@@ -709,9 +709,7 @@ rebuildInstallPlan
           where
             corePackageDbs :: [PackageDB]
             corePackageDbs =
-              applyPackageDbFlags
-                [GlobalPackageDB]
-                (projectConfigPackageDBs projectConfigShared)
+              Cabal.interpretPackageDbFlags False (projectConfigPackageDBs projectConfigShared)
 
             withRepoCtx :: (RepoContext -> IO a) -> IO a
             withRepoCtx =
@@ -1177,13 +1175,6 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do
     hashesFromRepoMetadata
       <> hashesFromTarballFiles
 
--- | Append the given package databases to an existing PackageDBStack.
--- A @Nothing@ entry will clear everything before it.
-applyPackageDbFlags :: PackageDBStack -> [Maybe PackageDB] -> PackageDBStack
-applyPackageDbFlags dbs' [] = dbs'
-applyPackageDbFlags _ (Nothing : dbs) = applyPackageDbFlags [] dbs
-applyPackageDbFlags dbs' (Just db : dbs) = applyPackageDbFlags (dbs' ++ [db]) dbs
-
 -- ------------------------------------------------------------
 
 -- * Installation planning
@@ -2321,10 +2312,7 @@ elaborateInstallPlan
         corePackageDbs
           ++ [distPackageDB (compilerId compiler)]
 
-      corePackageDbs =
-        applyPackageDbFlags
-          (storePackageDBStack compiler)
-          (projectConfigPackageDBs sharedPackageConfig)
+      corePackageDbs = storePackageDBStack compiler (projectConfigPackageDBs sharedPackageConfig)
 
       -- For this local build policy, every package that lives in a local source
       -- dir (as opposed to a tarball), or depends on such a package, will be

diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/cabal.test.hs b/cabal-testsuite/PackageTests/PackageDB/t9678/cabal.test.hs
@@ -0,0 +1,11 @@
+import Test.Cabal.Prelude
+main = cabalTest $ do
+    recordMode DoNotRecord $ withRepo "repo" $ withPackageDb $ do
+        withDirectory "p1" $
+            setup_install []
+
+        env <- getTestEnv
+        let pkgDbPath = testPackageDbDir env
+
+        withDirectory "p2" $ do
+            void $ cabal' "v2-build" ["--package-db=" ++ pkgDbPath]
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/p1/CHANGELOG.md b/cabal-testsuite/PackageTests/PackageDB/t9678/p1/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for p1
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/p1/p1.cabal b/cabal-testsuite/PackageTests/PackageDB/t9678/p1/p1.cabal
@@ -0,0 +1,18 @@
+cabal-version:   3.0
+name:            p1
+version:         0.1.0.0
+license:         NONE
+author:          [email protected]
+maintainer:      Matthew Pickering
+build-type:      Simple
+extra-doc-files: CHANGELOG.md
+
+common warnings
+    ghc-options: -Wall
+
+library
+    import:           warnings
+    exposed-modules:  MyLib
+    build-depends:    base
+    hs-source-dirs:   src
+    default-language: Haskell2010
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/p1/src/MyLib.hs b/cabal-testsuite/PackageTests/PackageDB/t9678/p1/src/MyLib.hs
@@ -0,0 +1,4 @@
+module MyLib (someFunc) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/p2/CHANGELOG.md b/cabal-testsuite/PackageTests/PackageDB/t9678/p2/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for p2
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/p2/cabal.project b/cabal-testsuite/PackageTests/PackageDB/t9678/p2/cabal.project
@@ -0,0 +1 @@
+packages: .
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/p2/p2.cabal b/cabal-testsuite/PackageTests/PackageDB/t9678/p2/p2.cabal
@@ -0,0 +1,18 @@
+cabal-version:   3.0
+name:            p2
+version:         0.1.0.0
+license:         NONE
+author:          [email protected]
+maintainer:      Matthew Pickering
+build-type:      Simple
+extra-doc-files: CHANGELOG.md
+
+common warnings
+    ghc-options: -Wall
+
+library
+    import:           warnings
+    exposed-modules:  MyLib
+    build-depends:    base, p1, p3
+    hs-source-dirs:   src
+    default-language: Haskell2010
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/p2/src/MyLib.hs b/cabal-testsuite/PackageTests/PackageDB/t9678/p2/src/MyLib.hs
@@ -0,0 +1,4 @@
+module MyLib (someFunc) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/repo/p3-0.1.0.0/CHANGELOG.md b/cabal-testsuite/PackageTests/PackageDB/t9678/repo/p3-0.1.0.0/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for p1
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/repo/p3-0.1.0.0/p3.cabal b/cabal-testsuite/PackageTests/PackageDB/t9678/repo/p3-0.1.0.0/p3.cabal
@@ -0,0 +1,18 @@
+cabal-version:   3.0
+name:            p3
+version:         0.1.0.0
+license:         NONE
+author:          [email protected]
+maintainer:      Matthew Pickering
+build-type:      Simple
+extra-doc-files: CHANGELOG.md
+
+common warnings
+    ghc-options: -Wall
+
+library
+    import:           warnings
+    exposed-modules:  MyLib
+    build-depends:    base
+    hs-source-dirs:   src
+    default-language: Haskell2010
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/repo/p3-0.1.0.0/src/MyLib.hs b/cabal-testsuite/PackageTests/PackageDB/t9678/repo/p3-0.1.0.0/src/MyLib.hs
@@ -0,0 +1,4 @@
+module MyLib (someFunc) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"
diff --git a/changelog.d/issue-9678 b/changelog.d/issue-9678
@@ -0,0 +1,16 @@
+synopsis: Clarify the semantics of the -package-db flag
+packages: cabal-install
+prs:
+issues: #9678
+
+description: {
+
+The `--package-db` flag now only applies to the default
+immutable initial package stack rather than also applying to the store
+package database.
+
+This fixes an assertion failure which was triggered when using -package-db and also
+clarifies how it should interact with `--store-dir` and `--dist-dir` flags.
+
+}
+
diff --git a/doc/cabal-project-description-file.rst b/doc/cabal-project-description-file.rst
@@ -372,6 +372,11 @@ package, and thus apply globally:
     :synopsis: PackageDB stack manipulation
     :since: 3.7
 
+    By modifying ``package-dbs`` you can modify the default package environment
+    which ``cabal`` will see. The package databases you add using ``package-dbs``
+    will not be written into and only used as immutable package stores to initialise
+    the environment with additional packages that ``cabal`` can choose to use.
+
     There are three package databases involved with most builds:
 
     global
@@ -381,37 +386,42 @@ package, and thus apply globally:
     in-place
         Project-specific build directory
 
-    By default, the package stack you will have with v2 commands is:
+    By default, the initial package stack prefix you will have with v2 commands is:
 
     ::
 
-        -- [global, store]
+        -- prefix = [global]
 
-    So all remote packages required by your project will be
-    registered in the store package db (because it is last).
+    So the initial set of packages which is used by cabal is just the packages
+    installed in the global package database which comes with ``ghc``.
 
-    When cabal starts building your local projects, it appends the in-place db
-    to the end:
+    When cabal builds a package it will start populating the ``store`` package database,
+    whose packages will then be subsequently be available to be used in future runs.
 
     ::
 
-        -- [global, store, in-place]
+        -- prefix ++ [store]
+
+    When cabal builds your local projects, packages are registered into the local
+    in-place package database.
+
+    ::
 
-    So your local packages get put in ``dist-newstyle`` instead of the store.
+        -- prefix ++ [store, in-place]
 
-    This flag manipulates the default prefix: ``[global, store]`` and accepts
+    This flag manipulates the default prefix: ``[global]`` and accepts
     paths, the special value ``global`` referring to the global package db, and
     ``clear`` which removes all prior entries. For example,
 
     ::
 
-        -- [global, store, foo]
+        -- prefix = [global, foo]
         package-dbs: foo
 
-        -- [foo]
+        -- prefix = [foo]
         package-dbs: clear, foo
 
-        -- [bar, baz]
+        -- prefix = [bar, baz]
         package-dbs: clear, foo, clear, bar, baz
 
     The command line variant of this flag is ``--package-db=DB`` which can be