Fix command line parsing

Author: erikd

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

@@ -11,7 +11,6 @@ module Distribution.Client.CmdOutdated
 import qualified Data.Set as Set
 
 import Distribution.Client.Compat.Prelude
-
 import Distribution.Client.Config
   ( SavedConfig
       ( savedGlobalFlags
@@ -27,7 +26,6 @@ import Distribution.Client.NixStyleOptions
 import Distribution.Client.Outdated
   ( IgnoreMajorVersionBumps (..)
   , ListOutdatedSettings (..)
-  , OutdatedFlags (..)
   )
 import qualified Distribution.Client.Outdated as V1Outdated
 import Distribution.Client.ProjectConfig
@@ -46,7 +44,8 @@ import Distribution.Client.Sandbox
   ( loadConfigOrSandboxConfig
   )
 import Distribution.Client.Setup
-  ( GlobalFlags (..)
+  ( ConfigFlags (..)
+  , GlobalFlags (..)
   , configCompilerAux'
   , withRepoContext
   )
@@ -56,14 +55,27 @@ import Distribution.Client.Types.PackageLocation
 import Distribution.Client.Types.PackageSpecifier
   ( PackageSpecifier (..)
   )
+import qualified Distribution.Compat.CharParsing as P
+import Distribution.ReadE
+  ( parsecToReadE
+  )
 import Distribution.Simple.Command
   ( CommandUI (..)
+  , OptionField
+  , ShowOrParseArgs
+  , optArg
+  , option
+  , reqArg
   , usageAlternatives
   )
 import Distribution.Simple.Flag
-  ( flagToMaybe
+  ( Flag (..)
+  , flagToMaybe
   , fromFlagOrDefault
   )
+import Distribution.Simple.Setup
+  ( trueArg
+  )
 import Distribution.Simple.Utils
   ( debug
   , dieWithException
@@ -101,13 +113,13 @@ outdatedCommand =
     { commandName = "v2-outdated"
     , commandSynopsis = "Check for outdated dependencies."
     , commandUsage = usageAlternatives "v2-outdated" ["[FLAGS]", "[PACKAGES]"]
-    , commandDefaultFlags = defaultNixStyleFlags V1Outdated.defaultOutdatedFlags
+    , commandDefaultFlags = defaultNixStyleFlags defaultOutdatedFlags
     , commandDescription = Just $ \_ ->
         wrapText $
           "Checks for outdated dependencies in the package description file "
             ++ "or freeze file"
     , commandNotes = Nothing
-    , commandOptions = nixStyleOptions V1Outdated.outdatedOptions
+    , commandOptions = nixStyleOptions outdatedOptions
     }
 
 -- | To a first approximation, the @outdated@ command runs the first phase of
@@ -133,10 +145,11 @@ outdatedAction flags _extraArgs globalFlags = do
     sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext
     prjBaseCtxt <- establishProjectBaseContext verbosity cliConfig OtherCommand
     pkgVerConstraints <-
-      if | v1FreezeFile -> V1Outdated.depsFromFreezeFile verbosity
-         | v2FreezeFile ->
-            V1Outdated.depsFromNewFreezeFile verbosity globalFlags comp platform mprojectDir mprojectFile
-         | otherwise -> pure $ extractPackageVersionConstraints (localPackages prjBaseCtxt)
+      if
+          | v1FreezeFile -> V1Outdated.depsFromFreezeFile verbosity
+          | v2FreezeFile ->
+              V1Outdated.depsFromNewFreezeFile verbosity globalFlags comp platform mprojectDir mprojectFile
+          | otherwise -> pure $ extractPackageVersionConstraints (localPackages prjBaseCtxt)
 
     debug verbosity $
       "Dependencies loaded: " ++ intercalate ", " (map prettyShow pkgVerConstraints)
@@ -155,7 +168,6 @@ outdatedAction flags _extraArgs globalFlags = do
         globalFlags
         flags
         mempty -- ClientInstallFlags, not needed here
-
     outdatedFlags :: OutdatedFlags
     outdatedFlags = extraFlags flags
 
@@ -185,7 +197,29 @@ outdatedAction flags _extraArgs globalFlags = do
     verbosity =
       if quiet
         then silent
-        else fromFlagOrDefault normal (outdatedVerbosity outdatedFlags)
+        else fromFlagOrDefault normal (configVerbosity $ configFlags flags)
+
+data OutdatedFlags = OutdatedFlags
+  { outdatedFreezeFile :: Flag Bool
+  , outdatedNewFreezeFile :: Flag Bool
+  , outdatedSimpleOutput :: Flag Bool
+  , outdatedExitCode :: Flag Bool
+  , outdatedQuiet :: Flag Bool
+  , outdatedIgnore :: [PackageName]
+  , outdatedMinor :: Maybe IgnoreMajorVersionBumps
+  }
+
+defaultOutdatedFlags :: OutdatedFlags
+defaultOutdatedFlags =
+  OutdatedFlags
+    { outdatedFreezeFile = mempty
+    , outdatedNewFreezeFile = mempty
+    , outdatedSimpleOutput = mempty
+    , outdatedExitCode = mempty
+    , outdatedQuiet = mempty
+    , outdatedIgnore = mempty
+    , outdatedMinor = mempty
+    }
 
 extractPackageVersionConstraints :: [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] -> [PackageVersionConstraint]
 extractPackageVersionConstraints =
@@ -214,3 +248,78 @@ genericPackageDependencies gpd =
   where
     extract :: forall a confVar. Semigroup a => (UnqualComponentName, CondTree confVar [Dependency] a) -> [Dependency]
     extract = snd . ignoreConditions . snd
+
+outdatedOptions :: ShowOrParseArgs -> [OptionField OutdatedFlags]
+outdatedOptions _showOrParseArgs =
+  [ option
+      []
+      ["freeze-file", "v1-freeze-file"]
+      "Act on the freeze file"
+      outdatedFreezeFile
+      (\v flags -> flags{outdatedFreezeFile = v})
+      trueArg
+  , option
+      []
+      ["v2-freeze-file", "new-freeze-file"]
+      "Act on the new-style freeze file (default: cabal.project.freeze)"
+      outdatedNewFreezeFile
+      (\v flags -> flags{outdatedNewFreezeFile = v})
+      trueArg
+  , option
+      []
+      ["simple-output"]
+      "Only print names of outdated dependencies, one per line"
+      outdatedSimpleOutput
+      (\v flags -> flags{outdatedSimpleOutput = v})
+      trueArg
+  , option
+      []
+      ["exit-code"]
+      "Exit with non-zero when there are outdated dependencies"
+      outdatedExitCode
+      (\v flags -> flags{outdatedExitCode = v})
+      trueArg
+  , option
+      ['q']
+      ["quiet"]
+      "Don't print any output. Implies '--exit-code' and '-v0'"
+      outdatedQuiet
+      (\v flags -> flags{outdatedQuiet = v})
+      trueArg
+  , option
+      []
+      ["ignore"]
+      "Packages to ignore"
+      outdatedIgnore
+      (\v flags -> flags{outdatedIgnore = v})
+      (reqArg "PKGS" pkgNameListParser (map prettyShow))
+  , option
+      []
+      ["minor"]
+      "Ignore major version bumps for these packages"
+      outdatedMinor
+      (\v flags -> flags{outdatedMinor = v})
+      ( optArg
+          "PKGS"
+          ignoreMajorVersionBumpsParser
+          ("", Just IgnoreMajorVersionBumpsAll)
+          ignoreMajorVersionBumpsPrinter
+      )
+  ]
+  where
+    ignoreMajorVersionBumpsPrinter
+      :: Maybe IgnoreMajorVersionBumps
+      -> [Maybe String]
+    ignoreMajorVersionBumpsPrinter Nothing = []
+    ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone) = []
+    ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing]
+    ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) =
+      map (Just . prettyShow) pkgs
+
+    ignoreMajorVersionBumpsParser =
+      (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser
+
+    pkgNameListParser =
+      parsecToReadE
+        ("Couldn't parse the list of package names: " ++)
+        (fmap toList (P.sepByNonEmpty parsec (P.char ',')))