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

Merge branch 'no-color'

Browse Source
This commit is contained in:
Julian Ospald 2021-09-23 23:28:04 +02:00
commit ff2b06a5e8
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
17 changed files with 149 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -11,21 +11,23 @@
module Main where
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Errors
import GHCup.Platform
import GHCup.Utils.Dirs
import GHCup.Utils.Logger
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

1
app/ghcup-gen/Validate.hs
View File

@ -15,6 +15,7 @@ import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.Version.QQ
import Codec.Archive

9
app/ghcup/BrickMain.hs
View File

@ -13,9 +13,9 @@ module BrickMain where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types.Optics hiding ( getGHCupInfo )
import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.Prelude ( decUTF8Safe )
import GHCup.Utils.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

1
lib/GHCup.hs
View File

@ -34,6 +34,7 @@ import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import GHCup.Utils.Version.QQ

1
lib/GHCup/Download.hs
View File

@ -35,6 +35,7 @@ import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
import GHCup.Version

1
lib/GHCup/Platform.hs
View File

@ -23,6 +23,7 @@ import GHCup.Types
import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ

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)

2
lib/GHCup/Types/JSON.hs
View File

@ -24,6 +24,8 @@ module GHCup.Types.JSON where
import GHCup.Types
import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude
import GHCup.Utils.Logger () -- TH is broken shite and needs GHCup.Utils.Logger for linking, although we don't depend on the file.
-- This is due to the boot file.
import Control.Applicative ( (<|>) )
import Data.Aeson

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

@ -23,12 +23,9 @@ import GHCup.Types
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Data.Text ( Text )
import Optics
import URI.ByteString
import System.Console.Pretty
import qualified Data.Text as T
makePrisms ''Tool
makePrisms ''Architecture
@ -117,80 +114,6 @@ getDirs :: ( MonadReader env m
getDirs = gets @"dirs"
logInfo :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logInfo = logInternal Info
logWarn :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logWarn = logInternal Warn
logDebug :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logDebug = logInternal Debug
logError :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logError = logInternal Error
logInternal :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
) => LogLevel
-> Text
-> m ()
logInternal logLevel msg = do
LoggerConfig {..} <- gets @"loggerConfig"
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
let l = case logLevel of
Debug -> style' "[ Debug ]"
Info -> style' "[ Info ]"
Warn -> style' "[ Warn ]"
Error -> style' "[ Error ]"
let strs = T.split (== '\n') msg
let out = case strs of
[] -> T.empty
(x:xs) ->
foldr (\a b -> a <> "\n" <> b) mempty
. ((l <> " " <> x) :)
. fmap (\line' -> style' "[ ... ] " <> line' )
$ xs
when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))
$ liftIO $ colorOutter out
-- raw output
let lr = case logLevel of
Debug -> "Debug:"
Info -> "Info:"
Warn -> "Warn:"
Error -> "Error:"
let outr = lr <> " " <> msg <> "\n"
liftIO $ rawOutter outr
getLogCleanup :: ( MonadReader env m
, LabelOptic' "logCleanup" A_Lens env (IO ())
)

1
lib/GHCup/Utils.hs
View File

@ -35,6 +35,7 @@ import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Utils.File
import GHCup.Utils.Logger
import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ

1
lib/GHCup/Utils/Dirs.hs
View File

@ -38,6 +38,7 @@ import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics
import GHCup.Utils.MegaParsec
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
import Control.Exception.Safe

5
lib/GHCup/Utils/File/Common.hs-boot Normal file
View File

@ -0,0 +1,5 @@
module GHCup.Utils.File.Common where
import Text.Regex.Posix
findFiles :: FilePath -> Regex -> IO [FilePath]

1
lib/GHCup/Utils/File/Posix.hs
View File

@ -17,6 +17,7 @@ module GHCup.Utils.File.Posix where
import GHCup.Utils.File.Common
import GHCup.Utils.Prelude
import GHCup.Utils.Logger
import GHCup.Types
import GHCup.Types.Optics

80
lib/GHCup/Utils/Logger.hs
View File

@ -1,5 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Module : GHCup.Utils.Logger
@ -16,21 +18,97 @@ module GHCup.Utils.Logger where
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils.File
import {-# SOURCE #-} GHCup.Utils.File.Common
import GHCup.Utils.String.QQ
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Text ( Text )
import Optics
import Prelude hiding ( appendFile )
import System.Console.Pretty
import System.FilePath
import System.IO.Error
import Text.Regex.Posix
import qualified Data.ByteString as B
import GHCup.Utils.Prelude
import qualified Data.Text as T
logInfo :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logInfo = logInternal Info
logWarn :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logWarn = logInternal Warn
logDebug :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logDebug = logInternal Debug
logError :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logError = logInternal Error
logInternal :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
) => LogLevel
-> Text
-> 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
let l = case logLevel of
Debug -> style' "[ Debug ]"
Info -> style' "[ Info ]"
Warn -> style' "[ Warn ]"
Error -> style' "[ Error ]"
let strs = T.split (== '\n') msg
let out = case strs of
[] -> T.empty
(x:xs) ->
foldr (\a b -> a <> "\n" <> b) mempty
. ((l <> " " <> x) :)
. fmap (\line' -> style' "[ ... ] " <> line' )
$ xs
when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))
$ liftIO $ consoleOutter out
-- raw output
let lr = case logLevel of
Debug -> "Debug:"
Info -> "Info:"
Warn -> "Warn:"
Error -> "Error:"
let outr = lr <> " " <> msg <> "\n"
liftIO $ fileOutter outr
initGHCupFileLogging :: ( MonadReader env m

21
lib/GHCup/Utils/Logger.hs-boot Normal file
View File

@ -0,0 +1,21 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
module GHCup.Utils.Logger where
import GHCup.Types
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Text ( Text )
import Optics
logWarn :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()

1
lib/GHCup/Utils/Prelude.hs
View File

@ -23,6 +23,7 @@ module GHCup.Utils.Prelude where
import GHCup.Types
#endif
import GHCup.Types.Optics
import {-# SOURCE #-} GHCup.Utils.Logger
import Control.Applicative
import Control.Exception.Safe