From 41a4ef1cb7d52de04e49ca51a4815ac247eaabc4 Mon Sep 17 00:00:00 2001
From: Alexander Biehl <abiehl@novomind.com>
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 83d7db3124..d99e91a757 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 dcc5c41da7..484f1d73ca 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 726390b50f..a1895e583c 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 429f8e7587..29c1f78008 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 0ea3c53549..dad01e8874 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 5f4f104ebb..f1c7047812 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 15ace6411b..d34c909ff5 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 5f6f489199..c4e51ff7ef 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 f2d1e03121..202c99094b 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"
--
GitLab