@@ -1,7 +1,6 @@
1{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4−{-# LANGUAGE MultiWayIf #-}
5{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
7-- | Provides a logging handler that facilitates safe ouputting to terminal using MVar based locking.
6-- | 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_
28import Control.Monad.IO.Class (liftIO)
27import Control.Monad.IO.Class (liftIO)
29import Control.Monad.Loops (iterateUntil)
28import Control.Monad.Loops (iterateUntil)
30import Control.Monad.Reader (MonadIO)
29import Control.Monad.Reader (MonadIO)
30+import Data.Semigroup ((<>))
31import Data.Text (Text)
31import Data.Text (Text)
32+import qualified Data.Text as T
32import qualified Data.Text.IO as T
33import qualified Data.Text.IO as T
33import System.Console.ANSI (Color (Red, White, Yellow), ColorIntensity (Vivid),
34import System.Console.ANSI (Color (Red, White, Yellow), ColorIntensity (Vivid),
34 ConsoleIntensity (FaintIntensity), ConsoleLayer (Foreground),
35 ConsoleIntensity (FaintIntensity), ConsoleLayer (Foreground),
@@ -141,19 +142,16 @@ withExitFailMessage msg f = f `catch` \(e :: ExitCode) -> do
142-- | Write log to stdout, with colors (unless `noColor`)
143-- | Write log to stdout, with colors (unless `noColor`)
143writeLogWith :: (MonadIO m, MonadMask m) => (Text -> IO ()) -> Bool -> WithSeverity Text -> m ()
144writeLogWith :: (MonadIO m, MonadMask m) => (Text -> IO ()) -> Bool -> WithSeverity Text -> m ()
144−writeLogWith f noColor (WithSeverity severity s) = case sevColor severity of
145+writeLogWith f noColor (WithSeverity severity s)
145− Just setColor -> bracket_ setColor reset $ liftIO (T.putStr 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]
146− Nothing -> liftIO $ f s
150+ | otherwise = liftIO $ f s
148 -- We must reset *before* outputting the newline (if any), otherwise the cursor won't be reset.
152 -- We must reset *before* outputting the newline (if any), otherwise the cursor won't be reset.
149 reset = liftIO $ setSGR [Reset] >> f ""
153 reset = liftIO $ setSGR [Reset] >> f ""
150− sevColor sev = if
154+ put sgr = liftIO $ bracket_ (setSGR sgr) reset $ T.putStr s
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
158-- | Allow the user to immediately switch to verbose logging upon pressing a particular key.
156-- | Allow the user to immediately switch to verbose logging upon pressing a particular key.
159allowUserToMakeLoggingVerbose
157allowUserToMakeLoggingVerbose