Commit ea01974b authored by mightybyte's avatar mightybyte Committed by Mikhail Glushenkov

Initial working version of the gen-bounds command.

parent ab516463
......@@ -13,7 +13,7 @@
-- The cabal freeze command
-----------------------------------------------------------------------------
module Distribution.Client.Freeze (
freeze,
freeze, getFreezePkgs
) where
import Distribution.Client.Config ( SavedConfig(..) )
......@@ -88,19 +88,9 @@ freeze :: Verbosity
freeze verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo
globalFlags freezeFlags = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repoCtxt
pkgConfigDb <- readPkgConfigDb verbosity conf
pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
[UserTargetLocalDir "."]
sanityCheck pkgSpecifiers
pkgs <- planPackages
verbosity comp platform mSandboxPkgInfo freezeFlags
installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers
pkgs <- getFreezePkgs
verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo
globalFlags freezeFlags
if null pkgs
then notice verbosity $ "No packages to be frozen. "
......@@ -110,11 +100,38 @@ freeze verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo
"The following packages would be frozen:"
: formatPkgs pkgs
else freezePackages globalFlags verbosity pkgs
else freezePackages verbosity globalFlags pkgs
where
dryRun = fromFlag (freezeDryRun freezeFlags)
getFreezePkgs :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramConfiguration
-> Maybe SandboxPackageInfo
-> GlobalFlags
-> FreezeFlags
-> IO [PlanPackage]
getFreezePkgs verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo
globalFlags freezeFlags = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repoCtxt
pkgConfigDb <- readPkgConfigDb verbosity conf
pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
[UserTargetLocalDir "."]
sanityCheck pkgSpecifiers
planPackages
verbosity comp platform mSandboxPkgInfo freezeFlags
installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers
where
sanityCheck pkgSpecifiers = do
when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $
die $ "internal error: 'resolveUserTargets' returned "
......@@ -209,8 +226,8 @@ pruneInstallPlan installPlan pkgSpecifiers =
++ "unexpected package specifiers!"
freezePackages :: Package pkg => GlobalFlags -> Verbosity -> [pkg] -> IO ()
freezePackages globalFlags verbosity pkgs = do
freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO ()
freezePackages verbosity globalFlags pkgs = do
pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $
loadUserConfig verbosity "" (flagToMaybe . globalConstraintsFile $ globalFlags)
......
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.GenBounds
-- Copyright : (c) Doug Beardsley 2015
-- License : BSD-like
--
-- Maintainer : cabal-devel@gmail.com
-- Stability : provisional
-- Portability : portable
--
-- The cabal gen-bounds command for generating PVP-compliant version bounds.
-----------------------------------------------------------------------------
module Distribution.Client.GenBounds (
genBounds
) where
import Data.Version
( Version(..), showVersion )
import Distribution.Client.Freeze
( getFreezePkgs )
import Distribution.Client.Sandbox.Types
( SandboxPackageInfo(..) )
import Distribution.Client.Setup
( GlobalFlags(..), FreezeFlags(..), RepoContext )
import Distribution.Package
( Package(..), Dependency(..), PackageName(..)
, packageName, packageVersion )
import Distribution.PackageDescription
( buildDepends )
import Distribution.PackageDescription.Configuration
( finalizePackageDescription )
import Distribution.PackageDescription.Parse
( readPackageDescription )
import Distribution.Simple.Compiler
( Compiler, PackageDBStack, compilerInfo )
import Distribution.Simple.Program
( ProgramConfiguration )
import Distribution.Simple.Utils
( tryFindPackageDesc )
import Distribution.System
( Platform )
import Distribution.Verbosity
( Verbosity )
import Distribution.Version
( LowerBound(..), UpperBound(..), VersionRange(..), asVersionIntervals
, orLaterVersion, earlierVersion, intersectVersionRanges )
import System.Directory
( getCurrentDirectory )
hasUpperBound :: VersionRange -> Bool
hasUpperBound vr =
case asVersionIntervals vr of
[] -> False
is -> if snd (last is) == NoUpperBound then False else True
-- This version is slightly different than the one in
-- Distribution.Client.Init. This one uses a.b.c as the lower bound because
-- the user could be using a new function introduced in a.b.c which would
-- make "> a.b" incorrect.
pvpize :: Version -> VersionRange
pvpize v = orLaterVersion (vn 3)
`intersectVersionRanges`
earlierVersion (incVersion 1 (vn 2))
where
vn n = (v { versionBranch = take n (versionBranch v) })
incVersion :: Int -> Version -> Version
incVersion n (Version vlist tags) = Version (incVersion' n vlist) tags
where
incVersion' 0 [] = [1]
incVersion' 0 (v:_) = [v+1]
incVersion' m [] = replicate m 0 ++ [1]
incVersion' m (v:vs) = v : incVersion' (m-1) vs
showInterval :: (LowerBound, UpperBound) -> String
showInterval (LowerBound _ _, NoUpperBound) =
error "Error: expected upper bound...this should never happen!"
showInterval (LowerBound l _, UpperBound u _) =
unwords [">=", showVersion l, "&& <", showVersion u]
padAfter :: Int -> String -> String
padAfter n str = str ++ replicate (n - length str) ' '
showBounds :: Package pkg => Int -> pkg -> String
showBounds padTo p = unwords $
(padAfter padTo $ unPackageName $ packageName p) :
map showInterval (asVersionIntervals $ pvpize $ packageVersion p)
genBounds
:: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramConfiguration
-> Maybe SandboxPackageInfo
-> GlobalFlags
-> FreezeFlags
-> IO ()
genBounds verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo
globalFlags freezeFlags = do
let cinfo = compilerInfo comp
cwd <- getCurrentDirectory
path <- tryFindPackageDesc cwd
gpd <- readPackageDescription verbosity path
let epd = finalizePackageDescription [] (const True) platform cinfo [] gpd
case epd of
Left _ -> putStrLn "finalizePackageDescription failed"
Right (pd,_) -> do
let needBounds = filter (not . hasUpperBound . depVersion) $ buildDepends pd
if (null needBounds)
then putStrLn "Congratulations, all your dependencies have upper bounds!"
else go needBounds
where
go needBounds = do
pkgs <- getFreezePkgs
verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo
globalFlags freezeFlags
putStrLn $ unlines
[ ""
, "The following packages need bounds and here is a suggested starting point."
, "You can copy and paste this into the build-depends section in your .cabal"
, "file and it should work (with the appropriate removal of commas)."
, ""
, "Note that version bounds are a statement that you've successfully built and"
, "tested your package and expect it to work with any of the specified package"
, "versions (PROVIDED that those packages continue to conform with the PVP)."
, "Therefore, the version bounds generated here are the most conservative"
, "based on the versions that you are currently building with. If you know"
, "your package will work with versions outside the ranges generated here,"
, "feel free to widen them."
, ""
]
let isNeeded pkg = unPackageName (packageName pkg) `elem` map depName needBounds
let thePkgs = filter isNeeded pkgs
let padTo = maximum $ map (length . unPackageName . packageName) pkgs
mapM_ (putStrLn . (++",") . showBounds padTo) thePkgs
depName :: Dependency -> String
depName (Dependency (PackageName nm) _) = nm
depVersion :: Dependency -> VersionRange
depVersion (Dependency _ vr) = vr
......@@ -18,6 +18,8 @@ module Distribution.Client.Init (
-- * Commands
initCabal
, pvpize
, incVersion
) where
......@@ -467,11 +469,11 @@ chooseDep flags (m, Just ps)
return $ P.Dependency (P.pkgName . head $ pids)
(pvpize . maximum . map P.pkgVersion $ pids)
pvpize :: Version -> VersionRange
pvpize v = orLaterVersion v'
`intersectVersionRanges`
earlierVersion (incVersion 1 v')
where v' = (v { versionBranch = take 2 (versionBranch v) })
pvpize :: Version -> VersionRange
pvpize v = orLaterVersion v'
`intersectVersionRanges`
earlierVersion (incVersion 1 v')
where v' = (v { versionBranch = take 2 (versionBranch v) })
incVersion :: Int -> Version -> Version
incVersion n (Version vlist tags) = Version (incVersion' n vlist) tags
......
......@@ -31,6 +31,7 @@ module Distribution.Client.Setup
, infoCommand, InfoFlags(..)
, fetchCommand, FetchFlags(..)
, freezeCommand, FreezeFlags(..)
, genBoundsCommand
, getCommand, unpackCommand, GetFlags(..)
, checkCommand
, formatCommand
......@@ -162,6 +163,7 @@ globalCommand commands = CommandUI {
, "upload"
, "report"
, "freeze"
, "gen-bounds"
, "haddock"
, "hscolour"
, "copy"
......@@ -212,6 +214,7 @@ globalCommand commands = CommandUI {
, addCmd "report"
, par
, addCmd "freeze"
, addCmd "gen-bounds"
, addCmd "haddock"
, addCmd "hscolour"
, addCmd "copy"
......@@ -742,6 +745,22 @@ freezeCommand = CommandUI {
}
genBoundsCommand :: CommandUI FreezeFlags
genBoundsCommand = CommandUI {
commandName = "gen-bounds",
commandSynopsis = "Generate dependency bounds.",
commandDescription = Just $ \_ -> wrapText $
"Generates bounds for all dependencies that do not currently have them. "
++ "Generated bounds are printed to stdout. You can then paste them into your .cabal file.\n"
++ "\n",
commandNotes = Nothing,
commandUsage = usageFlags "gen-bounds",
commandDefaultFlags = defaultFreezeFlags,
commandOptions = \ _ -> [
optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v })
]
}
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------
......
......@@ -25,6 +25,7 @@ import Distribution.Client.Setup
, installCommand, upgradeCommand, uninstallCommand
, FetchFlags(..), fetchCommand
, FreezeFlags(..), freezeCommand
, genBoundsCommand
, GetFlags(..), getCommand, unpackCommand
, checkCommand
, formatCommand
......@@ -77,6 +78,7 @@ import Distribution.Client.Update (update)
import Distribution.Client.Exec (exec)
import Distribution.Client.Fetch (fetch)
import Distribution.Client.Freeze (freeze)
import Distribution.Client.GenBounds (genBounds)
import Distribution.Client.Check as Check (check)
--import Distribution.Client.Clean (clean)
import qualified Distribution.Client.Upload as Upload
......@@ -262,6 +264,7 @@ mainWorker args = topHandler $
, regularCmd execCommand execAction
, regularCmd userConfigCommand userConfigAction
, regularCmd cleanCommand cleanAction
, regularCmd genBoundsCommand genBoundsAction
, wrapperCmd copyCommand copyVerbosity copyDistPref
, wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref
, wrapperCmd registerCommand regVerbosity regDistPref
......@@ -1014,6 +1017,25 @@ freezeAction freezeFlags _extraArgs globalFlags = do
mSandboxPkgInfo
globalFlags' freezeFlags
genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO ()
genBoundsAction freezeFlags _extraArgs globalFlags = do
let verbosity = fromFlag (freezeVerbosity freezeFlags)
(useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags
let configFlags = savedConfigureFlags config
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, platform, conf) <- configCompilerAux' configFlags
maybeWithSandboxPackageInfo verbosity configFlags globalFlags'
comp platform conf useSandbox $ \mSandboxPkgInfo ->
maybeWithSandboxDirOnSearchPath useSandbox $
withRepoContext verbosity globalFlags' $ \repoContext ->
genBounds verbosity
(configPackageDB' configFlags)
repoContext
comp platform conf
mSandboxPkgInfo
globalFlags' freezeFlags
uploadAction :: UploadFlags -> [String] -> Action
uploadAction uploadFlags extraArgs globalFlags = do
config <- loadConfig verbosity (globalConfigFile globalFlags)
......
......@@ -159,6 +159,7 @@ executable cabal
Distribution.Client.FetchUtils
Distribution.Client.FileMonitor
Distribution.Client.Freeze
Distribution.Client.GenBounds
Distribution.Client.Get
Distribution.Client.Glob
Distribution.Client.GlobalFlags
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment