Unverified Commit 1a493e75 authored by Oleg Grenrus's avatar Oleg Grenrus Committed by GitHub

Merge pull request #6929 from phadej/verbosity-stderr

Add stderr Verbosity modifier
parents eedba762 811dc5b8
......@@ -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
......
......@@ -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
......
......@@ -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,10 +459,12 @@ 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.
......@@ -465,8 +472,9 @@ notice verbosity msg = withFrozenCallStack $ do
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.
......@@ -474,9 +482,12 @@ noticeNoWrap verbosity msg = withFrozenCallStack $ do
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.
......
......@@ -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
......
......@@ -20,6 +20,7 @@ data VerbosityFlag
| VNoWrap
| VMarkOutput
| VTimestamp
| VStderr
deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable)
instance Binary VerbosityFlag
......
......@@ -187,6 +187,7 @@ autogen-includes
autogen-modules
* Monoidal field
* Available since ``cabal-version: 2.0``.
* Documentation of :pkg-field:`autogen-modules`
.. math::
......@@ -277,6 +278,7 @@ cxx-sources
default-extensions
* Monoidal field
* Available since ``cabal-version: 1.10``.
* Documentation of :pkg-field:`default-extensions`
.. math::
......@@ -284,6 +286,7 @@ default-extensions
default-language
* Optional field
* Available since ``cabal-version: 1.10``.
* Documentation of :pkg-field:`default-language`
.. math::
......@@ -456,6 +459,7 @@ mixins
other-extensions
* Monoidal field
* Available since ``cabal-version: 1.10``.
* Documentation of :pkg-field:`other-extensions`
.. math::
......@@ -463,6 +467,7 @@ other-extensions
other-languages
* Monoidal field
* Available since ``cabal-version: 1.10``.
* Documentation of :pkg-field:`other-languages`
.. math::
......
......@@ -22,6 +22,7 @@ import Distribution.Types.PackageName (PackageName)
import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint)
import Distribution.Types.Version (Version)
import Distribution.Types.VersionRange (VersionRange)
import Distribution.Verbosity (Verbosity)
-- instances
import Test.QuickCheck.Instances.Cabal ()
......@@ -44,4 +45,5 @@ tests = testGroup "Described"
, testDescribed (Proxy :: Proxy ModuleRenaming)
, testDescribed (Proxy :: Proxy IncludeRenaming)
, testDescribed (Proxy :: Proxy Mixin)
, testDescribed (Proxy :: Proxy Verbosity)
]
......@@ -25,6 +25,6 @@ tests = testGroup "Distribution.Utils.Structured"
-- The difference is in encoding of newtypes
#if MIN_VERSION_base(4,7,0)
, testCase "GenericPackageDescription" $ structureHash (Proxy :: Proxy GenericPackageDescription) @?= md5FromInteger 0xc3fd68379b7d09c2e3f751d10dde4fd6
, testCase "LocalBuildInfo" $ structureHash (Proxy :: Proxy LocalBuildInfo) @?= md5FromInteger 0xdafbf0d7fd7bf4dd63a8601c39475a8a
, testCase "LocalBuildInfo" $ structureHash (Proxy :: Proxy LocalBuildInfo) @?= md5FromInteger 0x54cdbbfa6df9a9fb2c6d792d1d77d672
#endif
]
......@@ -8,7 +8,7 @@ executable buildinfo-reference-generator
ghc-options: -Wall
main-is: Main.hs
build-depends:
, base ^>=4.12
, base ^>=4.12 || ^>=4.13
, Cabal
, Cabal-described
, containers
......
......@@ -27,7 +27,7 @@ Field syntax is described as they are in the latest cabal file format version.
[ \mathord{"}\mathtt{1}\mathord{"} \cdots \mathord{"}\mathtt{9}\mathord{"} ]
Character set compelements have :math:`c` superscript:
Character set complements have :math:`c` superscript:
.. math::
......@@ -102,7 +102,7 @@ Space separated
.. math::
{{spaceList}}
Comma semarted
Comma separated
Are used for lists of things with complicated grammars, for example :pkg-field:`build-depends`
There can be leading or trailing comma (but not both) since ``cabal-version: 2.2``.
Note, the comma cannot exist alone.
......
......@@ -3,4 +3,8 @@ packages: Cabal/Cabal-described
packages: buildinfo-reference-generator/
tests: False
optimization: False
with-compiler: ghc-8.6.5
with-compiler: ghc-8.8.3
-- avoiding extra dependencies
constraints: rere -rere-cfg
constraints: these -assoc
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment