Fix commercialhaskell#5364 Add new LogFunc to environment

mpilgrem · mpilgrem · commit 4a9955930b2c · 2020-08-07T22:21:02.000+01:00
The 'SQL' debug log messages take their logging function from the environment, not from the `configRunner` of the `Config`. This proposed change uses a new helper function, `withLocalLogFunc`, to modify that part of the environment.
diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs
@@ -403,7 +403,7 @@ configFromConfigMonoid
 
      withNewLogFunc go useColor'' stylesUpdate' $ \logFunc -> do
        let configRunner = configRunner'' & logFuncL .~ logFunc
-       withPantryConfig
+       withLocalLogFunc logFunc $ withPantryConfig
          pantryRoot
          hsc
          (maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack)
@@ -415,6 +415,10 @@ configFromConfigMonoid
            (configStackRoot </> relFileStorage)
            (\configUserStorage -> inner Config {..}))
 
+-- | Runs the provided action with the given 'LogFunc' in the environment
+withLocalLogFunc :: HasLogFunc env => LogFunc -> RIO env a -> RIO env a
+withLocalLogFunc logFunc = local (set logFuncL logFunc)
+
 -- | Runs the provided action with a new 'LogFunc', given a 'StylesUpdate'.
 withNewLogFunc :: MonadUnliftIO m
                => GlobalOpts
