Merge pull request #5789 from mpilgrem/fix1369

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

Author: mpilgrem

ChangeLog.md

@@ -31,6 +31,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)
 * Add the possibility of a `sh` script to customise fully GHC installation. See
   [#5585](https://github.com/commercialhaskell/stack/pull/5585)
 * `tools` subcommand added to `stack ls`, to list stack's installed tools.

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"