Skip to content

Commit 191253b

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 ce23a63 commit 191253b

File tree

5 files changed

+351
-14
lines changed

5 files changed

+351
-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: 325 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,325 @@
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+
import Distribution.Client.Config
15+
( SavedConfig
16+
( savedGlobalFlags
17+
)
18+
)
19+
import Distribution.Client.Errors (CabalInstallException (OutdatedAction))
20+
import qualified Distribution.Client.IndexUtils as IndexUtils
21+
import Distribution.Client.NixStyleOptions
22+
( NixStyleFlags (..)
23+
, defaultNixStyleFlags
24+
, nixStyleOptions
25+
)
26+
import Distribution.Client.Outdated
27+
( IgnoreMajorVersionBumps (..)
28+
, ListOutdatedSettings (..)
29+
)
30+
import qualified Distribution.Client.Outdated as V1Outdated
31+
import Distribution.Client.ProjectConfig
32+
( ProjectConfig (..)
33+
, commandLineFlagsToProjectConfig
34+
)
35+
import Distribution.Client.ProjectFlags
36+
( ProjectFlags (..)
37+
)
38+
import Distribution.Client.ProjectOrchestration
39+
( CurrentCommand (..)
40+
, ProjectBaseContext (..)
41+
, establishProjectBaseContext
42+
)
43+
import Distribution.Client.Sandbox
44+
( loadConfigOrSandboxConfig
45+
)
46+
import Distribution.Client.Setup
47+
( ConfigFlags (..)
48+
, GlobalFlags (..)
49+
, configCompilerAux'
50+
, withRepoContext
51+
)
52+
import Distribution.Client.Types.PackageLocation
53+
( UnresolvedPkgLoc
54+
)
55+
import Distribution.Client.Types.PackageSpecifier
56+
( PackageSpecifier (..)
57+
)
58+
import qualified Distribution.Compat.CharParsing as P
59+
import Distribution.ReadE
60+
( parsecToReadE
61+
)
62+
import Distribution.Simple.Command
63+
( CommandUI (..)
64+
, OptionField
65+
, ShowOrParseArgs
66+
, optArg
67+
, option
68+
, reqArg
69+
, usageAlternatives
70+
)
71+
import Distribution.Simple.Flag
72+
( Flag (..)
73+
, flagToMaybe
74+
, fromFlagOrDefault
75+
)
76+
import Distribution.Simple.Setup
77+
( trueArg
78+
)
79+
import Distribution.Simple.Utils
80+
( debug
81+
, dieWithException
82+
, wrapText
83+
)
84+
import Distribution.Solver.Types.SourcePackage
85+
( SourcePackage (..)
86+
)
87+
import Distribution.Types.CondTree
88+
( CondTree (..)
89+
, ignoreConditions
90+
)
91+
import Distribution.Types.Dependency (Dependency (..))
92+
import Distribution.Types.GenericPackageDescription
93+
( GenericPackageDescription (..)
94+
)
95+
import Distribution.Types.PackageName
96+
( PackageName
97+
)
98+
import Distribution.Types.PackageVersionConstraint
99+
( PackageVersionConstraint (..)
100+
)
101+
import Distribution.Types.UnqualComponentName (UnqualComponentName)
102+
import Distribution.Verbosity
103+
( normal
104+
, silent
105+
)
106+
import Distribution.Version
107+
( simplifyVersionRange
108+
)
109+
110+
outdatedCommand :: CommandUI (NixStyleFlags OutdatedFlags)
111+
outdatedCommand =
112+
CommandUI
113+
{ commandName = "v2-outdated"
114+
, commandSynopsis = "Check for outdated dependencies."
115+
, commandUsage = usageAlternatives "v2-outdated" ["[FLAGS]", "[PACKAGES]"]
116+
, commandDefaultFlags = defaultNixStyleFlags defaultOutdatedFlags
117+
, commandDescription = Just $ \_ ->
118+
wrapText $
119+
"Checks for outdated dependencies in the package description file "
120+
++ "or freeze file"
121+
, commandNotes = Nothing
122+
, commandOptions = nixStyleOptions outdatedOptions
123+
}
124+
125+
-- | To a first approximation, the @outdated@ command runs the first phase of
126+
-- the @build@ command where we bring the install plan up to date, and then
127+
-- based on the install plan we write out a @cabal.project.outdated@ config file.
128+
--
129+
-- For more details on how this works, see the module
130+
-- "Distribution.Client.ProjectOrchestration"
131+
outdatedAction :: NixStyleFlags OutdatedFlags -> [String] -> GlobalFlags -> IO ()
132+
outdatedAction flags _extraArgs globalFlags = do
133+
let mprojectDir = flagToMaybe . flagProjectDir $ projectFlags flags
134+
mprojectFile = flagToMaybe . flagProjectFile $ projectFlags flags
135+
136+
config <- loadConfigOrSandboxConfig verbosity globalFlags
137+
let globalFlags' = savedGlobalFlags config `mappend` globalFlags
138+
139+
(comp, platform, _progdb) <- configCompilerAux' $ configFlags flags
140+
141+
withRepoContext verbosity globalFlags' $ \repoContext -> do
142+
when (not v2FreezeFile && (isJust mprojectDir || isJust mprojectFile)) $
143+
dieWithException verbosity OutdatedAction
144+
145+
sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext
146+
prjBaseCtxt <- establishProjectBaseContext verbosity cliConfig OtherCommand
147+
pkgVerConstraints <-
148+
if
149+
| v1FreezeFile -> V1Outdated.depsFromFreezeFile verbosity
150+
| v2FreezeFile ->
151+
V1Outdated.depsFromNewFreezeFile verbosity globalFlags comp platform mprojectDir mprojectFile
152+
| otherwise -> pure $ extractPackageVersionConstraints (localPackages prjBaseCtxt)
153+
154+
debug verbosity $
155+
"Dependencies loaded: " ++ intercalate ", " (map prettyShow pkgVerConstraints)
156+
157+
let outdatedDeps = V1Outdated.listOutdated pkgVerConstraints sourcePkgDb (ListOutdatedSettings ignorePred minorPred)
158+
159+
when (not quiet) $
160+
V1Outdated.showResult verbosity outdatedDeps simpleOutput
161+
if exitCode && (not . null $ outdatedDeps)
162+
then exitFailure
163+
else pure ()
164+
where
165+
cliConfig :: ProjectConfig
166+
cliConfig =
167+
commandLineFlagsToProjectConfig
168+
globalFlags
169+
flags
170+
mempty -- ClientInstallFlags, not needed here
171+
outdatedFlags :: OutdatedFlags
172+
outdatedFlags = extraFlags flags
173+
174+
v1FreezeFile, v2FreezeFile, simpleOutput, exitCode, quiet :: Bool
175+
v1FreezeFile = fromFlagOrDefault False $ outdatedFreezeFile outdatedFlags
176+
v2FreezeFile = fromFlagOrDefault False $ outdatedNewFreezeFile outdatedFlags
177+
simpleOutput = fromFlagOrDefault False $ outdatedSimpleOutput outdatedFlags
178+
exitCode = fromFlagOrDefault quiet $ outdatedExitCode outdatedFlags
179+
quiet = fromFlagOrDefault False $ outdatedQuiet outdatedFlags
180+
181+
ignorePred :: PackageName -> Bool
182+
ignorePred =
183+
let ignoreSet = Set.fromList $ outdatedIgnore outdatedFlags
184+
in \pkgname -> pkgname `Set.member` ignoreSet
185+
186+
minorPred :: PackageName -> Bool
187+
minorPred =
188+
case outdatedMinor outdatedFlags of
189+
Nothing -> const False
190+
Just IgnoreMajorVersionBumpsNone -> const False
191+
Just IgnoreMajorVersionBumpsAll -> const True
192+
Just (IgnoreMajorVersionBumpsSome pkgs) ->
193+
let minorSet = Set.fromList pkgs
194+
in \pkgname -> pkgname `Set.member` minorSet
195+
196+
verbosity :: Verbosity
197+
verbosity =
198+
if quiet
199+
then silent
200+
else fromFlagOrDefault normal (configVerbosity $ configFlags flags)
201+
202+
data OutdatedFlags = OutdatedFlags
203+
{ outdatedFreezeFile :: Flag Bool
204+
, outdatedNewFreezeFile :: Flag Bool
205+
, outdatedSimpleOutput :: Flag Bool
206+
, outdatedExitCode :: Flag Bool
207+
, outdatedQuiet :: Flag Bool
208+
, outdatedIgnore :: [PackageName]
209+
, outdatedMinor :: Maybe IgnoreMajorVersionBumps
210+
}
211+
212+
defaultOutdatedFlags :: OutdatedFlags
213+
defaultOutdatedFlags =
214+
OutdatedFlags
215+
{ outdatedFreezeFile = mempty
216+
, outdatedNewFreezeFile = mempty
217+
, outdatedSimpleOutput = mempty
218+
, outdatedExitCode = mempty
219+
, outdatedQuiet = mempty
220+
, outdatedIgnore = mempty
221+
, outdatedMinor = mempty
222+
}
223+
224+
extractPackageVersionConstraints :: [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] -> [PackageVersionConstraint]
225+
extractPackageVersionConstraints =
226+
map toPackageVersionConstraint . concatMap genericPackageDependencies . mapMaybe getGenericPackageDescription
227+
where
228+
getGenericPackageDescription :: PackageSpecifier (SourcePackage UnresolvedPkgLoc) -> Maybe GenericPackageDescription
229+
getGenericPackageDescription ps =
230+
case ps of
231+
NamedPackage{} -> Nothing
232+
SpecificSourcePackage x -> Just $ srcpkgDescription x
233+
234+
toPackageVersionConstraint :: Dependency -> PackageVersionConstraint
235+
toPackageVersionConstraint (Dependency name versionRange _) =
236+
PackageVersionConstraint name (simplifyVersionRange versionRange)
237+
238+
genericPackageDependencies :: GenericPackageDescription -> [Dependency]
239+
genericPackageDependencies gpd =
240+
concat
241+
[ maybe [] (snd . ignoreConditions) $ condLibrary gpd
242+
, concatMap extract $ condSubLibraries gpd
243+
, concatMap extract $ condForeignLibs gpd
244+
, concatMap extract $ condExecutables gpd
245+
, concatMap extract $ condTestSuites gpd
246+
, concatMap extract $ condBenchmarks gpd
247+
]
248+
where
249+
extract :: forall a confVar. Semigroup a => (UnqualComponentName, CondTree confVar [Dependency] a) -> [Dependency]
250+
extract = snd . ignoreConditions . snd
251+
252+
outdatedOptions :: ShowOrParseArgs -> [OptionField OutdatedFlags]
253+
outdatedOptions _showOrParseArgs =
254+
[ option
255+
[]
256+
["freeze-file", "v1-freeze-file"]
257+
"Act on the freeze file"
258+
outdatedFreezeFile
259+
(\v flags -> flags{outdatedFreezeFile = v})
260+
trueArg
261+
, option
262+
[]
263+
["v2-freeze-file", "new-freeze-file"]
264+
"Act on the new-style freeze file (default: cabal.project.freeze)"
265+
outdatedNewFreezeFile
266+
(\v flags -> flags{outdatedNewFreezeFile = v})
267+
trueArg
268+
, option
269+
[]
270+
["simple-output"]
271+
"Only print names of outdated dependencies, one per line"
272+
outdatedSimpleOutput
273+
(\v flags -> flags{outdatedSimpleOutput = v})
274+
trueArg
275+
, option
276+
[]
277+
["exit-code"]
278+
"Exit with non-zero when there are outdated dependencies"
279+
outdatedExitCode
280+
(\v flags -> flags{outdatedExitCode = v})
281+
trueArg
282+
, option
283+
['q']
284+
["quiet"]
285+
"Don't print any output. Implies '--exit-code' and '-v0'"
286+
outdatedQuiet
287+
(\v flags -> flags{outdatedQuiet = v})
288+
trueArg
289+
, option
290+
[]
291+
["ignore"]
292+
"Packages to ignore"
293+
outdatedIgnore
294+
(\v flags -> flags{outdatedIgnore = v})
295+
(reqArg "PKGS" pkgNameListParser (map prettyShow))
296+
, option
297+
[]
298+
["minor"]
299+
"Ignore major version bumps for these packages"
300+
outdatedMinor
301+
(\v flags -> flags{outdatedMinor = v})
302+
( optArg
303+
"PKGS"
304+
ignoreMajorVersionBumpsParser
305+
("", Just IgnoreMajorVersionBumpsAll)
306+
ignoreMajorVersionBumpsPrinter
307+
)
308+
]
309+
where
310+
ignoreMajorVersionBumpsPrinter
311+
:: Maybe IgnoreMajorVersionBumps
312+
-> [Maybe String]
313+
ignoreMajorVersionBumpsPrinter Nothing = []
314+
ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone) = []
315+
ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing]
316+
ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) =
317+
map (Just . prettyShow) pkgs
318+
319+
ignoreMajorVersionBumpsParser =
320+
(Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser
321+
322+
pkgNameListParser =
323+
parsecToReadE
324+
("Couldn't parse the list of package names: " ++)
325+
(fmap toList (P.sepByNonEmpty parsec (P.char ',')))

‎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
@@ -419,6 +420,7 @@ mainWorker args = do
419420
, newCmd CmdBench.benchCommand CmdBench.benchAction
420421
, newCmd CmdExec.execCommand CmdExec.execAction
421422
, newCmd CmdClean.cleanCommand CmdClean.cleanAction
423+
, newCmd CmdOutdated.outdatedCommand CmdOutdated.outdatedAction
422424
, newCmd CmdSdist.sdistCommand CmdSdist.sdistAction
423425
, legacyCmd configureExCommand configureAction
424426
, legacyCmd buildCommand buildAction

0 commit comments

Comments
 (0)