Make most v2- commands respect verbose setting

Issue haskell#5956
bacchanalia · Feb 21, 2022 · a95da36 · a95da36
1 parent 9a104a9
commit a95da36
Show file tree

Hide file tree

Showing 2 changed files with 39 additions and 12 deletions.
diff --git a/cabal-install/main/Main.hs b/cabal-install/main/Main.hs
@@ -248,17 +248,17 @@ mainWorker args = do
       , regularCmd CmdListBin.listbinCommand     CmdListBin.listbinAction
 
       ] ++ concat
-      [ newCmd  CmdConfigure.configureCommand CmdConfigure.configureAction
-      , newCmd  CmdUpdate.updateCommand       CmdUpdate.updateAction
-      , newCmd  CmdBuild.buildCommand         CmdBuild.buildAction
-      , newCmd  CmdRepl.replCommand           CmdRepl.replAction
-      , newCmd  CmdFreeze.freezeCommand       CmdFreeze.freezeAction
-      , newCmd  CmdHaddock.haddockCommand     CmdHaddock.haddockAction
-      , newCmd  CmdInstall.installCommand     CmdInstall.installAction
-      , newCmd  CmdRun.runCommand             CmdRun.runAction
-      , newCmd  CmdTest.testCommand           CmdTest.testAction
-      , newCmd  CmdBench.benchCommand         CmdBench.benchAction
-      , newCmd  CmdExec.execCommand           CmdExec.execAction
+      [ newCmdWithVerbosity  CmdConfigure.configureCommand CmdConfigure.configureAction
+      , newCmdWithVerbosity  CmdUpdate.updateCommand       CmdUpdate.updateAction
+      , newCmdWithVerbosity  CmdBuild.buildCommand         CmdBuild.buildAction
+      , newCmdWithVerbosity  CmdRepl.replCommand           CmdRepl.replAction
+      , newCmdWithVerbosity  CmdFreeze.freezeCommand       CmdFreeze.freezeAction
+      , newCmdWithVerbosity  CmdHaddock.haddockCommand     CmdHaddock.haddockAction
+      , newCmdWithVerbosity  CmdInstall.installCommand     CmdInstall.installAction
+      , newCmdWithVerbosity  CmdRun.runCommand             CmdRun.runAction
+      , newCmdWithVerbosity  CmdTest.testCommand           CmdTest.testAction
+      , newCmdWithVerbosity  CmdBench.benchCommand         CmdBench.benchAction
+      , newCmdWithVerbosity  CmdExec.execCommand           CmdExec.execAction
       , newCmd  CmdClean.cleanCommand         CmdClean.cleanAction
       , newCmd  CmdSdist.sdistCommand         CmdSdist.sdistAction
 

diff --git a/cabal-install/src/Distribution/Client/CmdLegacy.hs b/cabal-install/src/Distribution/Client/CmdLegacy.hs
@@ -2,11 +2,20 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns #-}
-module Distribution.Client.CmdLegacy ( legacyCmd, legacyWrapperCmd, newCmd ) where
+module Distribution.Client.CmdLegacy ( legacyCmd, legacyWrapperCmd, newCmd, newCmdWithVerbosity ) where
 
 import Prelude ()
 import Distribution.Client.Compat.Prelude
 
+
+import Distribution.Client.NixStyleOptions
+    ( NixStyleFlags(..) )
+import Distribution.Client.ProjectConfig
+    ( ProjectConfig(..), ProjectConfigBuildOnly(..), ProjectConfigShared(..), withProjectOrGlobalConfig )
+import Distribution.Client.ProjectOrchestration
+    ( CurrentCommand(..), ProjectBaseContext(..), commandLineFlagsToProjectConfig, establishProjectBaseContext )
+import Distribution.Client.ProjectFlags
+    ( flagIgnoreProject )
 import Distribution.Client.Sandbox
     ( loadConfigOrSandboxConfig, findSavedDistPref )
 import qualified Distribution.Client.Setup as Client
@@ -142,3 +151,21 @@ newCmd origUi@CommandUI{..} action = [cmd defaultUi, cmd newUi, cmd origUi]
             , commandDescription = (defaultMsg .) <$> commandDescription
             , commandNotes = (defaultMsg .) <$> commandNotes
             }
+
+-- | Create a CommandSpec for a new-style command with the config verbosity.
+newCmdWithVerbosity :: CommandUI (NixStyleFlags a) -> (NixStyleFlags a -> [String] -> Client.GlobalFlags -> IO action) -> [CommandSpec (Client.GlobalFlags -> IO action)]
+newCmdWithVerbosity cmd action = newCmd cmd $ \flags args globals -> do
+  let flagVerbosity    = Client.configVerbosity . configFlags $ flags
+      verbosity0       = Setup.fromFlagOrDefault normal flagVerbosity
+      ignoreProject    = flagIgnoreProject . projectFlags $ flags
+      cliConfig        = commandLineFlagsToProjectConfig globals flags mempty
+      globalConfigFlag = projectConfigConfigFile . projectConfigShared $ cliConfig
+      with = do
+        ctx <- establishProjectBaseContext verbosity0 cliConfig OtherCommand
+        let projectVerbosity = projectConfigVerbosity . projectConfigBuildOnly . projectConfig $ ctx
+        return flags{ configFlags = (configFlags flags){ Client.configVerbosity = projectVerbosity <> flagVerbosity } }
+      without globalConfig = do
+        let globalVerbosity = projectConfigVerbosity . projectConfigBuildOnly $ globalConfig
+        return flags{ configFlags = (configFlags flags){ Client.configVerbosity = globalVerbosity <> flagVerbosity } }
+  flags' <- withProjectOrGlobalConfig verbosity0 ignoreProject globalConfigFlag with without
+  action flags' args globals