Merge pull request haskell#3165 from 23Skidoo/allow-newer-cabal

Improvements to '--allow-newer'

Cabal/Cabal.cabal

@@ -32,6 +32,10 @@ extra-source-files:
   -- Generated with 'misc/gen-extra-source-files.sh'
   -- Do NOT edit this section manually; instead, run the script.
   -- BEGIN gen-extra-source-files
+  tests/PackageTests/AllowNewer/AllowNewer.cabal
+  tests/PackageTests/AllowNewer/benchmarks/Bench.hs
+  tests/PackageTests/AllowNewer/src/Foo.hs
+  tests/PackageTests/AllowNewer/tests/Test.hs
   tests/PackageTests/BenchmarkExeV10/Foo.hs
   tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs
   tests/PackageTests/BenchmarkExeV10/my.cabal

Cabal/Distribution/PackageDescription/Configuration.hs

@@ -28,6 +28,8 @@ module Distribution.PackageDescription.Configuration (
     mapTreeData,
     mapTreeConds,
     mapTreeConstrs,
+    transformAllBuildInfos,
+    transformAllBuildDepends,
   ) where
 
 import Distribution.Package
@@ -665,3 +667,82 @@ biFillInDefaults bi =
     if null (hsSourceDirs bi)
     then bi { hsSourceDirs = [currentDir] }
     else bi
