{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Provides a logging handler that facilitates safe ouputting to terminal using MVar based locking.
-- | Spinner.hs and Process.hs work on this guarantee.
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

-- | Create a new 'CliConfig', initialized with the provided values.
newCliConfig
  :: Severity
  -- ^ The initial log level. Messages below this severity will not be
  -- logged, unless the log level is subsequently altered using
  -- 'setLogLevel'.
  -> Bool -- ^ Should ANSI terminal formatting be disabled?
  -> Bool -- ^ Should spinners be disabled?
  -> (e -> (Text, ExitCode))
  -- ^ How to display errors, and compute the 'ExitCode' corresponding
  -- to each error.
  -> 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  -- Discard if sev is above configured log level
        else do
          -- If the last output was an overwrite (with cursor on same line), ...
          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  -- first clear it,
          Bool -> Output -> IO Bool
forall (m :: * -> *). MonadIO m => Bool -> Output -> m Bool
handleLog' Bool
noColor Output
output  -- then, actually write the msg.

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  -- Explicitly flush, as there is no newline
    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
      -- Go to the first column and clear the whole line
      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

-- | Like `putLog` but without the implicit newline added.
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

-- | Indicates unstructured errors form one variant (or conceptual projection)
-- of the error type.
--
-- Shouldn't really use this, but who has time to clean up that much!
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

-- | Like `putLog Alert` but also abrupts the program.
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

-- | Log an error as though it were a warning, in a non-fatal way.
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

-- | Intercept ExitFailure exceptions and log the given alert before exiting.
--
-- This is useful when you want to provide contextual information to a deeper failure.
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

-- | Log a message to standard output.
writeLog
  :: (MonadIO m)
  => Bool -- ^ Should a new line be printed after the message?
  -> Bool -- ^ Should ANSI terminal formatting be used when printing the message?
  -> WithSeverity Text -- ^ The message to print.
  -> 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]

-- | Runs an action only when the current log level matches a given
-- predicate.
whenLogLevel
  :: (MonadIO m, HasCliConfig e m)
  => (Severity -> Bool) -- ^ What severity(ies) should this action run in?
  -> m ()               -- ^ The action to run.
  -> 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

-- | Allows the user to immediately switch to verbose logging when a
-- particular sequence of characters is read from the terminal.
--
-- Call this function in a thread, and kill it to turn off keystroke monitoring.
allowUserToMakeLoggingVerbose
  :: (MonadIO m, MonadMask m, CliLog m, HasCliConfig e m)
  => String  -- ^ The key(s) which should be read to indicate a shift in verbosity.
  -> Text    -- ^ A description of the key that must be pressed.
  -> 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  -- Only show tip for actions taking too long (10 seconds or more)
      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 -- Check again in case the user had pressed Ctrl+e recently
        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"

-- | Like `getChar` but also retrieves the subsequently pressed keys.
--
-- Allowing, for example, the ↑ key, which consists of the three characters
-- ['\ESC','[','A'] to be distinguished from an actual \ESC character input.
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 a computation in 'CliT', sharing the configuration with the
-- child thread.
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

-- | Conservatively determines whether the encoding supports Unicode.
--
-- Currently this uses a whitelist of known-to-work encodings. In principle it
-- could test dynamically by opening a file with this encoding, but it doesn't
-- look like base exposes any way to determine this in a pure fashion.
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
  ]