@@ -29,6 +29,7 @@ import Control.Monad.Log (MonadLog, Severity (..), WithSeverity (..), logMessage
2929
3030data LoggingConfig = LoggingConfig
3131 { _loggingConfig_level :: Severity
32+ , _loggingConfig_noColor :: Bool -- Disallow coloured output
3233 , _loggingConfig_lock :: MVar Bool -- Whether the last message was an Overwrite output
3334 }
3435
@@ -51,25 +52,24 @@ getSeverity = \case
5152 _ -> Nothing
5253
5354handleLog :: MonadIO m => LoggingConfig -> Output -> m ()
54−handleLog c output = do
55− let lock = _loggingConfig_lock c
55+handleLog (LoggingConfig level noColor lock) output = do
5656 liftIO $ modifyMVar_ lock $ \wasOverwriting -> do
5757 case getSeverity output of
58− Nothing -> handleLog' output
58+ Nothing -> handleLog' noColor output
5959 Just sev -> do
6060 -- Discard unless severity is above configured log level
61− unless (sev > _loggingConfig_level c) $ do
61+ unless (sev > level) $ do
6262 -- If the last output was an overwrite (with cursor on same line), first clear it,
63− when wasOverwriting $ handleLog' Output_ClearLine
63+ when wasOverwriting $ handleLog' noColor Output_ClearLine
6464 -- ... then actually write the log.
65− handleLog' output
65+ handleLog' noColor output
6666 return $ isOverwrite output
6767
68−handleLog' :: MonadIO m => Output -> m ()
69−handleLog' = \case
70− Output_Log m -> liftIO $ writeLogWith T.putStrLn m
68+handleLog' :: MonadIO m => Bool -> Output -> m ()
69+handleLog' noColor = \case
70+ Output_Log m -> liftIO $ writeLogWith T.putStrLn noColor m
7171 Output_LogRaw m -> liftIO $ do
72− writeLogWith T.putStr m
72+ writeLogWith T.putStr noColor m
7373 hFlush stdout
7474 Output_Overwrite xs -> liftIO $ putStrs $ "\r" : xs
7575 Output_ClearLine -> liftIO $ do
@@ -95,16 +95,16 @@ failWith s = do
9595 putLog Alert s
9696 liftIO $ exitWith $ ExitFailure 2
9797
98−-- | Write log to stdout with colors
99−-- TODO: Disable colours when not on interactive terminal
100−writeLogWith :: (MonadIO m, MonadMask m) => (Text -> IO ()) -> WithSeverity Text -> m ()
101−writeLogWith f (WithSeverity severity s) = case sevColor severity of
98+-- | Write log to stdout, with colors (unless `noColor`)
99+writeLogWith :: (MonadIO m, MonadMask m) => (Text -> IO ()) -> Bool -> WithSeverity Text -> m ()
100+writeLogWith f noColor (WithSeverity severity s) = case sevColor severity of
102101 Just setColor -> bracket_ setColor reset $ liftIO (T.putStr s)
103102 Nothing -> liftIO $ f s
104103 where
105104 -- We must reset *before* the newline, else the cursor won't be reset.
106105 reset = liftIO $ setSGR [Reset] >> f ""
107106 sevColor sev = if
107+ | noColor -> Nothing
108108 | sev <= Error -> Just $ liftIO $ setSGR [SetColor Foreground Vivid Red]
109109 | sev <= Warning -> Just $ liftIO $ setSGR [SetColor Foreground Vivid Yellow]
110110 | otherwise -> Nothing