Refactor clean and sdist to use NixStyleFlags

- Consistently use `NixStyleFlags` for all v2- commands. - This will simplify future changes such as #7999. - Mostly keep option parsers unchanged with the following exceptions: - Reorder options to by consistent with nixStyleOptions ConfigFlags > ProjectFlags > ExtraFlags - Add --ignore-project to clean, which currently does nothing, but will be useful for future clean improvements.
haskell · Feb 26, 2022 · 5e8deb0 · 5e8deb0
1 parent 9a104a9
commit 5e8deb0
Show file tree

Hide file tree

Showing 3 changed files with 65 additions and 77 deletions.
diff --git a/cabal-install/src/Distribution/Client/CmdClean.hs b/cabal-install/src/Distribution/Client/CmdClean.hs
@@ -6,19 +6,22 @@ import Distribution.Client.Compat.Prelude
 
 import Distribution.Client.DistDirLayout
     ( DistDirLayout(..), defaultDistDirLayout )
+import Distribution.Client.NixStyleOptions
+    ( NixStyleFlags (..), defaultNixStyleFlags )
 import Distribution.Client.ProjectConfig
     ( findProjectRoot )
+import Distribution.Client.ProjectFlags
+    ( ProjectFlags(..), projectFlagsOptions )
 import Distribution.Client.ScriptUtils
     ( getScriptCacheDirectoryRoot )
 import Distribution.Client.Setup
-    ( GlobalFlags )
-import Distribution.ReadE ( succeedReadE )
+    ( ConfigFlags(..), GlobalFlags, liftOptions )
 import Distribution.Simple.Setup
-    ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe
+    ( Flag(..), toFlag, fromFlagOrDefault, flagToMaybe
     , optionDistPref, optionVerbosity, falseArg
     )
 import Distribution.Simple.Command
