diff --git a/cabal-install/src/Distribution/Client/CmdClean.hs b/cabal-install/src/Distribution/Client/CmdClean.hs index a0eee3e33fa..1172e375ca1 100644 --- 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 index d4f87074a2a..591136714a5 100644 --- 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,10 +31,8 @@ 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 @@ -42,12 +40,12 @@ import Distribution.PackageDescription.Configuration 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,10 +82,8 @@ 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 } ------------------------------------------------------------------------------- @@ -95,40 +91,45 @@ sdistCommand = CommandUI ------------------------------------------------------------------------------- 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) ] @@ -136,8 +137,8 @@ sdistOptions showOrParseArgs = -- 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 index 6884708b30e..4a828199db4 100644 --- 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 diff --git a/changelog.d/pr-8017 b/changelog.d/pr-8017 new file mode 100644 index 00000000000..bafab8f0ad7 --- /dev/null +++ b/changelog.d/pr-8017 @@ -0,0 +1,10 @@ +synopsis: Refactor clean and sdist option parsing +packages: cabal-install +prs: #8017 + +description: { + +- Reorder options for clean and sdist to be consistent with other commands. +- Add --ignore-project flag to clean. + +}