Discontent with the verbose output of version 2.3.3 of the Haskell Tool Stack when using a Solarized Dark terminal theme took me down the rabbit-hole of logging with the rio and monad-logger packages.
RIO.logDebug
The RIO module exports logDebug:
|
1 2 |
logDebug :: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) => Utf8Builder -> m () |
In respect of the RIO env a type, RIO env is an instance of MonadIO and env (RIO env) is an instance of MonadReader.
The class HasLogFunc env promises method logFuncL :: Lens' env LogFunc, that is, a simple lens (Lens') that gets or sets a LogFunc in env.
stack defines, in various modules, a number of instances for HasLogFunc including BuildConfig, Config, Ctx, DotConfig, EnvConfig, PathInfo, Runner, WithGHC env (subject to constraint HasLogFunc env).
The fields of a Runner value include a GlobalOpts value. The fields of a Config value include a Runner value. The fields of a BuildConfig value include a Config value. The fields of a DotConfig, EnvConfig or PathInfo value include a BuildConfig value. The fields of a Ctx include an EnvConfig value.
RIO.LogFunc
The RIO module exports the type LogFunc but not its constructors, a form of data encapsulation. A LogFunc value can be obtained from newLogFunc :: (MonadIO n, MonadIO m) => LogOptions -> n (LogFunc, m ()) or, more conveniently, the module exports withLogFunc :: MonadUnliftIO m => LogOptions -> (LogFunc -> m a) -> m a.
Both functions require a LogOptions value. Again, the module exports the type but not its constructors. A ‘default’ LogOptions value can be obtained from logOptionsHandle :: MonadIO m => Handle -> Bool -> m LogOptions and the module exports a series of setLog... functions with types of the form option -> LogOption -> LogOption.
Before rio-0.1.18.0 there were no setLog... functions in respect of the colours (strictly, ‘ANSI’ control character sequences) used in the LogFunc action. Some of the default colours chosen did not work well with the Solarized Dark theme (‘bright black’ – base03 – for secondary content and ‘bright green’ – base01 – for highlights). I proposed a pull request that, once accepted, added setLogLevelColors, setLogSecondaryColor (for secondary content) and setLogAccentColors.
Control.Monad.Logger.logDebugNS
The Control.Monad.Logger module of the monad-logger package exports logDebugNS. The ‘N’ in its name indicates non-Template Haskell and the ‘S’ indicates that it takes a ‘source’ (of type LogSource, a synonym for Text) as well as a log message (of type Text).
|
1 |
logDebugNS :: MonadLogger m => LogSource -> Text -> m () |
The class Monad m => MonadLogger m promises method monadLoggerLog :: ToLogStr msg => Loc -> LogSource -> LogLevel -> msg -> m ().
The types RIO.LogLevel and Control.Monad.Logger.LogLevel are isomorphic but different.
The RIO.Orphans module of package rio-orphans exports an instance of MonadLogger for RIO env, subject to the constraint HasLogFunc env.
persistent
stack depends on the pantry package, and both depend on the persistent and persistent-sqlite packages which, in turn, depend on the monad-logger package. In particular, pantry makes use of Database.Persist.Sqlite.withSqliteConnInfo in Pantry.SQLite.initStorage:
|
1 2 |
withSqliteConnInfo :: (MonadUnliftIO m, MonadLogger m) => SqliteConnectionInfo -> (SqlBackend -> m a) -> m a |
This introduces the MonadLogger m constraint that must be satisfied.
stack
An important function in stack-2.3.3 is withRunnerGlobal, exported by module Stack.Runners and used in Main.main. It applies runRIO to a Runner and an ‘inner’ RIO Runner a action. The Runner includes a runnerLogFunc that depends a LogOptions that is a function of a GlobalOpts value.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
withRunnerGlobal :: GlobalOpts -> RIO Runner a -> IO a withRunnerGlobal go inner = do ... logOptions0 <- logOptionsHandle stderr False let logOptions = setLogUseColor useColor $ setLogUseTime (globalTimeInLog go) $ setLogMinLevel (globalLogLevel go) $ setLogVerboseFormat (globalLogLevel go <= LevelDebug) $ setLogTerminal (globalTerminal go) logOptions0 withLogFunc logOptions $ \logFunc -> runRIO Runner { runnerGlobalOpts = go , runnerUseColor = useColor , runnerLogFunc = logFunc , runnerTermWidth = termWidth , runnerProcessContext = menv } inner |
I modified the function, so that the LogOptions value was also a function of the globalStylesUpdate of the GlobalOpts value. I did so with an additional helper function withNewLogFunc:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
withNewLogFunc :: MonadUnliftIO m => GlobalOpts -> Bool -- ^ Use color -> StylesUpdate -> (LogFunc -> m a) -> m a withNewLogFunc go useColor (StylesUpdate update) inner = do logOptions0 <- logOptionsHandle stderr False let logOptions = setLogUseColor useColor $ setLogLevelColors logLevelColors $ setLogSecondaryColor secondaryColor $ setLogAccentColors (const highlightColor) $ setLogUseTime (globalTimeInLog go) $ setLogMinLevel (globalLogLevel go) $ setLogVerboseFormat (globalLogLevel go <= LevelDebug) $ setLogTerminal (globalTerminal go) logOptions0 withLogFunc logOptions inner where styles = defaultStyles // update logLevelColors :: LogLevel -> Utf8Builder logLevelColors level = fromString $ setSGRCode $ snd $ styles ! logLevelToStyle level secondaryColor = fromString $ setSGRCode $ snd $ styles ! Secondary highlightColor = fromString $ setSGRCode $ snd $ styles ! Highlight |
Another important function in stack-2.3.3 is configFromConfigMonoid, exported by Stack.Config. It ultimately, via withPantryConfig, applies runRIO to the environment and an ‘inner’ RIO env a action which is a function of a Config value.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
{-# LANGUAGE RecordWildCards #-} configFromConfigMonoid :: HasRunner env => Path Abs Dir -- ^ stack root, e.g. ~/.stack -> Path Abs File -- ^ user config file path, e.g. ~/.stack/config.yaml -> Maybe AbstractResolver -> ProjectConfig (Project, Path Abs File) -> ConfigMonoid -> (Config -> RIO env a) -> RIO env a configFromConfigMonoid configStackRoot configUserConfigPath configResolver configProject ConfigMonoid{..} inner = do ... withPantryConfig pantryRoot hsc (maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack) clConnectionCount (fromFirst defaultCasaRepoPrefix configMonoidCasaRepoPrefix) defaultCasaMaxPerRequest (\configPantryConfig -> initUserStorage (configStackRoot </> relFileStorage) (\configUserStorage -> inner Config {..})) |
The function makes use of GHC’s Record Wild Cards extension to the Haskell language. A Config value includes fields (among others) named configRunner, configPantryConfig and configUserStorage. The Config {..} syntax expands to include Config { ..., configPantryConfig = configPantryConfig, ... } etc.
I modified the configFromConfigMonoid function so that the Config value had a configRunner field with a value that, in turn, had a runnerLongFunc field that was an updated LogFuncvalue.
I also modified the function so that the withPantryConfigaction had a local environment that included the same updated LogFunc value. To do that, I used a helper function withLocalLogFunc:
|
1 2 3 |
withLocalLogFunc :: HasLogFunc env => LogFunc -> RIO env a -> RIO env a withLocalLogFunc logFunc = local (set logFuncL logFunc) |
The modified function was as below (in reality, other changes have been made to the function since stack-2.3.3):
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
configFromConfigMonoid configStackRoot configUserConfigPath configResolver configProject ConfigMonoid{..} inner = do ... withNewLogFunc go useColor'' stylesUpdate' $ \logFunc -> do let configRunner = configRunner'' & logFuncL .~ logFunc withLocalLogFunc logFunc $ withPantryConfig pantryRoot hsc (maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack) clConnectionCount (fromFirst defaultCasaRepoPrefix configMonoidCasaRepoPrefix) defaultCasaMaxPerRequest (\configPantryConfig -> initUserStorage (configStackRoot </> relFileStorage) (\configUserStorage -> inner Config {..})) |