From ef8da9bceccc19469cb3ea2d4508a327c907ab51 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 23 Sep 2021 12:16:49 +0200 Subject: [PATCH] Make sure NO_COLOR also applies to logging --- app/ghcup-gen/Main.hs | 10 +++++++--- app/ghcup/BrickMain.hs | 7 ++++--- app/ghcup/Main.hs | 29 ++++++++++++++++------------- lib/GHCup/Types.hs | 9 +++++---- lib/GHCup/Types/Optics.hs | 13 +++++++------ 5 files changed, 39 insertions(+), 29 deletions(-) diff --git a/app/ghcup-gen/Main.hs b/app/ghcup-gen/Main.hs index 47ca21a..a177c7a 100644 --- a/app/ghcup-gen/Main.hs +++ b/app/ghcup-gen/Main.hs @@ -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 diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 0ab825f..e9148e1 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -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 diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index b4eac9a..48b326d 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -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 |] -- 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 |] 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 diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 2516a03..b01b202 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -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) diff --git a/lib/GHCup/Types/Optics.hs b/lib/GHCup/Types/Optics.hs index 7b1cdc7..3d6f3c2 100644 --- a/lib/GHCup/Types/Optics.hs +++ b/lib/GHCup/Types/Optics.hs @@ -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