Add package-db flag for v2 commands (haskell#7676)

Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
andreabedini · May 5, 2022 · 0fedc7d · 0fedc7d
1 parent b037ea2
commit 0fedc7d
Show file tree

Hide file tree

Showing 30 changed files with 276 additions and 25 deletions.
diff --git a/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs b/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs
@@ -483,7 +483,7 @@ instance Arbitrary TestShowDetails where
 instance Arbitrary PackageDB where
     arbitrary = oneof [ pure GlobalPackageDB
                       , pure UserPackageDB
-                      , SpecificPackageDB <$> arbitraryShortToken
+                      , SpecificPackageDB <$> arbitraryShortPath
                       ]
 
 -------------------------------------------------------------------------------
@@ -503,8 +503,14 @@ shortListOf1 bound gen = sized $ \n -> do
     vectorOf k gen
 
 arbitraryShortToken :: Gen String
-arbitraryShortToken =
-    shortListOf1 5 $ elements [c | c <- ['#' ..  '~' ], c `notElem` "{}[]" ]
+arbitraryShortToken = arbitraryShortStringWithout "{}[]"
+
+arbitraryShortPath :: Gen String
+arbitraryShortPath = arbitraryShortStringWithout "{}[],"
+
+arbitraryShortStringWithout :: String -> Gen String
+arbitraryShortStringWithout excludeChars =
+    shortListOf1 5 $ elements [c | c <- ['#' ..  '~' ], c `notElem` excludeChars ]
 
 -- |
 intSqrt :: Int -> Int

diff --git a/Cabal/src/Distribution/Simple/Setup.hs b/Cabal/src/Distribution/Simple/Setup.hs
@@ -38,7 +38,7 @@ module Distribution.Simple.Setup (
   GlobalFlags(..),   emptyGlobalFlags,   defaultGlobalFlags,   globalCommand,
   ConfigFlags(..),   emptyConfigFlags,   defaultConfigFlags,   configureCommand,
   configPrograms,
-  configAbsolutePaths, readPackageDbList, showPackageDbList,
+  configAbsolutePaths, readPackageDb, readPackageDbList, showPackageDb, showPackageDbList,
   CopyFlags(..),     emptyCopyFlags,     defaultCopyFlags,     copyCommand,
   InstallFlags(..),  emptyInstallFlags,  defaultInstallFlags,  installCommand,
   HaddockTarget(..),
@@ -751,18 +751,28 @@ configureOptions showOrParseArgs =
         (fmap fromPathTemplate . get) (set . fmap toPathTemplate)
 
 readPackageDbList :: String -> [Maybe PackageDB]
-readPackageDbList "clear"  = [Nothing]
-readPackageDbList "global" = [Just GlobalPackageDB]
-readPackageDbList "user"   = [Just UserPackageDB]
-readPackageDbList other    = [Just (SpecificPackageDB other)]
+readPackageDbList str = [readPackageDb str]
+
+-- | Parse a PackageDB stack entry
+--
+-- @since 3.7.0.0
+readPackageDb :: String -> Maybe PackageDB
+readPackageDb "clear"  = Nothing
+readPackageDb "global" = Just GlobalPackageDB
+readPackageDb "user"   = Just UserPackageDB
+readPackageDb other    = Just (SpecificPackageDB other)
 
 showPackageDbList :: [Maybe PackageDB] -> [String]
 showPackageDbList = map showPackageDb
-  where
-    showPackageDb Nothing                       = "clear"
-    showPackageDb (Just GlobalPackageDB)        = "global"
-    showPackageDb (Just UserPackageDB)          = "user"
-    showPackageDb (Just (SpecificPackageDB db)) = db
+
+-- | Show a PackageDB stack entry
+--
+-- @since 3.7.0.0
+showPackageDb :: Maybe PackageDB -> String
+showPackageDb Nothing                       = "clear"
+showPackageDb (Just GlobalPackageDB)        = "global"
+showPackageDb (Just UserPackageDB)          = "user"
+showPackageDb (Just (SpecificPackageDB db)) = db
 
 showProfDetailLevelFlag :: Flag ProfDetailLevel -> [String]
 showProfDetailLevelFlag NoFlag    = []

diff --git a/cabal-install/src/Distribution/Client/PackageHash.hs b/cabal-install/src/Distribution/Client/PackageHash.hs
@@ -34,7 +34,7 @@ import Distribution.Types.Flag
          ( FlagAssignment, showFlagAssignment )
 import Distribution.Simple.Compiler
          ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)
-         , ProfDetailLevel(..), showProfDetailLevel )
+         , ProfDetailLevel(..), PackageDB, showProfDetailLevel )
 import Distribution.Simple.InstallDirs
          ( PathTemplate, fromPathTemplate )
 import Distribution.Types.PkgconfigVersion (PkgconfigVersion)
