Skip to content

Commit 1eaf2ee

Browse files
23Skidoo23Skidoo
committed
Merge pull request #3165 from 23Skidoo/allow-newer-cabal
Improvements to '--allow-newer'
2 parents 9efca85 + 53cfe17 commit 1eaf2ee

File tree

19 files changed

+291
-176
lines changed

19 files changed

+291
-176
lines changed

‎Cabal/Cabal.cabal

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,10 @@ extra-source-files:
3232
-- Generated with 'misc/gen-extra-source-files.sh'
3333
-- Do NOT edit this section manually; instead, run the script.
3434
-- BEGIN gen-extra-source-files
35+
tests/PackageTests/AllowNewer/AllowNewer.cabal
36+
tests/PackageTests/AllowNewer/benchmarks/Bench.hs
37+
tests/PackageTests/AllowNewer/src/Foo.hs
38+
tests/PackageTests/AllowNewer/tests/Test.hs
3539
tests/PackageTests/BenchmarkExeV10/Foo.hs
3640
tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs
3741
tests/PackageTests/BenchmarkExeV10/my.cabal

‎Cabal/Distribution/PackageDescription/Configuration.hs

Lines changed: 81 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,8 @@ module Distribution.PackageDescription.Configuration (
2828
mapTreeData,
2929
mapTreeConds,
3030
mapTreeConstrs,
31+
transformAllBuildInfos,
32+
transformAllBuildDepends,
3133
) where
3234

