{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Cli.Extras.Logging
( AsUnstructuredError (..)
, newCliConfig
, mkDefaultCliConfig
, runCli
, verboseLogLevel
, isOverwrite
, getSeverity
, getLogLevel
, setLogLevel
, putLog
, putLogRaw
, failWith
, withExitFailMessage
, writeLog
, allowUserToMakeLoggingVerbose
, getChars
, handleLog
) where
import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Concurrent.MVar (modifyMVar_, newMVar)
import Control.Lens (Prism', review)
import Control.Monad (unless, void, when)
import Control.Monad.Catch (MonadCatch, MonadMask, bracket, catch, throwM)
import Control.Monad.Except (runExceptT, throwError)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Log (Severity (..), WithSeverity (..), logMessage, runLoggingT)
import Control.Monad.Loops (iterateUntil)
import Control.Monad.Reader (MonadIO, ReaderT (..))
import Data.IORef (atomicModifyIORef', newIORef, readIORef, writeIORef)
import Data.List (isInfixOf)
import Data.Semigroup ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import GHC.IO.Encoding.Types
import System.Console.ANSI (Color (Red, Yellow), ColorIntensity (Vivid),
ConsoleIntensity (FaintIntensity), ConsoleLayer (Foreground),
SGR (SetColor, SetConsoleIntensity), clearLine)
import System.Environment
import System.Exit (ExitCode (..))
import System.IO
import qualified Cli.Extras.TerminalString as TS
import Cli.Extras.Theme
import Cli.Extras.Types
putLog :: CliLog m => Severity -> Text -> m ()
putLog :: Severity -> Text -> m ()
putLog sev :: Severity
sev = Output -> m ()
forall message (m :: * -> *). MonadLog message m => message -> m ()
logMessage (Output -> m ()) -> (Text -> Output) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithSeverity Text -> Output
Output_Log (WithSeverity Text -> Output)
-> (Text -> WithSeverity Text) -> Text -> Output
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Severity -> Text -> WithSeverity Text
forall a. Severity -> a -> WithSeverity a
WithSeverity Severity
sev
putLog' :: CliConfig -> Severity -> Text -> IO ()
putLog' :: CliConfig -> Severity -> Text -> IO ()
putLog' conf :: CliConfig
conf sev :: Severity
sev t :: Text
t = LoggingT Output IO () -> Handler IO Output -> IO ()
forall message (m :: * -> *) a.
LoggingT message m a -> Handler m message -> m a
runLoggingT (Severity -> Text -> LoggingT Output IO ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
sev Text
t) (CliConfig -> Handler IO Output
forall (m :: * -> *). MonadIO m => CliConfig -> Output -> m ()
handleLog CliConfig
conf)
mkDefaultCliConfig :: [String] -> IO CliConfig
mkDefaultCliConfig :: [String] -> IO CliConfig
mkDefaultCliConfig cliArgs :: [String]
cliArgs = do
let logLevel :: Severity
logLevel = if (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["-v", "--verbose"]) [String]
cliArgs then Severity
Debug else Severity
Notice
Bool
notInteractive <- Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool
isInteractiveTerm
Severity -> Bool -> Bool -> IO CliConfig
newCliConfig Severity
logLevel Bool
notInteractive Bool
notInteractive
where
isInteractiveTerm :: IO Bool
isInteractiveTerm = do
Bool
isTerm <- Handle -> IO Bool
hIsTerminalDevice Handle
stdout
let inShellCompletion :: Bool
inShellCompletion = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf "completion" (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String]
cliArgs
Maybe String
termEnv <- String -> IO (Maybe String)
lookupEnv "TERM"
let isDumb :: Bool
isDumb = Maybe String
termEnv Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just "dumb"
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool
isTerm Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
inShellCompletion Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isDumb
newCliConfig
:: Severity
-> Bool
-> Bool
-> IO CliConfig
newCliConfig :: Severity -> Bool -> Bool -> IO CliConfig
newCliConfig sev :: Severity
sev noColor :: Bool
noColor noSpinner :: Bool
noSpinner = do
IORef Severity
level <- Severity -> IO (IORef Severity)
forall a. a -> IO (IORef a)
newIORef Severity
sev
MVar Bool
lock <- Bool -> IO (MVar Bool)
forall a. a -> IO (MVar a)
newMVar Bool
False
IORef Bool
tipDisplayed <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
IORef ([Bool], [TerminalString])
stack <- ([Bool], [TerminalString]) -> IO (IORef ([Bool], [TerminalString]))
forall a. a -> IO (IORef a)
newIORef ([], [])
Maybe TextEncoding
textEncoding <- Handle -> IO (Maybe TextEncoding)
hGetEncoding Handle
stdout
let theme :: CliTheme
theme = if Bool -> (TextEncoding -> Bool) -> Maybe TextEncoding -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False TextEncoding -> Bool
supportsUnicode Maybe TextEncoding
textEncoding
then CliTheme
unicodeTheme
else CliTheme
noUnicodeTheme
CliConfig -> IO CliConfig
forall (m :: * -> *) a. Monad m => a -> m a
return (CliConfig -> IO CliConfig) -> CliConfig -> IO CliConfig
forall a b. (a -> b) -> a -> b
$ IORef Severity
-> Bool
-> Bool
-> MVar Bool
-> IORef Bool
-> IORef ([Bool], [TerminalString])
-> CliTheme
-> CliConfig
CliConfig IORef Severity
level Bool
noColor Bool
noSpinner MVar Bool
lock IORef Bool
tipDisplayed IORef ([Bool], [TerminalString])
stack CliTheme
theme
runCli :: MonadIO m => CliConfig -> CliT e m a -> m (Either e a)
runCli :: CliConfig -> CliT e m a -> m (Either e a)
runCli c :: CliConfig
c =
ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
(ExceptT e m a -> m (Either e a))
-> (CliT e m a -> ExceptT e m a) -> CliT e m a -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LoggingT Output (ExceptT e m) a
-> Handler (ExceptT e m) Output -> ExceptT e m a)
-> Handler (ExceptT e m) Output
-> LoggingT Output (ExceptT e m) a
-> ExceptT e m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT Output (ExceptT e m) a
-> Handler (ExceptT e m) Output -> ExceptT e m a
forall message (m :: * -> *) a.
LoggingT message m a -> Handler m message -> m a
runLoggingT (CliConfig -> Handler (ExceptT e m) Output
forall (m :: * -> *). MonadIO m => CliConfig -> Output -> m ()
handleLog CliConfig
c)
(LoggingT Output (ExceptT e m) a -> ExceptT e m a)
-> (CliT e m a -> LoggingT Output (ExceptT e m) a)
-> CliT e m a
-> ExceptT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT CliConfig (LoggingT Output (ExceptT e m)) a
-> CliConfig -> LoggingT Output (ExceptT e m) a)
-> CliConfig
-> ReaderT CliConfig (LoggingT Output (ExceptT e m)) a
-> LoggingT Output (ExceptT e m) a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT CliConfig (LoggingT Output (ExceptT e m)) a
-> CliConfig -> LoggingT Output (ExceptT e m) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CliConfig
c
(ReaderT CliConfig (LoggingT Output (ExceptT e m)) a
-> LoggingT Output (ExceptT e m) a)
-> (CliT e m a
-> ReaderT CliConfig (LoggingT Output (ExceptT e m)) a)
-> CliT e m a
-> LoggingT Output (ExceptT e m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CliT e m a -> ReaderT CliConfig (LoggingT Output (ExceptT e m)) a
forall e (m :: * -> *) a.
CliT e m a -> ReaderT CliConfig (LoggingT Output (ExceptT e m)) a
unCliT
verboseLogLevel :: Severity
verboseLogLevel :: Severity
verboseLogLevel = Severity
Debug
isOverwrite :: Output -> Bool
isOverwrite :: Output -> Bool
isOverwrite = \case
Output_Overwrite _ -> Bool
True
_ -> Bool
False
getSeverity :: Output -> Maybe Severity
getSeverity :: Output -> Maybe Severity
getSeverity = \case
Output_Log (WithSeverity sev :: Severity
sev _) -> Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
sev
Output_LogRaw (WithSeverity sev :: Severity
sev _) -> Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
sev
_ -> Maybe Severity
forall a. Maybe a
Nothing
getLogLevel :: (MonadIO m, HasCliConfig m) => m Severity
getLogLevel :: m Severity
getLogLevel = CliConfig -> m Severity
forall (m :: * -> *). MonadIO m => CliConfig -> m Severity
getLogLevel' (CliConfig -> m Severity) -> m CliConfig -> m Severity
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m CliConfig
forall (m :: * -> *). HasCliConfig m => m CliConfig
getCliConfig
getLogLevel' :: MonadIO m => CliConfig -> m Severity
getLogLevel' :: CliConfig -> m Severity
getLogLevel' = IO Severity -> m Severity
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Severity -> m Severity)
-> (CliConfig -> IO Severity) -> CliConfig -> m Severity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef Severity -> IO Severity
forall a. IORef a -> IO a
readIORef (IORef Severity -> IO Severity)
-> (CliConfig -> IORef Severity) -> CliConfig -> IO Severity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CliConfig -> IORef Severity
_cliConfig_logLevel
setLogLevel :: (MonadIO m, HasCliConfig m) => Severity -> m ()
setLogLevel :: Severity -> m ()
setLogLevel sev :: Severity
sev = do
CliConfig
conf <- m CliConfig
forall (m :: * -> *). HasCliConfig m => m CliConfig
getCliConfig
CliConfig -> Severity -> m ()
forall (m :: * -> *). MonadIO m => CliConfig -> Severity -> m ()
setLogLevel' CliConfig
conf Severity
sev
setLogLevel' :: MonadIO m => CliConfig -> Severity -> m ()
setLogLevel' :: CliConfig -> Severity -> m ()
setLogLevel' conf :: CliConfig
conf sev :: Severity
sev = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Severity -> Severity -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (CliConfig -> IORef Severity
_cliConfig_logLevel CliConfig
conf) Severity
sev
handleLog :: MonadIO m => CliConfig -> Output -> m ()
handleLog :: CliConfig -> Output -> m ()
handleLog conf :: CliConfig
conf output :: Output
output = do
Severity
level <- CliConfig -> m Severity
forall (m :: * -> *). MonadIO m => CliConfig -> m Severity
getLogLevel' CliConfig
conf
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar Bool -> (Bool -> IO Bool) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (CliConfig -> MVar Bool
_cliConfig_lock CliConfig
conf) ((Bool -> IO Bool) -> IO ()) -> (Bool -> IO Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ \wasOverwriting :: Bool
wasOverwriting -> do
let noColor :: Bool
noColor = CliConfig -> Bool
_cliConfig_noColor CliConfig
conf
case Output -> Maybe Severity
getSeverity Output
output of
Nothing -> Bool -> Output -> IO Bool
forall (m :: * -> *). MonadIO m => Bool -> Output -> m Bool
handleLog' Bool
noColor Output
output
Just sev :: Severity
sev -> if Severity
sev Severity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
> Severity
level
then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
wasOverwriting
else do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wasOverwriting (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Output -> IO Bool
forall (m :: * -> *). MonadIO m => Bool -> Output -> m Bool
handleLog' Bool
noColor Output
Output_ClearLine
Bool -> Output -> IO Bool
forall (m :: * -> *). MonadIO m => Bool -> Output -> m Bool
handleLog' Bool
noColor Output
output
handleLog' :: MonadIO m => Bool -> Output -> m Bool
handleLog' :: Bool -> Output -> m Bool
handleLog' noColor :: Bool
noColor output :: Output
output = do
case Output
output of
Output_Log m :: WithSeverity Text
m -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> Bool -> WithSeverity Text -> IO ()
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
Bool -> Bool -> WithSeverity Text -> m ()
writeLog Bool
True Bool
noColor WithSeverity Text
m
Output_LogRaw m :: WithSeverity Text
m -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> Bool -> WithSeverity Text -> IO ()
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
Bool -> Bool -> WithSeverity Text -> m ()
writeLog Bool
False Bool
noColor WithSeverity Text
m
Handle -> IO ()
hFlush Handle
stdout
Output_Write ts :: [TerminalString]
ts -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Int -> [TerminalString] -> Text
TS.render (Bool -> Bool
not Bool
noColor) Maybe Int
forall a. Maybe a
Nothing [TerminalString]
ts
Handle -> IO ()
hFlush Handle
stdout
Output_Overwrite ts :: [TerminalString]
ts -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Maybe Int
width <- IO (Maybe Int)
TS.getTerminalWidth
Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ "\r" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> Maybe Int -> [TerminalString] -> Text
TS.render (Bool -> Bool
not Bool
noColor) Maybe Int
width [TerminalString]
ts
Handle -> IO ()
hFlush Handle
stdout
Output_ClearLine -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStr "\r"
IO ()
clearLine
Handle -> IO ()
hFlush Handle
stdout
Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Output -> Bool
isOverwrite Output
output
putLogRaw :: CliLog m => Severity -> Text -> m ()
putLogRaw :: Severity -> Text -> m ()
putLogRaw sev :: Severity
sev = Output -> m ()
forall message (m :: * -> *). MonadLog message m => message -> m ()
logMessage (Output -> m ()) -> (Text -> Output) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithSeverity Text -> Output
Output_LogRaw (WithSeverity Text -> Output)
-> (Text -> WithSeverity Text) -> Text -> Output
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Severity -> Text -> WithSeverity Text
forall a. Severity -> a -> WithSeverity a
WithSeverity Severity
sev
class AsUnstructuredError e where
asUnstructuredError :: Prism' e Text
instance AsUnstructuredError Text where
asUnstructuredError :: p Text (f Text) -> p Text (f Text)
asUnstructuredError = p Text (f Text) -> p Text (f Text)
forall a. a -> a
id
failWith :: (CliThrow e m, AsUnstructuredError e) => Text -> m a
failWith :: Text -> m a
failWith = e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> m a) -> (Text -> e) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AReview e Text -> Text -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e Text
forall e. AsUnstructuredError e => Prism' e Text
asUnstructuredError
withExitFailMessage :: (CliLog m, MonadCatch m) => Text -> m a -> m a
withExitFailMessage :: Text -> m a -> m a
withExitFailMessage msg :: Text
msg f :: m a
f = m a
f m a -> (ExitCode -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(ExitCode
e :: ExitCode) -> do
case ExitCode
e of
ExitFailure _ -> Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Alert Text
msg
ExitSuccess -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ExitCode -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ExitCode
e
writeLog :: (MonadIO m, MonadMask m) => Bool -> Bool -> WithSeverity Text -> m ()
writeLog :: Bool -> Bool -> WithSeverity Text -> m ()
writeLog withNewLine :: Bool
withNewLine noColor :: Bool
noColor (WithSeverity severity :: Severity
severity s :: Text
s) = if Text -> Bool
T.null Text
s then () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else m ()
write
where
write :: m ()
write
| Bool
noColor Bool -> Bool -> Bool
&& Severity
severity Severity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
<= Severity
Warning = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
putFn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (Severity -> String
forall a. Show a => a -> String
show Severity
severity) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
| Bool -> Bool
not Bool
noColor Bool -> Bool -> Bool
&& Severity
severity Severity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
<= Severity
Error = [SGR] -> Handle -> Bool -> Text -> m ()
forall (m :: * -> *).
MonadIO m =>
[SGR] -> Handle -> Bool -> Text -> m ()
TS.putStrWithSGR [SGR]
errorColors Handle
h Bool
withNewLine Text
s
| Bool -> Bool
not Bool
noColor Bool -> Bool -> Bool
&& Severity
severity Severity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
<= Severity
Warning = [SGR] -> Handle -> Bool -> Text -> m ()
forall (m :: * -> *).
MonadIO m =>
[SGR] -> Handle -> Bool -> Text -> m ()
TS.putStrWithSGR [SGR]
warningColors Handle
h Bool
withNewLine Text
s
| Bool -> Bool
not Bool
noColor Bool -> Bool -> Bool
&& Severity
severity Severity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
>= Severity
Debug = [SGR] -> Handle -> Bool -> Text -> m ()
forall (m :: * -> *).
MonadIO m =>
[SGR] -> Handle -> Bool -> Text -> m ()
TS.putStrWithSGR [SGR]
debugColors Handle
h Bool
withNewLine Text
s
| Bool
otherwise = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
putFn Text
s
putFn :: Text -> IO ()
putFn = if Bool
withNewLine then Handle -> Text -> IO ()
T.hPutStrLn Handle
h else Handle -> Text -> IO ()
T.hPutStr Handle
h
h :: Handle
h = if Severity
severity Severity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
<= Severity
Error then Handle
stderr else Handle
stdout
errorColors :: [SGR]
errorColors = [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Red]
warningColors :: [SGR]
warningColors = [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Yellow]
debugColors :: [SGR]
debugColors = [ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
FaintIntensity]
allowUserToMakeLoggingVerbose
:: CliConfig
-> String
-> IO ()
allowUserToMakeLoggingVerbose :: CliConfig -> String -> IO ()
allowUserToMakeLoggingVerbose conf :: CliConfig
conf keyCode :: String
keyCode = do
let unlessVerbose :: m () -> m ()
unlessVerbose f :: m ()
f = do
Severity
l <- CliConfig -> m Severity
forall (m :: * -> *). MonadIO m => CliConfig -> m Severity
getLogLevel' CliConfig
conf
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Severity
l Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
== Severity
verboseLogLevel) m ()
f
showTip :: IO ThreadId
showTip = IO ThreadId -> IO ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> IO ThreadId) -> IO ThreadId -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (m :: * -> *). MonadIO m => m () -> m ()
unlessVerbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ 10Int -> Int -> Int
forall a. Num a => a -> a -> a
*1000000
Bool
tipDisplayed <- IO Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (CliConfig -> IORef Bool
_cliConfig_tipDisplayed CliConfig
conf) ((Bool -> (Bool, Bool)) -> IO Bool)
-> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ (,) Bool
True
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
tipDisplayed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (m :: * -> *). MonadIO m => m () -> m ()
unlessVerbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
CliConfig -> Severity -> Text -> IO ()
putLog' CliConfig
conf Severity
Notice "Tip: Press Ctrl+e to display full output"
IO ThreadId -> (ThreadId -> IO ()) -> (ThreadId -> IO ()) -> IO ()
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket IO ThreadId
showTip (IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> (ThreadId -> IO ()) -> ThreadId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> IO ()
killThread) ((ThreadId -> IO ()) -> IO ()) -> (ThreadId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \_ -> do
IO () -> IO ()
forall (m :: * -> *). MonadIO m => m () -> m ()
unlessVerbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
NoBuffering
String
_ <- (String -> Bool) -> IO String -> IO String
forall (m :: * -> *) a. Monad m => (a -> Bool) -> m a -> m a
iterateUntil (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
keyCode) IO String
getChars
CliConfig -> Severity -> Text -> IO ()
putLog' CliConfig
conf Severity
Warning "Ctrl+e pressed; making output verbose (-v)"
CliConfig -> Severity -> IO ()
forall (m :: * -> *). MonadIO m => CliConfig -> Severity -> m ()
setLogLevel' CliConfig
conf Severity
verboseLogLevel
getChars :: IO String
getChars :: IO String
getChars = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
f String
forall a. Monoid a => a
mempty
where
f :: String -> IO String
f xs :: String
xs = do
Char
x <- IO Char
getChar
Handle -> IO Bool
hReady Handle
stdin IO Bool -> (Bool -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
True -> String -> IO String
f (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs)
False -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs)
supportsUnicode :: TextEncoding -> Bool
supportsUnicode :: TextEncoding -> Bool
supportsUnicode enc :: TextEncoding
enc = (TextEncoding -> Bool) -> [TextEncoding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((TextEncoding -> String
textEncodingName TextEncoding
enc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool)
-> (TextEncoding -> String) -> TextEncoding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextEncoding -> String
textEncodingName)
[ TextEncoding
utf8
, TextEncoding
utf8_bom
, TextEncoding
utf16
, TextEncoding
utf16be
, TextEncoding
utf16le
, TextEncoding
utf32
, TextEncoding
utf32be
, TextEncoding
utf32le
]