hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Make sure NO_COLOR also applies to logging

Browse Source
This commit is contained in:
Julian Ospald 2021-09-23 12:16:49 +02:00
parent 3cd55beab1
commit ef8da9bcec
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
5 changed files with 39 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
app/ghcup-gen/Main.hs
View File

@ -20,12 +20,14 @@ import GHCup.Types.JSON ( )
import Control.Monad.Trans.Reader ( runReaderT )
import Control.Monad.IO.Class
import Data.Char ( toLower )
import Data.Maybe
#if !MIN_VERSION_base(4,13,0)
import Data.Semigroup ( (<>) )
#endif
import Options.Applicative hiding ( style )
import Haskus.Utils.Variant.Excepts
import System.Console.Pretty
import System.Environment
import System.Exit
import System.IO ( stderr )
import Text.Regex.Posix
@ -114,9 +116,11 @@ com = subparser
main :: IO ()
main = do
let loggerConfig = LoggerConfig { lcPrintDebug = True
, colorOutter = T.hPutStr stderr
, rawOutter = \_ -> pure ()
no_color <- isJust <$> lookupEnv "NO_COLOR"
let loggerConfig = LoggerConfig { lcPrintDebug = True
, consoleOutter = T.hPutStr stderr
, fileOutter = \_ -> pure ()
, fancyColors = not no_color
}
dirs <- liftIO getAllDirs
let leanAppstate = LeanAppState (Settings True False Never Curl True GHCupURL False GPGNone) dirs defaultKeyBindings loggerConfig

7
app/ghcup/BrickMain.hs
View File

@ -537,9 +537,10 @@ settings' :: IORef AppState
{-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do
dirs <- getAllDirs
let loggerConfig = LoggerConfig { lcPrintDebug = False
, colorOutter = \_ -> pure ()
, rawOutter = \_ -> pure ()
let loggerConfig = LoggerConfig { lcPrintDebug = False
, consoleOutter = \_ -> pure ()
, fileOutter = \_ -> pure ()
, fancyColors = True
}
newIORef $ AppState (Settings { cache = True
, noVerify = False

29
app/ghcup/Main.hs
View File

@ -1338,9 +1338,10 @@ tagCompleter :: Tool -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do
dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
, rawOutter = mempty
{ lcPrintDebug = False
, consoleOutter = mempty
, fileOutter = mempty
, fancyColors = False
}
let appState = LeanAppState
(Settings True False Never Curl False GHCupURL True GPGNone)
@ -1364,9 +1365,10 @@ versionCompleter :: Maybe ListCriteria -> Tool -> Completer
versionCompleter criteria tool = listIOCompleter $ do
dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
, rawOutter = mempty
{ lcPrintDebug = False
, consoleOutter = mempty
, fileOutter = mempty
, fancyColors = False
}
let settings = Settings True False Never Curl False GHCupURL True GPGNone
let leanAppState = LeanAppState
@ -1688,17 +1690,19 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-- logger interpreter
logfile <- flip runReaderT dirs initGHCupFileLogging
no_color <- isJust <$> lookupEnv "NO_COLOR"
let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings
, colorOutter = T.hPutStr stderr
, rawOutter =
, consoleOutter = T.hPutStr stderr
, fileOutter =
case optCommand of
Nuke -> \_ -> pure ()
_ -> T.appendFile logfile
, fancyColors = not no_color
}
let leanAppstate = LeanAppState settings dirs keybindings loggerConfig
let runLogger = flip runReaderT leanAppstate
let siletRunLogger = flip runReaderT (leanAppstate { loggerConfig = loggerConfig { colorOutter = \_ -> pure () } } :: LeanAppState)
let siletRunLogger = flip runReaderT (leanAppstate { loggerConfig = loggerConfig { consoleOutter = \_ -> pure () } } :: LeanAppState)
-------------------------
@ -2336,7 +2340,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
List ListOptions {..} ->
runListGHC (do
l <- listVersions loTool lCriteria
liftIO $ printListResult lRawFormat l
liftIO $ printListResult no_color lRawFormat l
pure ExitSuccess
)
@ -2807,9 +2811,8 @@ fromVersion' (SetToolTag t') tool =
throwE $ TagNotFound t' tool
printListResult :: Bool -> [ListResult] -> IO ()
printListResult raw lr = do
no_color <- isJust <$> lookupEnv "NO_COLOR"
printListResult :: Bool -> Bool -> [ListResult] -> IO ()
printListResult no_color raw lr = do
let
color | raw || no_color = flip const

9
lib/GHCup/Types.hs
View File

@ -576,11 +576,12 @@ data LogLevel = Warn
deriving (Eq, Ord, Show)
data LoggerConfig = LoggerConfig
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, colorOutter :: T.Text -> IO () -- ^ how to write the color output
, rawOutter :: T.Text -> IO () -- ^ how to write the full raw output
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, consoleOutter :: T.Text -> IO () -- ^ how to write the console output
, fileOutter :: T.Text -> IO () -- ^ how to write the file output
, fancyColors :: Bool
}
deriving Show
instance NFData LoggerConfig where
rnf (LoggerConfig !lcPrintDebug !_ !_) = rnf lcPrintDebug
rnf (LoggerConfig !lcPrintDebug !_ !_ !fancyColors) = rnf (lcPrintDebug, fancyColors)

13
lib/GHCup/Types/Optics.hs
View File

@ -158,11 +158,12 @@ logInternal :: ( MonadReader env m
-> m ()
logInternal logLevel msg = do
LoggerConfig {..} <- gets @"loggerConfig"
let color' c = if fancyColors then color c else id
let style' = case logLevel of
Debug -> style Bold . color Blue
Info -> style Bold . color Green
Warn -> style Bold . color Yellow
Error -> style Bold . color Red
Debug -> style Bold . color' Blue
Info -> style Bold . color' Green
Warn -> style Bold . color' Yellow
Error -> style Bold . color' Red
let l = case logLevel of
Debug -> style' "[ Debug ]"
Info -> style' "[ Info ]"
@ -178,7 +179,7 @@ logInternal logLevel msg = do
$ xs
when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))
$ liftIO $ colorOutter out
$ liftIO $ consoleOutter out
-- raw output
let lr = case logLevel of
@ -187,7 +188,7 @@ logInternal logLevel msg = do
Warn -> "Warn:"
Error -> "Error:"
let outr = lr <> " " <> msg <> "\n"
liftIO $ rawOutter outr
liftIO $ fileOutter outr