Merge pull request #6745 from haskell/install-commandui

Make NixStyleOptions

Author: phadej

cabal-install/Distribution/Client/CmdHaddock.hs

@@ -16,9 +16,10 @@ module Distribution.Client.CmdHaddock (
 import Distribution.Client.ProjectOrchestration
 import Distribution.Client.CmdErrorMessages
 
+import Distribution.Client.NixStyleOptions
+         ( NixStyleFlags, nixStyleOptions, defaultNixStyleFlags )
 import Distribution.Client.Setup
          ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )
-import qualified Distribution.Client.Setup as Client
 import Distribution.Simple.Setup
          ( HaddockFlags(..), TestFlags, BenchmarkFlags(..), fromFlagOrDefault )
 import Distribution.Simple.Command
@@ -31,10 +32,8 @@ import Distribution.Simple.Utils
 import Control.Monad (when)
 
 
-haddockCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags
-                            , HaddockFlags, TestFlags, BenchmarkFlags
-                            )
-haddockCommand = Client.installCommand {
+haddockCommand :: CommandUI (NixStyleFlags ())
+haddockCommand = CommandUI {
   commandName         = "v2-haddock",
   commandSynopsis     = "Build Haddock documentation",
   commandUsage        = usageAlternatives "v2-haddock" [ "[FLAGS] TARGET" ],
@@ -61,7 +60,9 @@ haddockCommand = Client.installCommand {
      ++ "    Build documentation for the package named pkgname\n\n"
 
      ++ cmdCommonHelpTextNewBuildBeta
-   }
+  , commandOptions      = nixStyleOptions (const [])
+  , commandDefaultFlags = defaultNixStyleFlags ()
+  }
    --TODO: [nice to have] support haddock on specific components, not just
    -- whole packages and the silly --executables etc modifiers.
 
@@ -71,10 +72,10 @@ haddockCommand = Client.installCommand {
 -- "Distribution.Client.ProjectOrchestration"
 --
 haddockAction :: ( ConfigFlags, ConfigExFlags, InstallFlags
-                 , HaddockFlags, TestFlags, BenchmarkFlags )
+                 , HaddockFlags, TestFlags, BenchmarkFlags, () )
                  -> [String] -> GlobalFlags -> IO ()
 haddockAction ( configFlags, configExFlags, installFlags
-              , haddockFlags, testFlags, benchmarkFlags )
+              , haddockFlags, testFlags, benchmarkFlags, () )
                 targetStrings globalFlags = do
 
     baseCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand

cabal-install/Distribution/Client/CmdInstall.hs

@@ -33,11 +33,7 @@ import Distribution.Client.CmdInstall.ClientInstallFlags
 import Distribution.Client.CmdInstall.ClientInstallTargetSelector
 
 import Distribution.Client.Setup
-         ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..)
-         , configureExOptions, haddockOptions, installOptions, testOptions
-         , benchmarkOptions, configureOptions, liftOptions )
-import Distribution.Solver.Types.ConstraintSource
-         ( ConstraintSource(..) )
+         ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..) )
 import Distribution.Client.Types
          ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage
          , SourcePackageDb(..) )
@@ -50,6 +46,8 @@ import Distribution.Client.ProjectConfig
          ( ProjectPackageLocation(..)
          , fetchAndReadSourcePackages
          )
+import Distribution.Client.NixStyleOptions
+         ( NixStyleFlags, nixStyleOptions, defaultNixStyleFlags )
 import Distribution.Client.ProjectConfig.Types
          ( ProjectConfig(..), ProjectConfigShared(..)
          , ProjectConfigBuildOnly(..), PackageConfig(..)
@@ -99,7 +97,7 @@ import Distribution.Simple.Setup
 import Distribution.Solver.Types.SourcePackage
          ( SourcePackage(..) )
 import Distribution.Simple.Command
-         ( CommandUI(..), OptionField(..), usageAlternatives )
+         ( CommandUI(..), usageAlternatives )
 import Distribution.Simple.Configure
          ( configCompilerEx )
 import Distribution.Simple.Compiler
@@ -149,10 +147,7 @@ import System.Directory
 import System.FilePath
          ( (</>), (<.>), takeDirectory, takeBaseName )
 
-installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags
-                            , HaddockFlags, TestFlags, BenchmarkFlags
-                            , ClientInstallFlags
-                            )
+installCommand :: CommandUI (NixStyleFlags ClientInstallFlags)
 installCommand = CommandUI
   { commandName         = "v2-install"
   , commandSynopsis     = "Install packages."
@@ -179,44 +174,9 @@ installCommand = CommandUI
       ++ "    Install the package in the ./pkgfoo directory\n"
 
       ++ cmdCommonHelpTextNewBuildBeta
-  , commandOptions      = \showOrParseArgs ->
-        liftOptions get1 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
-                               ConstraintSourceCommandlineFlag)
-     ++ liftOptions get3 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
-          -- 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 (clientInstallOptions showOrParseArgs)
-  , commandDefaultFlags = ( mempty, mempty, mempty, mempty, mempty, mempty
-                          , defaultClientInstallFlags )
+  , commandOptions      = nixStyleOptions clientInstallOptions
+  , commandDefaultFlags = defaultNixStyleFlags defaultClientInstallFlags
   }
