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

29
app/ghcup/Main.hs
View File

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

9
lib/GHCup/Types.hs
View File

@ -576,11 +576,12 @@ data LogLevel = Warn
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
data LoggerConfig = LoggerConfig data LoggerConfig = LoggerConfig
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter { lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, colorOutter :: T.Text -> IO () -- ^ how to write the color output , consoleOutter :: T.Text -> IO () -- ^ how to write the console output
, rawOutter :: T.Text -> IO () -- ^ how to write the full raw output , fileOutter :: T.Text -> IO () -- ^ how to write the file output
, fancyColors :: Bool
} }
deriving Show deriving Show
instance NFData LoggerConfig where 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 () -> m ()
logInternal logLevel msg = do logInternal logLevel msg = do
LoggerConfig {..} <- gets @"loggerConfig" LoggerConfig {..} <- gets @"loggerConfig"
let color' c = if fancyColors then color c else id
let style' = case logLevel of let style' = case logLevel of
Debug -> style Bold . color Blue Debug -> style Bold . color' Blue
Info -> style Bold . color Green Info -> style Bold . color' Green
Warn -> style Bold . color Yellow Warn -> style Bold . color' Yellow
Error -> style Bold . color Red Error -> style Bold . color' Red
let l = case logLevel of let l = case logLevel of
Debug -> style' "[ Debug ]" Debug -> style' "[ Debug ]"
Info -> style' "[ Info ]" Info -> style' "[ Info ]"
@ -178,7 +179,7 @@ logInternal logLevel msg = do
$ xs $ xs
when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug))) when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))
$ liftIO $ colorOutter out $ liftIO $ consoleOutter out
-- raw output -- raw output
let lr = case logLevel of let lr = case logLevel of
@ -187,7 +188,7 @@ logInternal logLevel msg = do
Warn -> "Warn:" Warn -> "Warn:"
Error -> "Error:" Error -> "Error:"
let outr = lr <> " " <> msg <> "\n" let outr = lr <> " " <> msg <> "\n"
liftIO $ rawOutter outr liftIO $ fileOutter outr