From 811dc5b81e4a87d2d776ce7db39714d423063977 Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Mon, 29 Jun 2020 14:32:59 +0300
Subject: [PATCH] Add stderr Verbosity modifier
Rework verbosity parsing too and add tests.
---
.../src/Test/QuickCheck/Instances/Cabal.hs | 12 +-
.../src/Distribution/Described.hs | 10 ++
Cabal/Distribution/Simple/Utils.hs | 54 +++++---
Cabal/Distribution/Verbosity.hs | 117 ++++++++++++------
Cabal/Distribution/Verbosity/Internal.hs | 1 +
Cabal/doc/buildinfo-fields-reference.rst | 5 +
.../tests/UnitTests/Distribution/Described.hs | 2 +
.../Distribution/Utils/Structured.hs | 2 +-
.../buildinfo-reference-generator.cabal | 2 +-
buildinfo-reference-generator/template.zinza | 4 +-
cabal.project.buildinfo | 6 +-
11 files changed, 152 insertions(+), 63 deletions(-)
diff --git a/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs b/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs
index f22d1134be..2a4a8ebab7 100644
--- a/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs
+++ b/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
diff --git a/Cabal/Cabal-described/src/Distribution/Described.hs b/Cabal/Cabal-described/src/Distribution/Described.hs
index 6db2f29e6f..d095040a87 100644
--- a/Cabal/Cabal-described/src/Distribution/Described.hs
+++ b/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
diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs
index 349ed93b32..26c727b465 100644
--- a/Cabal/Distribution/Simple/Utils.hs
+++ b/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,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.
diff --git a/Cabal/Distribution/Verbosity.hs b/Cabal/Distribution/Verbosity.hs
index cafc233108..8edba708b4 100644
--- a/Cabal/Distribution/Verbosity.hs
+++ b/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
diff --git a/Cabal/Distribution/Verbosity/Internal.hs b/Cabal/Distribution/Verbosity/Internal.hs
index 3ec22b5308..b65b4c0838 100644
--- a/Cabal/Distribution/Verbosity/Internal.hs
+++ b/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
diff --git a/Cabal/doc/buildinfo-fields-reference.rst b/Cabal/doc/buildinfo-fields-reference.rst
index 5a6bbaddef..936aa31235 100644
--- a/Cabal/doc/buildinfo-fields-reference.rst
+++ b/Cabal/doc/buildinfo-fields-reference.rst
@@ -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::
diff --git a/Cabal/tests/UnitTests/Distribution/Described.hs b/Cabal/tests/UnitTests/Distribution/Described.hs
index 2daa55b8ce..2c73c805c7 100644
--- a/Cabal/tests/UnitTests/Distribution/Described.hs
+++ b/Cabal/tests/UnitTests/Distribution/Described.hs
@@ -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)
]
diff --git a/Cabal/tests/UnitTests/Distribution/Utils/Structured.hs b/Cabal/tests/UnitTests/Distribution/Utils/Structured.hs
index 0b658f42d9..c9a09826ca 100644
--- a/Cabal/tests/UnitTests/Distribution/Utils/Structured.hs
+++ b/Cabal/tests/UnitTests/Distribution/Utils/Structured.hs
@@ -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
]
diff --git a/buildinfo-reference-generator/buildinfo-reference-generator.cabal b/buildinfo-reference-generator/buildinfo-reference-generator.cabal
index 37174b7a0f..cd222b59be 100644
--- a/buildinfo-reference-generator/buildinfo-reference-generator.cabal
+++ b/buildinfo-reference-generator/buildinfo-reference-generator.cabal
@@ -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
diff --git a/buildinfo-reference-generator/template.zinza b/buildinfo-reference-generator/template.zinza
index 6716b1da22..ef02203057 100644
--- a/buildinfo-reference-generator/template.zinza
+++ b/buildinfo-reference-generator/template.zinza
@@ -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.
diff --git a/cabal.project.buildinfo b/cabal.project.buildinfo
index 3db5a58b77..defeb65b59 100644
--- a/cabal.project.buildinfo
+++ b/cabal.project.buildinfo
@@ -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
--
GitLab