Skip to content

Commit b02f6bb

Browse files
erikderikd
committed
Implementation of v2-outdated command
When the `Outdated.hs` module gets dropped, some parts of that module that are used in this one, should be moved to this module.
1 parent 37bbefc commit b02f6bb

File tree

5 files changed

+242
-14
lines changed

5 files changed

+242
-14
lines changed

‎cabal-install/cabal-install.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -90,6 +90,7 @@ library
9090
Distribution.Client.CmdInstall.ClientInstallTargetSelector
9191
Distribution.Client.CmdLegacy
9292
Distribution.Client.CmdListBin
93+
Distribution.Client.CmdOutdated
9394
Distribution.Client.CmdRepl
9495
Distribution.Client.CmdRun
9596
Distribution.Client.CmdSdist

‎cabal-install/src/Distribution/Client/CmdOutdated.hs‎

Lines changed: 216 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,216 @@
1+
{-# LANGUAGE MultiWayIf #-}
2+
{-# LANGUAGE NamedFieldPuns #-}
3+
{-# LANGUAGE RankNTypes #-}
4+
5+
-- | cabal-install CLI command: outdated
6+
module Distribution.Client.CmdOutdated
7+
( outdatedCommand
8+
, outdatedAction
9+
) where
10+
11+
import qualified Data.Set as Set
12+
13+
import Distribution.Client.Compat.Prelude
14+
15+
import Distribution.Client.Config
16+
( SavedConfig
17+
( savedGlobalFlags
18+
)
19+
)
20+
import Distribution.Client.Errors (CabalInstallException (OutdatedAction))
21+
import qualified Distribution.Client.IndexUtils as IndexUtils
22+
import Distribution.Client.NixStyleOptions
23+
( NixStyleFlags (..)
24+
, defaultNixStyleFlags
25+
, nixStyleOptions
26+
)
27+
import Distribution.Client.Outdated
28+
( IgnoreMajorVersionBumps (..)
29+
, ListOutdatedSettings (..)
30+
, OutdatedFlags (..)
31+
)
32+
import qualified Distribution.Client.Outdated as V1Outdated
33+
import Distribution.Client.ProjectConfig
34+
( ProjectConfig (..)
35+
, commandLineFlagsToProjectConfig
36+
)
37+
import Distribution.Client.ProjectFlags
38+
( ProjectFlags (..)
39+
)
40+
import Distribution.Client.ProjectOrchestration
41+
( CurrentCommand (..)
42+
, ProjectBaseContext (..)
43+
, establishProjectBaseContext
44+
)
45+
import Distribution.Client.Sandbox
46+
( loadConfigOrSandboxConfig
47+
)
48+
import Distribution.Client.Setup
49+
( GlobalFlags (..)
50+
, configCompilerAux'
51+
, withRepoContext
52+
)
53+
import Distribution.Client.Types.PackageLocation
54+
( UnresolvedPkgLoc
55+
)
56+
import Distribution.Client.Types.PackageSpecifier
57+
( PackageSpecifier (..)
58+
)
59+
import Distribution.Simple.Command
60+
( CommandUI (..)
61+
, usageAlternatives
62+
)
63+
import Distribution.Simple.Flag
64+
( flagToMaybe
65+
, fromFlagOrDefault
66+
)
67+
import Distribution.Simple.Utils
68+
( debug
69+
, dieWithException
70+
, wrapText
71+
)
72+
import Distribution.Solver.Types.SourcePackage
73+
( SourcePackage (..)
74+
)
75+
import Distribution.Types.CondTree
76+
( CondTree (..)
77+
, ignoreConditions
78+
)
79+
import Distribution.Types.Dependency (Dependency (..))
80+
import Distribution.Types.GenericPackageDescription
81+
( GenericPackageDescription (..)
82+
)
83+
import Distribution.Types.PackageName
84+
( PackageName
85+
)
86+
import Distribution.Types.PackageVersionConstraint
87+
( PackageVersionConstraint (..)
88+
)
89+
import Distribution.Types.UnqualComponentName (UnqualComponentName)
90+
import Distribution.Verbosity
91+
( normal
92+
, silent
93+
)
94+
import Distribution.Version
95+
( simplifyVersionRange
96+
)
97+
98+
outdatedCommand :: CommandUI (NixStyleFlags OutdatedFlags)
99+
outdatedCommand =
100+
CommandUI
101+
{ commandName = "v2-outdated"
102+
, commandSynopsis = "Check for outdated dependencies."
103+
, commandUsage = usageAlternatives "v2-outdated" ["[FLAGS]", "[PACKAGES]"]
104+
, commandDefaultFlags = defaultNixStyleFlags V1Outdated.defaultOutdatedFlags
105+
, commandDescription = Just $ \_ ->
106+
wrapText $
107+
"Checks for outdated dependencies in the package description file "
108+
++ "or freeze file"
109+
, commandNotes = Nothing
110+
, commandOptions = nixStyleOptions V1Outdated.outdatedOptions
111+
}
112+
113+
-- | To a first approximation, the @outdated@ command runs the first phase of
114+
-- the @build@ command where we bring the install plan up to date, and then
115+
-- based on the install plan we write out a @cabal.project.outdated@ config file.
116+
--
117+
-- For more details on how this works, see the module
118+
-- "Distribution.Client.ProjectOrchestration"
119+
outdatedAction :: NixStyleFlags OutdatedFlags -> [String] -> GlobalFlags -> IO ()
120+
outdatedAction flags _extraArgs globalFlags = do
121+
let mprojectDir = flagToMaybe . flagProjectDir $ projectFlags flags
122+
mprojectFile = flagToMaybe . flagProjectFile $ projectFlags flags
123+
124+
config <- loadConfigOrSandboxConfig verbosity globalFlags
125+
let globalFlags' = savedGlobalFlags config `mappend` globalFlags
126+
127+
(comp, platform, _progdb) <- configCompilerAux' $ configFlags flags
128+
129+
withRepoContext verbosity globalFlags' $ \repoContext -> do
130+
when (not v2FreezeFile && (isJust mprojectDir || isJust mprojectFile)) $
131+
dieWithException verbosity OutdatedAction
132+
133+
sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext
134+
prjBaseCtxt <- establishProjectBaseContext verbosity cliConfig OtherCommand
135+
pkgVerConstraints <-
136+
if | v1FreezeFile -> V1Outdated.depsFromFreezeFile verbosity
137+
| v2FreezeFile ->
138+
V1Outdated.depsFromNewFreezeFile verbosity globalFlags comp platform mprojectDir mprojectFile
139+
| otherwise -> pure $ extractPackageVersionConstraints (localPackages prjBaseCtxt)
140+
141+
debug verbosity $
142+
"Dependencies loaded: " ++ intercalate ", " (map prettyShow pkgVerConstraints)
143+
144+
let outdatedDeps = V1Outdated.listOutdated pkgVerConstraints sourcePkgDb (ListOutdatedSettings ignorePred minorPred)
145+
146+
when (not quiet) $
147+
V1Outdated.showResult verbosity outdatedDeps simpleOutput
148+
if exitCode && (not . null $ outdatedDeps)
149+
then exitFailure
150+
else pure ()
151+
where
152+
cliConfig :: ProjectConfig
153+
cliConfig =
154+
commandLineFlagsToProjectConfig
155+
globalFlags
156+
flags
157+
mempty -- ClientInstallFlags, not needed here
158+
159+
outdatedFlags :: OutdatedFlags
160+
outdatedFlags = extraFlags flags
161+
162+
v1FreezeFile, v2FreezeFile, simpleOutput, exitCode, quiet :: Bool
163+
v1FreezeFile = fromFlagOrDefault False $ outdatedFreezeFile outdatedFlags
164+
v2FreezeFile = fromFlagOrDefault False $ outdatedNewFreezeFile outdatedFlags
165+
simpleOutput = fromFlagOrDefault False $ outdatedSimpleOutput outdatedFlags
166+
exitCode = fromFlagOrDefault quiet $ outdatedExitCode outdatedFlags
167+
quiet = fromFlagOrDefault False $ outdatedQuiet outdatedFlags
168+
169+
ignorePred :: PackageName -> Bool
170+
ignorePred =
171+
let ignoreSet = Set.fromList $ outdatedIgnore outdatedFlags
172+
in \pkgname -> pkgname `Set.member` ignoreSet
173+
174+
minorPred :: PackageName -> Bool
175+
minorPred =
176+
case outdatedMinor outdatedFlags of
177+
Nothing -> const False
178+
Just IgnoreMajorVersionBumpsNone -> const False
179+
Just IgnoreMajorVersionBumpsAll -> const True
180+
Just (IgnoreMajorVersionBumpsSome pkgs) ->
181+
let minorSet = Set.fromList pkgs
182+
in \pkgname -> pkgname `Set.member` minorSet
183+
184+
verbosity :: Verbosity
185+
verbosity =
186+
if quiet
187+
then silent
188+
else fromFlagOrDefault normal (outdatedVerbosity outdatedFlags)
189+
190+
extractPackageVersionConstraints :: [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] -> [PackageVersionConstraint]
191+
extractPackageVersionConstraints =
192+
map toPackageVersionConstraint . concatMap genericPackageDependencies . mapMaybe getGenericPackageDescription
193+
where
194+
getGenericPackageDescription :: PackageSpecifier (SourcePackage UnresolvedPkgLoc) -> Maybe GenericPackageDescription
195+
getGenericPackageDescription ps =
196+
case ps of
197+
NamedPackage{} -> Nothing
198+
SpecificSourcePackage x -> Just $ srcpkgDescription x
199+
200+
toPackageVersionConstraint :: Dependency -> PackageVersionConstraint
201+
toPackageVersionConstraint (Dependency name versionRange _) =
202+
PackageVersionConstraint name (simplifyVersionRange versionRange)
203+
204+
genericPackageDependencies :: GenericPackageDescription -> [Dependency]
205+
genericPackageDependencies gpd =
206+
concat
207+
[ maybe [] (snd . ignoreConditions) $ condLibrary gpd
208+
, concatMap extract $ condSubLibraries gpd
209+
, concatMap extract $ condForeignLibs gpd
210+
, concatMap extract $ condExecutables gpd
211+
, concatMap extract $ condTestSuites gpd
212+
, concatMap extract $ condBenchmarks gpd
213+
]
214+
where
215+
extract :: forall a confVar. Semigroup a => (UnqualComponentName, CondTree confVar [Dependency] a) -> [Dependency]
216+
extract = snd . ignoreConditions . snd

‎cabal-install/src/Distribution/Client/Main.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -127,6 +127,7 @@ import qualified Distribution.Client.CmdHaddockProject as CmdHaddockProject
127127
import qualified Distribution.Client.CmdInstall as CmdInstall
128128
import Distribution.Client.CmdLegacy
129129
import qualified Distribution.Client.CmdListBin as CmdListBin
130+
import qualified Distribution.Client.CmdOutdated as CmdOutdated
130131
import qualified Distribution.Client.CmdRepl as CmdRepl
131132
import qualified Distribution.Client.CmdRun as CmdRun
132133
import qualified Distribution.Client.CmdSdist as CmdSdist
@@ -416,6 +417,7 @@ mainWorker args = do
416417
, newCmd CmdBench.benchCommand CmdBench.benchAction
417418
, newCmd CmdExec.execCommand CmdExec.execAction
418419
, newCmd CmdClean.cleanCommand CmdClean.cleanAction
420+
, newCmd CmdOutdated.outdatedCommand CmdOutdated.outdatedAction
419421
, newCmd CmdSdist.sdistCommand CmdSdist.sdistAction
420422
, legacyCmd configureExCommand configureAction
421423
, legacyCmd buildCommand buildAction

‎cabal-install/src/Distribution/Client/Outdated.hs‎

Lines changed: 19 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -14,10 +14,17 @@
1414
-- Implementation of the 'outdated' command. Checks for outdated
1515
-- dependencies in the package description file or freeze file.
1616
module Distribution.Client.Outdated
17-
( outdatedCommand
18-
, outdatedAction
17+
( IgnoreMajorVersionBumps (..)
1918
, ListOutdatedSettings (..)
19+
, OutdatedFlags (..)
20+
, defaultOutdatedFlags
21+
, depsFromFreezeFile
22+
, depsFromNewFreezeFile
23+
, outdatedAction
24+
, outdatedCommand
25+
, outdatedOptions
2026
, listOutdated
27+
, showResult
2128
)
2229
where
2330

@@ -164,7 +171,7 @@ import System.Directory
164171
outdatedCommand :: CommandUI (ProjectFlags, OutdatedFlags)
165172
outdatedCommand =
166173
CommandUI
167-
{ commandName = "outdated"
174+
{ commandName = "v1-outdated"
168175
, commandSynopsis = "Check for outdated dependencies."
169176
, commandDescription = Just $ \_ ->
170177
wrapText $
@@ -325,15 +332,8 @@ outdatedAction (ProjectFlags{flagProjectDir, flagProjectFile}, OutdatedFlags{..}
325332
then depsFromFreezeFile verbosity
326333
else
327334
if newFreezeFile
328-
then do
329-
httpTransport <-
330-
configureTransport
331-
verbosity
332-
(fromNubList . globalProgPathExtra $ globalFlags)
333-
(flagToMaybe . globalHttpTransport $ globalFlags)
334-
depsFromNewFreezeFile verbosity httpTransport comp platform mprojectDir mprojectFile
335-
else do
336-
depsFromPkgDesc verbosity comp platform
335+
then depsFromNewFreezeFile verbosity globalFlags comp platform mprojectDir mprojectFile
336+
else depsFromPkgDesc verbosity comp platform
337337
debug verbosity $
338338
"Dependencies loaded: "
339339
++ intercalate ", " (map prettyShow deps)
@@ -404,8 +404,13 @@ depsFromFreezeFile verbosity = do
404404
return deps
405405

406406
-- | Read the list of dependencies from the new-style freeze file.
407-
depsFromNewFreezeFile :: Verbosity -> HttpTransport -> Compiler -> Platform -> Maybe FilePath -> Maybe FilePath -> IO [PackageVersionConstraint]
408-
depsFromNewFreezeFile verbosity httpTransport compiler (Platform arch os) mprojectDir mprojectFile = do
407+
depsFromNewFreezeFile :: Verbosity -> GlobalFlags -> Compiler -> Platform -> Maybe FilePath -> Maybe FilePath -> IO [PackageVersionConstraint]
408+
depsFromNewFreezeFile verbosity globalFlags compiler (Platform arch os) mprojectDir mprojectFile = do
409+
httpTransport <-
410+
configureTransport
411+
verbosity
412+
(fromNubList . globalProgPathExtra $ globalFlags)
413+
(flagToMaybe . globalHttpTransport $ globalFlags)
409414
projectRoot <-
410415
either throwIO return
411416
=<< findProjectRoot verbosity mprojectDir mprojectFile

‎changelog.d/pr-9373‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
synopsis: Implpement v2-outdated command
2+
packages: cabal-install
3+
prs: #9373
4+
issues:

0 commit comments

Comments
 (0)