Commit 2502ea1b authored by Mikhail Glushenkov's avatar Mikhail Glushenkov Committed by GitHub
Browse files

Merge pull request #4091 from hvr/pr/nowrap

Implement +nowrap verbosity flag to suppress log-msg line-wrapping
parents 8cd99d8f b3f53eff
...@@ -326,12 +326,13 @@ hPutCallStackPrefix h verbosity = withFrozenCallStack $ do ...@@ -326,12 +326,13 @@ hPutCallStackPrefix h verbosity = withFrozenCallStack $ do
-- produce the desired output. -- produce the desired output.
-- --
-- Like 'die', these messages are always displayed on @stderr@, irrespective -- Like 'die', these messages are always displayed on @stderr@, irrespective
-- of the 'Verbosity' level. -- of the 'Verbosity' level. The 'Verbosity' parameter is needed though to
-- decide how to format the output (e.g. line-wrapping).
-- --
dieMsg :: String -> NoCallStackIO () dieMsg :: Verbosity -> String -> NoCallStackIO ()
dieMsg msg = do dieMsg verbosity msg = do
hFlush stdout hFlush stdout
hPutStr stderr (wrapText msg) hPutStr stderr (wrapTextVerbosity verbosity msg)
-- | As 'dieMsg' but with pre-formatted text. -- | As 'dieMsg' but with pre-formatted text.
-- --
...@@ -349,7 +350,7 @@ warn verbosity msg = withFrozenCallStack $ do ...@@ -349,7 +350,7 @@ warn verbosity msg = withFrozenCallStack $ do
when (verbosity >= normal) $ do when (verbosity >= normal) $ do
hFlush stdout hFlush stdout
hPutCallStackPrefix stderr verbosity hPutCallStackPrefix stderr verbosity
hPutStr stderr (wrapText ("Warning: " ++ msg)) hPutStr stderr (wrapTextVerbosity verbosity ("Warning: " ++ msg))
-- | Useful status messages. -- | Useful status messages.
-- --
...@@ -362,7 +363,7 @@ notice :: Verbosity -> String -> IO () ...@@ -362,7 +363,7 @@ notice :: Verbosity -> String -> IO ()
notice verbosity msg = withFrozenCallStack $ do notice verbosity msg = withFrozenCallStack $ do
when (verbosity >= normal) $ do when (verbosity >= normal) $ do
hPutCallStackPrefix stdout verbosity hPutCallStackPrefix stdout verbosity
putStr (wrapText msg) putStr (wrapTextVerbosity verbosity msg)
noticeNoWrap :: Verbosity -> String -> IO () noticeNoWrap :: Verbosity -> String -> IO ()
noticeNoWrap verbosity msg = withFrozenCallStack $ do noticeNoWrap verbosity msg = withFrozenCallStack $ do
...@@ -382,7 +383,7 @@ info :: Verbosity -> String -> IO () ...@@ -382,7 +383,7 @@ info :: Verbosity -> String -> IO ()
info verbosity msg = withFrozenCallStack $ info verbosity msg = withFrozenCallStack $
when (verbosity >= verbose) $ do when (verbosity >= verbose) $ do
hPutCallStackPrefix stdout verbosity hPutCallStackPrefix stdout verbosity
putStr (wrapText msg) putStr (wrapTextVerbosity verbosity msg)
-- | Detailed internal debugging information -- | Detailed internal debugging information
-- --
...@@ -392,7 +393,7 @@ debug :: Verbosity -> String -> IO () ...@@ -392,7 +393,7 @@ debug :: Verbosity -> String -> IO ()
debug verbosity msg = withFrozenCallStack $ debug verbosity msg = withFrozenCallStack $
when (verbosity >= deafening) $ do when (verbosity >= deafening) $ do
hPutCallStackPrefix stdout verbosity hPutCallStackPrefix stdout verbosity
putStr (wrapText msg) putStr (wrapTextVerbosity verbosity msg)
hFlush stdout hFlush stdout
-- | A variant of 'debug' that doesn't perform the automatic line -- | A variant of 'debug' that doesn't perform the automatic line
...@@ -433,6 +434,12 @@ wrapText = unlines ...@@ -433,6 +434,12 @@ wrapText = unlines
. words) . words)
. lines . lines
-- | Wraps text unless the @+nowrap@ verbosity flag is active
wrapTextVerbosity :: Verbosity -> String -> String
wrapTextVerbosity verb
| isVerboseNoWrap verb = unlines . lines -- makes sure there's a trailing LF
| otherwise = wrapText
-- | Wraps a list of words to a list of lines of words of a particular width. -- | Wraps a list of words to a list of lines of words of a particular width.
wrapLine :: Int -> [String] -> [[String]] wrapLine :: Int -> [String] -> [[String]]
wrapLine width = wrap 0 [] wrapLine width = wrap 0 []
......
...@@ -34,6 +34,9 @@ module Distribution.Verbosity ( ...@@ -34,6 +34,9 @@ module Distribution.Verbosity (
-- * Call stacks -- * Call stacks
verboseCallSite, verboseCallStack, verboseCallSite, verboseCallStack,
isVerboseCallSite, isVerboseCallStack, isVerboseCallSite, isVerboseCallStack,
-- * line-wrapping
verboseNoWrap, isVerboseNoWrap,
) where ) where
import Prelude () import Prelude ()
...@@ -140,6 +143,7 @@ parseVerbosity = parseIntVerbosity <++ parseStringVerbosity ...@@ -140,6 +143,7 @@ parseVerbosity = parseIntVerbosity <++ parseStringVerbosity
parseExtra = char '+' >> choice parseExtra = char '+' >> choice
[ string "callsite" >> return verboseCallSite [ string "callsite" >> return verboseCallSite
, string "callstack" >> return verboseCallStack , string "callstack" >> return verboseCallStack
, string "nowrap" >> return verboseNoWrap
] ]
flagToVerbosity :: ReadE Verbosity flagToVerbosity :: ReadE Verbosity
...@@ -164,6 +168,7 @@ showForGHC v = maybe (error "unknown verbosity") show $ ...@@ -164,6 +168,7 @@ showForGHC v = maybe (error "unknown verbosity") show $
data VerbosityFlag data VerbosityFlag
= VCallStack = VCallStack
| VCallSite | VCallSite
| VNoWrap
deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded) deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded)
instance Binary VerbosityFlag instance Binary VerbosityFlag
...@@ -183,3 +188,11 @@ isVerboseCallSite = (Set.member VCallSite) . vFlags ...@@ -183,3 +188,11 @@ isVerboseCallSite = (Set.member VCallSite) . vFlags
-- | Test if we should output call stacks when we log. -- | Test if we should output call stacks when we log.
isVerboseCallStack :: Verbosity -> Bool isVerboseCallStack :: Verbosity -> Bool
isVerboseCallStack = (Set.member VCallStack) . vFlags isVerboseCallStack = (Set.member VCallStack) . vFlags
-- | Disable line-wrapping for log messages.
verboseNoWrap :: Verbosity -> Verbosity
verboseNoWrap v = v { vFlags = Set.insert VNoWrap (vFlags v) }
-- | Test if line-wrapping is disabled for log messages.
isVerboseNoWrap :: Verbosity -> Bool
isVerboseNoWrap = (Set.member VNoWrap) . vFlags
...@@ -636,7 +636,7 @@ dieOnBuildFailures verbosity plan buildOutcomes ...@@ -636,7 +636,7 @@ dieOnBuildFailures verbosity plan buildOutcomes
| otherwise = do | otherwise = do
-- For failures where we have a build log, print the log plus a header -- For failures where we have a build log, print the log plus a header
sequence_ sequence_
[ do dieMsg $ [ do dieMsg verbosity $
'\n' : renderFailureDetail False pkg reason '\n' : renderFailureDetail False pkg reason
++ "\nBuild log ( " ++ logfile ++ " ):" ++ "\nBuild log ( " ++ logfile ++ " ):"
readFile logfile >>= dieMsgNoWrap readFile logfile >>= dieMsgNoWrap
......
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