-    ( CommandUI(..), option, reqArg )
+    ( CommandUI(..), option )
 import Distribution.Simple.Utils
     ( info, die', wrapText, handleDoesNotExist )
 import Distribution.Verbosity
@@ -36,21 +39,15 @@ import System.FilePath
     ( (</>) )
 
 data CleanFlags = CleanFlags
-    { cleanSaveConfig  :: Flag Bool
-    , cleanVerbosity   :: Flag Verbosity
-    , cleanDistDir     :: Flag FilePath
-    , cleanProjectFile :: Flag FilePath
+    { cleanSaveConfig :: Flag Bool
     } deriving (Eq)
 
 defaultCleanFlags :: CleanFlags
 defaultCleanFlags = CleanFlags
-    { cleanSaveConfig  = toFlag False
-    , cleanVerbosity   = toFlag normal
-    , cleanDistDir     = NoFlag
-    , cleanProjectFile = mempty
+    { cleanSaveConfig = toFlag False
     }
 
-cleanCommand :: CommandUI CleanFlags
+cleanCommand :: CommandUI (NixStyleFlags CleanFlags)
 cleanCommand = CommandUI
     { commandName         = "v2-clean"
     , commandSynopsis     = "Clean the package store and remove temporary files."
@@ -61,31 +58,33 @@ cleanCommand = CommandUI
      ++ "(.hi, .o, preprocessed sources, etc.) and also empties out the "
      ++ "local caches (by default).\n\n"
     , commandNotes        = Nothing
-    , commandDefaultFlags = defaultCleanFlags
+    , commandDefaultFlags = defaultNixStyleFlags defaultCleanFlags
     , commandOptions      = \showOrParseArgs ->
         [ optionVerbosity
-            cleanVerbosity (\v flags -> flags { cleanVerbosity = v })
+            (configVerbosity . configFlags)
+            (\v flags -> flags { configFlags = (configFlags flags) { configVerbosity = v } })
         , optionDistPref
-            cleanDistDir (\dd flags -> flags { cleanDistDir = dd })
+            (configDistPref . configFlags)
+            (\dd flags -> flags { configFlags = (configFlags flags) { configDistPref = dd } })
             showOrParseArgs
-        , option [] ["project-file"]
-            ("Set the name of the cabal.project file"
-             ++ " to search for in parent directories")
-            cleanProjectFile (\pf flags -> flags {cleanProjectFile = pf})
-            (reqArg "FILE" (succeedReadE Flag) flagToList)
-        , option ['s'] ["save-config"]
+        ] ++ liftOptions projectFlags
+               (\x flags -> flags { projectFlags = x })
+               (projectFlagsOptions showOrParseArgs)
+          ++
+        [ option ['s'] ["save-config"]
             "Save configuration, only remove build artifacts"
-            cleanSaveConfig (\sc flags -> flags { cleanSaveConfig = sc })
+            (cleanSaveConfig . extraFlags)
+            (\sc flags -> flags { extraFlags = (extraFlags flags) { cleanSaveConfig = sc } })
             falseArg
         ]
   }
 
-cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO ()
-cleanAction CleanFlags{..} extraArgs _ = do
-    let verbosity      = fromFlagOrDefault normal cleanVerbosity
-        saveConfig     = fromFlagOrDefault False  cleanSaveConfig
-        mdistDirectory = flagToMaybe cleanDistDir
-        mprojectFile   = flagToMaybe cleanProjectFile
+cleanAction :: NixStyleFlags CleanFlags -> [String] -> GlobalFlags -> IO ()
+cleanAction NixStyleFlags{..} extraArgs _ = do
+    let verbosity      = fromFlagOrDefault normal $ configVerbosity configFlags
+        saveConfig     = fromFlagOrDefault False  $ cleanSaveConfig extraFlags
+        mdistDirectory = flagToMaybe $ configDistPref configFlags
+        mprojectFile   = flagToMaybe $ flagProjectFileName projectFlags
 
     -- TODO interpret extraArgs as targets and clean those targets only (issue #7506)
     --

diff --git a/cabal-install/src/Distribution/Client/CmdSdist.hs b/cabal-install/src/Distribution/Client/CmdSdist.hs
@@ -16,12 +16,12 @@ import Distribution.Client.CmdErrorMessages
 import Distribution.Client.ProjectOrchestration
     ( ProjectBaseContext(..), CurrentCommand(..), establishProjectBaseContext, establishProjectBaseContextWithRoot)
 import Distribution.Client.NixStyleOptions
-         ( NixStyleFlags (..), defaultNixStyleFlags )
+    ( NixStyleFlags(..), defaultNixStyleFlags )
 import Distribution.Client.TargetSelector
     ( TargetSelector(..), ComponentKind
     , readTargetSelectors, reportTargetSelectorProblems )
 import Distribution.Client.Setup
-    ( GlobalFlags(..) )
+    ( ConfigFlags(..), GlobalFlags(..), liftOptions )
 import Distribution.Solver.Types.SourcePackage
     ( SourcePackage(..) )
 import Distribution.Client.Types
@@ -31,23 +31,21 @@ import Distribution.Client.DistDirLayout
 import Distribution.Client.ProjectConfig
     ( ProjectConfig, withProjectOrGlobalConfig, commandLineFlagsToProjectConfig, projectConfigConfigFile, projectConfigShared )
 import Distribution.Client.ProjectFlags
-     ( ProjectFlags (..), defaultProjectFlags, projectFlagsOptions )
+    ( ProjectFlags(..), projectFlagsOptions )
 
-import Distribution.Compat.Lens
-    ( _1, _2 )
 import Distribution.Package
     ( Package(packageId) )
 import Distribution.PackageDescription.Configuration
     ( flattenPackageDescription )
 import Distribution.ReadE
     ( succeedReadE )
 import Distribution.Simple.Command
-    ( CommandUI(..), OptionField, option, reqArg, liftOptionL, ShowOrParseArgs )
+    ( CommandUI(..), OptionField, option, reqArg, ShowOrParseArgs )
 import Distribution.Simple.PreProcess
     ( knownSuffixHandlers )
 import Distribution.Simple.Setup
     ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe
-    , optionVerbosity, optionDistPref, trueArg, configVerbosity, configDistPref
+    , optionVerbosity, optionDistPref, trueArg
     )
 import Distribution.Simple.SrcDist
     ( listPackageSourcesWithDie )
@@ -75,7 +73,7 @@ import System.FilePath
 -- Command
 -------------------------------------------------------------------------------
 
-sdistCommand :: CommandUI (ProjectFlags, SdistFlags)
+sdistCommand :: CommandUI (NixStyleFlags SdistFlags)
 sdistCommand = CommandUI
     { commandName = "v2-sdist"
     , commandSynopsis = "Generate a source distribution file (.tar.gz)."
@@ -84,60 +82,63 @@ sdistCommand = CommandUI
     , commandDescription  = Just $ \_ -> wrapText
         "Generates tarballs of project packages suitable for upload to Hackage."
     , commandNotes = Nothing
-    , commandDefaultFlags = (defaultProjectFlags, defaultSdistFlags)
-    , commandOptions = \showOrParseArgs ->
-        map (liftOptionL _1) (projectFlagsOptions showOrParseArgs) ++
-        map (liftOptionL _2) (sdistOptions showOrParseArgs)
+    , commandDefaultFlags = defaultNixStyleFlags defaultSdistFlags
+    , commandOptions = sdistOptions
     }
 
 -------------------------------------------------------------------------------
 -- Flags
 -------------------------------------------------------------------------------
 
 data SdistFlags = SdistFlags
-    { sdistVerbosity     :: Flag Verbosity
-    , sdistDistDir       :: Flag FilePath
-    , sdistListSources   :: Flag Bool
+    { sdistListSources   :: Flag Bool
     , sdistNulSeparated  :: Flag Bool
     , sdistOutputPath    :: Flag FilePath
     }
 
 defaultSdistFlags :: SdistFlags
 defaultSdistFlags = SdistFlags
-    { sdistVerbosity     = toFlag normal
-    , sdistDistDir       = mempty
-    , sdistListSources   = toFlag False
+    { sdistListSources   = toFlag False
     , sdistNulSeparated  = toFlag False
     , sdistOutputPath    = mempty
     }
 
-sdistOptions :: ShowOrParseArgs -> [OptionField SdistFlags]
+sdistOptions :: ShowOrParseArgs -> [OptionField (NixStyleFlags SdistFlags)]
 sdistOptions showOrParseArgs =
     [ optionVerbosity
-        sdistVerbosity (\v flags -> flags { sdistVerbosity = v })
+        (configVerbosity . configFlags)
+        (\v flags -> flags { configFlags = (configFlags flags) { configVerbosity = v } })
     , optionDistPref
-        sdistDistDir (\dd flags -> flags { sdistDistDir = dd })
+        (configDistPref . configFlags)
+        (\dd flags -> flags { configFlags = (configFlags flags) { configDistPref = dd } })
         showOrParseArgs
-    , option ['l'] ["list-only"]
+    ] ++ liftOptions projectFlags
+           (\x flags -> flags { projectFlags = x })
+           (projectFlagsOptions showOrParseArgs)
+      ++
+    [ option ['l'] ["list-only"]
         "Just list the sources, do not make a tarball"
-        sdistListSources (\v flags -> flags { sdistListSources = v })
+        (sdistListSources . extraFlags)
+        (\v flags -> flags { extraFlags = (extraFlags flags) { sdistListSources = v } })
         trueArg
     , option [] ["null-sep"]
         "Separate the source files with NUL bytes rather than newlines."
-        sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v })
+        (sdistNulSeparated . extraFlags)
+        (\v flags -> flags { extraFlags = (extraFlags flags) { sdistNulSeparated = v } })
         trueArg
     , option ['o'] ["output-directory", "outputdir"]
         "Choose the output directory of this command. '-' sends all output to stdout"
-        sdistOutputPath (\o flags -> flags { sdistOutputPath = o })
+        (sdistOutputPath . extraFlags)
+        (\o flags -> flags { extraFlags = (extraFlags flags) { sdistOutputPath = o } })
         (reqArg "PATH" (succeedReadE Flag) flagToList)
     ]
 
 -------------------------------------------------------------------------------
 -- Action
 -------------------------------------------------------------------------------
 
-sdistAction :: (ProjectFlags, SdistFlags) -> [String] -> GlobalFlags -> IO ()
-sdistAction (ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do
+sdistAction :: NixStyleFlags SdistFlags -> [String] -> GlobalFlags -> IO ()
+sdistAction flags@NixStyleFlags{..} targetStrings globalFlags = do
     (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject
 
     let localPkgs = localPackages baseCtx
@@ -183,22 +184,14 @@ sdistAction (ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do
             | otherwise ->
                 traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distDirLayout) format (outputPath pkg) pkg) pkgs
   where
-    verbosity      = fromFlagOrDefault normal sdistVerbosity
-    listSources    = fromFlagOrDefault False sdistListSources
-    nulSeparated   = fromFlagOrDefault False sdistNulSeparated
-    mOutputPath    = flagToMaybe sdistOutputPath
-    ignoreProject  = flagIgnoreProject
+    verbosity      = fromFlagOrDefault normal $ configVerbosity configFlags
+    listSources    = fromFlagOrDefault False  $ sdistListSources extraFlags
+    nulSeparated   = fromFlagOrDefault False  $ sdistNulSeparated extraFlags
+    mOutputPath    = flagToMaybe $ sdistOutputPath extraFlags
+    ignoreProject  = flagIgnoreProject projectFlags
 
     prjConfig :: ProjectConfig
-    prjConfig = commandLineFlagsToProjectConfig
-        globalFlags
-        (defaultNixStyleFlags ())
-          { configFlags = (configFlags $ defaultNixStyleFlags ())
-            { configVerbosity = sdistVerbosity
-            , configDistPref = sdistDistDir
-            }
-          }
-        mempty
+    prjConfig = commandLineFlagsToProjectConfig globalFlags flags mempty
 
     globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig)
 

diff --git a/cabal-install/src/Distribution/Client/ProjectFlags.hs b/cabal-install/src/Distribution/Client/ProjectFlags.hs
@@ -10,11 +10,11 @@ module Distribution.Client.ProjectFlags (
 import Distribution.Client.Compat.Prelude
 import Prelude ()
 
+import Distribution.Client.Setup   (yesNoOpt)
 import Distribution.ReadE          (succeedReadE)
 import Distribution.Simple.Command
-    ( MkOptDescr, OptionField(optionName), ShowOrParseArgs (..), boolOpt', option
-    , reqArg )
-import Distribution.Simple.Setup   (Flag (..), flagToList, flagToMaybe, toFlag, trueArg)
+    ( OptionField(optionName), ShowOrParseArgs (..), option, reqArg )
+import Distribution.Simple.Setup   (Flag (..), flagToList, toFlag)
 
 data ProjectFlags = ProjectFlags
     { flagProjectFileName :: Flag FilePath
@@ -63,7 +63,3 @@ instance Monoid ProjectFlags where
 
 instance Semigroup ProjectFlags where
     (<>) = gmappend
-
-yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b
-yesNoOpt ShowArgs sf lf = trueArg sf lf
-yesNoOpt _        sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf