Add stderr Verbosity modifier

Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs

@@ -308,7 +308,17 @@ instance Arbitrary FlagAssignment where
 -------------------------------------------------------------------------------
 
 instance Arbitrary Verbosity where
-    arbitrary = elements [minBound..maxBound]
+    arbitrary = do
+        v <- elements [minBound..maxBound]
+        -- verbose markoutput is left out on purpose
+        flags <- listOf $ elements
+            [ verboseCallSite
+            , verboseCallStack
+            , verboseNoWrap
+            , verboseTimestamp
+            , verboseStderr
+            ]
+        return (foldr ($) v flags)
 
 -------------------------------------------------------------------------------
 -- SourceRepo

Cabal/Cabal-described/src/Distribution/Described.hs

@@ -95,6 +95,7 @@ import Distribution.Types.SourceRepo               (RepoType)
 import Distribution.Types.TestType                 (TestType)
 import Distribution.Types.UnitId                   (UnitId)
 import Distribution.Types.UnqualComponentName      (UnqualComponentName)
+import Distribution.Verbosity                      (Verbosity)
 import Distribution.Version                        (Version, VersionRange)
 import Language.Haskell.Extension                  (Extension, Language)
 
@@ -485,6 +486,15 @@ instance Described RepoType where
 instance Described TestType where
     describe _ = REUnion ["exitcode-stdio-1.0", "detailed-0.9"]
 
+instance Described Verbosity where
+    describe _ = REUnion
+        [ REUnion ["0", "1", "2", "3"]
+        , REUnion ["silent", "normal", "verbose", "debug", "deafening"]
+          <> REMunch reEps (RESpaces <> "+" <>
+            -- markoutput is left out on purpose
+            REUnion ["callsite", "callstack", "nowrap", "timestamp", "stderr", "stdout" ])
+        ]
+
 instance Described Version where
     describe _ = REMunch1 reDot reDigits where
         reDigits = REUnion

Cabal/Distribution/Simple/Utils.hs

@@ -227,7 +227,7 @@ import System.FilePath as FilePath
     , splitDirectories, searchPathSeparator )
 import System.IO
     ( Handle, hSetBinaryMode, hGetContents, stderr, stdout, hPutStr, hFlush
-    , hClose, hSetBuffering, BufferMode(..) )
+    , hClose, hSetBuffering, BufferMode(..), hPutStrLn )
 import System.IO.Error
 import System.IO.Unsafe
     ( unsafeInterleaveIO )
@@ -431,6 +431,11 @@ displaySomeException se =
 topHandler :: IO a -> IO a
 topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog
 
+verbosityHandle :: Verbosity -> Handle
+verbosityHandle verbosity
+    | isVerboseStderr verbosity = stderr
+    | otherwise                 = stdout
+
 -- | Non fatal conditions that may be indicative of an error or problem.
 --
 -- We display these at the 'normal' verbosity level.
@@ -454,29 +459,35 @@ warn verbosity msg = withFrozenCallStack $ do
 notice :: Verbosity -> String -> IO ()
 notice verbosity msg = withFrozenCallStack $ do
   when (verbosity >= normal) $ do
+    let h = verbosityHandle verbosity
     ts <- getPOSIXTime
-    hPutStr stdout . withMetadata ts NormalMark FlagTrace verbosity
-                   . wrapTextVerbosity verbosity
-                   $ msg
+    hPutStr h
+        $ withMetadata ts NormalMark FlagTrace verbosity
+        $ wrapTextVerbosity verbosity
+        $ msg
 
 -- | Display a message at 'normal' verbosity level, but without
 -- wrapping.
 --
 noticeNoWrap :: Verbosity -> String -> IO ()
 noticeNoWrap verbosity msg = withFrozenCallStack $ do
   when (verbosity >= normal) $ do
+    let h = verbosityHandle verbosity
     ts <- getPOSIXTime
-    hPutStr stdout . withMetadata ts NormalMark FlagTrace verbosity $ msg
+    hPutStr h . withMetadata ts NormalMark FlagTrace verbosity $ msg
 
 -- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity
 -- level.  Use this if you need fancy formatting.
 --
 noticeDoc :: Verbosity -> Disp.Doc -> IO ()
 noticeDoc verbosity msg = withFrozenCallStack $ do
   when (verbosity >= normal) $ do
+    let h = verbosityHandle verbosity
     ts <- getPOSIXTime
-    hPutStr stdout . withMetadata ts NormalMark FlagTrace verbosity
-                   . Disp.renderStyle defaultStyle $ msg
+    hPutStr h
+        $ withMetadata ts NormalMark FlagTrace verbosity
+        $ Disp.renderStyle defaultStyle
+        $ msg
 
 -- | Display a "setup status message".  Prefer using setupMessage'
 -- if possible.
@@ -492,17 +503,21 @@ setupMessage verbosity msg pkgid = withFrozenCallStack $ do
 info :: Verbosity -> String -> IO ()
 info verbosity msg = withFrozenCallStack $
   when (verbosity >= verbose) $ do
+    let h = verbosityHandle verbosity
     ts <- getPOSIXTime
-    hPutStr stdout . withMetadata ts NeverMark FlagTrace verbosity
-                   . wrapTextVerbosity verbosity
-                   $ msg
+    hPutStr h
+        $ withMetadata ts NeverMark FlagTrace verbosity
+        $ wrapTextVerbosity verbosity
+        $ msg
 
 infoNoWrap :: Verbosity -> String -> IO ()
 infoNoWrap verbosity msg = withFrozenCallStack $
   when (verbosity >= verbose) $ do
+    let h = verbosityHandle verbosity
     ts <- getPOSIXTime
-    hPutStr stdout . withMetadata ts NeverMark FlagTrace verbosity
-                   $ msg
+    hPutStr h
+        $ withMetadata ts NeverMark FlagTrace verbosity
+        $ msg
 
 -- | Detailed internal debugging information
 --
@@ -511,10 +526,11 @@ infoNoWrap verbosity msg = withFrozenCallStack $
 debug :: Verbosity -> String -> IO ()
 debug verbosity msg = withFrozenCallStack $
   when (verbosity >= deafening) $ do
+    let h = verbosityHandle verbosity
     ts <- getPOSIXTime
-    hPutStr stdout . withMetadata ts NeverMark FlagTrace verbosity
-                   . wrapTextVerbosity verbosity
-                   $ msg
+    hPutStr h $ withMetadata ts NeverMark FlagTrace verbosity
+              $ wrapTextVerbosity verbosity
+              $ msg
     -- ensure that we don't lose output if we segfault/infinite loop
     hFlush stdout
 
@@ -523,9 +539,11 @@ debug verbosity msg = withFrozenCallStack $
 debugNoWrap :: Verbosity -> String -> IO ()
 debugNoWrap verbosity msg = withFrozenCallStack $
   when (verbosity >= deafening) $ do
+    let h = verbosityHandle verbosity
     ts <- getPOSIXTime
-    hPutStr stdout . withMetadata ts NeverMark FlagTrace verbosity
-                   $ msg
+    hPutStr h
+        $ withMetadata ts NeverMark FlagTrace verbosity
+        $ msg
     -- ensure that we don't lose output if we segfault/infinite loop
     hFlush stdout
 
@@ -536,7 +554,7 @@ chattyTry :: String  -- ^ a description of the action we were attempting
           -> IO ()
 chattyTry desc action =
   catchIO action $ \exception ->
-    putStrLn $ "Error while " ++ desc ++ ": " ++ show exception
+    hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception
 
 -- | Run an IO computation, returning @e@ if it raises a "file
 -- does not exist" error.

Cabal/Distribution/Verbosity.hs

@@ -48,6 +48,10 @@ module Distribution.Verbosity (
   -- * timestamps
   verboseTimestamp, isVerboseTimestamp,
   verboseNoTimestamp,
+
+  -- * Stderr
+  verboseStderr, isVerboseStderr,
+  verboseNoStderr,
   ) where
 
 import Prelude ()
@@ -57,10 +61,13 @@ import Distribution.ReadE
 
 import Data.List (elemIndex)
 import Distribution.Parsec
+import Distribution.Pretty
 import Distribution.Verbosity.Internal
+import Distribution.Utils.Generic (isAsciiAlpha)
 
 import qualified Data.Set as Set
 import qualified Distribution.Compat.CharParsing as P
+import qualified Text.PrettyPrint as PP
 
 data Verbosity = Verbosity {
     vLevel :: VerbosityLevel,
@@ -146,74 +153,94 @@ intToVerbosity _ = Nothing
 -- | Parser verbosity
 --
 -- >>> explicitEitherParsec parsecVerbosity "normal"
--- Right (Right (Verbosity {vLevel = Normal, vFlags = fromList [], vQuiet = False}))
+-- Right (Verbosity {vLevel = Normal, vFlags = fromList [], vQuiet = False})
 --
 -- >>> explicitEitherParsec parsecVerbosity "normal+nowrap  "
--- Right (Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap], vQuiet = False}))
+-- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap], vQuiet = False})
 --
 -- >>> explicitEitherParsec parsecVerbosity "normal+nowrap +markoutput"
--- Right (Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}))
+-- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False})
 --
 -- >>> explicitEitherParsec parsecVerbosity "normal +nowrap +markoutput"
--- Right (Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}))
+-- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False})
 --
 -- >>> explicitEitherParsec parsecVerbosity "normal+nowrap+markoutput"
--- Right (Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}))
+-- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False})
+--
+-- >>> explicitEitherParsec parsecVerbosity "deafening+nowrap+stdout+stderr+callsite+callstack"
+-- Right (Verbosity {vLevel = Deafening, vFlags = fromList [VCallStack,VCallSite,VNoWrap,VStderr], vQuiet = False})
 --
 -- /Note:/ this parser will eat trailing spaces.
 --
-parsecVerbosity :: CabalParsing m => m (Either Int Verbosity)
+instance Parsec Verbosity where
+    parsec = parsecVerbosity
+
+instance Pretty Verbosity where
+    pretty = PP.text . showForCabal
+
+parsecVerbosity :: CabalParsing m => m Verbosity
 parsecVerbosity = parseIntVerbosity <|> parseStringVerbosity
   where
-    parseIntVerbosity = fmap Left P.integral
-    parseStringVerbosity = fmap Right $ do
+    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
-        extras <- many (parseExtra <* P.spaces)
-        return (foldr (.) id extras (mkVerbosity level))
-    parseVerbosityLevel = P.choice
-        [ P.string "silent" >> return Silent
-        , P.string "normal" >> return Normal
-        , P.string "verbose" >> return Verbose
-        , P.string "debug"  >> return Deafening
-        , P.string "deafening" >> return Deafening
-        ]
-    parseExtra = P.char '+' >> P.choice
-        [ P.string "callsite"  >> return verboseCallSite
-        , P.string "callstack" >> return verboseCallStack
-        , P.string "nowrap"    >> return verboseNoWrap
-        , P.string "markoutput" >> return verboseMarkOutput
-        , P.string "timestamp" >> return verboseTimestamp
-        ]
+        flags <- many (parseFlag <* P.spaces)
+        return $ foldl' (flip ($)) (mkVerbosity 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
+            "stderr"     -> return verboseStderr
+            "stdout"     -> return verboseNoStderr
+            _            -> P.unexpected $ "Bad verbosity flag: " ++ token
 
 flagToVerbosity :: ReadE Verbosity
-flagToVerbosity = parsecToReadE id $ do
-    e <- parsecVerbosity
-    case e of
-       Right v -> return v
-       Left i -> case intToVerbosity i of
-           Just v  -> return v
-           Nothing -> fail $ "Bad verbosity: " ++ show i ++ ". Valid values are 0..3"
-
-showForCabal, showForGHC :: Verbosity -> String
+flagToVerbosity = parsecToReadE id parsecVerbosity
 
+showForCabal :: Verbosity -> String
 showForCabal v
     | Set.null (vFlags v)
     = maybe (error "unknown verbosity") show $
         elemIndex v [silent,normal,verbose,deafening]
     | otherwise
-    = unwords $ (case vLevel v of
-                    Silent -> "silent"
-                    Normal -> "normal"
-                    Verbose -> "verbose"
-                    Deafening -> "debug")
-              : concatMap showFlag (Set.toList (vFlags v))
+    = unwords
+        $ showLevel (vLevel v)
+        : concatMap showFlag (Set.toList (vFlags v))
   where
+    showLevel Silent    = "silent"
+    showLevel Normal    = "normal"
+    showLevel Verbose   = "verbose"
+    showLevel Deafening = "debug"
+
     showFlag VCallSite   = ["+callsite"]
     showFlag VCallStack  = ["+callstack"]
     showFlag VNoWrap     = ["+nowrap"]
     showFlag VMarkOutput = ["+markoutput"]
     showFlag VTimestamp  = ["+timestamp"]
+    showFlag VStderr     = ["+stderr"]
+
+showForGHC :: Verbosity -> String
 showForGHC   v = maybe (error "unknown verbosity") show $
     elemIndex v [silent,normal,__,verbose,deafening]
         where __ = silent -- this will be always ignored by elemIndex
@@ -251,6 +278,14 @@ verboseTimestamp = verboseFlag VTimestamp
 verboseNoTimestamp :: Verbosity -> Verbosity
 verboseNoTimestamp = verboseNoFlag VTimestamp
 
+-- | Turn on timestamps for log messages.
+verboseStderr :: Verbosity -> Verbosity
+verboseStderr = verboseFlag VStderr
+
+-- | Turn off timestamps for log messages.
+verboseNoStderr :: Verbosity -> Verbosity
+verboseNoStderr = verboseNoFlag VStderr
+
 -- | Helper function for flag enabling functions
 verboseFlag :: VerbosityFlag -> (Verbosity -> Verbosity)
 verboseFlag flag v = v { vFlags = Set.insert flag (vFlags v) }
@@ -290,6 +325,10 @@ isVerboseQuiet = vQuiet
 isVerboseTimestamp :: Verbosity -> Bool
 isVerboseTimestamp = isVerboseFlag VTimestamp
 
+-- | Test if we should output to stderr when we log.
+isVerboseStderr :: Verbosity -> Bool
+isVerboseStderr = isVerboseFlag VStderr
+
 -- | Helper function for flag testing functions.
 isVerboseFlag :: VerbosityFlag -> Verbosity -> Bool
 isVerboseFlag flag = (Set.member flag) . vFlags

Cabal/Distribution/Verbosity/Internal.hs

@@ -20,6 +20,7 @@ data VerbosityFlag
     | VNoWrap
     | VMarkOutput
     | VTimestamp
+    | VStderr
     deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable)
 
 instance Binary VerbosityFlag