{-# 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 :: forall e.
Severity
-> Bool -> Bool -> (e -> (Text, ExitCode)) -> IO (CliConfig e)
newCliConfig Severity
sev Bool
noColor Bool
noSpinner e -> (Text, ExitCode)
errorLogExitCode = do
  level <- Severity -> IO (IORef Severity)
forall a. a -> IO (IORef a)
newIORef Severity
sev
  lock <- newMVar False
  tipDisplayed <- newIORef False
  stack <- newIORef ([], [])
  textEncoding <- hGetEncoding stdout
  let 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
  return $ CliConfig level noColor noSpinner lock tipDisplayed stack errorLogExitCode theme

runCli :: MonadIO m => CliConfig e -> CliT e m a -> m a
runCli :: forall (m :: * -> *) e a.
MonadIO m =>
CliConfig e -> CliT e m a -> m a
runCli 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 [TerminalString]
_ -> Bool
True
  Output
_ -> Bool
False

getSeverity :: Output -> Maybe Severity
getSeverity :: Output -> Maybe Severity
getSeverity = \case
  Output_Log (WithSeverity Severity
sev Text
_) -> Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
sev
  Output_LogRaw (WithSeverity Severity
sev Text
_) -> Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
sev
  Output
_ -> Maybe Severity
forall a. Maybe a
Nothing

getLogLevel :: (MonadIO m, HasCliConfig e m) => m Severity
getLogLevel :: forall (m :: * -> *) e. (MonadIO m, HasCliConfig e m) => 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' :: forall (m :: * -> *) e. MonadIO m => CliConfig e -> m Severity
getLogLevel' = IO Severity -> m Severity
forall a. IO a -> m a
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 :: forall (m :: * -> *) e.
(MonadIO m, HasCliConfig e m) =>
Severity -> m ()
setLogLevel Severity
sev = do
  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
  liftIO $ writeIORef l sev

handleLog :: MonadIO m => CliConfig e -> Output -> m ()
handleLog :: forall (m :: * -> *) e. MonadIO m => CliConfig e -> Output -> m ()
handleLog CliConfig e
conf Output
output = do
  level <- CliConfig e -> m Severity
forall (m :: * -> *) e. MonadIO m => CliConfig e -> m Severity
getLogLevel' CliConfig e
conf
  liftIO $ modifyMVar_ (_cliConfig_lock conf) $ \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
      Maybe Severity
Nothing -> Bool -> Output -> IO Bool
forall (m :: * -> *). MonadIO m => Bool -> Output -> m Bool
handleLog' Bool
noColor Output
output
      Just Severity
sev -> if Severity
sev Severity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
> Severity
level
        then Bool -> IO Bool
forall a. a -> IO a
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' :: forall (m :: * -> *). MonadIO m => Bool -> Output -> m Bool
handleLog' Bool
noColor Output
output = do
  case Output
output of
    Output_Log WithSeverity Text
m -> IO () -> m ()
forall a. IO a -> m a
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 WithSeverity Text
m -> IO () -> m ()
forall a. IO a -> m a
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 [TerminalString]
ts -> IO () -> m ()
forall a. IO a -> m a
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 [TerminalString]
ts -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      width <- IO (Maybe Int)
TS.getTerminalWidth
      T.putStr $ "\r" <> TS.render (not noColor) width ts
      hFlush stdout
    Output
Output_ClearLine -> IO () -> m ()
forall a. IO a -> m a
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 String
"\r"
      IO ()
clearLine
      Handle -> IO ()
hFlush Handle
stdout
  Bool -> m Bool
forall a. a -> m a
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 :: forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLogRaw 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 :: Prism' Text 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 :: forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith = e -> m a
forall a. 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
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 :: forall e (m :: * -> *). (HasCliConfig e m, CliLog m) => e -> m ()
errorToWarning e
e = do
  c <- m (CliConfig e)
forall e (m :: * -> *). HasCliConfig e m => m (CliConfig e)
getCliConfig
  putLog Warning $ fst $ _cliConfig_errorLogExitCode c 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 :: forall (m :: * -> *) a.
(CliLog m, MonadCatch m) =>
Text -> m a -> m a
withExitFailMessage Text
msg m a
f = m a
f m a -> (ExitCode -> m a) -> m a
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(ExitCode
e :: ExitCode) -> do
  case ExitCode
e of
    ExitFailure Int
_ -> Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Alert Text
msg
    ExitCode
ExitSuccess -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  ExitCode -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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 :: forall (m :: * -> *).
MonadIO m =>
Bool -> Bool -> WithSeverity Text -> m ()
writeLog Bool
withNewLine Bool
noColor (WithSeverity Severity
severity Text
s) = if Text -> Bool
T.null Text
s then () -> m ()
forall a. a -> m a
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 a. IO a -> m a
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 -> 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 a. IO a -> m a
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 :: forall (m :: * -> *) e.
(MonadIO m, HasCliConfig e m) =>
(Severity -> Bool) -> m () -> m ()
whenLogLevel Severity -> Bool
level m ()
f = do
  l <- m Severity
forall (m :: * -> *) e. (MonadIO m, HasCliConfig e m) => m Severity
getLogLevel
  when (level l) 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 :: forall (m :: * -> *) e.
(MonadIO m, MonadMask m, CliLog m, HasCliConfig e m) =>
String -> Text -> m ()
allowUserToMakeLoggingVerbose String
keyCode Text
desc = m ThreadId -> (ThreadId -> m ()) -> (ThreadId -> m ()) -> m ()
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket m ThreadId
showTip (IO () -> m ()
forall a. IO a -> m a
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
$ \ThreadId
_ -> 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 a. IO a -> m a
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 -> 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 a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getChars
    putLog Warning $ desc <> " pressed; making output verbose (-v)"
    setLogLevel 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
      conf <- CliT e IO (CliConfig e)
forall e (m :: * -> *). HasCliConfig e m => m (CliConfig e)
getCliConfig
      liftIO $ threadDelay $ 10*1000000  -- Only show tip for actions taking too long (10 seconds or more)
      tipDisplayed <- liftIO $ atomicModifyIORef' (_cliConfig_tipDisplayed conf) $ (,) True
      unless tipDisplayed $ whenLogLevel (/= verboseLogLevel) $ do -- Check again in case the user had pressed Ctrl+e recently
        putLog Notice $ "Tip: Press " <> desc <> " 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 String
xs = do
      x <- IO Char
getChar
      hReady stdin >>= \case
        Bool
True -> String -> IO String
f (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs)
        Bool
False -> String -> IO String
forall a. a -> IO a
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 :: forall e (m :: * -> *).
(HasCliConfig e m, MonadIO m) =>
CliT e IO () -> m ThreadId
fork CliT e IO ()
f = do
  c <- m (CliConfig e)
forall e (m :: * -> *). HasCliConfig e m => m (CliConfig e)
getCliConfig
  liftIO $ forkIO $ runCli c 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 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
  ]