diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for rio +## 0.1.18.0 + +* Add colours to the `LogOption` constructor [#222](https://github.com/commercialhaskell/rio/pull/222) + ## 0.1.17.0 * Expose `Bifunctor`, `Bifoldable`, and `Bitraversable`. diff --git a/rio.cabal b/rio.cabal --- a/rio.cabal +++ b/rio.cabal @@ -1,11 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.1. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack +-- +-- hash: 087056e2734e9ef4da6545d2654c71c939cf6f9a04aac90c5427c43597cb8b88 name: rio -version: 0.1.17.0 +version: 0.1.18.0 synopsis: A standard library for Haskell description: See README and Haddocks at category: Control diff --git a/src/RIO/Prelude/Logger.hs b/src/RIO/Prelude/Logger.hs --- a/src/RIO/Prelude/Logger.hs +++ b/src/RIO/Prelude/Logger.hs @@ -24,6 +24,9 @@ , setLogUseColor , setLogUseLoc , setLogFormat + , setLogLevelColors + , setLogSecondaryColor + , setLogAccentColors -- ** Standard logging functions , logDebug , logInfo @@ -56,6 +59,9 @@ , noLogging -- ** Accessors , logFuncUseColorL + , logFuncLogLevelColorsL + , logFuncSecondaryColorL + , logFuncAccentColorsL -- * Type-generic logger -- $type-generic-intro , glog @@ -319,6 +325,7 @@ , logTerminal = True , logUseTime = False , logUseColor = False + , logColors = defaultLogColors , logUseLoc = False , logFormat = id , logSend = \new -> atomicModifyIORef' ref $ \old -> (old <> new, ()) @@ -357,6 +364,7 @@ #else , logUseColor = verbose && terminal #endif + , logColors = defaultLogColors , logUseLoc = verbose , logFormat = id , logSend = \builder -> @@ -459,11 +467,45 @@ , logTerminal :: !Bool , logUseTime :: !Bool , logUseColor :: !Bool + , logColors :: !LogColors , logUseLoc :: !Bool , logFormat :: !(Utf8Builder -> Utf8Builder) , logSend :: !(Builder -> IO ()) } +-- | ANSI color codes for use in the configuration of the creation of a +-- 'LogFunc'. +-- +-- @since 0.1.18.0 +data LogColors = LogColors + { -- | The color associated with each 'LogLevel'. + logColorLogLevels :: !(LogLevel -> Utf8Builder) + -- | The color of secondary content. + , logColorSecondary :: !Utf8Builder + -- | The color of accents, which are indexed by 'Int'. + , logColorAccents :: !(Int -> Utf8Builder) + } + +defaultLogColors :: LogColors +defaultLogColors = LogColors + { logColorLogLevels = defaultLogLevelColors + , logColorSecondary = defaultLogSecondaryColor + , logColorAccents = defaultLogAccentColors + } + +defaultLogLevelColors :: LogLevel -> Utf8Builder +defaultLogLevelColors LevelDebug = "\ESC[32m" -- Green +defaultLogLevelColors LevelInfo = "\ESC[34m" -- Blue +defaultLogLevelColors LevelWarn = "\ESC[33m" -- Yellow +defaultLogLevelColors LevelError = "\ESC[31m" -- Red +defaultLogLevelColors (LevelOther _) = "\ESC[35m" -- Magenta + +defaultLogSecondaryColor :: Utf8Builder +defaultLogSecondaryColor = "\ESC[90m" -- Bright black (gray) + +defaultLogAccentColors :: Int -> Utf8Builder +defaultLogAccentColors = const "\ESC[92m" -- Bright green + -- | Set the minimum log level. Messages below this level will not be -- printed. -- @@ -526,6 +568,44 @@ setLogUseColor :: Bool -> LogOptions -> LogOptions setLogUseColor c options = options { logUseColor = c } +-- | ANSI color codes for 'LogLevel' in the log output. +-- +-- Default: 'LevelDebug' = \"\\ESC[32m\" -- Green +-- 'LevelInfo' = \"\\ESC[34m\" -- Blue +-- 'LevelWarn' = \"\\ESC[33m\" -- Yellow +-- 'LevelError' = \"\\ESC[31m\" -- Red +-- 'LevelOther' _ = \"\\ESC[35m\" -- Magenta +-- +-- @since 0.1.18.0 +setLogLevelColors :: (LogLevel -> Utf8Builder) -> LogOptions -> LogOptions +setLogLevelColors logLevelColors options = + let lc = (logColors options){ logColorLogLevels = logLevelColors } + in options { logColors = lc } + +-- | ANSI color codes for secondary content in the log output. +-- +-- Default: \"\\ESC[90m\" -- Bright black (gray) +-- +-- @since 0.1.18.0 +setLogSecondaryColor :: Utf8Builder -> LogOptions -> LogOptions +setLogSecondaryColor c options = + let lc = (logColors options){ logColorSecondary = c } + in options { logColors = lc } + +-- | ANSI color codes for accents in the log output. Accent colors are indexed +-- by 'Int'. +-- +-- Default: 'const' \"\\ESC[92m\" -- Bright green, for all indicies +-- +-- @since 0.1.18.0 +setLogAccentColors + :: (Int -> Utf8Builder) -- ^ This should be a total function. + -> LogOptions + -> LogOptions +setLogAccentColors accentColors options = + let lc = (logColors options){ logColorAccents = accentColors } + in options { logColors = lc } + -- | Use code location in the log output. -- -- Default: `True` if in verbose mode, `False` otherwise. @@ -560,12 +640,10 @@ "\n" where reset = "\ESC[0m" - setBlack = "\ESC[90m" - setGreen = "\ESC[32m" - setBlue = "\ESC[34m" - setYellow = "\ESC[33m" - setRed = "\ESC[31m" - setMagenta = "\ESC[35m" + lc = logColors lo + levelColor = logColorLogLevels lc level + timestampColor = logColorSecondary lc + locColor = logColorSecondary lc ansi :: Utf8Builder -> Utf8Builder ansi xs | logUseColor lo = xs @@ -575,7 +653,7 @@ getTimestamp logVerbose | logVerbose && logUseTime lo = do now <- getZonedTime - return $ ansi setBlack <> fromString (formatTime' now) <> ": " + return $ ansi timestampColor <> fromString (formatTime' now) <> ": " | otherwise = return mempty where formatTime' = @@ -583,14 +661,13 @@ getLevel :: Bool -> Utf8Builder getLevel logVerbose - | logVerbose = + | logVerbose = ansi levelColor <> case level of - LevelDebug -> ansi setGreen <> "[debug] " - LevelInfo -> ansi setBlue <> "[info] " - LevelWarn -> ansi setYellow <> "[warn] " - LevelError -> ansi setRed <> "[error] " + LevelDebug -> "[debug] " + LevelInfo -> "[info] " + LevelWarn -> "[warn] " + LevelError -> "[error] " LevelOther name -> - ansi setMagenta <> "[" <> display name <> "] " @@ -603,7 +680,7 @@ getLoc :: Utf8Builder getLoc - | logUseLoc lo = ansi setBlack <> "\n@(" <> displayCallStack cs <> ")" + | logUseLoc lo = ansi locColor <> "\n@(" <> displayCallStack cs <> ")" | otherwise = mempty -- | Convert a 'CallStack' value into a 'Utf8Builder' indicating @@ -688,6 +765,42 @@ -- @since 0.1.0.0 logFuncUseColorL :: HasLogFunc env => SimpleGetter env Bool logFuncUseColorL = logFuncL.to (maybe False logUseColor . lfOptions) + +-- | What color is the log func configured to use for each 'LogLevel'? +-- +-- Intended for use by code which wants to optionally add additional color to +-- its log messages. +-- +-- @since 0.1.18.0 +logFuncLogLevelColorsL :: HasLogFunc env + => SimpleGetter env (LogLevel -> Utf8Builder) +logFuncLogLevelColorsL = logFuncL.to + (maybe defaultLogLevelColors + (logColorLogLevels . logColors) . lfOptions) + +-- | What color is the log func configured to use for secondary content? +-- +-- Intended for use by code which wants to optionally add additional color to +-- its log messages. +-- +-- @since 0.1.18.0 +logFuncSecondaryColorL :: HasLogFunc env + => SimpleGetter env Utf8Builder +logFuncSecondaryColorL = logFuncL.to + (maybe defaultLogSecondaryColor + (logColorSecondary . logColors) . lfOptions) + +-- | What accent colors, indexed by 'Int', is the log func configured to use? +-- +-- Intended for use by code which wants to optionally add additional color to +-- its log messages. +-- +-- @since 0.1.18.0 +logFuncAccentColorsL :: HasLogFunc env + => SimpleGetter env (Int -> Utf8Builder) +logFuncAccentColorsL = logFuncL.to + (maybe defaultLogAccentColors + (logColorAccents . logColors) . lfOptions) -- | Disable logging capabilities in a given sub-routine -- diff --git a/src/RIO/Process.hs b/src/RIO/Process.hs --- a/src/RIO/Process.hs +++ b/src/RIO/Process.hs @@ -407,9 +407,10 @@ end <- getMonotonicTime let diff = end - start useColor <- view logFuncUseColorL + accentColors <- view logFuncAccentColorsL logDebug ("Process finished in " <> - (if useColor then "\ESC[92m" else "") <> -- green + (if useColor then accentColors 0 else "") <> -- accent color 0 timeSpecMilliSecondText diff <> (if useColor then "\ESC[0m" else "") <> -- reset ": " <> display cmdText)