@@ -12,13 +12,17 @@ module Obelisk.CLI.Logging
1212 , failWith
1313 , putLog
1414 , putLogRaw
15+ , setLogLevelIfKeyPressed
1516 , handleLog
17+ , getLogLevel
18+ , newLoggingConfig
1619 ) where
1720
18−import Control.Concurrent.MVar (MVar, modifyMVar_)
19−import Control.Monad (void, when)
21+import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar)
22+import Control.Monad (unless, void, when)
2023import Control.Monad.Catch (MonadMask, bracket_)
2124import Control.Monad.IO.Class (liftIO)
25+import Control.Monad.Loops (iterateUntil)
2226import Control.Monad.Reader (MonadIO)
2327import Data.Text (Text)
2428import qualified Data.Text.IO as T
@@ -26,16 +30,23 @@ import System.Console.ANSI (Color (Red, White, Yellow), ColorIntensity (Vivid),
2630 ConsoleIntensity (FaintIntensity), ConsoleLayer (Foreground),
2731 SGR (Reset, SetColor, SetConsoleIntensity), clearLine, setSGR)
2832import System.Exit (ExitCode (ExitFailure), exitWith)
29−import System.IO (hFlush, stdout)
33+import System.IO (BufferMode (NoBuffering), hFlush, hReady, hSetBuffering, stdin, stdout)
3034
3135import Control.Monad.Log (MonadLog, Severity (..), WithSeverity (..), logMessage)
36+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
3237
3338data LoggingConfig = LoggingConfig
34− { _loggingConfig_level :: Severity
39+ { _loggingConfig_level :: IORef Severity -- We are capable of changing the log level at runtime
3540 , _loggingConfig_noColor :: Bool -- Disallow coloured output
3641 , _loggingConfig_lock :: MVar Bool -- Whether the last message was an Overwrite output
3742 }
3843
44+newLoggingConfig :: Severity -> Bool -> IO LoggingConfig
45+newLoggingConfig sev noColor = do
46+ level <- newIORef sev
47+ lock <- newMVar False
48+ return $ LoggingConfig level noColor lock
49+
3950data Output
4051 = Output_Log (WithSeverity Text) -- Regular logging message (with colors and newlines)
4152 | Output_LogRaw (WithSeverity Text) -- Like `Output_Log` but without the implicit newline added.
@@ -54,8 +65,24 @@ getSeverity = \case
5465 Output_LogRaw (WithSeverity sev _) -> Just sev
5566 _ -> Nothing
5667
68+setLogLevel :: MonadIO m => LoggingConfig -> Severity -> m ()
69+setLogLevel (LoggingConfig levelRef _ _) = liftIO . writeIORef levelRef
70+
71+getLogLevel :: 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
82+
5783handleLog :: MonadIO m => LoggingConfig -> Output -> m ()
58−handleLog (LoggingConfig level noColor lock) output = do
84+handleLog (LoggingConfig levelRef noColor lock) output = do
85+ level <- liftIO $ readIORef levelRef
5986 liftIO $ modifyMVar_ lock $ \wasOverwriting -> do
6087 case getSeverity output of
6188 Nothing -> handleLog' noColor output
@@ -113,3 +140,17 @@ writeLogWith f noColor (WithSeverity severity s) = case sevColor severity of
113140 | sev <= Warning -> Just $ liftIO $ setSGR [SetColor Foreground Vivid Yellow]
114141 | sev >= Debug -> Just $ liftIO $ setSGR [SetColor Foreground Vivid White, SetConsoleIntensity FaintIntensity]
115142 | otherwise -> Nothing
143+
144+-- | Like `getChar` but also retrieves the subsequently pressed keys.
145+--
146+-- Allowing, for example, the ↑ key, which consists of the three characters
147+-- ['\ESC','[','A'] to be distinguished from an actual \ESC character input.
148+getChars :: IO String
149+getChars = reverse <$> f mempty
150+ where
151+ f xs = do
152+ x <- getChar
153+ hReady stdin >>= \case
154+ True -> f (x:xs )
155+ False -> return (x:xs)
156+