3335
import Distribution.Package
@@ -665,3 +667,82 @@ biFillInDefaults bi =
665667
if null (hsSourceDirs bi)
666668
then bi { hsSourceDirs = [currentDir] }
667669
else bi
670+
671+
-- Walk a 'GenericPackageDescription' and apply @onBuildInfo@/@onSetupBuildInfo@
672+
-- to all nested 'BuildInfo'/'SetupBuildInfo' values.
673+
transformAllBuildInfos :: (BuildInfo -> BuildInfo)
674+
-> (SetupBuildInfo -> SetupBuildInfo)
675+
-> GenericPackageDescription
676+
-> GenericPackageDescription
677+
transformAllBuildInfos onBuildInfo onSetupBuildInfo gpd = gpd'
678+
where
679+
onLibrary lib = lib { libBuildInfo = onBuildInfo $ libBuildInfo lib }
680+
onExecutable exe = exe { buildInfo = onBuildInfo $ buildInfo exe }
681+
onTestSuite tst = tst { testBuildInfo = onBuildInfo $ testBuildInfo tst }
682+
onBenchmark bmk = bmk { benchmarkBuildInfo =
683+
onBuildInfo $ benchmarkBuildInfo bmk }
684+
685+
pd = packageDescription gpd
686+
pd' = pd {
687+
library = fmap onLibrary (library pd),
688+
executables = map onExecutable (executables pd),
689+
testSuites = map onTestSuite (testSuites pd),
690+
benchmarks = map onBenchmark (benchmarks pd),
691+
setupBuildInfo = fmap onSetupBuildInfo (setupBuildInfo pd)
692+
}
693+
694+
gpd' = transformAllCondTrees onLibrary onExecutable
695+
onTestSuite onBenchmark id
696+
$ gpd { packageDescription = pd' }
697+
698+
-- | Walk a 'GenericPackageDescription' and apply @f@ to all nested
699+
-- @build-depends@ fields.
700+
transformAllBuildDepends :: (Dependency -> Dependency)
701+
-> GenericPackageDescription
702+
-> GenericPackageDescription
703+
transformAllBuildDepends f gpd = gpd'
704+
where
705+
onBI bi = bi { targetBuildDepends = map f $ targetBuildDepends bi }
706+
onSBI stp = stp { setupDepends = map f $ setupDepends stp }
707+
onPD pd = pd { buildDepends = map f $ buildDepends pd }
708+
709+
pd' = onPD $ packageDescription gpd
710+
gpd' = transformAllCondTrees id id id id (map f)
711+
. transformAllBuildInfos onBI onSBI
712+
$ gpd { packageDescription = pd' }
713+
714+
-- | Walk all 'CondTree's inside a 'GenericPackageDescription' and apply
715+
-- appropriate transformations to all nodes. Helper function used by
716+
-- 'transformAllBuildDepends' and 'transformAllBuildInfos'.
717+
transformAllCondTrees :: (Library -> Library)
718+
-> (Executable -> Executable)
719+
-> (TestSuite -> TestSuite)
720+
-> (Benchmark -> Benchmark)
721+
-> ([Dependency] -> [Dependency])
722+
-> GenericPackageDescription -> GenericPackageDescription
723+
transformAllCondTrees onLibrary onExecutable
724+
onTestSuite onBenchmark onDepends gpd = gpd'
725+
where
726+
gpd' = gpd {
727+
condLibrary = condLib',
728+
condExecutables = condExes',
729+
condTestSuites = condTests',
730+
condBenchmarks = condBenchs'
731+
}
732+
733+
condLib = condLibrary gpd
734+
condExes = condExecutables gpd
735+
condTests = condTestSuites gpd
736+
condBenchs = condBenchmarks gpd
737+
738+
condLib' = fmap (onCondTree onLibrary) condLib
739+
condExes' = map (mapSnd $ onCondTree onExecutable) condExes
740+
condTests' = map (mapSnd $ onCondTree onTestSuite) condTests
741+
condBenchs' = map (mapSnd $ onCondTree onBenchmark) condBenchs
742+
743+
mapSnd :: (a -> b) -> (c,a) -> (c,b)
744+
mapSnd = fmap
745+
746+
onCondTree :: (a -> b) -> CondTree v [Dependency] a
747+
-> CondTree v [Dependency] b
748+
onCondTree g = mapCondTree g onDepends id

‎Cabal/Distribution/Simple/Configure.hs

Lines changed: 21 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -48,6 +48,7 @@ module Distribution.Simple.Configure (configure,
4848
ConfigStateFileError(..),
4949
tryGetConfigStateFile,
5050
platformDefines,
51+
relaxPackageDeps,
5152
)
5253
where
5354

@@ -309,7 +310,13 @@ findDistPrefOrDefault = findDistPref defaultDistPref
309310
-- Returns the @.setup-config@ file.
310311
configure :: (GenericPackageDescription, HookedBuildInfo)
311312
-> ConfigFlags -> IO LocalBuildInfo
312-
configure (pkg_descr0, pbi) cfg = do
313+
configure (pkg_descr0', pbi) cfg = do
314+
let pkg_descr0 =
315+
-- Ignore '--allow-newer' when we're given '--exact-configuration'.
316+
if fromFlagOrDefault False (configExactConfiguration cfg)
317+
then pkg_descr0'
318+
else relaxPackageDeps (configAllowNewer cfg) pkg_descr0'
319+
313320
setupMessage verbosity "Configuring" (packageId pkg_descr0)
314321

315322
checkDeprecatedFlags verbosity cfg
@@ -787,6 +794,19 @@ dependencySatisfiable
787794
isInternalDep = not . null
788795
$ PackageIndex.lookupDependency internalPackageSet d
789796

797+
-- | Relax the dependencies of this package if needed
798+
relaxPackageDeps :: AllowNewer -> GenericPackageDescription
799+
-> GenericPackageDescription
800+
relaxPackageDeps AllowNewerNone = id
801+
relaxPackageDeps AllowNewerAll =
802+
transformAllBuildDepends $ \(Dependency pkgName verRange) ->
803+
Dependency pkgName (removeUpperBound verRange)
804+
relaxPackageDeps (AllowNewerSome pkgNames) =
805+
transformAllBuildDepends $ \d@(Dependency pkgName verRange) ->
806+
if pkgName `elem` pkgNames
807+
then Dependency pkgName (removeUpperBound verRange)
808+
else d
809+
790810
-- | Finalize a generic package description. The workhorse is
791811
-- 'finalizePackageDescription' but there's a bit of other nattering
792812
-- about necessary.

‎Cabal/Distribution/Simple/Setup.hs

Lines changed: 72 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,7 @@ module Distribution.Simple.Setup (
3434

3535
GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand,
3636
ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand,
37+
AllowNewer(..), isAllowNewer,
3738
configAbsolutePaths, readPackageDbList, showPackageDbList,
3839
CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand,
3940
InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand,
@@ -64,7 +65,8 @@ module Distribution.Simple.Setup (
6465
fromFlagOrDefault,
6566
flagToMaybe,
6667
flagToList,
67-
boolOpt, boolOpt', trueArg, falseArg, optionVerbosity, optionNumJobs ) where
68+
boolOpt, boolOpt', trueArg, falseArg,
69+
optionVerbosity, optionNumJobs, readPToMaybe ) where
6870

6971
import Distribution.Compiler
7072
import Distribution.ReadE
@@ -86,6 +88,7 @@ import Distribution.Compat.Semigroup as Semi
8688

8789
import Control.Monad (liftM)
8890
import Data.List ( sort )
91+
import Data.Maybe ( listToMaybe )
8992
import Data.Char ( isSpace, isAlpha )
9093
import GHC.Generics (Generic)
9194

@@ -252,6 +255,56 @@ instance Semigroup GlobalFlags where
252255
-- * Config flags
253256
-- ------------------------------------------------------------
254257

258+
-- | Policy for relaxing upper bounds in dependencies. For example, given
259+
-- 'build-depends: array >= 0.3 && < 0.5', are we allowed to relax the upper
260+
-- bound and choose a version of 'array' that is greater or equal to 0.5? By
261+
-- default the upper bounds are always strictly honored.
262+
data AllowNewer =
263+
264+
-- | Default: honor the upper bounds in all dependencies, never choose
265+
-- versions newer than allowed.
266+
AllowNewerNone
267+
268+
-- | Ignore upper bounds in dependencies on the given packages.
269+
| AllowNewerSome [PackageName]
270+
271+
-- | Ignore upper bounds in dependencies on all packages.
272+
| AllowNewerAll
273+
deriving (Eq, Ord, Read, Show, Generic)
274+
275+
instance Binary AllowNewer
276+
277+
instance Semigroup AllowNewer where
278+
AllowNewerNone <> r = r
279+
l@AllowNewerAll <> _ = l
280+
l@(AllowNewerSome _) <> AllowNewerNone = l
281+
(AllowNewerSome _) <> r@AllowNewerAll = r
282+
(AllowNewerSome a) <> (AllowNewerSome b) = AllowNewerSome (a ++ b)
283+
284+
instance Monoid AllowNewer where
285+
mempty = AllowNewerNone
286+
mappend = (Semi.<>)
287+
288+
-- | Convert 'AllowNewer' to a boolean.
289+
isAllowNewer :: AllowNewer -> Bool
290+
isAllowNewer AllowNewerNone = False
291+
isAllowNewer (AllowNewerSome _) = True
292+
isAllowNewer AllowNewerAll = True
293+
294+
allowNewerParser :: ReadE AllowNewer
295+
allowNewerParser = ReadE $ \s ->
296+
case readPToMaybe pkgsParser s of
297+
Just pkgs -> Right . AllowNewerSome $ pkgs
298+
Nothing -> Left ("Cannot parse the list of packages: " ++ s)
299+
where
300+
pkgsParser = Parse.sepBy1 parse (Parse.char ',')
301+
302+
allowNewerPrinter :: AllowNewer -> [Maybe String]
303+
allowNewerPrinter AllowNewerNone = []
304+
allowNewerPrinter AllowNewerAll = [Nothing]
305+
allowNewerPrinter (AllowNewerSome pkgs) =
306+
[Just . intercalate "," . map display $ pkgs]
307+
255308
-- | Flags to @configure@ command.
256309
--
257310
-- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags'
@@ -319,7 +372,9 @@ data ConfigFlags = ConfigFlags {
319372
configFlagError :: Flag String,
320373
-- ^Halt and show an error message indicating an error in flag assignment
321374
configRelocatable :: Flag Bool, -- ^ Enable relocatable package built
322-
configDebugInfo :: Flag DebugInfoLevel -- ^ Emit debug info.
375+
configDebugInfo :: Flag DebugInfoLevel, -- ^ Emit debug info.
376+
configAllowNewer :: AllowNewer -- ^ Ignore upper bounds on all or some
377+
-- dependencies.
323378
}
324379
deriving (Generic, Read, Show)
325380

@@ -365,7 +420,8 @@ defaultConfigFlags progConf = emptyConfigFlags {
365420
configExactConfiguration = Flag False,
366421
configFlagError = NoFlag,
367422
configRelocatable = Flag False,
368-
configDebugInfo = Flag NoDebugInfo
423+
configDebugInfo = Flag NoDebugInfo,
424+
configAllowNewer = AllowNewerNone
369425
}
370426

371427
configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags
@@ -602,6 +658,11 @@ configureOptions showOrParseArgs =
602658
configLibCoverage (\v flags -> flags { configLibCoverage = v })
603659
(boolOpt [] [])
604660

661+
,option [] ["allow-newer"]
662+
("Ignore upper bounds in all dependencies or DEPS")
663+
configAllowNewer (\v flags -> flags { configAllowNewer = v})
664+
(optArg "DEPS" allowNewerParser AllowNewerAll allowNewerPrinter)
665+
605666
,option "" ["exact-configuration"]
606667
"All direct dependencies and flags are provided on the command line."
607668
configExactConfiguration
@@ -769,7 +830,8 @@ instance Monoid ConfigFlags where
769830
configBenchmarks = mempty,
770831
configFlagError = mempty,
771832
configRelocatable = mempty,
772-
configDebugInfo = mempty
833+
configDebugInfo = mempty,
834+
configAllowNewer = mempty
773835
}
774836
mappend = (Semi.<>)
775837

@@ -817,7 +879,8 @@ instance Semigroup ConfigFlags where
817879
configBenchmarks = combine configBenchmarks,
818880
configFlagError = combine configFlagError,
819881
configRelocatable = combine configRelocatable,
820-
configDebugInfo = combine configDebugInfo
882+
configDebugInfo = combine configDebugInfo,
883+
configAllowNewer = combine configAllowNewer
821884
}
822885
where combine field = field a `mappend` field b
823886

@@ -2156,6 +2219,10 @@ optionNumJobs get set =
21562219
-- * Other Utils
21572220
-- ------------------------------------------------------------
21582221

2222+
readPToMaybe :: Parse.ReadP a a -> String -> Maybe a
2223+
readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
2224+
, all isSpace s ]
2225+
21592226
-- | Arguments to pass to a @configure@ script, e.g. generated by
21602227
-- @autoconf@.
21612228
configureArgs :: Bool -> ConfigFlags -> [String]

‎Cabal/changelog

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,8 @@
1919
work-around for #2398)
2020
* Library support for multi-instance package DBs (#2948).
2121
* Improved the './Setup configure' solver (#3082, #3076).
22+
* The '--allow-newer' option can be now used with './Setup
23+
configure' (#3163).
2224

2325
1.22.0.0 Johan Tibell <johan.tibell@gmail.com> January 2015
2426
* Support GHC 7.10.

‎Cabal/tests/PackageTests/AllowNewer/AllowNewer.cabal

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,25 @@
1+
name: AllowNewer
2+
version: 0.1.0.0
3+
license: BSD3
4+
author: Foo Bar
5+
maintainer: cabal-dev@haskell.org
6+
build-type: Simple
7+
cabal-version: >=1.10
8+
9+
library
10+
exposed-modules: Foo
11+
hs-source-dirs: src
12+
build-depends: base < 1
13+
default-language: Haskell2010
14+
15+
test-suite foo-test
16+
type: exitcode-stdio-1.0
17+
main-is: Test.hs
18+
hs-source-dirs: tests
19+
build-depends: base < 1
20+
21+
benchmark foo-bench
22+
type: exitcode-stdio-1.0
23+
main-is: Bench.hs
24+
hs-source-dirs: benchmarks
25+
build-depends: base < 1

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

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
module Main where
2+
3+
main :: IO ()
4+
main = return ()

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

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
module Main where
2+
3+
main :: IO ()
4+
main = return ()

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

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
!module Main where
2+
3+
main :: IO ()
4+
main = return ()

‎Cabal/tests/PackageTests/Tests.hs

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -221,6 +221,22 @@ nonSharedLibTests config =
221221
cabal_build ["--enable-tests"]
222222
cabal "test" []
223223

224+
-- Test that '--allow-newer' works via the 'Setup.hs configure' interface.
225+
, tc "AllowNewer" $ do
226+
shouldFail $ cabal "configure" []
227+
cabal "configure" ["--allow-newer"]
228+
shouldFail $ cabal "configure" ["--allow-newer=baz,quux"]
229+
cabal "configure" ["--allow-newer=base", "--allow-newer=baz,quux"]
230+
cabal "configure" ["--allow-newer=bar", "--allow-newer=base,baz"
231+
,"--allow-newer=quux"]
232+
shouldFail $ cabal "configure" ["--enable-tests"]
233+
cabal "configure" ["--enable-tests", "--allow-newer"]
234+
shouldFail $ cabal "configure" ["--enable-benchmarks"]
235+
cabal "configure" ["--enable-benchmarks", "--allow-newer"]
236+
shouldFail $ cabal "configure" ["--enable-benchmarks", "--enable-tests"]
237+
cabal "configure" ["--enable-benchmarks", "--enable-tests"
238+
,"--allow-newer"]
239+
224240
-- Test that Cabal can choose flags to disable building a component when that
225241
-- component's dependencies are unavailable. The build should succeed without
226242
-- requiring the component's dependencies or imports.

‎HACKING.md

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -70,7 +70,7 @@ To build and test the `Cabal` library, do:
7070
we cannot use `cabal` for the next steps;
7171
we need to use Setup instead.
7272
So, compile Setup.hs:
73-
73+
7474
~~~~
7575
ghc --make -threaded Setup.hs
7676
~~~~
@@ -89,7 +89,7 @@ To build and test the `Cabal` library, do:
8989
~~~~
9090
~/MyHaskellCode/cabal/Cabal/.cabal-sandbox/$SOMESTUFF-packages.conf.d
9191
~~~~
92-
92+
9393
(or, as a relative path with my setup:)
9494
9595
~~~~

0 commit comments

Comments
 (0)