-  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)
-
 
 -- | The @install@ command actually serves four different needs. It installs:
 -- * exes:

cabal-install/Distribution/Client/CmdRepl.hs

@@ -23,6 +23,8 @@ import Distribution.Client.Compat.Prelude
 import Distribution.Compat.Lens
 import qualified Distribution.Types.Lens as L
 
+import Distribution.Client.NixStyleOptions
+         ( NixStyleFlags, nixStyleOptions, defaultNixStyleFlags )
 import Distribution.Client.CmdErrorMessages
 import qualified Distribution.Client.InstallPlan as InstallPlan
 import Distribution.Client.ProjectBuilding
@@ -45,7 +47,7 @@ import Distribution.Simple.Setup
          , fromFlagOrDefault, replOptions
          , Flag(..), toFlag, trueArg, falseArg )
 import Distribution.Simple.Command
-         ( CommandUI(..), liftOption, usageAlternatives, option
+         ( CommandUI(..), liftOptionL, usageAlternatives, option
          , ShowOrParseArgs, OptionField, reqArg )
 import Distribution.Compiler
          ( CompilerFlavor(GHC) )
@@ -144,10 +146,7 @@ envOptions _ =
         ("couldn't parse dependencies: " ++)
         (parsecCommaList parsec)
 
-replCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags
-                         , HaddockFlags, TestFlags, BenchmarkFlags
-                         , ReplFlags, EnvFlags
-                         )
+replCommand :: CommandUI (NixStyleFlags (ReplFlags, EnvFlags))
 replCommand = Client.installCommand {
   commandName         = "v2-repl",
   commandSynopsis     = "Open an interactive session for the given component.",
@@ -185,31 +184,11 @@ replCommand = Client.installCommand {
         ++ "to the default component (or no component if there is no project present)\n"
 
      ++ cmdCommonHelpTextNewBuildBeta,
-  commandDefaultFlags = ( configFlags, configExFlags, installFlags
-                        , haddockFlags, testFlags, benchmarkFlags
-                        , [], defaultEnvFlags
-                        ),
-  commandOptions = \showOrParseArgs ->
-        map liftOriginal (commandOptions Client.installCommand showOrParseArgs)
-        ++ map liftReplOpts (replOptions showOrParseArgs)
-        ++ map liftEnvOpts  (envOptions  showOrParseArgs)
-   }
-  where
-    (configFlags,configExFlags,installFlags,haddockFlags,testFlags,benchmarkFlags)
-      = commandDefaultFlags Client.installCommand
-
-    liftOriginal = liftOption projectOriginal updateOriginal
-    liftReplOpts = liftOption projectReplOpts updateReplOpts
-    liftEnvOpts  = liftOption projectEnvOpts  updateEnvOpts
-
-    projectOriginal              (a,b,c,d,e,f,_,_) = (a,b,c,d,e,f)
-    updateOriginal (a,b,c,d,e,f) (_,_,_,_,_,_,g,h) = (a,b,c,d,e,f,g,h)
-
-    projectReplOpts  (_,_,_,_,_,_,g,_) = g
-    updateReplOpts g (a,b,c,d,e,f,_,h) = (a,b,c,d,e,f,g,h)
-
-    projectEnvOpts  (_,_,_,_,_,_,_,h) = h
-    updateEnvOpts h (a,b,c,d,e,f,g,_) = (a,b,c,d,e,f,g,h)
+  commandDefaultFlags = defaultNixStyleFlags ([], defaultEnvFlags),
+  commandOptions = nixStyleOptions $ \showOrParseArgs ->
+    map (liftOptionL _1) (replOptions showOrParseArgs) ++
+    map (liftOptionL _2) (envOptions showOrParseArgs)
+  }
 
 -- | The @repl@ command is very much like @build@. It brings the install plan
 -- up to date, selects that part of the plan needed by the given or implicit
@@ -224,11 +203,11 @@ replCommand = Client.installCommand {
 --
 replAction :: ( ConfigFlags, ConfigExFlags, InstallFlags
               , HaddockFlags, TestFlags, BenchmarkFlags
-              , ReplFlags, EnvFlags )
+              , (ReplFlags, EnvFlags) )
            -> [String] -> GlobalFlags -> IO ()
 replAction ( configFlags, configExFlags, installFlags
            , haddockFlags, testFlags, benchmarkFlags
-           , replFlags, envFlags )
+           , (replFlags, envFlags) )
            targetStrings globalFlags = do
     let
       ignoreProject = fromFlagOrDefault False (envIgnoreProject envFlags)