+
+-- Walk a 'GenericPackageDescription' and apply @onBuildInfo@/@onSetupBuildInfo@
+-- to all nested 'BuildInfo'/'SetupBuildInfo' values.
+transformAllBuildInfos :: (BuildInfo -> BuildInfo)
+                       -> (SetupBuildInfo -> SetupBuildInfo)
+                       -> GenericPackageDescription
+                       -> GenericPackageDescription
+transformAllBuildInfos onBuildInfo onSetupBuildInfo gpd = gpd'
+  where
+    onLibrary    lib  = lib { libBuildInfo  = onBuildInfo $ libBuildInfo  lib }
+    onExecutable exe  = exe { buildInfo     = onBuildInfo $ buildInfo     exe }
+    onTestSuite  tst  = tst { testBuildInfo = onBuildInfo $ testBuildInfo tst }
+    onBenchmark  bmk  = bmk { benchmarkBuildInfo =
+                                 onBuildInfo $ benchmarkBuildInfo bmk }
+
+    pd = packageDescription gpd
+    pd'  = pd {
+      library        = fmap onLibrary        (library pd),
+      executables    = map  onExecutable     (executables pd),
+      testSuites     = map  onTestSuite      (testSuites pd),
+      benchmarks     = map  onBenchmark      (benchmarks pd),
+      setupBuildInfo = fmap onSetupBuildInfo (setupBuildInfo pd)
+      }
+
+    gpd' = transformAllCondTrees onLibrary onExecutable
+           onTestSuite onBenchmark id
+           $ gpd { packageDescription = pd' }
+
+-- | Walk a 'GenericPackageDescription' and apply @f@ to all nested
+-- @build-depends@ fields.
+transformAllBuildDepends :: (Dependency -> Dependency)
+                         -> GenericPackageDescription
+                         -> GenericPackageDescription
+transformAllBuildDepends f gpd = gpd'
+  where
+    onBI  bi  = bi  { targetBuildDepends = map f $ targetBuildDepends bi }
+    onSBI stp = stp { setupDepends       = map f $ setupDepends stp      }
+    onPD  pd  = pd  { buildDepends       = map f $ buildDepends pd       }
+
+    pd'   = onPD $ packageDescription gpd
+    gpd'  = transformAllCondTrees id id id id (map f)
+            . transformAllBuildInfos onBI onSBI
+            $ gpd { packageDescription = pd' }
+
+-- | Walk all 'CondTree's inside a 'GenericPackageDescription' and apply
+-- appropriate transformations to all nodes. Helper function used by
+-- 'transformAllBuildDepends' and 'transformAllBuildInfos'.
+transformAllCondTrees :: (Library -> Library)
+                      -> (Executable -> Executable)
+                      -> (TestSuite -> TestSuite)
+                      -> (Benchmark -> Benchmark)
+                      -> ([Dependency] -> [Dependency])
+                      -> GenericPackageDescription -> GenericPackageDescription
+transformAllCondTrees onLibrary onExecutable
+  onTestSuite onBenchmark onDepends gpd = gpd'
+  where
+    gpd'    = gpd {
+      condLibrary        = condLib',
+      condExecutables    = condExes',
+      condTestSuites     = condTests',
+      condBenchmarks     = condBenchs'
+      }
+
+    condLib    = condLibrary        gpd
+    condExes   = condExecutables    gpd
+    condTests  = condTestSuites     gpd
+    condBenchs = condBenchmarks     gpd
+
+    condLib'    = fmap (onCondTree onLibrary)             condLib
+    condExes'   = map  (mapSnd $ onCondTree onExecutable) condExes
+    condTests'  = map  (mapSnd $ onCondTree onTestSuite)  condTests
+    condBenchs' = map  (mapSnd $ onCondTree onBenchmark)  condBenchs
+
+    mapSnd :: (a -> b) -> (c,a) -> (c,b)
+    mapSnd = fmap
+
+    onCondTree :: (a -> b) -> CondTree v [Dependency] a
+               -> CondTree v [Dependency] b
+    onCondTree g = mapCondTree g onDepends id

Cabal/Distribution/Simple/Configure.hs

@@ -48,6 +48,7 @@ module Distribution.Simple.Configure (configure,
                                       ConfigStateFileError(..),
                                       tryGetConfigStateFile,
                                       platformDefines,
+                                      relaxPackageDeps,
                                      )
     where
 
@@ -309,7 +310,13 @@ findDistPrefOrDefault = findDistPref defaultDistPref
 -- Returns the @.setup-config@ file.
 configure :: (GenericPackageDescription, HookedBuildInfo)
           -> ConfigFlags -> IO LocalBuildInfo
-configure (pkg_descr0, pbi) cfg = do
+configure (pkg_descr0', pbi) cfg = do
+    let pkg_descr0 =
+          -- Ignore '--allow-newer' when we're given '--exact-configuration'.
+          if fromFlagOrDefault False (configExactConfiguration cfg)
+          then pkg_descr0'
+          else relaxPackageDeps (configAllowNewer cfg) pkg_descr0'
+
     setupMessage verbosity "Configuring" (packageId pkg_descr0)
 
     checkDeprecatedFlags verbosity cfg
@@ -787,6 +794,19 @@ dependencySatisfiable
         isInternalDep = not . null
                       $ PackageIndex.lookupDependency internalPackageSet d
 
+-- | Relax the dependencies of this package if needed
+relaxPackageDeps :: AllowNewer -> GenericPackageDescription
+                 -> GenericPackageDescription
+relaxPackageDeps AllowNewerNone = id
+relaxPackageDeps AllowNewerAll  =
+  transformAllBuildDepends $ \(Dependency pkgName verRange) ->
+  Dependency pkgName (removeUpperBound verRange)
+relaxPackageDeps (AllowNewerSome pkgNames) =
+  transformAllBuildDepends $ \d@(Dependency pkgName verRange) ->
+  if pkgName `elem` pkgNames
+  then Dependency pkgName (removeUpperBound verRange)
+  else d
+
 -- | Finalize a generic package description.  The workhorse is
 -- 'finalizePackageDescription' but there's a bit of other nattering
 -- about necessary.

Cabal/Distribution/Simple/Setup.hs

@@ -34,6 +34,7 @@ module Distribution.Simple.Setup (
 
   GlobalFlags(..),   emptyGlobalFlags,   defaultGlobalFlags,   globalCommand,
   ConfigFlags(..),   emptyConfigFlags,   defaultConfigFlags,   configureCommand,
+  AllowNewer(..),    isAllowNewer,
   configAbsolutePaths, readPackageDbList, showPackageDbList,
   CopyFlags(..),     emptyCopyFlags,     defaultCopyFlags,     copyCommand,
   InstallFlags(..),  emptyInstallFlags,  defaultInstallFlags,  installCommand,
@@ -64,7 +65,8 @@ module Distribution.Simple.Setup (
   fromFlagOrDefault,
   flagToMaybe,
   flagToList,
-  boolOpt, boolOpt', trueArg, falseArg, optionVerbosity, optionNumJobs ) where
+  boolOpt, boolOpt', trueArg, falseArg,
+  optionVerbosity, optionNumJobs, readPToMaybe ) where
 
 import Distribution.Compiler
 import Distribution.ReadE
@@ -86,6 +88,7 @@ import Distribution.Compat.Semigroup as Semi
 
 import Control.Monad (liftM)
 import Data.List   ( sort )
+import Data.Maybe  ( listToMaybe )
 import Data.Char   ( isSpace, isAlpha )
 import GHC.Generics (Generic)
 
@@ -252,6 +255,56 @@ instance Semigroup GlobalFlags where
 -- * Config flags
 -- ------------------------------------------------------------
 
+-- | Policy for relaxing upper bounds in dependencies. For example, given
+-- 'build-depends: array >= 0.3 && < 0.5', are we allowed to relax the upper
+-- bound and choose a version of 'array' that is greater or equal to 0.5? By
+-- default the upper bounds are always strictly honored.
+data AllowNewer =
+
+  -- | Default: honor the upper bounds in all dependencies, never choose
+  -- versions newer than allowed.
+  AllowNewerNone
+
+  -- | Ignore upper bounds in dependencies on the given packages.
+  | AllowNewerSome [PackageName]
+
+  -- | Ignore upper bounds in dependencies on all packages.
+  | AllowNewerAll
+  deriving (Eq, Ord, Read, Show, Generic)
+
+instance Binary AllowNewer
+
+instance Semigroup AllowNewer where
+  AllowNewerNone       <> r                    = r
+  l@AllowNewerAll      <> _                    = l
+  l@(AllowNewerSome _) <> AllowNewerNone       = l
+  (AllowNewerSome   _) <> r@AllowNewerAll      = r
+  (AllowNewerSome   a) <> (AllowNewerSome b)   = AllowNewerSome (a ++ b)
+
+instance Monoid AllowNewer where
+  mempty  = AllowNewerNone
+  mappend = (Semi.<>)
+
+-- | Convert 'AllowNewer' to a boolean.
+isAllowNewer :: AllowNewer -> Bool
+isAllowNewer AllowNewerNone     = False
+isAllowNewer (AllowNewerSome _) = True
+isAllowNewer AllowNewerAll      = True
+
+allowNewerParser :: ReadE AllowNewer
+allowNewerParser = ReadE $ \s ->
+  case readPToMaybe pkgsParser s of
+    Just pkgs -> Right . AllowNewerSome $ pkgs
+    Nothing   -> Left ("Cannot parse the list of packages: " ++ s)
+  where
+    pkgsParser = Parse.sepBy1 parse (Parse.char ',')
+
+allowNewerPrinter :: AllowNewer -> [Maybe String]
+allowNewerPrinter AllowNewerNone        = []
+allowNewerPrinter AllowNewerAll         = [Nothing]
+allowNewerPrinter (AllowNewerSome pkgs) =
+  [Just . intercalate "," . map display $ pkgs]
+
 -- | Flags to @configure@ command.
 --
 -- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags'
@@ -319,7 +372,9 @@ data ConfigFlags = ConfigFlags {
     configFlagError :: Flag String,
       -- ^Halt and show an error message indicating an error in flag assignment
     configRelocatable :: Flag Bool, -- ^ Enable relocatable package built
-    configDebugInfo :: Flag DebugInfoLevel  -- ^ Emit debug info.
+    configDebugInfo :: Flag DebugInfoLevel,  -- ^ Emit debug info.
+    configAllowNewer :: AllowNewer      -- ^ Ignore upper bounds on all or some
+                                        -- dependencies.
   }
   deriving (Generic, Read, Show)
 
@@ -365,7 +420,8 @@ defaultConfigFlags progConf = emptyConfigFlags {
     configExactConfiguration = Flag False,
     configFlagError    = NoFlag,
     configRelocatable  = Flag False,
-    configDebugInfo    = Flag NoDebugInfo
+    configDebugInfo    = Flag NoDebugInfo,
+    configAllowNewer   = AllowNewerNone
   }
 
 configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags
@@ -602,6 +658,11 @@ configureOptions showOrParseArgs =
          configLibCoverage (\v flags -> flags { configLibCoverage = v })
          (boolOpt [] [])
 
+      ,option [] ["allow-newer"]
+       ("Ignore upper bounds in all dependencies or DEPS")
+       configAllowNewer (\v flags -> flags { configAllowNewer = v})
+       (optArg "DEPS" allowNewerParser AllowNewerAll allowNewerPrinter)
+
       ,option "" ["exact-configuration"]
          "All direct dependencies and flags are provided on the command line."
          configExactConfiguration
@@ -769,7 +830,8 @@ instance Monoid ConfigFlags where
     configBenchmarks          = mempty,
     configFlagError     = mempty,
     configRelocatable   = mempty,
-    configDebugInfo     = mempty
+    configDebugInfo     = mempty,
+    configAllowNewer    = mempty
   }
   mappend = (Semi.<>)
 
@@ -817,7 +879,8 @@ instance Semigroup ConfigFlags where
     configBenchmarks          = combine configBenchmarks,
     configFlagError     = combine configFlagError,
     configRelocatable   = combine configRelocatable,
-    configDebugInfo     = combine configDebugInfo
+    configDebugInfo     = combine configDebugInfo,
+    configAllowNewer    = combine configAllowNewer
   }
     where combine field = field a `mappend` field b
 
@@ -2156,6 +2219,10 @@ optionNumJobs get set =
 -- * Other Utils
 -- ------------------------------------------------------------
 
+readPToMaybe :: Parse.ReadP a a -> String -> Maybe a
+readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
+                                     , all isSpace s ]
+
 -- | Arguments to pass to a @configure@ script, e.g. generated by
 -- @autoconf@.
 configureArgs :: Bool -> ConfigFlags -> [String]

