Fix #1369 Add build option --cabal-verbosity=VERBOSITY

Retains the existing `--[no-]cabal-verbose`, as an alternative flag on the command line.

As with the existing flag, the new option can be set in configuration files. The new option has priority in configuration files.

Error messages are provided if the specified verbosity is not recognised by Cabal (the library).

The `ChangeLog.md` and documentation are updated accordingly.

Unit tests are updated accordingly.

Tested by building Stack and using it with various combinations of options at the command line and/or in a `stack.yaml` file.

Author: mpilgrem

ChangeLog.md

@@ -32,6 +32,9 @@ Other enhancements:
 * Fuller help is provided at the command line if a subcommand is missing (for
   example, `stack ls` now yields the equivalent of `stack ls --help`). See
   [#809](https://github.com/commercialhaskell/stack/issues/809)
+* Add build option `--cabal-verbosity=VERBOSITY` to specify the Cabal verbosity
+  level (the option accepts Cabal's numerical and extended syntax).
+  See [#1369](https://github.com/commercialhaskell/stack/issues/809)
 
 Bug fixes:
 

doc/yaml_configuration.md

@@ -864,6 +864,7 @@ build:
     no-run-benchmarks: false
   force-dirty: false
   reconfigure: false
+  cabal-verbosity: normal
   cabal-verbose: false
   split-objs: false
 

src/Stack/Build/Execute.hs

@@ -60,6 +60,7 @@ import           Distribution.System            (OS (Windows),
 import qualified Distribution.Text as C
 import           Distribution.Types.PackageName (mkPackageName)
 import           Distribution.Types.UnqualComponentName (mkUnqualComponentName)
+import           Distribution.Verbosity (showForCabal)
 import           Distribution.Version (mkVersion)
 import           Path
 import           Path.CheckInstall
@@ -1355,7 +1356,10 @@ withSingleContext ActionContext {..} ee@ExecuteEnv {..} task@Task {..} allDeps m
                             liftIO $ atomicModifyIORef' eeCustomBuilt $
                                 \oldCustomBuilt -> (Set.insert (packageName package) oldCustomBuilt, ())
                             return outputFile
-            runExe exeName $ (if boptsCabalVerbose eeBuildOpts then ("--verbose":) else id) setupArgs
+            let cabalVerboseArg =
+                  let CabalVerbosity cv = boptsCabalVerbose eeBuildOpts
+                  in  "--verbose=" <> showForCabal cv
+            runExe exeName $ cabalVerboseArg:setupArgs
 
 -- Implements running a package's build, used to implement 'ATBuild' and
 -- 'ATBuildFinal' tasks.  In particular this does the following:

src/Stack/Config/Build.hs

@@ -6,6 +6,7 @@ module Stack.Config.Build where
 
 import           Stack.Prelude
 import           Stack.Types.Config
+import           Distribution.Verbosity   (normal)
 
 -- | Interprets BuildOptsMonoid options.
 buildOptsFromMonoid :: BuildOptsMonoid -> BuildOpts
@@ -41,7 +42,7 @@ buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts
     , boptsBenchmarkOpts =
           benchmarkOptsFromMonoid buildMonoidBenchmarkOpts additionalArgs
     , boptsReconfigure = fromFirstFalse buildMonoidReconfigure
-    , boptsCabalVerbose = fromFirstFalse buildMonoidCabalVerbose
+    , boptsCabalVerbose = fromFirst (CabalVerbosity normal) buildMonoidCabalVerbose
     , boptsSplitObjs = fromFirstFalse buildMonoidSplitObjs
     , boptsSkipComponents = buildMonoidSkipComponents
     , boptsInterleavedOutput = fromFirstTrue buildMonoidInterleavedOutput

src/Stack/Options/BuildMonoidParser.hs

@@ -3,9 +3,10 @@
 module Stack.Options.BuildMonoidParser where
 
 import qualified Data.Text as T
+import           Distribution.Parsec (eitherParsec)
 import           Options.Applicative
 import           Options.Applicative.Builder.Extra
-import           Stack.Build                       (splitObjsWarning)
+import           Stack.Build (splitObjsWarning)
 import           Stack.Prelude
 import           Stack.Options.BenchParser
 import           Stack.Options.TestParser
@@ -155,11 +156,7 @@ buildOptsMonoidParser hide0 =
              "reconfigure"
              "Perform the configure step even if unnecessary. Useful in some corner cases with custom Setup.hs files"
             hide
-    cabalVerbose =
-        firstBoolFlagsFalse
-            "cabal-verbose"
-            "Ask Cabal to be verbose in its output"
-            hide
+    cabalVerbose = cabalVerbosityOptsParser hideBool
     splitObjs =
         firstBoolFlagsFalse
             "split-objs"
@@ -183,3 +180,27 @@ buildOptsMonoidParser hide0 =
                 (long "ddump-dir" <>
                  help "Specify output ddump-files" <>
                  hide))
+
+-- | Parser for Cabal verbosity options
+cabalVerbosityOptsParser :: Bool -> Parser (First CabalVerbosity)
+cabalVerbosityOptsParser hide =
+  cabalVerbosityParser hide <|> cabalVerboseParser hide
+
+-- | Parser for Cabal verbosity option
+cabalVerbosityParser :: Bool -> Parser (First CabalVerbosity)
+cabalVerbosityParser hide =
+  let pCabalVerbosity = option (eitherReader eitherParsec)
+         (  long "cabal-verbosity"
+         <> metavar "VERBOSITY"
+         <> help "Cabal verbosity (accepts Cabal's numerical and extended syntax)"
+         <> hideMods hide)
+  in  First . Just <$> pCabalVerbosity
+
+-- | Parser for the Cabal verbose flag, retained for backward compatibility
+cabalVerboseParser :: Bool -> Parser (First CabalVerbosity)
+cabalVerboseParser hide =
+  let pVerboseFlag = firstBoolFlagsFalse
+                       "cabal-verbose"
+                       "Ask Cabal to be verbose in its output"
+                       (hideMods hide)
+  in  toFirstCabalVerbosity <$> pVerboseFlag

src/Stack/Types/Config/Build.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP               #-}
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -27,12 +28,27 @@ module Stack.Types.Config.Build
     , BuildSubset(..)
     , ApplyCLIFlag (..)
     , boptsCLIFlagsByName
+    , CabalVerbosity (..)
+    , toFirstCabalVerbosity
     )
     where
 
-import           Pantry.Internal.AesonExtended
 import qualified Data.Map.Strict as Map
+import qualified Data.Text as T
+#if MIN_VERSION_Cabal(3,4,0)
+import           Distribution.Parsec (Parsec (..), simpleParsec)
+import           Distribution.Verbosity (Verbosity, normal, verbose)
+#else
+import qualified Distribution.Compat.CharParsing as P
+import           Distribution.Parsec (CabalParsing(..), Parsec (..)
+                   , simpleParsec)
+import           Distribution.Utils.Generic (isAsciiAlpha)
+import           Distribution.Verbosity (Verbosity, deafening, intToVerbosity
+                   , normal, silent, verbose, verboseCallSite, verboseCallStack
+                   , verboseMarkOutput, verboseNoWrap, verboseTimestamp)
+#endif
 import           Generics.Deriving.Monoid (memptydefault, mappenddefault)
+import           Pantry.Internal.AesonExtended
 import           Stack.Prelude
 
 -- | Build options that is interpreted by the build command.
@@ -82,7 +98,7 @@ data BuildOpts =
             -- ^ Only perform the configure step when building
             ,boptsReconfigure :: !Bool
             -- ^ Perform the configure step even if already configured
-            ,boptsCabalVerbose :: !Bool
+            ,boptsCabalVerbose :: !CabalVerbosity
             -- ^ Ask Cabal to be verbose in its builds
             ,boptsSplitObjs :: !Bool
             -- ^ Whether to enable split-objs.
@@ -118,7 +134,7 @@ defaultBuildOpts = BuildOpts
     , boptsBenchmarks = defaultFirstFalse buildMonoidBenchmarks
     , boptsBenchmarkOpts = defaultBenchmarkOpts
     , boptsReconfigure = defaultFirstFalse buildMonoidReconfigure
-    , boptsCabalVerbose = defaultFirstFalse buildMonoidCabalVerbose
+    , boptsCabalVerbose = CabalVerbosity normal
     , boptsSplitObjs = defaultFirstFalse buildMonoidSplitObjs
     , boptsSkipComponents = []
     , boptsInterleavedOutput = defaultFirstTrue buildMonoidInterleavedOutput
@@ -209,7 +225,7 @@ data BuildOptsMonoid = BuildOptsMonoid
     , buildMonoidBenchmarks :: !FirstFalse
     , buildMonoidBenchmarkOpts :: !BenchmarkOptsMonoid
     , buildMonoidReconfigure :: !FirstFalse
-    , buildMonoidCabalVerbose :: !FirstFalse
+    , buildMonoidCabalVerbose :: !(First CabalVerbosity)
     , buildMonoidSplitObjs :: !FirstFalse
     , buildMonoidSkipComponents :: ![Text]
     , buildMonoidInterleavedOutput :: !FirstTrue
@@ -242,7 +258,9 @@ instance FromJSON (WithJSONWarnings BuildOptsMonoid) where
               buildMonoidBenchmarks <- FirstFalse <$> o ..:? buildMonoidBenchmarksArgName
               buildMonoidBenchmarkOpts <- jsonSubWarnings (o ..:? buildMonoidBenchmarkOptsArgName ..!= mempty)
               buildMonoidReconfigure <- FirstFalse <$> o ..:? buildMonoidReconfigureArgName
-              buildMonoidCabalVerbose <- FirstFalse <$> o ..:? buildMonoidCabalVerboseArgName
+              cabalVerbosity <- First <$> o ..:? buildMonoidCabalVerbosityArgName
+              cabalVerbose <- FirstFalse <$> o ..:? buildMonoidCabalVerboseArgName
+              let buildMonoidCabalVerbose = cabalVerbosity <> toFirstCabalVerbosity cabalVerbose
               buildMonoidSplitObjs <- FirstFalse <$> o ..:? buildMonoidSplitObjsName
               buildMonoidSkipComponents <- o ..:? buildMonoidSkipComponentsName ..!= mempty
               buildMonoidInterleavedOutput <- FirstTrue <$> o ..:? buildMonoidInterleavedOutputName
@@ -312,6 +330,9 @@ buildMonoidBenchmarkOptsArgName = "benchmark-opts"
 buildMonoidReconfigureArgName :: Text
 buildMonoidReconfigureArgName = "reconfigure"
 
+buildMonoidCabalVerbosityArgName :: Text
+buildMonoidCabalVerbosityArgName = "cabal-verbosity"
+
 buildMonoidCabalVerboseArgName :: Text
 buildMonoidCabalVerboseArgName = "cabal-verbose"
 
@@ -477,3 +498,71 @@ data FileWatchOpts
   | FileWatch
   | FileWatchPoll
   deriving (Show,Eq)
+
+newtype CabalVerbosity = CabalVerbosity Verbosity
+  deriving (Eq, Show)
+
+toFirstCabalVerbosity :: FirstFalse -> First CabalVerbosity
+toFirstCabalVerbosity vf = First $ getFirstFalse vf <&> \p ->
+  if p then verboseLevel else normalLevel
+ where
+  verboseLevel = CabalVerbosity verbose
+  normalLevel  = CabalVerbosity normal
+
+instance FromJSON CabalVerbosity where
+
+  parseJSON = withText "CabalVerbosity" $ \t ->
+    let s = T.unpack t
+        errMsg = fail $ "Unrecognised Cabal verbosity: " ++ s
+    in  maybe errMsg pure (simpleParsec s)
+
+instance Parsec CabalVerbosity where
+
+-- The Cabal package does not provide a Verbosity instance of Parsec before
+-- Cabal-3.4.0.0. The code below is adapted from the instance provided in
+-- Cabal-3.4.0.0.
+#if MIN_VERSION_Cabal(3,4,0)
+
+  parsec = CabalVerbosity <$> parsec
+
+#else
+
+  parsec = CabalVerbosity <$> parsecVerbosity
+
+parsecVerbosity :: CabalParsing m => m Verbosity
+parsecVerbosity = parseIntVerbosity <|> parseStringVerbosity
+ where
+  parseIntVerbosity = do
+    i <- P.integral
+    case intToVerbosity i of
+      Just v  -> return v
+      Nothing -> P.unexpected $ "Bad integral verbosity: " ++ show i ++
+                   ". Valid values are 0..3"
+
+  parseStringVerbosity = do
+    level <- parseVerbosityLevel
+    _ <- P.spaces
+    flags <- many (parseFlag <* P.spaces)
+    return $ foldl' (flip ($)) level flags
+
+  parseVerbosityLevel = do
+    token <- P.munch1 isAsciiAlpha
+    case token of
+      "silent"    -> return silent
+      "normal"    -> return normal
+      "verbose"   -> return verbose
+      "debug"     -> return deafening
+      "deafening" -> return deafening
+      _           -> P.unexpected $ "Bad verbosity level: " ++ token
+
+  parseFlag = do
+    _ <- P.char '+'
+    token <- P.munch1 isAsciiAlpha
+    case token of
+      "callsite"   -> return verboseCallSite
+      "callstack"  -> return verboseCallStack
+      "nowrap"     -> return verboseNoWrap
+      "markoutput" -> return verboseMarkOutput
+      "timestamp"  -> return verboseTimestamp
+      _            -> P.unexpected $ "Bad verbosity flag: " ++ token
+#endif

src/test/Stack/ConfigSpec.hs

@@ -6,6 +6,7 @@
 module Stack.ConfigSpec where
 
 import Control.Arrow
+import Distribution.Verbosity (verbose)
 import Pantry.Internal.AesonExtended
 import Data.Yaml
 import Pantry.Internal (pcHpackExecutable)
@@ -182,7 +183,7 @@ spec = beforeAll setup $ do
       boptsBenchmarkOpts `shouldBe` BenchmarkOpts {beoAdditionalArgs = Just "-O2"
                                                    ,beoDisableRun = True}
       boptsReconfigure `shouldBe` True
-      boptsCabalVerbose `shouldBe` True
+      boptsCabalVerbose `shouldBe` CabalVerbosity verbose
 
     it "finds the config file in a parent directory" $ inTempDir $ do
       writeFile "package.yaml" "name: foo"