cabal-install/Distribution/Client/CmdRun.hs

@@ -25,18 +25,16 @@ import Distribution.Client.CmdErrorMessages
 
 import Distribution.Client.CmdRun.ClientRunFlags
 
+import Distribution.Client.NixStyleOptions
+         ( NixStyleFlags, nixStyleOptions, defaultNixStyleFlags )
 import Distribution.Client.Setup
-         ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..)
-         , configureExOptions, haddockOptions, installOptions, testOptions
-         , benchmarkOptions, configureOptions, liftOptions )
-import Distribution.Solver.Types.ConstraintSource
-         ( ConstraintSource(..) )
+         ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..) )
 import Distribution.Client.GlobalFlags
          ( defaultGlobalFlags )
 import Distribution.Simple.Setup
          ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault )
 import Distribution.Simple.Command
-         ( CommandUI(..), OptionField (..), usageAlternatives )
+         ( CommandUI(..), usageAlternatives )
 import Distribution.Types.ComponentName
          ( showComponentName )
 import Distribution.Deprecated.Text
@@ -109,10 +107,7 @@ import System.FilePath
          ( (</>), isValid, isPathSeparator, takeExtension )
 
 
-runCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags
-                        , HaddockFlags, TestFlags, BenchmarkFlags
-                        , ClientRunFlags
-                        )
+runCommand :: CommandUI (NixStyleFlags ClientRunFlags)
 runCommand = CommandUI
   { commandName         = "v2-run"
   , commandSynopsis     = "Run an executable."
@@ -148,37 +143,9 @@ runCommand = CommandUI
       ++ "    Build with '-O2' and run the program, passing it extra arguments.\n\n"
 
       ++ cmdCommonHelpTextNewBuildBeta
-  , commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty, mempty)
-  , commandOptions      = \showOrParseArgs ->
-          liftOptions get1 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 ConstraintSourceCommandlineFlag)
-      ++ liftOptions get3 set3
-          -- hide "target-package-db" flag from the
-          -- install options.
-          (filter ((`notElem` ["target-package-db"])
-                   . optionName) $
-                                 installOptions     showOrParseArgs)
-      ++ liftOptions get4 set4 (haddockOptions     showOrParseArgs)
-      ++ liftOptions get5 set5 (testOptions        showOrParseArgs)
-      ++ liftOptions get6 set6 (benchmarkOptions   showOrParseArgs)
-      ++ liftOptions get7 set7 (clientRunOptions showOrParseArgs)
+  , commandDefaultFlags = defaultNixStyleFlags mempty
+  , commandOptions      = nixStyleOptions clientRunOptions
   }
-  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)
-
 
 -- | The @run@ command runs a specified executable-like component, building it
 -- first if necessary. The component can be either an executable, a test,

cabal-install/Distribution/Client/NixStyleOptions.hs

@@ -0,0 +1,63 @@
+-- | Command line options for nix-style / v2 commands.
+--
+-- The commands take a lot of the same options, which affect how install plan
+-- is constructed.
+module Distribution.Client.NixStyleOptions (
+    NixStyleFlags, nixStyleOptions, defaultNixStyleFlags,
+) where
+
+import Distribution.Client.Compat.Prelude
+import Prelude ()
+
+import Distribution.Simple.Command                       (OptionField (..), ShowOrParseArgs)
+import Distribution.Simple.Setup                         (BenchmarkFlags, HaddockFlags, TestFlags)
+import Distribution.Solver.Types.ConstraintSource        (ConstraintSource (..))
+
+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)
+
+nixStyleOptions
+    :: (ShowOrParseArgs -> [OptionField a])
+    -> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
+nixStyleOptions commandOptions showOrParseArgs =
+        liftOptions get1 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
+                               ConstraintSourceCommandlineFlag)
+     ++ liftOptions get3 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
+          -- 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)
+  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)
+
+defaultNixStyleFlags :: a ->  NixStyleFlags a
+defaultNixStyleFlags x = ( mempty, mempty, mempty, mempty, mempty, mempty, x )

cabal-install/cabal-install.cabal

@@ -220,6 +220,7 @@ executable cabal
         Distribution.Client.Manpage
         Distribution.Client.ManpageFlags
         Distribution.Client.Nix
+        Distribution.Client.NixStyleOptions
         Distribution.Client.Outdated
         Distribution.Client.PackageHash
         Distribution.Client.PackageUtils

cabal-install/cabal-install.cabal.pp

@@ -159,6 +159,7 @@
         Distribution.Client.Manpage
         Distribution.Client.ManpageFlags
         Distribution.Client.Nix
+        Distribution.Client.NixStyleOptions
         Distribution.Client.Outdated
         Distribution.Client.PackageHash
         Distribution.Client.PackageUtils