Add support for adjusting colors through LogSettings

pbrisbin · pbrisbin · commit 84aa56642eac · 2025-04-09T18:39:57.000-04:00
This commit extends our settings type with a `Colors -&gt; Colors` function
(that can set through code, for now), which is called in all the
`getColors` functions.

This will allow end-user customization of `Colors` used in all logging.

Concretely, I want this so that I can fix for the fact that `dim`
doesn't work on GitHub Actions. This hook will allow me to easily
substitute `gray` which looks the same in that environment.
diff --git a/Blammo/src/Blammo/Logging/Colors.hs b/Blammo/src/Blammo/Logging/Colors.hs
@@ -20,15 +20,17 @@ import Prelude
 
 import Blammo.Logging.Internal.Colors
 import Blammo.Logging.Internal.Logger
-import Blammo.Logging.LogSettings (shouldColorHandle)
+import Blammo.Logging.LogSettings (adjustColors, shouldColorHandle)
 import Control.Lens (to, view)
 import Control.Monad.IO.Class (MonadIO (..))
 import Control.Monad.Reader (MonadReader)
 import System.IO (Handle, stderr, stdout)
 
 -- | Return 'Colors' consistent with whatever your logging is doing
 getColorsLogger :: (MonadReader env m, HasLogger env) => m Colors
-getColorsLogger = view $ loggerL . to (getColors . lShouldColor)
+getColorsLogger = do
+  f <- view $ loggerL . to (adjustColors . lLogSettings)
+  view $ loggerL . to (f . getColors . lShouldColor)
 
 -- | Return 'Colors' consistent with logging, but for 'Handle'
 --
@@ -49,7 +51,7 @@ getColorsHandle
   :: (MonadIO m, MonadReader env m, HasLogger env) => Handle -> m Colors
 getColorsHandle h = do
   ls <- view $ loggerL . to lLogSettings
-  getColors <$> shouldColorHandle ls h
+  adjustColors ls . getColors <$> shouldColorHandle ls h
 
 -- | Short-cut for @'getColorsHandle' 'stdout'@
 getColorsStdout :: (MonadIO m, MonadReader env m, HasLogger env) => m Colors
diff --git a/Blammo/src/Blammo/Logging/LogSettings.hs b/Blammo/src/Blammo/Logging/LogSettings.hs
@@ -19,6 +19,7 @@ module Blammo.Logging.LogSettings
   , setLogSettingsDestination
   , setLogSettingsFormat
   , setLogSettingsColor
+  , setLogSettingsColors
   , setLogSettingsBreakpoint
   , setLogSettingsConcurrency
 
@@ -31,13 +32,15 @@ module Blammo.Logging.LogSettings
   , getLogSettingsConcurrency
 
     -- * Logic
+  , adjustColors
   , shouldLogLevel
   , shouldColorAuto
   , shouldColorHandle
   ) where
 
 import Prelude
 
+import Blammo.Logging.Internal.Colors (Colors)
 import Blammo.Logging.LogSettings.LogLevels (LogLevels)
 import qualified Blammo.Logging.LogSettings.LogLevels as LogLevels
 import Control.Monad.IO.Class (MonadIO (..))
@@ -50,6 +53,7 @@ data LogSettings = LogSettings
   , lsDestination :: LogDestination
   , lsFormat :: LogFormat
   , lsColor :: LogColor
+  , lsColors :: Colors -> Colors
   , lsBreakpoint :: Int
   , lsConcurrency :: Maybe Int
   }
@@ -117,6 +121,7 @@ defaultLogSettings =
     , lsDestination = LogDestinationStdout
     , lsFormat = LogFormatTerminal
     , lsColor = LogColorAuto
+    , lsColors = id
     , lsBreakpoint = 120
     , lsConcurrency = Just 1
     }
@@ -168,6 +173,10 @@ setLogSettingsBreakpoint x ls = ls {lsBreakpoint = x}
 setLogSettingsConcurrency :: Maybe Int -> LogSettings -> LogSettings
 setLogSettingsConcurrency x ls = ls {lsConcurrency = x}
 
+-- | Set a function to modify 'Colors' used in logging
+setLogSettingsColors :: (Colors -> Colors) -> LogSettings -> LogSettings
+setLogSettingsColors f ls = ls {lsColors = f}
+
 getLogSettingsLevels :: LogSettings -> LogLevels
 getLogSettingsLevels = lsLevels
 
@@ -186,6 +195,9 @@ getLogSettingsBreakpoint = lsBreakpoint
 getLogSettingsConcurrency :: LogSettings -> Maybe Int
 getLogSettingsConcurrency = lsConcurrency
 
+adjustColors :: LogSettings -> Colors -> Colors
+adjustColors = lsColors
+
 shouldLogLevel :: LogSettings -> LogSource -> LogLevel -> Bool
 shouldLogLevel = LogLevels.shouldLogLevel . getLogSettingsLevels
 
diff --git a/Blammo/src/Blammo/Logging/Logger.hs b/Blammo/src/Blammo/Logging/Logger.hs
@@ -101,7 +101,8 @@ setLoggerReformat f logger =
   logger
     { lReformat = \level bytes -> fromMaybe bytes $ do
         lm <- Aeson.decodeStrict bytes
-        pure $ f (lLogSettings logger) (getColors $ lShouldColor logger) level lm
+        let g = adjustColors $ lLogSettings logger
+        pure $ f (lLogSettings logger) (g $ getColors $ lShouldColor logger) level lm
     }
 
 getLoggerShouldLog :: Logger -> LogSource -> LogLevel -> Bool

Original file line number	Diff line number	Diff line change
`@@ -101,7 +101,8 @@ setLoggerReformat f logger =`
`101`	`101`	`logger`
`102`	`102`	`{ lReformat = \level bytes -> fromMaybe bytes $ do`
`103`	`103`	`lm <- Aeson.decodeStrict bytes`
`104`		`- pure $ f (lLogSettings logger) (getColors $ lShouldColor logger) level lm`
	`104`	`+ let g = adjustColors $ lLogSettings logger`
	`105`	`+ pure $ f (lLogSettings logger) (g $ getColors $ lShouldColor logger) level lm`
`105`	`106`	`}`
`106`	`107`
`107`	`108`	`getLoggerShouldLog :: Logger -> LogSource -> LogLevel -> Bool`