From 78da2426c0aedc422a30bddd44256a288e896bfc Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 24 Apr 2020 12:45:32 +0300 Subject: [PATCH] Add ProjectFlags, use in sdist --- Cabal/Distribution/Simple/Command.hs | 7 +- cabal-install/Distribution/Client/CmdSdist.hs | 88 ++++++++++--------- .../Client/ProjectConfig/Types.hs | 1 + .../Distribution/Client/ProjectFlags.hs | 37 ++++++++ cabal-install/Distribution/Client/Setup.hs | 2 +- cabal-install/cabal-install.cabal | 1 + cabal-install/cabal-install.cabal.pp | 1 + 7 files changed, 94 insertions(+), 43 deletions(-) create mode 100644 cabal-install/Distribution/Client/ProjectFlags.hs diff --git a/Cabal/Distribution/Simple/Command.hs b/Cabal/Distribution/Simple/Command.hs index b59ecb60cb1..d3afe765e43 100644 --- a/Cabal/Distribution/Simple/Command.hs +++ b/Cabal/Distribution/Simple/Command.hs @@ -56,7 +56,7 @@ module Distribution.Simple.Command ( option, multiOption, -- ** Liftings & Projections - liftOption, + liftOption, liftOptionL, -- * Option Descriptions OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder, @@ -74,6 +74,7 @@ import Distribution.Compat.Prelude hiding (get) import qualified Distribution.GetOpt as GetOpt import Distribution.ReadE import Distribution.Simple.Utils +import Distribution.Compat.Lens (ALens', (^#), (#~)) data CommandUI flags = CommandUI { @@ -251,6 +252,10 @@ liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b liftOption get' set' opt = opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt} +-- | @since 3.4.0.0 +liftOptionL :: ALens' b a -> OptionField a -> OptionField b +liftOptionL l = liftOption (^# l) (l #~) + liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b liftOptDescr get' set' (ChoiceOpt opts) = diff --git a/cabal-install/Distribution/Client/CmdSdist.hs b/cabal-install/Distribution/Client/CmdSdist.hs index 2f79e849f11..3ae01dc6d47 100644 --- a/cabal-install/Distribution/Client/CmdSdist.hs +++ b/cabal-install/Distribution/Client/CmdSdist.hs @@ -6,7 +6,6 @@ {-# LANGUAGE ViewPatterns #-} module Distribution.Client.CmdSdist ( sdistCommand, sdistAction, packageToSdist - , SdistFlags(..), defaultSdistFlags , OutputFormat(..)) where import Prelude () @@ -20,7 +19,7 @@ import Distribution.Client.TargetSelector ( TargetSelector(..), ComponentKind , readTargetSelectors, reportTargetSelectorProblems ) import Distribution.Client.Setup - ( GlobalFlags(..) ) + ( GlobalFlags(..), InstallFlags (installProjectFileName) ) import Distribution.Solver.Types.SourcePackage ( SourcePackage(..) ) import Distribution.Client.Types @@ -29,7 +28,11 @@ import Distribution.Client.DistDirLayout ( DistDirLayout(..), ProjectRoot (..) ) import Distribution.Client.ProjectConfig ( ProjectConfig, withProjectOrGlobalConfigIgn, commandLineFlagsToProjectConfig, projectConfigConfigFile, projectConfigShared ) +import Distribution.Client.ProjectFlags + ( ProjectFlags (..), defaultProjectFlags, projectFlagsOptions ) +import Distribution.Compat.Lens + ( _1, _2 ) import Distribution.Package ( Package(packageId) ) import Distribution.PackageDescription.Configuration @@ -39,7 +42,7 @@ import Distribution.Pretty import Distribution.ReadE ( succeedReadE ) import Distribution.Simple.Command - ( CommandUI(..), option, reqArg ) + ( CommandUI(..), OptionField, option, reqArg, liftOptionL, ShowOrParseArgs ) import Distribution.Simple.PreProcess ( knownSuffixHandlers ) import Distribution.Simple.Setup @@ -78,7 +81,11 @@ import System.Directory import System.FilePath ( (), (<.>), makeRelative, normalise, takeDirectory ) -sdistCommand :: CommandUI SdistFlags +------------------------------------------------------------------------------- +-- Command +------------------------------------------------------------------------------- + +sdistCommand :: CommandUI (ProjectFlags, SdistFlags) sdistCommand = CommandUI { commandName = "v2-sdist" , commandSynopsis = "Generate a source distribution file (.tar.gz)." @@ -87,41 +94,19 @@ sdistCommand = CommandUI , commandDescription = Just $ \_ -> wrapText "Generates tarballs of project packages suitable for upload to Hackage." , commandNotes = Nothing - , commandDefaultFlags = defaultSdistFlags + , commandDefaultFlags = (defaultProjectFlags, defaultSdistFlags) , commandOptions = \showOrParseArgs -> - [ optionVerbosity - sdistVerbosity (\v flags -> flags { sdistVerbosity = v }) - , optionDistPref - sdistDistDir (\dd flags -> flags { sdistDistDir = dd }) - showOrParseArgs - , option [] ["project-file"] - "Set the name of the cabal.project file to search for in parent directories" - sdistProjectFile (\pf flags -> flags { sdistProjectFile = pf }) - (reqArg "FILE" (succeedReadE Flag) flagToList) - , option ['z'] ["ignore-project"] - "Ignore local project configuration" - sdistIgnoreProject (\v flags -> flags { sdistIgnoreProject = v }) - trueArg - , option ['l'] ["list-only"] - "Just list the sources, do not make a tarball" - sdistListSources (\v flags -> flags { sdistListSources = v }) - trueArg - , option [] ["null-sep"] - "Separate the source files with NUL bytes rather than newlines." - sdistNulSeparated (\v flags -> 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 }) - (reqArg "PATH" (succeedReadE Flag) flagToList) - ] + map (liftOptionL _1) projectFlagsOptions ++ + map (liftOptionL _2) (sdistOptions showOrParseArgs) } +------------------------------------------------------------------------------- +-- Flags +------------------------------------------------------------------------------- + data SdistFlags = SdistFlags { sdistVerbosity :: Flag Verbosity , sdistDistDir :: Flag FilePath - , sdistProjectFile :: Flag FilePath - , sdistIgnoreProject :: Flag Bool , sdistListSources :: Flag Bool , sdistNulSeparated :: Flag Bool , sdistOutputPath :: Flag FilePath @@ -131,17 +116,38 @@ defaultSdistFlags :: SdistFlags defaultSdistFlags = SdistFlags { sdistVerbosity = toFlag normal , sdistDistDir = mempty - , sdistProjectFile = mempty - , sdistIgnoreProject = toFlag False , sdistListSources = toFlag False , sdistNulSeparated = toFlag False , sdistOutputPath = mempty } --- - -sdistAction :: SdistFlags -> [String] -> GlobalFlags -> IO () -sdistAction SdistFlags{..} targetStrings globalFlags = do +sdistOptions :: ShowOrParseArgs -> [OptionField SdistFlags] +sdistOptions showOrParseArgs = + [ optionVerbosity + sdistVerbosity (\v flags -> flags { sdistVerbosity = v }) + , optionDistPref + sdistDistDir (\dd flags -> flags { sdistDistDir = dd }) + showOrParseArgs + , option ['l'] ["list-only"] + "Just list the sources, do not make a tarball" + sdistListSources (\v flags -> flags { sdistListSources = v }) + trueArg + , option [] ["null-sep"] + "Separate the source files with NUL bytes rather than newlines." + sdistNulSeparated (\v flags -> 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 }) + (reqArg "PATH" (succeedReadE Flag) flagToList) + ] + +------------------------------------------------------------------------------- +-- Action +------------------------------------------------------------------------------- + +sdistAction :: (ProjectFlags, SdistFlags) -> [String] -> GlobalFlags -> IO () +sdistAction (ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do (baseCtx, distDirLayout) <- withProjectOrGlobalConfigIgn ignoreProject verbosity globalConfigFlag withProject withoutProject let localPkgs = localPackages baseCtx @@ -191,14 +197,14 @@ sdistAction SdistFlags{..} targetStrings globalFlags = do listSources = fromFlagOrDefault False sdistListSources nulSeparated = fromFlagOrDefault False sdistNulSeparated mOutputPath = flagToMaybe sdistOutputPath - ignoreProject = fromFlagOrDefault False sdistIgnoreProject + ignoreProject = fromFlagOrDefault False flagIgnoreProject prjConfig :: ProjectConfig prjConfig = commandLineFlagsToProjectConfig globalFlags mempty { configVerbosity = sdistVerbosity, configDistPref = sdistDistDir } mempty - mempty + mempty { installProjectFileName = flagProjectFileName } mempty mempty mempty diff --git a/cabal-install/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/Distribution/Client/ProjectConfig/Types.hs index e92cf632b67..401ec181dd6 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Types.hs @@ -163,6 +163,7 @@ data ProjectConfigShared projectConfigDistDir :: Flag FilePath, projectConfigConfigFile :: Flag FilePath, projectConfigProjectFile :: Flag FilePath, + -- projectConfigIgnoreProjectFile :: Flag Bool, -- TODO projectConfigHcFlavor :: Flag CompilerFlavor, projectConfigHcPath :: Flag FilePath, projectConfigHcPkg :: Flag FilePath, diff --git a/cabal-install/Distribution/Client/ProjectFlags.hs b/cabal-install/Distribution/Client/ProjectFlags.hs new file mode 100644 index 00000000000..5e0158ddaf8 --- /dev/null +++ b/cabal-install/Distribution/Client/ProjectFlags.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +module Distribution.Client.ProjectFlags ( + ProjectFlags(..), + defaultProjectFlags, + projectFlagsOptions, +) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.ReadE (succeedReadE) +import Distribution.Simple.Command (OptionField, option, reqArg) +import Distribution.Simple.Setup (Flag (..), toFlag, trueArg, flagToList) + +data ProjectFlags = ProjectFlags + { flagProjectFileName :: Flag FilePath + , flagIgnoreProject :: Flag Bool + } + +defaultProjectFlags :: ProjectFlags +defaultProjectFlags = ProjectFlags + { flagProjectFileName = mempty + , flagIgnoreProject = toFlag False + } + +projectFlagsOptions :: [OptionField ProjectFlags] +projectFlagsOptions = + [ option [] ["project-file"] + "Set the name of the cabal.project file to search for in parent directories" + flagProjectFileName (\pf flags -> flags { flagProjectFileName = pf }) + (reqArg "FILE" (succeedReadE Flag) flagToList) + , option ['z'] ["ignore-project"] + "Ignore local project configuration" + flagIgnoreProject (\v flags -> flags { flagIgnoreProject = v }) + trueArg + ] diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index 90bd1dac7a3..69cdd703f93 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -1767,7 +1767,7 @@ data InstallFlags = InstallFlags { -- read and written out in some cases. If the path is not found -- in the current working directory, we will successively probe -- relative to parent directories until this name is found. - installProjectFileName :: Flag FilePath + installProjectFileName :: Flag FilePath -- TODO: use ProjectFlags } deriving (Eq, Generic) diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 4c463e5d274..27241f5d6d6 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -229,6 +229,7 @@ executable cabal Distribution.Client.ProjectConfig Distribution.Client.ProjectConfig.Legacy Distribution.Client.ProjectConfig.Types + Distribution.Client.ProjectFlags Distribution.Client.ProjectOrchestration Distribution.Client.ProjectPlanOutput Distribution.Client.ProjectPlanning diff --git a/cabal-install/cabal-install.cabal.pp b/cabal-install/cabal-install.cabal.pp index 37690a341f4..9ee0e34ec0f 100644 --- a/cabal-install/cabal-install.cabal.pp +++ b/cabal-install/cabal-install.cabal.pp @@ -168,6 +168,7 @@ Distribution.Client.ProjectConfig Distribution.Client.ProjectConfig.Legacy Distribution.Client.ProjectConfig.Types + Distribution.Client.ProjectFlags Distribution.Client.ProjectOrchestration Distribution.Client.ProjectPlanOutput Distribution.Client.ProjectPlanning