{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Cli.Extras.Logging
( AsUnstructuredError (..)
, newCliConfig
, runCli
, verboseLogLevel
, isOverwrite
, getSeverity
, getLogLevel
, setLogLevel
, putLog
, putLogRaw
, failWith
, errorToWarning
, withExitFailMessage
, writeLog
, allowUserToMakeLoggingVerbose
, getChars
, fork
) where
import Control.Concurrent (ThreadId, 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 (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.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 (..), ColorIntensity (Vivid),
ConsoleIntensity (FaintIntensity), ConsoleLayer (Foreground),
SGR (SetColor, SetConsoleIntensity), clearLine)
import System.Exit (ExitCode (..))
import System.IO
import qualified Cli.Extras.TerminalString as TS
import Cli.Extras.Theme
import Cli.Extras.Types
newCliConfig
:: Severity
-> Bool
-> Bool
-> (e -> (Text, ExitCode))
-> IO (CliConfig e)
newCliConfig :: Severity
-> Bool -> Bool -> (e -> (Text, ExitCode)) -> IO (CliConfig e)
newCliConfig sev :: Severity
sev noColor :: Bool
noColor noSpinner :: Bool
noSpinner errorLogExitCode :: e -> (Text, ExitCode)
errorLogExitCode = 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 e -> IO (CliConfig e)
forall (m :: * -> *) a. Monad m => a -> m a
return (CliConfig e -> IO (CliConfig e))
-> CliConfig e -> IO (CliConfig e)
forall a b. (a -> b) -> a -> b
$ IORef Severity
-> Bool
-> Bool
-> MVar Bool
-> IORef Bool
-> IORef ([Bool], [TerminalString])
-> (e -> (Text, ExitCode))
-> CliTheme
-> CliConfig e
forall e.
IORef Severity
-> Bool
-> Bool
-> MVar Bool
-> IORef Bool
-> IORef ([Bool], [TerminalString])
-> (e -> (Text, ExitCode))
-> CliTheme
-> CliConfig e
CliConfig IORef Severity
level Bool
noColor Bool
noSpinner MVar Bool
lock IORef Bool
tipDisplayed IORef ([Bool], [TerminalString])
stack e -> (Text, ExitCode)
errorLogExitCode CliTheme
theme
runCli :: MonadIO m => CliConfig e -> CliT e m a -> m a
runCli :: CliConfig e -> CliT e m a -> m a
runCli c :: CliConfig e
c =
(LoggingT Output m a -> Handler m Output -> m a)
-> Handler m Output -> LoggingT Output m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT Output m a -> Handler m Output -> m a
forall message (m :: * -> *) a.
LoggingT message m a -> Handler m message -> m a
runLoggingT (CliConfig e -> Handler m Output
forall (m :: * -> *) e. MonadIO m => CliConfig e -> Output -> m ()
handleLog CliConfig e
c)
(LoggingT Output m a -> m a)
-> (CliT e m a -> LoggingT Output m a) -> CliT e m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT (e -> (Text, ExitCode)) (LoggingT Output m) a
-> (e -> (Text, ExitCode)) -> LoggingT Output m a)
-> (e -> (Text, ExitCode))
-> ReaderT (e -> (Text, ExitCode)) (LoggingT Output m) a
-> LoggingT Output m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (e -> (Text, ExitCode)) (LoggingT Output m) a
-> (e -> (Text, ExitCode)) -> LoggingT Output m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (CliConfig e -> e -> (Text, ExitCode)
forall e. CliConfig e -> e -> (Text, ExitCode)
_cliConfig_errorLogExitCode CliConfig e
c)
(ReaderT (e -> (Text, ExitCode)) (LoggingT Output m) a
-> LoggingT Output m a)
-> (CliT e m a
-> ReaderT (e -> (Text, ExitCode)) (LoggingT Output m) a)
-> CliT e m a
-> LoggingT Output m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DieT e m a -> ReaderT (e -> (Text, ExitCode)) (LoggingT Output m) a
forall e (m :: * -> *) a.
DieT e m a -> ReaderT (e -> (Text, ExitCode)) (LoggingT Output m) a
unDieT
(DieT e m a
-> ReaderT (e -> (Text, ExitCode)) (LoggingT Output m) a)
-> (CliT e m a -> DieT e m a)
-> CliT e m a
-> ReaderT (e -> (Text, ExitCode)) (LoggingT Output m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT (CliConfig e) (DieT e m) a -> CliConfig e -> DieT e m a)
-> CliConfig e -> ReaderT (CliConfig e) (DieT e m) a -> DieT e m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (CliConfig e) (DieT e m) a -> CliConfig e -> DieT e m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CliConfig e
c
(ReaderT (CliConfig e) (DieT e m) a -> DieT e m a)
-> (CliT e m a -> ReaderT (CliConfig e) (DieT e m) a)
-> CliT e m a
-> DieT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CliT e m a -> ReaderT (CliConfig e) (DieT e m) a
forall e (m :: * -> *) a.
CliT e m a -> ReaderT (CliConfig e) (DieT 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 e m) => m Severity
getLogLevel :: m Severity
getLogLevel = CliConfig e -> m Severity
forall (m :: * -> *) e. MonadIO m => CliConfig e -> m Severity
getLogLevel' (CliConfig e -> m Severity) -> m (CliConfig e) -> m Severity
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (CliConfig e)
forall e (m :: * -> *). HasCliConfig e m => m (CliConfig e)
getCliConfig
getLogLevel' :: MonadIO m => CliConfig e -> m Severity
getLogLevel' :: CliConfig e -> m Severity
getLogLevel' = IO Severity -> m Severity
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Severity -> m Severity)
-> (CliConfig e -> IO Severity) -> CliConfig e -> 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 e -> IORef Severity) -> CliConfig e -> IO Severity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CliConfig e -> IORef Severity
forall e. CliConfig e -> IORef Severity
_cliConfig_logLevel
setLogLevel :: (MonadIO m, HasCliConfig e m) => Severity -> m ()
setLogLevel :: Severity -> m ()
setLogLevel sev :: Severity
sev = do
IORef Severity
l <- CliConfig e -> IORef Severity
forall e. CliConfig e -> IORef Severity
_cliConfig_logLevel (CliConfig e -> IORef Severity)
-> m (CliConfig e) -> m (IORef Severity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (CliConfig e)
forall e (m :: * -> *). HasCliConfig e m => m (CliConfig e)
getCliConfig
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 IORef Severity
l Severity
sev
handleLog :: MonadIO m => CliConfig e -> Output -> m ()
handleLog :: CliConfig e -> Output -> m ()
handleLog conf :: CliConfig e
conf output :: Output
output = do
Severity
level <- CliConfig e -> m Severity
forall (m :: * -> *) e. MonadIO m => CliConfig e -> m Severity
getLogLevel' CliConfig e
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 e -> MVar Bool
forall e. CliConfig e -> MVar Bool
_cliConfig_lock CliConfig e
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 e -> Bool
forall e. CliConfig e -> Bool
_cliConfig_noColor CliConfig e
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 =>
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 =>
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
errorToWarning
:: (HasCliConfig e m, CliLog m)
=> e -> m ()
errorToWarning :: e -> m ()
errorToWarning e :: e
e = do
CliConfig e
c <- m (CliConfig e)
forall e (m :: * -> *). HasCliConfig e m => m (CliConfig e)
getCliConfig
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Warning (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ (Text, ExitCode) -> Text
forall a b. (a, b) -> a
fst ((Text, ExitCode) -> Text) -> (Text, ExitCode) -> Text
forall a b. (a -> b) -> a -> b
$ CliConfig e -> e -> (Text, ExitCode)
forall e. CliConfig e -> e -> (Text, ExitCode)
_cliConfig_errorLogExitCode CliConfig e
c e
e
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)
=> 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. Eq a => a -> a -> Bool
== Severity
Notice = [SGR] -> Handle -> Bool -> Text -> m ()
forall (m :: * -> *).
MonadIO m =>
[SGR] -> Handle -> Bool -> Text -> m ()
TS.putStrWithSGR [SGR]
noticeColors Handle
h Bool
withNewLine Text
s
| Bool -> Bool
not Bool
noColor Bool -> Bool -> Bool
&& Severity
severity Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
== Severity
Informational = [SGR] -> Handle -> Bool -> Text -> m ()
forall (m :: * -> *).
MonadIO m =>
[SGR] -> Handle -> Bool -> Text -> m ()
TS.putStrWithSGR [SGR]
infoColors 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]
infoColors :: [SGR]
infoColors = [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Green]
noticeColors :: [SGR]
noticeColors = [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Blue]
debugColors :: [SGR]
debugColors = [ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
FaintIntensity]
whenLogLevel
:: (MonadIO m, HasCliConfig e m)
=> (Severity -> Bool)
-> m ()
-> m ()
whenLogLevel :: (Severity -> Bool) -> m () -> m ()
whenLogLevel level :: Severity -> Bool
level f :: m ()
f = do
Severity
l <- m Severity
forall (m :: * -> *) e. (MonadIO m, HasCliConfig e m) => m Severity
getLogLevel
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Severity -> Bool
level Severity
l) m ()
f
allowUserToMakeLoggingVerbose
:: (MonadIO m, MonadMask m, CliLog m, HasCliConfig e m)
=> String
-> Text
-> m ()
allowUserToMakeLoggingVerbose :: String -> Text -> m ()
allowUserToMakeLoggingVerbose keyCode :: String
keyCode desc :: Text
desc = m ThreadId -> (ThreadId -> m ()) -> (ThreadId -> m ()) -> m ()
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket m ThreadId
showTip (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (ThreadId -> IO ()) -> ThreadId -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> IO ()
killThread) ((ThreadId -> m ()) -> m ()) -> (ThreadId -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \_ -> do
(Severity -> Bool) -> m () -> m ()
forall (m :: * -> *) e.
(MonadIO m, HasCliConfig e m) =>
(Severity -> Bool) -> m () -> m ()
whenLogLevel (Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
/= Severity
verboseLogLevel) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
NoBuffering
String
_ <- (String -> Bool) -> m String -> m 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) (m String -> m String) -> m String -> m String
forall a b. (a -> b) -> a -> b
$ IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getChars
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Warning (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
desc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " pressed; making output verbose (-v)"
Severity -> m ()
forall (m :: * -> *) e.
(MonadIO m, HasCliConfig e m) =>
Severity -> m ()
setLogLevel Severity
verboseLogLevel
where
showTip :: m ThreadId
showTip = CliT e IO () -> m ThreadId
forall e (m :: * -> *).
(HasCliConfig e m, MonadIO m) =>
CliT e IO () -> m ThreadId
fork (CliT e IO () -> m ThreadId) -> CliT e IO () -> m ThreadId
forall a b. (a -> b) -> a -> b
$ (Severity -> Bool) -> CliT e IO () -> CliT e IO ()
forall (m :: * -> *) e.
(MonadIO m, HasCliConfig e m) =>
(Severity -> Bool) -> m () -> m ()
whenLogLevel (Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
/= Severity
verboseLogLevel) (CliT e IO () -> CliT e IO ()) -> CliT e IO () -> CliT e IO ()
forall a b. (a -> b) -> a -> b
$ do
CliConfig e
conf <- CliT e IO (CliConfig e)
forall e (m :: * -> *). HasCliConfig e m => m (CliConfig e)
getCliConfig
IO () -> CliT e IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CliT e IO ()) -> IO () -> CliT e 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 -> CliT e IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> CliT e IO Bool) -> IO Bool -> CliT e 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 e -> IORef Bool
forall e. CliConfig e -> IORef Bool
_cliConfig_tipDisplayed CliConfig e
conf) ((Bool -> (Bool, Bool)) -> IO Bool)
-> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ (,) Bool
True
Bool -> CliT e IO () -> CliT e IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
tipDisplayed (CliT e IO () -> CliT e IO ()) -> CliT e IO () -> CliT e IO ()
forall a b. (a -> b) -> a -> b
$ (Severity -> Bool) -> CliT e IO () -> CliT e IO ()
forall (m :: * -> *) e.
(MonadIO m, HasCliConfig e m) =>
(Severity -> Bool) -> m () -> m ()
whenLogLevel (Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
/= Severity
verboseLogLevel) (CliT e IO () -> CliT e IO ()) -> CliT e IO () -> CliT e IO ()
forall a b. (a -> b) -> a -> b
$ do
Severity -> Text -> CliT e IO ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Notice (Text -> CliT e IO ()) -> Text -> CliT e IO ()
forall a b. (a -> b) -> a -> b
$ "Tip: Press " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
desc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " to display full output"
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)
fork :: (HasCliConfig e m, MonadIO m) => CliT e IO () -> m ThreadId
fork :: CliT e IO () -> m ThreadId
fork f :: CliT e IO ()
f = do
CliConfig e
c <- m (CliConfig e)
forall e (m :: * -> *). HasCliConfig e m => m (CliConfig e)
getCliConfig
IO ThreadId -> m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> m ThreadId) -> IO ThreadId -> m 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
$ CliConfig e -> CliT e IO () -> IO ()
forall (m :: * -> *) e a.
MonadIO m =>
CliConfig e -> CliT e m a -> m a
runCli CliConfig e
c CliT e IO ()
f
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
]