@@ -200,6 +200,7 @@ data PackageHashConfigInputs = PackageHashConfigInputs {
        pkgHashExtraIncludeDirs    :: [FilePath],
        pkgHashProgPrefix          :: Maybe PathTemplate,
        pkgHashProgSuffix          :: Maybe PathTemplate,
+       pkgHashPackageDbs          :: [Maybe PackageDB],
 
        -- Haddock options
        pkgHashDocumentation       :: Bool,
@@ -293,6 +294,7 @@ renderPackageHashInputs PackageHashInputs{
       , opt   "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs
       , opt   "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix
       , opt   "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix
+      , opt   "package-dbs" [] (unwords . map show) pkgHashPackageDbs
 
       , opt   "documentation"  False prettyShow pkgHashDocumentation
       , opt   "haddock-hoogle" False prettyShow pkgHashHaddockHoogle

diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs
@@ -55,6 +55,7 @@ import Distribution.Simple.Setup
          , TestFlags(..), testOptions', defaultTestFlags
          , BenchmarkFlags(..), benchmarkOptions', defaultBenchmarkFlags
          , programDbPaths', splitArgs, DumpBuildInfo (NoDumpBuildInfo, DumpBuildInfo)
+         , readPackageDb, showPackageDb
          )
 import Distribution.Client.NixStyleOptions (NixStyleFlags (..))
 import Distribution.Client.ProjectFlags (ProjectFlags (..), projectFlagsOptions, defaultProjectFlags)
@@ -92,7 +93,7 @@ import Distribution.Simple.Command
          , OptionField, option, reqArg' )
 import Distribution.Types.PackageVersionConstraint
          ( PackageVersionConstraint )
-import Distribution.Parsec (ParsecParser)
+import Distribution.Parsec (ParsecParser, parsecToken)
 
 import qualified Data.Map as Map
 import qualified Data.ByteString as BS
@@ -352,11 +353,11 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags
       configDistPref            = projectConfigDistDir,
       configHcFlavor            = projectConfigHcFlavor,
       configHcPath              = projectConfigHcPath,
-      configHcPkg               = projectConfigHcPkg
+      configHcPkg               = projectConfigHcPkg,
     --configProgramPathExtra    = projectConfigProgPathExtra DELETE ME
     --configInstallDirs         = projectConfigInstallDirs,
     --configUserInstall         = projectConfigUserInstall,
-    --configPackageDBs          = projectConfigPackageDBs,
+      configPackageDBs          = projectConfigPackageDBs
     } = configFlags
 
     ConfigExFlags {
@@ -593,7 +594,8 @@ convertToLegacySharedConfig
 
     configFlags = mempty {
       configVerbosity     = projectConfigVerbosity,
-      configDistPref      = projectConfigDistDir
+      configDistPref      = projectConfigDistDir,
+      configPackageDBs    = projectConfigPackageDBs
     }
 
     configExFlags = ConfigExFlags {
@@ -696,7 +698,7 @@ convertToLegacyAllPackageConfig
       configCabalFilePath       = mempty,
       configVerbosity           = mempty,
       configUserInstall         = mempty, --projectConfigUserInstall,
-      configPackageDBs          = mempty, --projectConfigPackageDBs,
+      configPackageDBs          = mempty,
       configGHCiLib             = mempty,
       configSplitSections       = mempty,
       configSplitObjs           = mempty,
@@ -976,6 +978,11 @@ legacySharedConfigFieldDescrs constraintSrc = concat
   , liftFields
       legacyConfigureShFlags
       (\flags conf -> conf { legacyConfigureShFlags = flags })
+  . addFields
+      [ commaNewLineListFieldParsec "package-dbs"
+        (Disp.text . showPackageDb) (fmap readPackageDb parsecToken)
+        configPackageDBs (\v conf -> conf { configPackageDBs = v })
+      ]
   . filterFields ["verbose", "builddir" ]
   . commandOptionsToFields
   $ configureOptions ParseArgs

diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs
@@ -56,7 +56,7 @@ import Distribution.System
 import Distribution.PackageDescription
          ( FlagAssignment )
 import Distribution.Simple.Compiler
-         ( Compiler, CompilerFlavor
+         ( Compiler, CompilerFlavor, PackageDB
          , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) )
 import Distribution.Simple.Setup
          ( Flag, HaddockTarget(..), TestShowDetails(..), DumpBuildInfo (..) )
@@ -175,7 +175,7 @@ data ProjectConfigShared
      --projectConfigInstallDirs       :: InstallDirs (Flag PathTemplate),
      --TODO: [required eventually] decide what to do with InstallDirs
      -- currently we don't allow it to be specified in the config file
-     --projectConfigPackageDBs        :: [Maybe PackageDB],
+       projectConfigPackageDBs        :: [Maybe PackageDB],
 
        -- configuration used both by the solver and other phases
        projectConfigRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.

diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs
@@ -594,7 +594,9 @@ rebuildInstallPlan verbosity
               Right plan -> return (plan, pkgConfigDB, tis, ar)
       where
         corePackageDbs :: [PackageDB]
-        corePackageDbs = [GlobalPackageDB]
+        corePackageDbs = applyPackageDbFlags [GlobalPackageDB]
+                                             (projectConfigPackageDBs projectConfigShared)
+
         withRepoCtx    = projectConfigWithSolverRepoContext verbosity
                            projectConfigShared
                            projectConfigBuildOnly
@@ -984,6 +986,12 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do
     return $! 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
@@ -1844,6 +1852,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
         elabLocalToProject  = isLocalToProject pkg
         elabBuildStyle      = if shouldBuildInplaceOnly pkg
                                 then BuildInplaceOnly else BuildAndInstall
+        elabPackageDbs             = projectConfigPackageDBs sharedPackageConfig
         elabBuildPackageDBStack    = buildAndRegisterDbs
         elabRegisterPackageDBStack = buildAndRegisterDbs
 
@@ -1859,7 +1868,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
 
         buildAndRegisterDbs
           | shouldBuildInplaceOnly pkg = inplacePackageDbs
-          | otherwise                  = storePackageDbs
+          | otherwise                  = corePackageDbs
 
         elabPkgDescriptionOverride = descOverride
 
@@ -1972,10 +1981,11 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
                = mempty
         perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig)
 
-    inplacePackageDbs = storePackageDbs
+    inplacePackageDbs = corePackageDbs
                      ++ [ distPackageDB (compilerId compiler) ]
 
-    storePackageDbs   = storePackageDBStack (compilerId compiler)
+    corePackageDbs = applyPackageDbFlags (storePackageDBStack (compilerId 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
@@ -3873,6 +3883,7 @@ packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg =
       pkgHashExtraIncludeDirs    = elabExtraIncludeDirs,
       pkgHashProgPrefix          = elabProgPrefix,
       pkgHashProgSuffix          = elabProgSuffix,
+      pkgHashPackageDbs          = elabPackageDbs,
 
       pkgHashDocumentation       = elabBuildHaddocks,
       pkgHashHaddockHoogle       = elabHaddockHoogle,

diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs
@@ -234,6 +234,7 @@ data ElaboratedConfiguredPackage
        -- warn if ALL local packages don't have any tests.)
        elabStanzasRequested :: OptionalStanzaMap (Maybe Bool),
 
+       elabPackageDbs             :: [Maybe PackageDB],
        elabSetupPackageDBStack    :: PackageDBStack,
        elabBuildPackageDBStack    :: PackageDBStack,
        elabRegisterPackageDBStack :: PackageDBStack,

diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
@@ -456,6 +456,7 @@ instance Arbitrary ProjectConfigShared where
         projectConfigHcPath               <- arbitraryFlag arbitraryShortToken
         projectConfigHcPkg                <- arbitraryFlag arbitraryShortToken
         projectConfigHaddockIndex         <- arbitrary
+        projectConfigPackageDBs           <- shortListOf 2 arbitrary
         projectConfigRemoteRepos          <- arbitrary
         projectConfigLocalNoIndexRepos    <- arbitrary
         projectConfigActiveRepos          <- arbitrary
@@ -494,6 +495,7 @@ instance Arbitrary ProjectConfigShared where
         <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath
         <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg
         <*> shrinker projectConfigHaddockIndex
+        <*> shrinker projectConfigPackageDBs
         <*> shrinker projectConfigRemoteRepos
         <*> shrinker projectConfigLocalNoIndexRepos
         <*> shrinker projectConfigActiveRepos

diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs
@@ -20,6 +20,8 @@ import Distribution.Client.Types
 import Distribution.Client.Types.OverwritePolicy         (OverwritePolicy)
 import Distribution.Client.Types.SourceRepo              (SourceRepositoryPackage)
 
+import Distribution.Simple.Compiler                      (PackageDB)
+
 import Data.TreeDiff.Class
 import Data.TreeDiff.Instances.Cabal ()
 import Network.URI
@@ -50,6 +52,7 @@ instance ToExpr OptionalStanza
 instance ToExpr Outcome
 instance ToExpr OverwritePolicy
 instance ToExpr PackageConfig
+instance ToExpr PackageDB
 instance ToExpr PackageProperty
 instance ToExpr PreSolver
 instance ToExpr ProjectConfig

diff --git a/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-base.out b/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-base.out
@@ -0,0 +1,16 @@
+# Setup configure
+Configuring p-1.0...
+# Setup build
+Preprocessing library for p-1.0..
+Building library for p-1.0..
+# Setup copy
+Installing library in <PATH>
+# Setup register
+Registering library for p-1.0..
+# cabal v2-build
+Resolving dependencies...
+Error: cabal: Could not resolve dependencies:
+[__0] trying: q-1.0 (user goal)
+[__1] unknown package: base (dependency of q)
+[__1] fail (backjumping, conflict set: base, q)
+After searching the rest of the dependency tree exhaustively, these were the goals I've had most trouble fulfilling: q (2), base (1)
diff --git a/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-base.test.hs b/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-base.test.hs
@@ -0,0 +1,12 @@
+import Test.Cabal.Prelude
+main = cabalTest $ do
+    withPackageDb $ do
+        withDirectory "p" $
+            setup_install []
+
+        env <- getTestEnv
+        let pkgDbPath = testPackageDbDir env
+
+        withDirectory "q" $ do
+            res <- fails $ cabal' "v2-build" ["--package-db=clear", "--package-db=" ++ pkgDbPath]
+            assertOutputContains "unknown package: base" res
diff --git a/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-p.out b/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-p.out
@@ -0,0 +1,16 @@
+# Setup configure
+Configuring p-1.0...
+# Setup build
+Preprocessing library for p-1.0..
+Building library for p-1.0..
+# Setup copy
+Installing library in <PATH>
+# Setup register
+Registering library for p-1.0..
+# cabal v2-build
+Resolving dependencies...
+Error: cabal: Could not resolve dependencies:
+[__0] trying: q-1.0 (user goal)
+[__1] unknown package: p (dependency of q)
+[__1] fail (backjumping, conflict set: p, q)
+After searching the rest of the dependency tree exhaustively, these were the goals I've had most trouble fulfilling: q (2), p (1)
diff --git a/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-p.test.hs b/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-p.test.hs
@@ -0,0 +1,9 @@
+import Test.Cabal.Prelude
+main = cabalTest $ do
+    withPackageDb $ do
+        withDirectory "p" $
+            setup_install []
+
+        withDirectory "q" $ do
+            res <- fails $ cabal' "v2-build" []
+            assertOutputContains "unknown package: p" res
diff --git a/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-packagedbs.out b/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-packagedbs.out
@@ -0,0 +1,2 @@
+# cabal v2-build
+Error: cabal: No package databases have been specified. If you use --package-db=clear, you must follow it with --package-db= with 'global', 'user' or a specific file.
diff --git a/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-packagedbs.test.hs b/cabal-testsuite/PackageTests/PackageDB/cabal-fail-no-packagedbs.test.hs
@@ -0,0 +1,6 @@
+import Test.Cabal.Prelude
+main = cabalTest $ do
+    withPackageDb $ do
+        withDirectory "p-no-package-dbs" $ do
+            res <- fails $ cabal' "v2-build" []
+            assertOutputContains "No package databases have been specified." res
diff --git a/cabal-testsuite/PackageTests/PackageDB/cabal-manual-packagedb.out b/cabal-testsuite/PackageTests/PackageDB/cabal-manual-packagedb.out
@@ -0,0 +1,17 @@
+# Setup configure
+Configuring p-1.0...
+# Setup build
+Preprocessing library for p-1.0..
+Building library for p-1.0..
+# Setup copy
+Installing library in <PATH>
+# Setup register
+Registering library for p-1.0..
+# cabal v2-build
+Resolving dependencies...
+Build profile: -w ghc-<GHCVER> -O1
+In order, the following will be built:
+ - q-1.0 (exe:q) (first run)
+Configuring executable 'q' for q-1.0..
+Preprocessing executable 'q' for q-1.0..
+Building executable 'q' for q-1.0..
diff --git a/cabal-testsuite/PackageTests/PackageDB/cabal-manual-packagedb.test.hs b/cabal-testsuite/PackageTests/PackageDB/cabal-manual-packagedb.test.hs
@@ -0,0 +1,12 @@
+import Test.Cabal.Prelude
+main = cabalTest $ do
+    withPackageDb $ do
+        withDirectory "p" $
+            setup_install []
+
+        env <- getTestEnv
+        let pkgDbPath = testPackageDbDir env
+        withDirectory "q" $
+            cabal "v2-build" [ "--package-db=clear"
+                             , "--package-db=global"
+                             , "--package-db=" ++ pkgDbPath]
diff --git a/cabal-testsuite/PackageTests/PackageDB/cabal-packagedb.out b/cabal-testsuite/PackageTests/PackageDB/cabal-packagedb.out
@@ -0,0 +1,17 @@
+# Setup configure
+Configuring p-1.0...
+# Setup build
+Preprocessing library for p-1.0..
+Building library for p-1.0..
+# Setup copy
+Installing library in <PATH>
+# Setup register
+Registering library for p-1.0..
+# cabal v2-build
+Resolving dependencies...
+Build profile: -w ghc-<GHCVER> -O1
+In order, the following will be built:
+ - q-1.0 (exe:q) (first run)
+Configuring executable 'q' for q-1.0..
+Preprocessing executable 'q' for q-1.0..
+Building executable 'q' for q-1.0..