@@ -9,18 +9,20 @@ module Obelisk.CLI.Logging
99 ( Severity (Error, Warning, Notice, Debug)
1010 , LoggingConfig (..)
1111 , Output (..)
12+ , forkML
13+ , allowUserToMakeLoggingVerbose
1214 , failWith
1315 , putLog
1416 , putLogRaw
15− , setLogLevelIfKeyPressed
1617 , handleLog
1718 , getLogLevel
1819 , newLoggingConfig
1920 ) where
2021
22+import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay)
2123import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar)
2224import Control.Monad (unless, void, when)
23−import Control.Monad.Catch (MonadMask, bracket_)
25+import Control.Monad.Catch (MonadMask, bracket, bracket_)
2426import Control.Monad.IO.Class (liftIO)
2527import Control.Monad.Loops (iterateUntil)
2628import Control.Monad.Reader (MonadIO)
@@ -32,20 +34,25 @@ import System.Console.ANSI (Color (Red, White, Yellow), ColorIntensity (Vivid),
3234import System.Exit (ExitCode (ExitFailure), exitWith)
3335import System.IO (BufferMode (NoBuffering), hFlush, hReady, hSetBuffering, stdin, stdout)
3436
35−import Control.Monad.Log (MonadLog, Severity (..), WithSeverity (..), logMessage)
37+import Control.Monad.Log (LoggingT, MonadLog, Severity (..), WithSeverity (..), logMessage, runLoggingT)
3638import Data.IORef (IORef, newIORef, readIORef, writeIORef)
3739
3840data LoggingConfig = LoggingConfig
3941 { _loggingConfig_level :: IORef Severity -- We are capable of changing the log level at runtime
4042 , _loggingConfig_noColor :: Bool -- Disallow coloured output
4143 , _loggingConfig_lock :: MVar Bool -- Whether the last message was an Overwrite output
44+ , _loggingConfig_tipDisplayed :: IORef Bool -- Whether the user tip (to make verbose) was already displayed
4245 }
4346
4447newLoggingConfig :: Severity -> Bool -> IO LoggingConfig
4548newLoggingConfig sev noColor = do
4649 level <- newIORef sev
4750 lock <- newMVar False
48− return $ LoggingConfig level noColor lock
51+ tipDisplayed <- newIORef False
52+ return $ LoggingConfig level noColor lock tipDisplayed
53+
54+verboseLogLevel :: Severity
55+verboseLogLevel = Debug
4956
5057data Output
5158 = Output_Log (WithSeverity Text) -- Regular logging message (with colors and newlines)
@@ -66,29 +73,21 @@ getSeverity = \case
6673 _ -> Nothing
6774
6875setLogLevel :: MonadIO m => LoggingConfig -> Severity -> m ()
69−setLogLevel (LoggingConfig levelRef _ _) = liftIO . writeIORef levelRef
76+setLogLevel conf = liftIO . writeIORef (_loggingConfig_level conf)
7077
7178getLogLevel :: MonadIO m => LoggingConfig -> m Severity
72−getLogLevel (LoggingConfig levelRef _ _) = liftIO $ readIORef levelRef
73−
74−setLogLevelIfKeyPressed :: (MonadIO m, MonadLog Output m) => LoggingConfig -> String -> Severity -> m () -> m ()
75−setLogLevelIfKeyPressed conf keyCode sev f = do
76− logLevel <- getLogLevel conf
77− unless (logLevel == sev) $ do
78− liftIO $ hSetBuffering stdin NoBuffering
79− _ <- iterateUntil (== keyCode) $ liftIO getChars
80− f
81− setLogLevel conf sev
79+getLogLevel = liftIO . readIORef . _loggingConfig_level
8280
8381handleLog :: MonadIO m => LoggingConfig -> Output -> m ()
84−handleLog (LoggingConfig levelRef noColor lock) output = do
85− level <- liftIO $ readIORef levelRef
86− liftIO $ modifyMVar_ lock $ \wasOverwriting -> do
82+handleLog conf output = do
83+ level <- getLogLevel conf
84+ liftIO $ modifyMVar_ (_loggingConfig_lock conf) $ \wasOverwriting -> do
85+ let noColor = _loggingConfig_noColor conf
8786 case getSeverity output of
8887 Nothing -> handleLog' noColor output
89− Just sev -> case sev > level of
90− True -> return wasOverwriting -- Discard if sev is above configured log level
91− False -> do
88+ Just sev -> if sev > level
89+ then return wasOverwriting -- Discard if sev is above configured log level
90+ else do
9291 -- If the last output was an overwrite (with cursor on same line), ...
9392 when wasOverwriting $
9493 void $ handleLog' noColor Output_ClearLine -- first clear it,
@@ -141,6 +140,36 @@ writeLogWith f noColor (WithSeverity severity s) = case sevColor severity of
141140 | sev >= Debug -> Just $ liftIO $ setSGR [SetColor Foreground Vivid White, SetConsoleIntensity FaintIntensity]
142141 | otherwise -> Nothing
143142
143+
144+-- | Allow the user to immediately switch to verbose logging upon pressing a particular key.
145+allowUserToMakeLoggingVerbose
146+ :: (MonadIO m, MonadMask m, MonadLog Output m)
147+ => LoggingConfig
148+ -> String -- ^ The key to press in order to make logging verbose
149+ -> m ()
150+allowUserToMakeLoggingVerbose conf keyCode = bracket showTip (liftIO . killThread) $ \_ -> do
151+ unlessVerbose $ do
152+ liftIO $ hSetBuffering stdin NoBuffering
153+ _ <- iterateUntil (== keyCode) $ liftIO getChars
154+ putLog Warning $ "Ctrl+e pressed; making output verbose (-v)"
155+ setLogLevel conf verboseLogLevel
156+ where
157+ showTip = forkML conf $ unlessVerbose $ do
158+ tipDisplayed <- liftIO $ readIORef $ _loggingConfig_tipDisplayed conf
159+ unless tipDisplayed $ do
160+ liftIO $ threadDelay $ 3*1000000 -- Only show tip for actions taking too long (3 seconds or more)
161+ unlessVerbose $ do -- Check again in case the user had pressed Ctrl+e recently
162+ putLog Notice $ "Tip: Press Ctrl+e to display full output"
163+ liftIO $ writeIORef (_loggingConfig_tipDisplayed conf) True
164+ unlessVerbose f = do
165+ l <- getLogLevel conf
166+ unless (l == verboseLogLevel) f
167+
168+-- | Like `forkIO` but using MonadLog
169+-- TODO: Can we obviate passing LoggingConfig just to use forkIO?
170+forkML :: (MonadIO m, MonadLog Output m) => LoggingConfig -> LoggingT Output IO () -> m ThreadId
171+forkML conf = liftIO . forkIO . flip runLoggingT (handleLog conf)
172+
144173-- | Like `getChar` but also retrieves the subsequently pressed keys.
145174--
146175-- Allowing, for example, the ↑ key, which consists of the three characters
@@ -153,4 +182,3 @@ getChars = reverse <$> f mempty
153182 hReady stdin >>= \case
154183 True -> f (x:xs )
155184 False -> return (x:xs)
156−