Cabal/changelog

@@ -19,6 +19,8 @@
 	  work-around for #2398)
 	* Library support for multi-instance package DBs (#2948).
 	* Improved the './Setup configure' solver (#3082, #3076).
+	* The '--allow-newer' option can be now used with './Setup
+	configure' (#3163).
 
 1.22.0.0 Johan Tibell <[email protected]> January 2015
 	* Support GHC 7.10.

Cabal/tests/PackageTests/AllowNewer/AllowNewer.cabal

@@ -0,0 +1,25 @@
+name:                AllowNewer
+version:             0.1.0.0
+license:             BSD3
+author:              Foo Bar
+maintainer:          [email protected]
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Foo
+  hs-source-dirs:      src
+  build-depends:       base < 1
+  default-language:    Haskell2010
+
+test-suite foo-test
+  type: exitcode-stdio-1.0
+  main-is:             Test.hs
+  hs-source-dirs:      tests
+  build-depends:       base < 1
+
+benchmark foo-bench
+  type: exitcode-stdio-1.0
+  main-is:             Bench.hs
+  hs-source-dirs:      benchmarks
+  build-depends:       base < 1

Cabal/tests/PackageTests/AllowNewer/benchmarks/Bench.hs

@@ -0,0 +1,4 @@
+module Main where
+
+main :: IO ()
+main = return ()

Cabal/tests/PackageTests/AllowNewer/src/Foo.hs

@@ -0,0 +1,4 @@
+module Main where
+
+main :: IO ()
+main = return ()

Cabal/tests/PackageTests/AllowNewer/tests/Test.hs

@@ -0,0 +1,4 @@
+!module Main where
+
+main :: IO ()
+main = return ()

Cabal/tests/PackageTests/Tests.hs

@@ -221,6 +221,22 @@ nonSharedLibTests config =
             cabal_build ["--enable-tests"]
             cabal "test" []
 
+  -- Test that '--allow-newer' works via the 'Setup.hs configure' interface.
+  , tc "AllowNewer" $ do
+        shouldFail $ cabal "configure" []
+        cabal "configure" ["--allow-newer"]
+        shouldFail $ cabal "configure" ["--allow-newer=baz,quux"]
+        cabal "configure" ["--allow-newer=base", "--allow-newer=baz,quux"]
+        cabal "configure" ["--allow-newer=bar", "--allow-newer=base,baz"
+                          ,"--allow-newer=quux"]
+        shouldFail $ cabal "configure" ["--enable-tests"]
+        cabal "configure" ["--enable-tests", "--allow-newer"]
+        shouldFail $ cabal "configure" ["--enable-benchmarks"]
+        cabal "configure" ["--enable-benchmarks", "--allow-newer"]
+        shouldFail $ cabal "configure" ["--enable-benchmarks", "--enable-tests"]
+        cabal "configure" ["--enable-benchmarks", "--enable-tests"
+                          ,"--allow-newer"]
+
   -- Test that Cabal can choose flags to disable building a component when that
   -- component's dependencies are unavailable. The build should succeed without
   -- requiring the component's dependencies or imports.

HACKING.md

@@ -70,7 +70,7 @@ To build and test the `Cabal` library, do:
     we cannot use `cabal` for the next steps;
     we need to use Setup instead.
     So, compile Setup.hs:
-    
+
     ~~~~
     ghc --make -threaded Setup.hs
     ~~~~
@@ -89,7 +89,7 @@ To build and test the `Cabal` library, do:
     ~~~~
     ~/MyHaskellCode/cabal/Cabal/.cabal-sandbox/$SOMESTUFF-packages.conf.d
     ~~~~
-    
+
     (or, as a relative path with my setup:)
 
     ~~~~