@@ -1,7 +1,6 @@
11{-# LANGUAGE FlexibleContexts #-}
22{-# LANGUAGE LambdaCase #-}
33{-# LANGUAGE MultiParamTypeClasses #-}
4−{-# LANGUAGE MultiWayIf #-}
54{-# LANGUAGE OverloadedStrings #-}
65{-# LANGUAGE ScopedTypeVariables #-}
76-- | Provides a logging handler that facilitates safe ouputting to terminal using MVar based locking.
@@ -28,7 +27,9 @@ import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, bracket, bracket_
2827import Control.Monad.IO.Class (liftIO)
2928import Control.Monad.Loops (iterateUntil)
3029import Control.Monad.Reader (MonadIO)
30+import Data.Semigroup ((<>))
3131import Data.Text (Text)
32+import qualified Data.Text as T
3233import qualified Data.Text.IO as T
3334import System.Console.ANSI (Color (Red, White, Yellow), ColorIntensity (Vivid),
3435 ConsoleIntensity (FaintIntensity), ConsoleLayer (Foreground),
@@ -141,19 +142,16 @@ withExitFailMessage msg f = f `catch` \(e :: ExitCode) -> do
141142
142143-- | Write log to stdout, with colors (unless `noColor`)
143144writeLogWith :: (MonadIO m, MonadMask m) => (Text -> IO ()) -> Bool -> WithSeverity Text -> m ()
144−writeLogWith f noColor (WithSeverity severity s) = case sevColor severity of
145− Just setColor -> bracket_ setColor reset $ liftIO (T.putStr s)
146− Nothing -> liftIO $ f s
145+writeLogWith f noColor (WithSeverity severity s)
146+ | noColor && severity <= Warning = liftIO $ f $ T.pack (show severity) <> ": " <> s
147+ | not noColor && severity <= Error = put [SetColor Foreground Vivid Red]
148+ | not noColor && severity <= Warning = put [SetColor Foreground Vivid Yellow]
149+ | not noColor && severity >= Debug = put [SetColor Foreground Vivid White, SetConsoleIntensity FaintIntensity]
150+ | otherwise = liftIO $ f s
147151 where
148152 -- We must reset *before* outputting the newline (if any), otherwise the cursor won't be reset.
149− reset = liftIO $ setSGR [Reset] >> f ""
150− sevColor sev = if
151− | noColor -> Nothing
152− | sev <= Error -> Just $ liftIO $ setSGR [SetColor Foreground Vivid Red]
153− | sev <= Warning -> Just $ liftIO $ setSGR [SetColor Foreground Vivid Yellow]
154− | sev >= Debug -> Just $ liftIO $ setSGR [SetColor Foreground Vivid White, SetConsoleIntensity FaintIntensity]
155− | otherwise -> Nothing
156−
153+ reset = setSGR [Reset] >> f ""
154+ put sgr = liftIO $ bracket_ (setSGR sgr) reset $ T.putStr s
157155
158156-- | Allow the user to immediately switch to verbose logging upon pressing a particular key.
159157allowUserToMakeLoggingVerbose