hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Make sure NO_COLOR also applies to logging

Browse Source
This commit is contained in:
Julian Ospald
2021-09-23 12:16:49 +02:00
parent 3cd55beab1
commit ef8da9bcec
5 changed files with 39 additions and 29 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
lib/GHCup/Types.hs
View File

@@ -576,11 +576,12 @@ data LogLevel = Warn
deriving (Eq, Ord, Show)
data LoggerConfig = LoggerConfig
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, colorOutter :: T.Text -> IO () -- ^ how to write the color output
, rawOutter :: T.Text -> IO () -- ^ how to write the full raw output
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, consoleOutter :: T.Text -> IO () -- ^ how to write the console output
, fileOutter :: T.Text -> IO () -- ^ how to write the file output
, fancyColors :: Bool
}
deriving Show
instance NFData LoggerConfig where
rnf (LoggerConfig !lcPrintDebug !_ !_) = rnf lcPrintDebug
rnf (LoggerConfig !lcPrintDebug !_ !_ !fancyColors) = rnf (lcPrintDebug, fancyColors)

13
lib/GHCup/Types/Optics.hs
View File

@@ -158,11 +158,12 @@ logInternal :: ( MonadReader env m
-> m ()
logInternal logLevel msg = do
LoggerConfig {..} <- gets @"loggerConfig"
let color' c = if fancyColors then color c else id
let style' = case logLevel of
Debug -> style Bold . color Blue
Info -> style Bold . color Green
Warn -> style Bold . color Yellow
Error -> style Bold . color Red
Debug -> style Bold . color' Blue
Info -> style Bold . color' Green
Warn -> style Bold . color' Yellow
Error -> style Bold . color' Red
let l = case logLevel of
Debug -> style' "[ Debug ]"
Info -> style' "[ Info ]"
@@ -178,7 +179,7 @@ logInternal logLevel msg = do
$ xs
when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))
$ liftIO $ colorOutter out
$ liftIO $ consoleOutter out
-- raw output
let lr = case logLevel of
@@ -187,7 +188,7 @@ logInternal logLevel msg = do
Warn -> "Warn:"
Error -> "Error:"
let outr = lr <> " " <> msg <> "\n"
liftIO $ rawOutter outr
liftIO $ fileOutter outr