Commit 1e89fd84 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov Committed by Mikhail Glushenkov

New 'cabal-install' command: 'outdated'.

Fixes #2139.
parent 4a3bf67f
......@@ -2,6 +2,8 @@
{-# LANGUAGE DeriveGeneric #-}
module Distribution.Types.Dependency
( Dependency(..)
, depPkgName
, depVerRange
, thisPackageVersion
, notThisPackageVersion
, simplifyDependency
......@@ -26,6 +28,12 @@ import Text.PrettyPrint ((<+>))
data Dependency = Dependency PackageName VersionRange
deriving (Generic, Read, Show, Eq, Typeable, Data)
depPkgName :: Dependency -> PackageName
depPkgName (Dependency pn _) = pn
depVerRange :: Dependency -> VersionRange
depVerRange (Dependency _ vr) = vr
instance Binary Dependency
instance NFData Dependency where rnf = genericRnf
......
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Outdated
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- Implementation of the 'outdated' command. Checks for outdated
-- dependencies in the package description file or freeze file.
-----------------------------------------------------------------------------
module Distribution.Client.Outdated ( outdated ) where
import Prelude ()
import Distribution.Client.Config
import Distribution.Client.IndexUtils as IndexUtils
import Distribution.Client.Compat.Prelude
import Distribution.Client.Setup
import Distribution.Client.Targets
import Distribution.Client.Types
import Distribution.Solver.Types.PackageConstraint
import Distribution.Solver.Types.PackageIndex
import Distribution.Client.Sandbox.PackageEnvironment
import Distribution.Package (PackageName, packageVersion)
import Distribution.PackageDescription (buildDepends)
import Distribution.PackageDescription.Configuration (finalizePD)
import Distribution.PackageDescription.Parse
(readPackageDescription)
import Distribution.Simple.Compiler (Compiler, compilerInfo)
import Distribution.Simple.Setup (fromFlagOrDefault)
import Distribution.Simple.Utils
(die, notice, debug, tryFindPackageDesc)
import Distribution.System (Platform)
import Distribution.Text (display)
import Distribution.Types.ComponentRequestedSpec
(defaultComponentRequestedSpec)
import Distribution.Types.Dependency
(Dependency(..), depPkgName, simplifyDependency)
import Distribution.Verbosity (Verbosity)
import Distribution.Version
(Version, UpperBound(..), asVersionIntervals, majorBoundVersion)
import qualified Data.Set as S
import System.Directory (getCurrentDirectory)
import System.Exit (exitFailure)
-- | Entry point for the 'outdated' command.
outdated :: Verbosity -> OutdatedFlags -> RepoContext
-> Compiler -> Platform
-> IO ()
outdated verbosity outdatedFlags repoContext comp platform = do
sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext
let freeze = fromFlagOrDefault False (outdatedFreeze outdatedFlags)
exitCode = fromFlagOrDefault False (outdatedExitCode outdatedFlags)
ignore = S.fromList (outdatedIgnore outdatedFlags)
minor = S.fromList (outdatedMinor outdatedFlags)
pkgIndex = packageIndex sourcePkgDb
deps <- if freeze
then depsFromFreezeFile verbosity
else depsFromPkgDesc verbosity comp platform
let outdatedDeps = listOutdated deps pkgIndex ignore minor
notice verbosity ("Outdated dependencies: "
++ intercalate ", "
(map (\(d, v) -> display d
++ " (latest: " ++ display v ++ ")") outdatedDeps))
if (exitCode && (not . null $ outdatedDeps))
then exitFailure
else return ()
-- | Read the list of dependencies from the freeze file.
depsFromFreezeFile :: Verbosity -> IO [Dependency]
depsFromFreezeFile verbosity = do
cwd <- getCurrentDirectory
userConfig <- loadUserConfig verbosity cwd Nothing
let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $ userConfig
deps = mapMaybe (packageConstraintToDependency . userToPackageConstraint)
ucnstrs
debug verbosity "Reading the list of dependencies from the freeze file"
return deps
-- | Read the list of dependencies from the package description.
depsFromPkgDesc :: Verbosity -> Compiler -> Platform -> IO [Dependency]
depsFromPkgDesc verbosity comp platform = do
cwd <- getCurrentDirectory
path <- tryFindPackageDesc cwd
gpd <- readPackageDescription verbosity path
let cinfo = compilerInfo comp
epd = finalizePD [] defaultComponentRequestedSpec
(const True) platform cinfo [] gpd
case epd of
Left _ -> die "finalizePD failed"
Right (pd, _) -> do
let bd = buildDepends pd
debug verbosity
"Reading the list of dependencies from the package description"
return bd
-- | Find all outdated dependencies.
listOutdated :: [Dependency] -> PackageIndex UnresolvedSourcePackage
-> S.Set PackageName -> S.Set PackageName
-> [(Dependency, Version)]
listOutdated deps pkgIndex ignore minor =
mapMaybe isOutdated $ map simplifyDependency deps
where
isOutdated :: Dependency -> Maybe (Dependency, Version)
isOutdated dep
| depPkgName dep `S.member` ignore = Nothing
| otherwise =
let this = map packageVersion $ lookupDependency pkgIndex dep
latest = lookupLatest dep
in (\v -> (dep, v)) `fmap` isOutdated' this latest
isOutdated' :: [Version] -> [Version] -> Maybe Version
isOutdated' [] _ = Nothing
isOutdated' _ [] = Nothing
isOutdated' this latest = let this' = last this
latest' = last latest
in if this' < latest' then Just latest' else Nothing
lookupLatest :: Dependency -> [Version]
lookupLatest dep
| depPkgName dep `S.member` minor =
map packageVersion $ lookupDependency pkgIndex (relaxMinor dep)
| otherwise =
map packageVersion $ lookupPackageName pkgIndex (depPkgName dep)
relaxMinor :: Dependency -> Dependency
relaxMinor (Dependency pn vr) = (Dependency pn vr')
where
vr' = let vis = asVersionIntervals vr
(_,upper) = last vis
in case upper of
NoUpperBound -> vr
UpperBound ver _ -> majorBoundVersion ver
......@@ -33,6 +33,7 @@ module Distribution.Client.Setup
, fetchCommand, FetchFlags(..)
, freezeCommand, FreezeFlags(..)
, genBoundsCommand
, outdatedCommand, OutdatedFlags(..)
, getCommand, unpackCommand, GetFlags(..)
, checkCommand
, formatCommand
......@@ -100,7 +101,7 @@ import Distribution.Simple.InstallDirs
import Distribution.Version
( Version, mkVersion, nullVersion, anyVersion, thisVersion )
import Distribution.Package
( PackageIdentifier, packageName, packageVersion )
( PackageIdentifier, PackageName, packageName, packageVersion )
import Distribution.Types.Dependency
import Distribution.PackageDescription
( BuildType(..), RepoKind(..) )
......@@ -110,7 +111,7 @@ import Distribution.Text
import Distribution.ReadE
( ReadE(..), readP_to_E, succeedReadE )
import qualified Distribution.Compat.ReadP as Parse
( ReadP, char, munch1, pfail, (+++) )
( ReadP, char, munch1, pfail, sepBy1, (+++) )
import Distribution.ParseUtils
( readPToMaybe )
import Distribution.Verbosity
......@@ -171,6 +172,7 @@ globalCommand commands = CommandUI {
, "report"
, "freeze"
, "gen-bounds"
, "outdated"
, "haddock"
, "hscolour"
, "copy"
......@@ -222,6 +224,7 @@ globalCommand commands = CommandUI {
, par
, addCmd "freeze"
, addCmd "gen-bounds"
, addCmd "outdated"
, addCmd "haddock"
, addCmd "hscolour"
, addCmd "copy"
......@@ -829,6 +832,10 @@ freezeCommand = CommandUI {
}
-- ------------------------------------------------------------
-- * 'gen-bounds' command
-- ------------------------------------------------------------
genBoundsCommand :: CommandUI FreezeFlags
genBoundsCommand = CommandUI {
commandName = "gen-bounds",
......@@ -845,6 +852,67 @@ genBoundsCommand = CommandUI {
]
}
-- ------------------------------------------------------------
-- * 'outdated' command
-- ------------------------------------------------------------
data OutdatedFlags = OutdatedFlags {
outdatedVerbosity :: Flag Verbosity,
outdatedFreeze :: Flag Bool,
outdatedExitCode :: Flag Bool,
outdatedIgnore :: [PackageName],
outdatedMinor :: [PackageName]
}
defaultOutdatedFlags :: OutdatedFlags
defaultOutdatedFlags = OutdatedFlags {
outdatedVerbosity = toFlag normal,
outdatedFreeze = mempty,
outdatedExitCode = mempty,
outdatedIgnore = mempty,
outdatedMinor = mempty
}
outdatedCommand :: CommandUI OutdatedFlags
outdatedCommand = CommandUI {
commandName = "outdated",
commandSynopsis = "Check for outdated dependencies",
commandDescription = Just $ \_ -> wrapText $
"Checks for outdated dependencies in the package description file "
++ "or freeze file",
commandNotes = Nothing,
commandUsage = usageFlags "outdated",
commandDefaultFlags = defaultOutdatedFlags,
commandOptions = \ _ -> [
optionVerbosity outdatedVerbosity
(\v flags -> flags { outdatedVerbosity = v })
,option [] ["freeze"]
"Act on the freeze file"
outdatedFreeze (\v flags -> flags { outdatedFreeze = v })
trueArg
,option [] ["exit-code"]
"Exit with non-zero when there are outdated dependencies"
outdatedExitCode (\v flags -> flags { outdatedExitCode = v })
trueArg
,option [] ["ignore"]
"Packages to ignore"
outdatedIgnore (\v flags -> flags { outdatedIgnore = v })
(reqArg "PKGS" pkgNameListParser (map display))
,option [] ["minor"]
"Ignore major version bumps for these packages"
outdatedMinor (\v flags -> flags { outdatedMinor = v })
(reqArg "PKGS" pkgNameListParser (map display))
]
}
where
pkgNameListParser = readP_to_E
("Couldn't parse the list of package names: " ++)
(Parse.sepBy1 parse (Parse.char ','))
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------
......
......@@ -14,21 +14,24 @@ module Distribution.Solver.Types.PackageConstraint (
PackageConstraint(..),
dispPackageConstraint,
showPackageConstraint,
packageConstraintToDependency
) where
import Distribution.Package (PackageName)
import Distribution.Version (VersionRange, simplifyVersionRange)
import Distribution.Compat.Binary (Binary(..))
import Distribution.Package (PackageName)
import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment)
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackagePath
import Distribution.Types.Dependency (Dependency(..))
import Distribution.Version (VersionRange, simplifyVersionRange)
import Distribution.Client.Compat.Prelude ((<<>>))
import GHC.Generics (Generic)
import Distribution.Compat.Binary (Binary)
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackagePath
import Distribution.Text (disp, flatStyle)
import Distribution.Text (disp, flatStyle)
import GHC.Generics (Generic)
import Text.PrettyPrint ((<+>))
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ((<+>))
-- | Determines to what packages and in what contexts a
-- constraint applies.
......@@ -70,10 +73,10 @@ instance Binary PackageProperty
-- | Pretty-prints a package property.
dispPackageProperty :: PackageProperty -> Disp.Doc
dispPackageProperty (PackagePropertyVersion verrange) = disp verrange
dispPackageProperty PackagePropertyInstalled = Disp.text "installed"
dispPackageProperty PackagePropertySource = Disp.text "source"
dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags
dispPackageProperty (PackagePropertyStanzas stanzas) =
dispPackageProperty PackagePropertyInstalled = Disp.text "installed"
dispPackageProperty PackagePropertySource = Disp.text "source"
dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags
dispPackageProperty (PackagePropertyStanzas stanzas) =
Disp.hsep $ map (Disp.text . showStanza) stanzas
-- | A package constraint consists of a scope plus a property
......@@ -102,3 +105,14 @@ showPackageConstraint pc@(PackageConstraint scope prop) =
PackagePropertyFlags _ -> (Disp.text "flags" <+>)
PackagePropertyStanzas _ -> (Disp.text "stanzas" <+>)
_ -> id
-- | Lossily convert a 'PackageConstraint' to a 'Dependency'.
packageConstraintToDependency :: PackageConstraint -> Maybe Dependency
packageConstraintToDependency (PackageConstraint scope prop) = toDep prop
where
toDep (PackagePropertyVersion vr) =
Just $ Dependency (scopeToPackageName scope) vr
toDep (PackagePropertyInstalled) = Nothing
toDep (PackagePropertySource) = Nothing
toDep (PackagePropertyFlags _) = Nothing
toDep (PackagePropertyStanzas _) = Nothing
......@@ -28,6 +28,7 @@ import Distribution.Client.Setup
, FetchFlags(..), fetchCommand
, FreezeFlags(..), freezeCommand
, genBoundsCommand
, OutdatedFlags(..), outdatedCommand
, GetFlags(..), getCommand, unpackCommand
, checkCommand
, formatCommand
......@@ -86,6 +87,7 @@ import Distribution.Client.Exec (exec)
import Distribution.Client.Fetch (fetch)
import Distribution.Client.Freeze (freeze)
import Distribution.Client.GenBounds (genBounds)
import Distribution.Client.Outdated (outdated)
import Distribution.Client.Check as Check (check)
--import Distribution.Client.Clean (clean)
import qualified Distribution.Client.Upload as Upload
......@@ -266,6 +268,7 @@ mainWorker args = topHandler $
, regularCmd userConfigCommand userConfigAction
, regularCmd cleanCommand cleanAction
, regularCmd genBoundsCommand genBoundsAction
, regularCmd outdatedCommand outdatedAction
, wrapperCmd copyCommand copyVerbosity copyDistPref
, wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref
, wrapperCmd registerCommand regVerbosity regDistPref
......@@ -892,6 +895,17 @@ genBoundsAction freezeFlags _extraArgs globalFlags = do
mSandboxPkgInfo
globalFlags' freezeFlags
outdatedAction :: OutdatedFlags -> [String] -> GlobalFlags -> IO ()
outdatedAction outdatedFlags _extraArgs globalFlags = do
let verbosity = fromFlag (outdatedVerbosity outdatedFlags)
(_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags
let configFlags = savedConfigureFlags config
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, platform, _progdb) <- configCompilerAux' configFlags
withRepoContext verbosity globalFlags' $ \repoContext ->
outdated verbosity outdatedFlags repoContext
comp platform
uploadAction :: UploadFlags -> [String] -> Action
uploadAction uploadFlags extraArgs globalFlags = do
config <- loadConfig verbosity (globalConfigFile globalFlags)
......
......@@ -250,6 +250,7 @@ executable cabal
Distribution.Client.List
Distribution.Client.Manpage
Distribution.Client.Nix
Distribution.Client.Outdated
Distribution.Client.PackageHash
Distribution.Client.PackageUtils
Distribution.Client.ParseUtils
......
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