Merge pull request #5360 from mpilgrem/logColors

Fix #5356 Allow all colours to be customised

Author: snoyberg

ChangeLog.md

@@ -40,6 +40,9 @@ Bug fixes:
 Other enhancements:
 
 * Add the `stack-developer-mode` flag
+* Customisable output styles (see `stack --help` and the `--stack-colors`
+  option, and `stack ls stack-colors --help`) now include `info`, `debug`,
+  `other-level`, `secondary` and `highlight`, used with verbose output.
 
 Bug fixes:
 

doc/yaml_configuration.md

@@ -614,7 +614,7 @@ Specify a variant binary distribution of GHC to use.  Known values:
 * `integersimple`: Use a GHC bindist that uses
   [integer-simple instead of GMP](https://ghc.haskell.org/trac/ghc/wiki/ReplacingGMPNotes)
 * any other value: Use a custom GHC bindist. You should specify
-  [setup-info](#setup-info) or [setup-info-locations](#setup-info-locations) 
+  [setup-info](#setup-info) or [setup-info-locations](#setup-info-locations)
   so `stack setup` knows where to download it,
   or pass the `stack setup --ghc-bindist` argument on the command-line
 
@@ -1143,11 +1143,12 @@ For example, users of the popular
 terminal theme might wish to set the styles as follows:
 
 ```yaml
-stack-colors: error=31:good=32:shell=35:dir=34:recommendation=32:target=95:module=35:package-component=95
+stack-colors: error=31:good=32:shell=35:dir=34:recommendation=32:target=95:module=35:package-component=95:secondary=92:highlight=32
 ```
 The styles can also be set at the command line using the equivalent `--stack-colors=<STYLES>`
 global option. Styles set at the command line take precedence over those set in
-a yaml configuration file.
+a yaml configuration file. (In respect of styles used in verbose output, some of
+that output occurs before the configuration file is processed.)
 
 (The British English spelling (colour) is also accepted. In yaml configuration
 files, the American spelling is the alternative that has priority.)

package.yaml

@@ -106,8 +106,8 @@ dependencies:
 - project-template
 - regex-applicative-text
 - retry
-- rio
-- rio-prettyprint
+- rio >= 0.1.18.0
+- rio-prettyprint >= 0.1.1.0
 - semigroups
 - split
 - stm

src/Stack/Config.hs

@@ -30,11 +30,13 @@ module Stack.Config
   ,defaultConfigYaml
   ,getProjectConfig
   ,withBuildConfig
+  ,withNewLogFunc
   ) where
 
 import           Control.Monad.Extra (firstJustM)
 import           Stack.Prelude
 import           Pantry.Internal.AesonExtended
+import           Data.Array.IArray ((!), (//))
 import qualified Data.ByteString as S
 import           Data.ByteString.Builder (byteString)
 import           Data.Coerce (coerce)
@@ -74,13 +76,16 @@ import           Stack.Types.Nix
 import           Stack.Types.Resolver
 import           Stack.Types.SourceMap
 import           Stack.Types.Version
-import           System.Console.ANSI (hSupportsANSIWithoutEmulation)
+import           System.Console.ANSI (hSupportsANSIWithoutEmulation, setSGRCode)
 import           System.Environment
 import           System.Info.ShortPathName (getShortPathName)
 import           System.PosixCompat.Files (fileOwner, getFileStatus)
 import           System.PosixCompat.User (getEffectiveUserID)
 import           RIO.List (unzip)
-import           RIO.PrettyPrint (stylesUpdateL, useColorL)
+import           RIO.PrettyPrint (Style (Highlight, Secondary),
+                   logLevelToStyle, stylesUpdateL, useColorL)
+import           RIO.PrettyPrint.StylesUpdate (StylesUpdate (..))
+import           RIO.PrettyPrint.DefaultStyles (defaultStyles)
 import           RIO.Process
 import           RIO.Time (toGregorian)
 
@@ -354,10 +359,12 @@ configFromConfigMonoid
                 ColorNever  -> False
                 ColorAlways -> True
                 ColorAuto  -> useAnsi
-         configRunner = configRunner'
-             & processContextL .~ origEnv
-             & stylesUpdateL .~ stylesUpdate'
-             & useColorL .~ fromMaybe useColor' mUseColor
+         useColor'' = fromMaybe useColor' mUseColor
+         configRunner'' = configRunner'
+               & processContextL .~ origEnv
+               & stylesUpdateL .~ stylesUpdate'
+               & useColorL .~ useColor''
+         go = runnerGlobalOpts configRunner'
 
      hsc <-
        case getFirst configMonoidPackageIndices of
@@ -394,17 +401,47 @@ configFromConfigMonoid
 
      let configStackDeveloperMode = fromFirst stackDeveloperModeDefault configMonoidStackDeveloperMode
 
-     withPantryConfig
-       pantryRoot
-       hsc
-       (maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack)
-       clConnectionCount
-       (fromFirst defaultCasaRepoPrefix configMonoidCasaRepoPrefix)
-       defaultCasaMaxPerRequest
-       snapLoc
-       (\configPantryConfig -> initUserStorage
-         (configStackRoot </> relFileStorage)
-         (\configUserStorage -> inner Config {..}))
+     withNewLogFunc go useColor'' stylesUpdate' $ \logFunc -> do
+       let configRunner = configRunner'' & logFuncL .~ logFunc
+       withPantryConfig
+         pantryRoot
+         hsc
+         (maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack)
+         clConnectionCount
+         (fromFirst defaultCasaRepoPrefix configMonoidCasaRepoPrefix)
+         defaultCasaMaxPerRequest
+         snapLoc
+         (\configPantryConfig -> initUserStorage
+           (configStackRoot </> relFileStorage)
+           (\configUserStorage -> inner Config {..}))
+
+-- | Runs the provided action with a new 'LogFunc', given a 'StylesUpdate'.
+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
 
 -- | Get the default location of the local programs directory.
 getDefaultLocalProgramsBase :: MonadThrow m

src/Stack/Runners.hs

@@ -148,15 +148,8 @@ withRunnerGlobal go inner = do
                                     <$> getTerminalWidth)
                                    pure (globalTermWidth go)
   menv <- mkDefaultProcessContext
-  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
+  let update = globalStylesUpdate go
+  withNewLogFunc go useColor update $ \logFunc -> runRIO Runner
     { runnerGlobalOpts = go
     , runnerUseColor = useColor
     , runnerLogFunc = logFunc

stack.cabal

@@ -4,7 +4,7 @@ cabal-version: 2.0
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 2a288b315557ca9df67fb60c003674a0dd6618aa5f8bc2b04527fb8feae4b16d
+-- hash: 40180d8b137f1935be8e5493b14ff579fc5174c0bd488f713b1020be585169e1
 
 name:           stack
 version:        2.4.0
@@ -284,8 +284,8 @@ library
     , project-template
     , regex-applicative-text
     , retry
-    , rio
-    , rio-prettyprint
+    , rio >=0.1.18.0
+    , rio-prettyprint >=0.1.1.0
     , semigroups
     , split
     , stm
@@ -408,8 +408,8 @@ executable stack
     , project-template
     , regex-applicative-text
     , retry
-    , rio
-    , rio-prettyprint
+    , rio >=0.1.18.0
+    , rio-prettyprint >=0.1.1.0
     , semigroups
     , split
     , stack
@@ -531,8 +531,8 @@ executable stack-integration-test
     , project-template
     , regex-applicative-text
     , retry
-    , rio
-    , rio-prettyprint
+    , rio >=0.1.18.0
+    , rio-prettyprint >=0.1.1.0
     , semigroups
     , split
     , stm
@@ -660,8 +660,8 @@ test-suite stack-test
     , raw-strings-qq
     , regex-applicative-text
     , retry
-    , rio
-    , rio-prettyprint
+    , rio >=0.1.18.0
+    , rio-prettyprint >=0.1.1.0
     , semigroups
     , smallcheck
     , split

stack.yaml

@@ -29,6 +29,8 @@ extra-deps:
 - http-download-0.2.0.0@rev:0
 - filelock-0.1.1.5@rev:0
 - pantry-0.5.1.1@rev:0
+- rio-0.1.18.0@rev:0
+- rio-prettyprint-0.1.1.0@rev:0
 - casa-client-0.0.1@rev:0
 - casa-types-0.0.1@rev:0