Commit 78da2426 authored by Oleg Grenrus's avatar Oleg Grenrus

Add ProjectFlags, use in sdist

parent b89a1c63
......@@ -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) =
......
......@@ -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
......
......@@ -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,
......
{-# 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
]
......@@ -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)
......
......@@ -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
......
......@@ -168,6 +168,7 @@ Version: 3.3.0.0
Distribution.Client.ProjectConfig
Distribution.Client.ProjectConfig.Legacy
Distribution.Client.ProjectConfig.Types
Distribution.Client.ProjectFlags
Distribution.Client.ProjectOrchestration
Distribution.Client.ProjectPlanOutput
Distribution.Client.ProjectPlanning
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment