Commit 02859ae9 authored by Oleg Grenrus's avatar Oleg Grenrus

Make NixStyleFlags a data type, and use it CmdUpdate

parent f6f78d11
......@@ -1880,7 +1880,7 @@ data TestFlags = TestFlags {
testFailWhenNoTestSuites :: Flag Bool,
-- TODO: think about if/how options are passed to test exes
testOptions :: [PathTemplate]
} deriving (Generic, Typeable)
} deriving (Show, Generic, Typeable)
defaultTestFlags :: TestFlags
defaultTestFlags = TestFlags {
......@@ -2000,7 +2000,7 @@ data BenchmarkFlags = BenchmarkFlags {
benchmarkDistPref :: Flag FilePath,
benchmarkVerbosity :: Flag Verbosity,
benchmarkOptions :: [PathTemplate]
} deriving (Generic, Typeable)
} deriving (Show, Generic, Typeable)
defaultBenchmarkFlags :: BenchmarkFlags
defaultBenchmarkFlags = BenchmarkFlags {
......
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
-- | cabal-install CLI command: haddock
--
......@@ -17,11 +17,11 @@ import Distribution.Client.ProjectOrchestration
import Distribution.Client.CmdErrorMessages
import Distribution.Client.NixStyleOptions
( NixStyleFlags, nixStyleOptions, defaultNixStyleFlags )
( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
import Distribution.Client.Setup
( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )
( GlobalFlags, ConfigFlags(..) )
import Distribution.Simple.Setup
( HaddockFlags(..), TestFlags, BenchmarkFlags(..), fromFlagOrDefault )
( HaddockFlags(..), fromFlagOrDefault )
import Distribution.Simple.Command
( CommandUI(..), usageAlternatives )
import Distribution.Verbosity
......@@ -71,13 +71,8 @@ haddockCommand = CommandUI {
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
--
haddockAction :: ( ConfigFlags, ConfigExFlags, InstallFlags
, HaddockFlags, TestFlags, BenchmarkFlags, () )
-> [String] -> GlobalFlags -> IO ()
haddockAction ( configFlags, configExFlags, installFlags
, haddockFlags, testFlags, benchmarkFlags, () )
targetStrings globalFlags = do
haddockAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
haddockAction NixStyleFlags {..} targetStrings globalFlags = do
baseCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand
targetSelectors <- either (reportTargetSelectorProblems verbosity) return
......
......@@ -33,7 +33,7 @@ import Distribution.Client.CmdInstall.ClientInstallFlags
import Distribution.Client.CmdInstall.ClientInstallTargetSelector
import Distribution.Client.Setup
( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..) )
( GlobalFlags(..), ConfigFlags(..) )
import Distribution.Client.Types
( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage
, SourcePackageDb(..) )
......@@ -47,7 +47,7 @@ import Distribution.Client.ProjectConfig
, fetchAndReadSourcePackages
)
import Distribution.Client.NixStyleOptions
( NixStyleFlags, nixStyleOptions, defaultNixStyleFlags )
( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
import Distribution.Client.ProjectConfig.Types
( ProjectConfig(..), ProjectConfigShared(..)
, ProjectConfigBuildOnly(..), PackageConfig(..)
......@@ -95,7 +95,7 @@ import Distribution.Client.InstallSymlink
import Distribution.Simple.Flag
( fromFlagOrDefault, flagToMaybe, flagElim )
import Distribution.Simple.Setup
( Flag(..), HaddockFlags, TestFlags, BenchmarkFlags )
( Flag(..) )
import Distribution.Solver.Types.SourcePackage
( SourcePackage(..) )
import Distribution.Simple.Command
......@@ -197,16 +197,8 @@ installCommand = CommandUI
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
--
installAction
:: ( ConfigFlags, ConfigExFlags, InstallFlags
, HaddockFlags, TestFlags, BenchmarkFlags
, ClientInstallFlags)
-> [String] -> GlobalFlags
-> IO ()
installAction ( configFlags, configExFlags, installFlags
, haddockFlags, testFlags, benchmarkFlags
, clientInstallFlags' )
targetStrings globalFlags = do
installAction :: NixStyleFlags ClientInstallFlags -> [String] -> GlobalFlags -> IO ()
installAction NixStyleFlags { extraFlags = clientInstallFlags', .. } targetStrings globalFlags = do
-- Ensure there were no invalid configuration options specified.
verifyPreconditionsOrDie verbosity configFlags'
......
......@@ -24,7 +24,7 @@ import Distribution.Compat.Lens
import qualified Distribution.Types.Lens as L
import Distribution.Client.NixStyleOptions
( NixStyleFlags, nixStyleOptions, defaultNixStyleFlags )
( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
import Distribution.Client.CmdErrorMessages
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.ProjectBuilding
......@@ -38,13 +38,12 @@ import Distribution.Client.ProjectPlanning
import Distribution.Client.ProjectPlanning.Types
( elabOrderExeDependencies )
import Distribution.Client.Setup
( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )
( GlobalFlags, ConfigFlags(..) )
import qualified Distribution.Client.Setup as Client
import Distribution.Client.Types
( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage )
import Distribution.Simple.Setup
( HaddockFlags, TestFlags, BenchmarkFlags
, fromFlagOrDefault, replOptions
( fromFlagOrDefault, replOptions
, Flag(..), toFlag, trueArg, falseArg )
import Distribution.Simple.Command
( CommandUI(..), liftOptionL, usageAlternatives, option
......@@ -197,14 +196,8 @@ replCommand = Client.installCommand {
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
--
replAction :: ( ConfigFlags, ConfigExFlags, InstallFlags
, HaddockFlags, TestFlags, BenchmarkFlags
, (ReplFlags, EnvFlags) )
-> [String] -> GlobalFlags -> IO ()
replAction ( configFlags, configExFlags, installFlags
, haddockFlags, testFlags, benchmarkFlags
, (replFlags, envFlags) )
targetStrings globalFlags = do
replAction :: NixStyleFlags (ReplFlags, EnvFlags) -> [String] -> GlobalFlags -> IO ()
replAction NixStyleFlags { extraFlags = (replFlags, envFlags), ..} targetStrings globalFlags = do
let
ignoreProject = fromFlagOrDefault False (envIgnoreProject envFlags)
with = withProject cliConfig verbosity targetStrings
......
......@@ -26,13 +26,13 @@ import Distribution.Client.CmdErrorMessages
import Distribution.Client.CmdRun.ClientRunFlags
import Distribution.Client.NixStyleOptions
( NixStyleFlags, nixStyleOptions, defaultNixStyleFlags )
( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
import Distribution.Client.Setup
( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..) )
( GlobalFlags(..), ConfigFlags(..) )
import Distribution.Client.GlobalFlags
( defaultGlobalFlags )
import Distribution.Simple.Setup
( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault )
import Distribution.Simple.Flag
( fromFlagOrDefault )
import Distribution.Simple.Command
( CommandUI(..), usageAlternatives )
import Distribution.Types.ComponentName
......@@ -153,14 +153,8 @@ runCommand = CommandUI
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
--
runAction :: ( ConfigFlags, ConfigExFlags, InstallFlags
, HaddockFlags, TestFlags, BenchmarkFlags
, ClientRunFlags )
-> [String] -> GlobalFlags -> IO ()
runAction ( configFlags, configExFlags, installFlags
, haddockFlags, testFlags, benchmarkFlags
, clientRunFlags )
targetStrings globalFlags = do
runAction :: NixStyleFlags ClientRunFlags -> [String] -> GlobalFlags -> IO ()
runAction NixStyleFlags {extraFlags=clientRunFlags, ..} targetStrings globalFlags = do
globalTmp <- getTemporaryDirectory
tmpDir <- createTempDirectory globalTmp "cabal-repl."
......
......@@ -15,6 +15,8 @@ module Distribution.Client.CmdUpdate (
import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Client.NixStyleOptions
( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
import Distribution.Client.Compat.Directory
( setModificationTime )
import Distribution.Client.ProjectOrchestration
......@@ -32,11 +34,11 @@ import Distribution.Client.FetchUtils
import Distribution.Client.JobControl
( newParallelJobControl, spawnJob, collectJob )
import Distribution.Client.Setup
( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags
( GlobalFlags, ConfigFlags(..)
, UpdateFlags, defaultUpdateFlags
, RepoContext(..) )
import Distribution.Simple.Setup
( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault )
import Distribution.Simple.Flag
( fromFlagOrDefault )
import Distribution.Simple.Utils
( die', notice, wrapText, writeFileAtomic, noticeNoWrap )
import Distribution.Verbosity
......@@ -60,21 +62,17 @@ import System.FilePath ((<.>), dropExtension)
import Data.Time (getCurrentTime)
import Distribution.Simple.Command
( CommandUI(..), usageAlternatives )
import qualified Distribution.Client.Setup as Client
import qualified Hackage.Security.Client as Sec
updateCommand :: CommandUI ( ConfigFlags, ConfigExFlags
, InstallFlags, HaddockFlags
, TestFlags, BenchmarkFlags
)
updateCommand = Client.installCommand {
commandName = "v2-update",
commandSynopsis = "Updates list of known packages.",
commandUsage = usageAlternatives "v2-update" [ "[FLAGS] [REPOS]" ],
commandDescription = Just $ \_ -> wrapText $
"For all known remote repositories, download the package list.",
commandNotes = Just $ \pname ->
updateCommand :: CommandUI (NixStyleFlags ())
updateCommand = CommandUI
{ commandName = "v2-update"
, commandSynopsis = "Updates list of known packages."
, commandUsage = usageAlternatives "v2-update" [ "[FLAGS] [REPOS]" ]
, commandDescription = Just $ \_ -> wrapText $
"For all known remote repositories, download the package list."
, commandNotes = Just $ \pname ->
"REPO has the format <repo-id>[,<index-state>] where index-state follows\n"
++ "the same format and syntax that is supported by the --index-state flag.\n\n"
++ "Examples:\n"
......@@ -98,6 +96,8 @@ updateCommand = Client.installCommand {
++ "https://github.com/haskell/cabal/issues and if you\nhave any time "
++ "to get involved and help with testing, fixing bugs etc then\nthat "
++ "is very much appreciated.\n"
, commandOptions = nixStyleOptions (const []) -- clientInstallOptions
, commandDefaultFlags = defaultNixStyleFlags () -- defaultClientInstallFlags
}
data UpdateRequest = UpdateRequest
......@@ -114,12 +114,8 @@ instance Parsec UpdateRequest where
state <- P.char ',' *> parsec <|> pure IndexStateHead
return (UpdateRequest name state)
updateAction :: ( ConfigFlags, ConfigExFlags, InstallFlags
, HaddockFlags, TestFlags, BenchmarkFlags )
-> [String] -> GlobalFlags -> IO ()
updateAction ( configFlags, configExFlags, installFlags
, haddockFlags, testFlags, benchmarkFlags )
extraArgs globalFlags = do
updateAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
updateAction NixStyleFlags {..} extraArgs globalFlags = do
projectConfig <- withProjectOrGlobalConfig verbosity globalConfigFlag
(projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand)
(\globalConfig -> return $ globalConfig <> cliConfig)
......
......@@ -3,7 +3,9 @@
-- The commands take a lot of the same options, which affect how install plan
-- is constructed.
module Distribution.Client.NixStyleOptions (
NixStyleFlags, nixStyleOptions, defaultNixStyleFlags,
NixStyleFlags (..),
nixStyleOptions,
defaultNixStyleFlags,
) where
import Distribution.Client.Compat.Prelude
......@@ -17,47 +19,53 @@ import Distribution.Client.Setup
(ConfigExFlags, ConfigFlags (..), InstallFlags (..), benchmarkOptions, configureExOptions,
configureOptions, haddockOptions, installOptions, liftOptions, testOptions)
-- TODO: turn into data record
-- Then we could use RecordWildCards in command implementation.
type NixStyleFlags a = (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, BenchmarkFlags, a)
data NixStyleFlags a = NixStyleFlags
{ configFlags :: ConfigFlags
, configExFlags :: ConfigExFlags
, installFlags :: InstallFlags
, haddockFlags :: HaddockFlags
, testFlags :: TestFlags
, benchmarkFlags :: BenchmarkFlags
, extraFlags :: a
}
nixStyleOptions
:: (ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions commandOptions showOrParseArgs =
liftOptions get1 set1
liftOptions configFlags set1
-- Note: [Hidden Flags]
-- hide "constraint", "dependency", and
-- "exact-configuration" from the configure options.
(filter ((`notElem` ["constraint", "dependency"
, "exact-configuration"])
. optionName) $ configureOptions showOrParseArgs)
++ liftOptions get2 set2 (configureExOptions showOrParseArgs
++ liftOptions configExFlags set2 (configureExOptions showOrParseArgs
ConstraintSourceCommandlineFlag)
++ liftOptions get3 set3
++ liftOptions installFlags set3
-- hide "target-package-db" and "symlink-bindir" flags from the
-- install options.
-- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags
(filter ((`notElem` ["target-package-db", "symlink-bindir"])
. optionName) $
installOptions showOrParseArgs)
++ liftOptions get4 set4
++ liftOptions haddockFlags set4
-- hide "verbose" and "builddir" flags from the
-- haddock options.
(filter ((`notElem` ["v", "verbose", "builddir"])
. optionName) $
haddockOptions showOrParseArgs)
++ liftOptions get5 set5 (testOptions showOrParseArgs)
++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs)
++ liftOptions get7 set7 (commandOptions showOrParseArgs)
++ liftOptions testFlags set5 (testOptions showOrParseArgs)
++ liftOptions benchmarkFlags set6 (benchmarkOptions showOrParseArgs)
++ liftOptions extraFlags set7 (commandOptions showOrParseArgs)
where
get1 (a,_,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f,g) = (a,b,c,d,e,f,g)
get2 (_,b,_,_,_,_,_) = b; set2 b (a,_,c,d,e,f,g) = (a,b,c,d,e,f,g)
get3 (_,_,c,_,_,_,_) = c; set3 c (a,b,_,d,e,f,g) = (a,b,c,d,e,f,g)
get4 (_,_,_,d,_,_,_) = d; set4 d (a,b,c,_,e,f,g) = (a,b,c,d,e,f,g)
get5 (_,_,_,_,e,_,_) = e; set5 e (a,b,c,d,_,f,g) = (a,b,c,d,e,f,g)
get6 (_,_,_,_,_,f,_) = f; set6 f (a,b,c,d,e,_,g) = (a,b,c,d,e,f,g)
get7 (_,_,_,_,_,_,g) = g; set7 g (a,b,c,d,e,f,_) = (a,b,c,d,e,f,g)
set1 x flags = flags { configFlags = x }
set2 x flags = flags { configExFlags = x }
set3 x flags = flags { installFlags = x }
set4 x flags = flags { haddockFlags = x }
set5 x flags = flags { testFlags = x }
set6 x flags = flags { benchmarkFlags = x }
set7 x flags = flags { extraFlags = x }
defaultNixStyleFlags :: a -> NixStyleFlags a
defaultNixStyleFlags x = ( mempty, mempty, mempty, mempty, mempty, mempty, x )
defaultNixStyleFlags x = NixStyleFlags mempty mempty mempty mempty mempty mempty x
......@@ -623,7 +623,7 @@ data ConfigExFlags = ConfigExFlags {
configWriteGhcEnvironmentFilesPolicy
:: Flag WriteGhcEnvironmentFilesPolicy
}
deriving (Eq, Generic)
deriving (Eq, Show, Generic)
defaultConfigExFlags :: ConfigExFlags
defaultConfigExFlags = mempty { configSolver = Flag defaultSolver }
......@@ -1707,7 +1707,7 @@ data InstallFlags = InstallFlags {
-- relative to parent directories until this name is found.
installProjectFileName :: Flag FilePath -- TODO: use ProjectFlags
}
deriving (Eq, Generic)
deriving (Eq, Show, Generic)
instance Binary InstallFlags
......
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