From 811dc5b81e4a87d2d776ce7db39714d423063977 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus 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 f22d1134bed..2a4a8ebab76 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 6db2f29e6f5..d095040a87c 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 349ed93b32f..26c727b4657 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 cafc233108c..8edba708b4b 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 3ec22b53081..b65b4c0838e 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 5a6bbaddefe..936aa312353 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 2daa55b8ce6..2c73c805c71 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 0b658f42d96..c9a09826ca0 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 37174b7a0f3..cd222b59bee 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 6716b1da22b..ef022030578 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 3db5a58b77a..defeb65b594 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