Skip to content

Commit 4ddab8d

Browse files
mightybytemightybyte
committed
Initial working version of the gen-bounds command
1 parent 1f14808 commit 4ddab8d

File tree

5 files changed

+230
-20
lines changed

5 files changed

+230
-20
lines changed

‎cabal-install/Distribution/Client/Freeze.hs

Lines changed: 32 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,7 @@
1313
-- The cabal freeze command
1414
-----------------------------------------------------------------------------
1515
module Distribution.Client.Freeze (
16-
freeze,
16+
freeze, getFreezePkgs
1717
) where
1818

1919
import Distribution.Client.Config ( SavedConfig(..) )
@@ -88,6 +88,36 @@ freeze :: Verbosity
8888
freeze verbosity packageDBs repos comp platform conf mSandboxPkgInfo
8989
globalFlags freezeFlags = do
9090

91+
pkgs <- getFreezePkgs
92+
verbosity packageDBs repos comp platform conf mSandboxPkgInfo
93+
globalFlags freezeFlags
94+
95+
if null pkgs
96+
then notice verbosity $ "No packages to be frozen. "
97+
++ "As this package has no dependencies."
98+
else if dryRun
99+
then notice verbosity $ unlines $
100+
"The following packages would be frozen:"
101+
: formatPkgs pkgs
102+
103+
else freezePackages verbosity pkgs
104+
105+
where
106+
dryRun = fromFlag (freezeDryRun freezeFlags)
107+
108+
getFreezePkgs :: Verbosity
109+
-> PackageDBStack
110+
-> [Repo]
111+
-> Compiler
112+
-> Platform
113+
-> ProgramConfiguration
114+
-> Maybe SandboxPackageInfo
115+
-> GlobalFlags
116+
-> FreezeFlags
117+
-> IO [PlanPackage]
118+
getFreezePkgs verbosity packageDBs repos comp platform conf mSandboxPkgInfo
119+
globalFlags freezeFlags = do
120+
91121
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
92122
sourcePkgDb <- getSourcePackages verbosity repos
93123

@@ -100,23 +130,10 @@ freeze verbosity packageDBs repos comp platform conf mSandboxPkgInfo
100130
[UserTargetLocalDir "."]
101131

102132
sanityCheck pkgSpecifiers
103-
pkgs <- planPackages
133+
planPackages
104134
verbosity comp platform mSandboxPkgInfo freezeFlags
105135
installedPkgIndex sourcePkgDb pkgSpecifiers
106-
107-
if null pkgs
108-
then notice verbosity $ "No packages to be frozen. "
109-
++ "As this package has no dependencies."
110-
else if dryRun
111-
then notice verbosity $ unlines $
112-
"The following packages would be frozen:"
113-
: formatPkgs pkgs
114-
115-
else freezePackages verbosity pkgs
116-
117136
where
118-
dryRun = fromFlag (freezeDryRun freezeFlags)
119-
120137
sanityCheck pkgSpecifiers = do
121138
when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $
122139
die $ "internal error: 'resolveUserTargets' returned "

‎cabal-install/Distribution/Client/GenBounds.hs

Lines changed: 151 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,151 @@
1+
-----------------------------------------------------------------------------
2+
-- |
3+
-- Module : Distribution.Client.GenBounds
4+
-- Copyright : (c) Doug Beardsley 2015
5+
-- License : BSD-like
6+
--
7+
-- Maintainer : cabal-devel@gmail.com
8+
-- Stability : provisional
9+
-- Portability : portable
10+
--
11+
-- The cabal gen-bounds command for generating PVP-compliant version bounds.
12+
-----------------------------------------------------------------------------
13+
module Distribution.Client.GenBounds (
14+
genBounds
15+
) where
16+
17+
import Data.Version
18+
( Version(..), showVersion )
19+
import Distribution.Client.Freeze
20+
( getFreezePkgs )
21+
import Distribution.Client.Sandbox.Types
22+
( SandboxPackageInfo(..) )
23+
import Distribution.Client.Setup
24+
( GlobalFlags(..), FreezeFlags(..) )
25+
import Distribution.Client.Types
26+
import Distribution.Package
27+
( Package(..), Dependency(..), PackageName(..)
28+
, packageName, packageVersion )
29+
import Distribution.PackageDescription
30+
( buildDepends )
31+
import Distribution.PackageDescription.Configuration
32+
( finalizePackageDescription )
33+
import Distribution.PackageDescription.Parse
34+
( readPackageDescription )
35+
import Distribution.Simple.Compiler
36+
( Compiler, PackageDBStack, compilerInfo )
37+
import Distribution.Simple.Program
38+
( ProgramConfiguration )
39+
import Distribution.Simple.Utils
40+
( tryFindPackageDesc )
41+
import Distribution.System
42+
( Platform )
43+
import Distribution.Verbosity
44+
( Verbosity )
45+
import Distribution.Version
46+
( LowerBound(..), UpperBound(..), VersionRange(..), asVersionIntervals
47+
, orLaterVersion, earlierVersion, intersectVersionRanges )
48+
import System.Directory
49+
( getCurrentDirectory )
50+
51+
hasUpperBound :: VersionRange -> Bool
52+
hasUpperBound vr =
53+
case asVersionIntervals vr of
54+
[] -> False
55+
is -> if snd (last is) == NoUpperBound then False else True
56+
57+
-- This version is slightly different than the one in
58+
-- Distribution.Client.Init. This one uses a.b.c as the lower bound because
59+
-- the user could be using a new function introduced in a.b.c which would
60+
-- make "> a.b" incorrect.
61+
pvpize :: Version -> VersionRange
62+
pvpize v = orLaterVersion (vn 3)
63+
`intersectVersionRanges`
64+
earlierVersion (incVersion 1 (vn 2))
65+
where
66+
vn n = (v { versionBranch = take n (versionBranch v) })
67+
68+
incVersion :: Int -> Version -> Version
69+
incVersion n (Version vlist tags) = Version (incVersion' n vlist) tags
70+
where
71+
incVersion' 0 [] = [1]
72+
incVersion' 0 (v:_) = [v+1]
73+
incVersion' m [] = replicate m 0 ++ [1]
74+
incVersion' m (v:vs) = v : incVersion' (m-1) vs
75+
76+
showInterval :: (LowerBound, UpperBound) -> String
77+
showInterval (LowerBound _ _, NoUpperBound) =
78+
error "Error: expected upper bound...this should never happen!"
79+
showInterval (LowerBound l _, UpperBound u _) =
80+
unwords [">=", showVersion l, "&& <", showVersion u]
81+
82+
padAfter :: Int -> String -> String
83+
padAfter n str = str ++ replicate (n - length str) ' '
84+
85+
showBounds :: Package pkg => Int -> pkg -> String
86+
showBounds padTo p = unwords $
87+
(padAfter padTo $ unPackageName $ packageName p) :
88+
map showInterval (asVersionIntervals $ pvpize $ packageVersion p)
89+
90+
genBounds
91+
:: Verbosity
92+
-> PackageDBStack
93+
-> [Repo]
94+
-> Compiler
95+
-> Platform
96+
-> ProgramConfiguration
97+
-> Maybe SandboxPackageInfo
98+
-> GlobalFlags
99+
-> FreezeFlags
100+
-> IO ()
101+
genBounds verbosity packageDBs repos comp platform conf mSandboxPkgInfo
102+
globalFlags freezeFlags = do
103+
104+
let cinfo = compilerInfo comp
105+
106+
cwd <- getCurrentDirectory
107+
path <- tryFindPackageDesc cwd
108+
gpd <- readPackageDescription verbosity path
109+
let epd = finalizePackageDescription [] (const True) platform cinfo [] gpd
110+
case epd of
111+
Left _ -> putStrLn "finalizePackageDescription failed"
112+
Right (pd,_) -> do
113+
let needBounds = filter (not . hasUpperBound . depVersion) $ buildDepends pd
114+
115+
if (null needBounds)
116+
then putStrLn "Congratulations, all your dependencies have upper bounds!"
117+
else go needBounds
118+
where
119+
go needBounds = do
120+
pkgs <- getFreezePkgs
121+
verbosity packageDBs repos comp platform conf mSandboxPkgInfo
122+
globalFlags freezeFlags
123+
124+
putStrLn $ unlines
125+
[ ""
126+
, "The following packages need bounds and here is a suggested starting point."
127+
, "You can copy and paste this into the build-depends section in your .cabal"
128+
, "file and it should work (with the appropriate removal of commas)."
129+
, ""
130+
, "Note that version bounds are a statement that you've successfully built and"
131+
, "tested your package and expect it to work with any of the specified package"
132+
, "versions (PROVIDED that those packages continue to conform with the PVP)."
133+
, "Therefore, the version bounds generated here are the most conservative"
134+
, "based on the versions that you are currently building with. If you know"
135+
, "your package will work with versions outside the ranges generated here,"
136+
, "feel free to widen them."
137+
, ""
138+
]
139+
140+
let isNeeded pkg = unPackageName (packageName pkg) `elem` map depName needBounds
141+
let thePkgs = filter isNeeded pkgs
142+
143+
let padTo = maximum $ map (length . unPackageName . packageName) pkgs
144+
mapM_ (putStrLn . (++",") . showBounds padTo) thePkgs
145+
146+
depName :: Dependency -> String
147+
depName (Dependency (PackageName nm) _) = nm
148+
149+
depVersion :: Dependency -> VersionRange
150+
depVersion (Dependency _ vr) = vr
151+

‎cabal-install/Distribution/Client/Init.hs

Lines changed: 7 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,8 @@ module Distribution.Client.Init (
1818

1919
-- * Commands
2020
initCabal
21+
, pvpize
22+
, incVersion
2123

2224
) where
2325

@@ -465,11 +467,11 @@ chooseDep flags (m, Just ps)
465467
return $ P.Dependency (P.pkgName . head $ pids)
466468
(pvpize . maximum . map P.pkgVersion $ pids)
467469

468-
pvpize :: Version -> VersionRange
469-
pvpize v = orLaterVersion v'
470-
`intersectVersionRanges`
471-
earlierVersion (incVersion 1 v')
472-
where v' = (v { versionBranch = take 2 (versionBranch v) })
470+
pvpize :: Version -> VersionRange
471+
pvpize v = orLaterVersion v'
472+
`intersectVersionRanges`
473+
earlierVersion (incVersion 1 v')
474+
where v' = (v { versionBranch = take 2 (versionBranch v) })
473475

474476
incVersion :: Int -> Version -> Version
475477
incVersion n (Version vlist tags) = Version (incVersion' n vlist) tags

‎cabal-install/Distribution/Client/Setup.hs

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ module Distribution.Client.Setup
2626
, infoCommand, InfoFlags(..)
2727
, fetchCommand, FetchFlags(..)
2828
, freezeCommand, FreezeFlags(..)
29+
, genBoundsCommand
2930
, getCommand, unpackCommand, GetFlags(..)
3031
, checkCommand
3132
, formatCommand
@@ -187,6 +188,7 @@ globalCommand commands = CommandUI {
187188
, "upload"
188189
, "report"
189190
, "freeze"
191+
, "gen-bounds"
190192
, "haddock"
191193
, "hscolour"
192194
, "copy"
@@ -237,6 +239,7 @@ globalCommand commands = CommandUI {
237239
, addCmd "report"
238240
, par
239241
, addCmd "freeze"
242+
, addCmd "gen-bounds"
240243
, addCmd "haddock"
241244
, addCmd "hscolour"
242245
, addCmd "copy"
@@ -799,6 +802,22 @@ freezeCommand = CommandUI {
799802

800803
}
801804

805+
genBoundsCommand :: CommandUI FreezeFlags
806+
genBoundsCommand = CommandUI {
807+
commandName = "gen-bounds",
808+
commandSynopsis = "Generate dependency bounds.",
809+
commandDescription = Just $ \_ -> wrapText $
810+
"Generates bounds for all dependencies that do not currently have them. "
811+
++ "Generated bounds are printed to stdout. You can then paste them into your .cabal file.\n"
812+
++ "\n",
813+
commandNotes = Nothing,
814+
commandUsage = usageFlags "gen-bounds",
815+
commandDefaultFlags = defaultFreezeFlags,
816+
commandOptions = \ _ -> [
817+
optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v })
818+
]
819+
}
820+
802821
-- ------------------------------------------------------------
803822
-- * Other commands
804823
-- ------------------------------------------------------------

‎cabal-install/Main.hs

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ import Distribution.Client.Setup
2525
, installCommand, upgradeCommand, uninstallCommand
2626
, FetchFlags(..), fetchCommand
2727
, FreezeFlags(..), freezeCommand
28+
, genBoundsCommand
2829
, GetFlags(..), getCommand, unpackCommand
2930
, checkCommand
3031
, formatCommand
@@ -71,6 +72,7 @@ import Distribution.Client.Update (update)
7172
import Distribution.Client.Exec (exec)
7273
import Distribution.Client.Fetch (fetch)
7374
import Distribution.Client.Freeze (freeze)
75+
import Distribution.Client.GenBounds (genBounds)
7476
import Distribution.Client.Check as Check (check)
7577
--import Distribution.Client.Clean (clean)
7678
import Distribution.Client.Upload as Upload (upload, check, report)
@@ -235,6 +237,7 @@ mainWorker args = topHandler $
235237
,infoCommand `commandAddAction` infoAction
236238
,fetchCommand `commandAddAction` fetchAction
237239
,freezeCommand `commandAddAction` freezeAction
240+
,genBoundsCommand `commandAddAction` genBoundsAction
238241
,getCommand `commandAddAction` getAction
239242
,hiddenCommand $
240243
unpackCommand `commandAddAction` unpackAction
@@ -971,6 +974,24 @@ freezeAction freezeFlags _extraArgs globalFlags = do
971974
mSandboxPkgInfo
972975
globalFlags' freezeFlags
973976

977+
genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO ()
978+
genBoundsAction freezeFlags _extraArgs globalFlags = do
979+
let verbosity = fromFlag (freezeVerbosity freezeFlags)
980+
(useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags
981+
let configFlags = savedConfigureFlags config
982+
globalFlags' = savedGlobalFlags config `mappend` globalFlags
983+
(comp, platform, conf) <- configCompilerAux' configFlags
984+
985+
maybeWithSandboxPackageInfo verbosity configFlags globalFlags'
986+
comp platform conf useSandbox $ \mSandboxPkgInfo ->
987+
maybeWithSandboxDirOnSearchPath useSandbox $
988+
genBounds verbosity
989+
(configPackageDB' configFlags)
990+
(globalRepos globalFlags')
991+
comp platform conf
992+
mSandboxPkgInfo
993+
globalFlags' freezeFlags
994+
974995
uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO ()
975996
uploadAction uploadFlags extraArgs globalFlags = do
976997
let verbosity = fromFlag (uploadVerbosity uploadFlags)

0 commit comments

Comments
 (0)