Commit b3f53eff authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺
Browse files

Implement +nowrap verbosity flag to suppress log-msg line-wrapping

Unfortunately, propagating the `Verbosity` to the `topHandler`
proves to be more complicated.

This is mostly a problem for `die` invocations which are translated
into user-error exceptions (which in turn then cause callstacks
to be printed; are we abusing `die`?)
parent 8cd99d8f
......@@ -326,12 +326,13 @@ hPutCallStackPrefix h verbosity = withFrozenCallStack $ do
-- produce the desired output.
--
-- 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 msg = do
dieMsg :: Verbosity -> String -> NoCallStackIO ()
dieMsg verbosity msg = do
hFlush stdout
hPutStr stderr (wrapText msg)
hPutStr stderr (wrapTextVerbosity verbosity msg)
-- | As 'dieMsg' but with pre-formatted text.
--
......@@ -349,7 +350,7 @@ warn verbosity msg = withFrozenCallStack $ do
when (verbosity >= normal) $ do
hFlush stdout
hPutCallStackPrefix stderr verbosity
hPutStr stderr (wrapText ("Warning: " ++ msg))
hPutStr stderr (wrapTextVerbosity verbosity ("Warning: " ++ msg))
-- | Useful status messages.
--
......@@ -362,7 +363,7 @@ notice :: Verbosity -> String -> IO ()
notice verbosity msg = withFrozenCallStack $ do
when (verbosity >= normal) $ do
hPutCallStackPrefix stdout verbosity
putStr (wrapText msg)
putStr (wrapTextVerbosity verbosity msg)
noticeNoWrap :: Verbosity -> String -> IO ()
noticeNoWrap verbosity msg = withFrozenCallStack $ do
......@@ -382,7 +383,7 @@ info :: Verbosity -> String -> IO ()
info verbosity msg = withFrozenCallStack $
when (verbosity >= verbose) $ do
hPutCallStackPrefix stdout verbosity
putStr (wrapText msg)
putStr (wrapTextVerbosity verbosity msg)
-- | Detailed internal debugging information
--
......@@ -392,7 +393,7 @@ debug :: Verbosity -> String -> IO ()
debug verbosity msg = withFrozenCallStack $
when (verbosity >= deafening) $ do
hPutCallStackPrefix stdout verbosity
putStr (wrapText msg)
putStr (wrapTextVerbosity verbosity msg)
hFlush stdout
-- | A variant of 'debug' that doesn't perform the automatic line
......@@ -433,6 +434,12 @@ wrapText = unlines
. words)
. 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.
wrapLine :: Int -> [String] -> [[String]]
wrapLine width = wrap 0 []
......
......@@ -34,6 +34,9 @@ module Distribution.Verbosity (
-- * Call stacks
verboseCallSite, verboseCallStack,
isVerboseCallSite, isVerboseCallStack,
-- * line-wrapping
verboseNoWrap, isVerboseNoWrap,
) where
import Prelude ()
......@@ -140,6 +143,7 @@ parseVerbosity = parseIntVerbosity <++ parseStringVerbosity
parseExtra = char '+' >> choice
[ string "callsite" >> return verboseCallSite
, string "callstack" >> return verboseCallStack
, string "nowrap" >> return verboseNoWrap
]
flagToVerbosity :: ReadE Verbosity
......@@ -164,6 +168,7 @@ showForGHC v = maybe (error "unknown verbosity") show $
data VerbosityFlag
= VCallStack
| VCallSite
| VNoWrap
deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded)
instance Binary VerbosityFlag
......@@ -183,3 +188,11 @@ isVerboseCallSite = (Set.member VCallSite) . vFlags
-- | Test if we should output call stacks when we log.
isVerboseCallStack :: Verbosity -> Bool
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
| otherwise = do
-- For failures where we have a build log, print the log plus a header
sequence_
[ do dieMsg $
[ do dieMsg verbosity $
'\n' : renderFailureDetail False pkg reason
++ "\nBuild log ( " ++ logfile ++ " ):"
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