@@ -9,16 +9,22 @@ module Obelisk.CLI.Logging
99 ( Severity (Error, Warning, Notice, Debug)
1010 , LoggingConfig (..)
1111 , Output (..)
12+ , forkML
13+ , allowUserToMakeLoggingVerbose
1214 , failWith
1315 , putLog
1416 , putLogRaw
1517 , handleLog
18+ , getLogLevel
19+ , newLoggingConfig
1620 ) where
1721
18−import Control.Concurrent.MVar (MVar, modifyMVar_)
19−import Control.Monad (void, when)
20−import Control.Monad.Catch (MonadMask, bracket_)
22+import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay)
23+import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar)
24+import Control.Monad (unless, void, when)
25+import Control.Monad.Catch (MonadMask, bracket, bracket_)
2126import Control.Monad.IO.Class (liftIO)
27+import Control.Monad.Loops (iterateUntil)
2228import Control.Monad.Reader (MonadIO)
2329import Data.Text (Text)
2430import qualified Data.Text.IO as T
@@ -26,16 +32,28 @@ import System.Console.ANSI (Color (Red, White, Yellow), ColorIntensity (Vivid),
2632 ConsoleIntensity (FaintIntensity), ConsoleLayer (Foreground),
2733 SGR (Reset, SetColor, SetConsoleIntensity), clearLine, setSGR)
2834import System.Exit (ExitCode (ExitFailure), exitWith)
29−import System.IO (hFlush, stdout)
35+import System.IO (BufferMode (NoBuffering), hFlush, hReady, hSetBuffering, stdin, stdout)
3036
31−import Control.Monad.Log (MonadLog, Severity (..), WithSeverity (..), logMessage)
37+import Control.Monad.Log (LoggingT, MonadLog, Severity (..), WithSeverity (..), logMessage, runLoggingT)
38+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
3239
3340data LoggingConfig = LoggingConfig
34− { _loggingConfig_level :: Severity
41+ { _loggingConfig_level :: IORef Severity -- We are capable of changing the log level at runtime
3542 , _loggingConfig_noColor :: Bool -- Disallow coloured output
3643 , _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
3745 }
3846
47+newLoggingConfig :: Severity -> Bool -> IO LoggingConfig
48+newLoggingConfig sev noColor = do
49+ level <- newIORef sev
50+ lock <- newMVar False
51+ tipDisplayed <- newIORef False
52+ return $ LoggingConfig level noColor lock tipDisplayed
53+
54+verboseLogLevel :: Severity
55+verboseLogLevel = Debug
56+
3957data Output
4058 = Output_Log (WithSeverity Text) -- Regular logging message (with colors and newlines)
4159 | Output_LogRaw (WithSeverity Text) -- Like `Output_Log` but without the implicit newline added.
@@ -54,14 +72,22 @@ getSeverity = \case
5472 Output_LogRaw (WithSeverity sev _) -> Just sev
5573 _ -> Nothing
5674
75+setLogLevel :: MonadIO m => LoggingConfig -> Severity -> m ()
76+setLogLevel conf = liftIO . writeIORef (_loggingConfig_level conf)
77+
78+getLogLevel :: MonadIO m => LoggingConfig -> m Severity
79+getLogLevel = liftIO . readIORef . _loggingConfig_level
80+
5781handleLog :: MonadIO m => LoggingConfig -> Output -> m ()
58−handleLog (LoggingConfig level noColor lock) output = do
59− 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
6086 case getSeverity output of
6187 Nothing -> handleLog' noColor output
62− Just sev -> case sev > level of
63− True -> return wasOverwriting -- Discard if sev is above configured log level
64− False -> do
88+ Just sev -> if sev > level
89+ then return wasOverwriting -- Discard if sev is above configured log level
90+ else do
6591 -- If the last output was an overwrite (with cursor on same line), ...
6692 when wasOverwriting $
6793 void $ handleLog' noColor Output_ClearLine -- first clear it,
@@ -113,3 +139,46 @@ writeLogWith f noColor (WithSeverity severity s) = case sevColor severity of
113139 | sev <= Warning -> Just $ liftIO $ setSGR [SetColor Foreground Vivid Yellow]
114140 | sev >= Debug -> Just $ liftIO $ setSGR [SetColor Foreground Vivid White, SetConsoleIntensity FaintIntensity]
115141 | otherwise -> Nothing
142+
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+
173+-- | Like `getChar` but also retrieves the subsequently pressed keys.
174+--
175+-- Allowing, for example, the ↑ key, which consists of the three characters
176+-- ['\ESC','[','A'] to be distinguished from an actual \ESC character input.
177+getChars :: IO String
178+getChars = reverse <$> f mempty
179+ where
180+ f xs = do
181+ x <- getChar
182+ hReady stdin >>= \case
183+ True -> f (x:xs )
184+ False -> return (x:xs)