{-# 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
  , 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

-- | Log a message to the console.
--
-- Logs safely even if there are ongoing spinners.
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)

--TODO: Use optparse-applicative instead
-- Given the program's command line arguments, produce a reasonable CliConfig
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
      -- Running in bash/fish/zsh completion
      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

      -- Respect the user’s TERM environment variable. Dumb terminals
      -- like Eshell cannot handle lots of control sequences that the
      -- spinner uses.
      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  -- 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, 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  -- 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

-- | 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

-- | Write log to stdout, with colors (unless `noColor`)
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]

-- | Allow the user to immediately switch to verbose logging upon pressing a particular key.
--
-- Call this function in a thread, and kill it to turn off keystroke monitoring.
allowUserToMakeLoggingVerbose
  :: CliConfig
  -> String  -- ^ The key to press in order to make logging verbose
  -> 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  -- Only show tip for actions taking too long (10 seconds or more)
        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 -- Check again in case the user had pressed Ctrl+e recently
          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

-- | 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)

-- | 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
  ]