From 41a4ef1cb7d52de04e49ca51a4815ac247eaabc4 Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Wed, 2 Aug 2017 15:18:52 +0200 Subject: [PATCH] Introduce applyFlagsDefault and use ViewPatterns (cherry picked from commit 71131cf4590bfd1e7bdc2cb8a896f3cde9dbf461) --- cabal-install/Distribution/Client/CmdBench.hs | 6 ++++-- cabal-install/Distribution/Client/CmdBuild.hs | 7 +++++-- .../Distribution/Client/CmdConfigure.hs | 6 ++++-- .../Distribution/Client/CmdFreeze.hs | 7 ++++--- .../Distribution/Client/CmdHaddock.hs | 6 ++++-- cabal-install/Distribution/Client/CmdRepl.hs | 6 ++++-- cabal-install/Distribution/Client/CmdRun.hs | 6 ++++-- cabal-install/Distribution/Client/CmdTest.hs | 6 ++++-- cabal-install/Distribution/Client/Setup.hs | 20 +++++++++++-------- 9 files changed, 45 insertions(+), 25 deletions(-) diff --git a/cabal-install/Distribution/Client/CmdBench.hs b/cabal-install/Distribution/Client/CmdBench.hs index 83d7db3124f..d99e91a7574 100644 --- a/cabal-install/Distribution/Client/CmdBench.hs +++ b/cabal-install/Distribution/Client/CmdBench.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: bench -- @@ -17,7 +18,8 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) @@ -75,7 +77,7 @@ benchCommand = Client.installCommand { -- benchAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -benchAction (configFlags, configExFlags, installFlags, haddockFlags) +benchAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig diff --git a/cabal-install/Distribution/Client/CmdBuild.hs b/cabal-install/Distribution/Client/CmdBuild.hs index dcc5c41da7b..484f1d73cae 100644 --- a/cabal-install/Distribution/Client/CmdBuild.hs +++ b/cabal-install/Distribution/Client/CmdBuild.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ViewPatterns #-} + -- | cabal-install CLI command: build -- module Distribution.Client.CmdBuild ( @@ -15,7 +17,8 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) @@ -72,7 +75,7 @@ buildCommand = Client.installCommand { -- buildAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -buildAction (configFlags, configExFlags, installFlags, haddockFlags) +buildAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig diff --git a/cabal-install/Distribution/Client/CmdConfigure.hs b/cabal-install/Distribution/Client/CmdConfigure.hs index 726390b50f9..a1895e583c7 100644 --- a/cabal-install/Distribution/Client/CmdConfigure.hs +++ b/cabal-install/Distribution/Client/CmdConfigure.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: configure -- module Distribution.Client.CmdConfigure ( @@ -10,7 +11,8 @@ import Distribution.Client.ProjectConfig ( writeProjectLocalExtraConfig ) import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) import Distribution.Verbosity @@ -76,7 +78,7 @@ configureCommand = Client.installCommand { -- configureAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -configureAction (configFlags, configExFlags, installFlags, haddockFlags) +configureAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) _extraArgs globalFlags = do --TODO: deal with _extraArgs, since flags with wrong syntax end up there diff --git a/cabal-install/Distribution/Client/CmdFreeze.hs b/cabal-install/Distribution/Client/CmdFreeze.hs index 429f8e75875..29c1f780087 100644 --- a/cabal-install/Distribution/Client/CmdFreeze.hs +++ b/cabal-install/Distribution/Client/CmdFreeze.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards #-} +{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ViewPatterns #-} -- | cabal-install CLI command: freeze -- @@ -31,7 +31,8 @@ import Distribution.Version import Distribution.PackageDescription ( FlagAssignment ) import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) import Distribution.Simple.Utils @@ -103,7 +104,7 @@ freezeCommand = Client.installCommand { -- freezeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -freezeAction (configFlags, configExFlags, installFlags, haddockFlags) +freezeAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) extraArgs globalFlags = do unless (null extraArgs) $ diff --git a/cabal-install/Distribution/Client/CmdHaddock.hs b/cabal-install/Distribution/Client/CmdHaddock.hs index 0ea3c53549f..dad01e88748 100644 --- a/cabal-install/Distribution/Client/CmdHaddock.hs +++ b/cabal-install/Distribution/Client/CmdHaddock.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: haddock -- @@ -17,7 +18,8 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags(..), fromFlagOrDefault, fromFlag ) @@ -71,7 +73,7 @@ haddockCommand = Client.installCommand { -- haddockAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -haddockAction (configFlags, configExFlags, installFlags, haddockFlags) +haddockAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig diff --git a/cabal-install/Distribution/Client/CmdRepl.hs b/cabal-install/Distribution/Client/CmdRepl.hs index 5f4f104ebb2..f1c70478125 100644 --- a/cabal-install/Distribution/Client/CmdRepl.hs +++ b/cabal-install/Distribution/Client/CmdRepl.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: repl -- @@ -17,7 +18,8 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) @@ -87,7 +89,7 @@ replCommand = Client.installCommand { -- replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -replAction (configFlags, configExFlags, installFlags, haddockFlags) +replAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig diff --git a/cabal-install/Distribution/Client/CmdRun.hs b/cabal-install/Distribution/Client/CmdRun.hs index 15ace6411bc..d34c909ff5e 100644 --- a/cabal-install/Distribution/Client/CmdRun.hs +++ b/cabal-install/Distribution/Client/CmdRun.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: run -- @@ -17,7 +18,8 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) @@ -84,7 +86,7 @@ runCommand = Client.installCommand { -- runAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -runAction (configFlags, configExFlags, installFlags, haddockFlags) +runAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig diff --git a/cabal-install/Distribution/Client/CmdTest.hs b/cabal-install/Distribution/Client/CmdTest.hs index 5f6f489199d..c4e51ff7ef4 100644 --- a/cabal-install/Distribution/Client/CmdTest.hs +++ b/cabal-install/Distribution/Client/CmdTest.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: test -- @@ -17,7 +18,8 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) @@ -78,7 +80,7 @@ testCommand = Client.installCommand { -- testAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -testAction (configFlags, configExFlags, installFlags, haddockFlags) +testAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index f2d1e031210..202c99094b0 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -49,6 +49,7 @@ module Distribution.Client.Setup , userConfigCommand, UserConfigFlags(..) , manpageCommand + , applyFlagDefaults , parsePackageArgs --TODO: stop exporting these: , showRepo @@ -128,6 +129,15 @@ import System.FilePath import Network.URI ( parseAbsoluteURI, uriToString ) +applyFlagDefaults :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +applyFlagDefaults (configFlags, configExFlags, installFlags, haddockFlags) = + ( commandDefaultFlags configureCommand <> configFlags + , defaultConfigExFlags <> configExFlags + , defaultInstallFlags <> installFlags + , Cabal.defaultHaddockFlags <> haddockFlags + ) + globalCommand :: [Command action] -> CommandUI GlobalFlags globalCommand commands = CommandUI { commandName = "", @@ -1023,10 +1033,7 @@ upgradeCommand = configureCommand { commandSynopsis = "(command disabled, use install instead)", commandDescription = Nothing, commandUsage = usageFlagsOrPackages "upgrade", - commandDefaultFlags = (commandDefaultFlags configureCommand, - defaultConfigExFlags, - defaultInstallFlags, - Cabal.defaultHaddockFlags), + commandDefaultFlags = (mempty, mempty, mempty, mempty), commandOptions = commandOptions installCommand } @@ -1533,10 +1540,7 @@ installCommand = CommandUI { ++ " " ++ (map (const ' ') pname) ++ " " ++ " Change installation destination\n", - commandDefaultFlags = (commandDefaultFlags configureCommand, - defaultConfigExFlags, - defaultInstallFlags, - Cabal.defaultHaddockFlags), + commandDefaultFlags = (mempty, mempty, mempty, mempty), commandOptions = \showOrParseArgs -> liftOptions get1 set1 (filter ((`notElem` ["constraint", "dependency"