Add the gen-bounds command

cabal-install/Distribution/Client/Freeze.hs

@@ -13,7 +13,7 @@
 -- The cabal freeze command
 -----------------------------------------------------------------------------
 module Distribution.Client.Freeze (
-    freeze,
+    freeze, getFreezePkgs
   ) where
 
 import Distribution.Client.Config ( SavedConfig(..) )
@@ -88,6 +88,36 @@ freeze :: Verbosity
 freeze verbosity packageDBs repos comp platform conf mSandboxPkgInfo
       globalFlags freezeFlags = do
 
+    pkgs  <- getFreezePkgs
+               verbosity packageDBs repos comp platform conf mSandboxPkgInfo
+               globalFlags freezeFlags
+
+    if null pkgs
+      then notice verbosity $ "No packages to be frozen. "
+                           ++ "As this package has no dependencies."
+      else if dryRun
+             then notice verbosity $ unlines $
+                     "The following packages would be frozen:"
+                   : formatPkgs pkgs
+
+             else freezePackages verbosity pkgs
+
+  where
+    dryRun = fromFlag (freezeDryRun freezeFlags)
+
+getFreezePkgs :: Verbosity
+              -> PackageDBStack
+              -> [Repo]
+              -> Compiler
+              -> Platform
+              -> ProgramConfiguration
+              -> Maybe SandboxPackageInfo
+              -> GlobalFlags
+              -> FreezeFlags
+              -> IO [PlanPackage]
+getFreezePkgs verbosity packageDBs repos comp platform conf mSandboxPkgInfo
+      globalFlags freezeFlags = do
+
     installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
     sourcePkgDb       <- getSourcePackages    verbosity repos
 
@@ -100,23 +130,10 @@ freeze verbosity packageDBs repos comp platform conf mSandboxPkgInfo
                        [UserTargetLocalDir "."]
 
     sanityCheck pkgSpecifiers
-    pkgs  <- planPackages
+    planPackages
                verbosity comp platform mSandboxPkgInfo freezeFlags
                installedPkgIndex sourcePkgDb pkgSpecifiers
-
-    if null pkgs
-      then notice verbosity $ "No packages to be frozen. "
-                           ++ "As this package has no dependencies."
-      else if dryRun
-             then notice verbosity $ unlines $
-                     "The following packages would be frozen:"
-                   : formatPkgs pkgs
-
-             else freezePackages verbosity pkgs
-
   where
-    dryRun = fromFlag (freezeDryRun freezeFlags)
-
     sanityCheck pkgSpecifiers = do
       when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $
         die $ "internal error: 'resolveUserTargets' returned "

cabal-install/Distribution/Client/GenBounds.hs

@@ -0,0 +1,151 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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(..) )
+import Distribution.Client.Types
+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
+    -> [Repo]
+    -> Compiler
+    -> Platform
+    -> ProgramConfiguration
+    -> Maybe SandboxPackageInfo
+    -> GlobalFlags
+    -> FreezeFlags
+    -> IO ()
+genBounds verbosity packageDBs repos 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 repos 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
+

cabal-install/Distribution/Client/Init.hs

@@ -18,6 +18,8 @@ module Distribution.Client.Init (
 
     -- * Commands
     initCabal
+  , pvpize
+  , incVersion
 
   ) where
 
@@ -465,11 +467,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

cabal-install/Distribution/Client/Setup.hs

@@ -26,6 +26,7 @@ module Distribution.Client.Setup
     , infoCommand, InfoFlags(..)
     , fetchCommand, FetchFlags(..)
     , freezeCommand, FreezeFlags(..)
+    , genBoundsCommand
     , getCommand, unpackCommand, GetFlags(..)
     , checkCommand
     , formatCommand
@@ -187,6 +188,7 @@ globalCommand commands = CommandUI {
           , "upload"
           , "report"
           , "freeze"
+          , "gen-bounds"
           , "haddock"
           , "hscolour"
           , "copy"
@@ -237,6 +239,7 @@ globalCommand commands = CommandUI {
         , addCmd "report"
         , par
         , addCmd "freeze"
+        , addCmd "gen-bounds"
         , addCmd "haddock"
         , addCmd "hscolour"
         , addCmd "copy"
@@ -799,6 +802,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
 -- ------------------------------------------------------------

cabal-install/Main.hs

@@ -25,6 +25,7 @@ import Distribution.Client.Setup
          , installCommand, upgradeCommand, uninstallCommand
          , FetchFlags(..), fetchCommand
          , FreezeFlags(..), freezeCommand
+         , genBoundsCommand
          , GetFlags(..), getCommand, unpackCommand
          , checkCommand
          , formatCommand
@@ -71,6 +72,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 Distribution.Client.Upload as Upload   (upload, check, report)
@@ -235,6 +237,7 @@ mainWorker args = topHandler $
       ,infoCommand            `commandAddAction` infoAction
       ,fetchCommand           `commandAddAction` fetchAction
       ,freezeCommand          `commandAddAction` freezeAction
+      ,genBoundsCommand       `commandAddAction` genBoundsAction
       ,getCommand             `commandAddAction` getAction
       ,hiddenCommand $
        unpackCommand          `commandAddAction` unpackAction
@@ -971,6 +974,24 @@ 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 $
+      genBounds verbosity
+            (configPackageDB' configFlags)
+            (globalRepos globalFlags')
+            comp platform conf
+            mSandboxPkgInfo
+            globalFlags' freezeFlags
+
 uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO ()
 uploadAction uploadFlags extraArgs globalFlags = do
   let verbosity = fromFlag (uploadVerbosity uploadFlags)

cabal-install/cabal-install.cabal

@@ -83,6 +83,7 @@ executable cabal
         Distribution.Client.Fetch
         Distribution.Client.FetchUtils
         Distribution.Client.Freeze
+        Distribution.Client.GenBounds
         Distribution.Client.Get
         Distribution.Client.GZipUtils
         Distribution.Client.Haddock