diff --git a/src/Cli/Extras.hs b/src/Cli/Extras.hs index 6df3d20..1c93a56 100644 --- a/src/Cli/Extras.hs +++ b/src/Cli/Extras.hs @@ -39,7 +39,7 @@ module Cli.Extras , callProcessAndLogOutput , createProcess , createProcess_ - , exitCodeToException + , throwExitCode , overCreateProcess , proc , readCreateProcessWithExitCode diff --git a/src/Cli/Extras/Logging.hs b/src/Cli/Extras/Logging.hs index 7300756..cb4dedc 100644 --- a/src/Cli/Extras/Logging.hs +++ b/src/Cli/Extras/Logging.hs @@ -158,6 +158,7 @@ instance AsUnstructuredError Text where failWith :: (CliThrow e m, AsUnstructuredError e) => Text -> m a failWith = throwError . review asUnstructuredError +-- | Log an error as though it were a warning, in a non-fatal way. errorToWarning :: (HasCliConfig e m, CliLog m) => e -> m () @@ -175,8 +176,13 @@ withExitFailMessage msg f = f `catch` \(e :: ExitCode) -> do ExitSuccess -> pure () throwM e --- | Write log to stdout, with colors (unless `noColor`) -writeLog :: (MonadIO m) => Bool -> Bool -> WithSeverity Text -> m () +-- | 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 withNewLine noColor (WithSeverity severity s) = if T.null s then pure () else write where write @@ -196,29 +202,39 @@ writeLog withNewLine noColor (WithSeverity severity s) = if T.null s then pure ( noticeColors = [SetColor Foreground Vivid Blue] debugColors = [SetConsoleIntensity FaintIntensity] --- | Allow the user to immediately switch to verbose logging upon pressing a particular key. +-- | 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 level f = do + l <- 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 to press in order to make logging verbose + => 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 keyCode = bracket showTip (liftIO . killThread) $ \_ -> do - unlessVerbose $ do +allowUserToMakeLoggingVerbose keyCode desc = bracket showTip (liftIO . killThread) $ \_ -> do + whenLogLevel (/= verboseLogLevel) $ do liftIO $ hSetBuffering stdin NoBuffering _ <- iterateUntil (== keyCode) $ liftIO getChars - putLog Warning "Ctrl+e pressed; making output verbose (-v)" + putLog Warning $ desc <> " pressed; making output verbose (-v)" setLogLevel verboseLogLevel where - showTip = fork $ unlessVerbose $ do + showTip = fork $ whenLogLevel (/= verboseLogLevel) $ do conf <- 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 $ unlessVerbose $ do -- Check again in case the user had pressed Ctrl+e recently - putLog Notice "Tip: Press Ctrl+e to display full output" - unlessVerbose f = do - l <- getLogLevel - unless (l == verboseLogLevel) f + 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. -- @@ -233,6 +249,8 @@ getChars = reverse <$> f mempty True -> f (x:xs) False -> return (x: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 f = do c <- getCliConfig diff --git a/src/Cli/Extras/Process.hs b/src/Cli/Extras/Process.hs index e212938..7f6dec7 100644 --- a/src/Cli/Extras/Process.hs +++ b/src/Cli/Extras/Process.hs @@ -16,7 +16,7 @@ module Cli.Extras.Process , callProcessAndLogOutput , createProcess , createProcess_ - , exitCodeToException + , throwExitCode , overCreateProcess , proc , readCreateProcessWithExitCode @@ -126,16 +126,22 @@ readCreateProcessWithExitCode procSpec = do putLog Debug $ "Creating process: " <> reconstructProcSpec procSpec liftIO $ Process.readCreateProcessWithExitCode process "" --- | Like `System.Process.readProcess` but logs the combined output (stdout and stderr) +-- | Like 'System.Process.readProcess', but such that each of the child +-- processes' standard output streams (stdout and stderr) is logged, -- with the corresponding severity. -- --- Usually this function is called as `readProcessAndLogOutput (Debug, Error)`. However --- some processes are known to spit out diagnostic or informative messages in stderr, in --- which case it is advisable to call it with a non-Error severity for stderr, like --- `readProcessAndLogOutput (Debug, Debug)`. +-- Usually, this function is called as @readProcessAndLogOutput (Debug, +-- Error)@. If the child process is known to print diagnostic or +-- informative messages to stderr, it is advisable to call +-- 'readProcessAndLogOutput' with a non-Error severity for stderr, for +-- example @readProcessAndLogOutput (Debug, Debug)@. readProcessAndLogOutput :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m) - => (Severity, Severity) -> ProcessSpec -> m Text + => (Severity, Severity) + -- ^ This tuple controls the severity of each output stream. Its @fst@ + -- is the severity of stdout; @snd@ is the severity of stderr. + -> ProcessSpec + -> m Text readProcessAndLogOutput (sev_out, sev_err) process = do (_, Just out, Just err, p) <- createProcess $ overCreateProcess (\p -> p { std_out = CreatePipe , std_err = CreatePipe }) process @@ -145,18 +151,24 @@ readProcessAndLogOutput (sev_out, sev_err) process = do outText <- liftIO $ T.decodeUtf8With lenientDecode <$> BS.hGetContents out putLogRaw sev_out outText - outText <$ (exitCodeToException process =<< waitForProcess p) + outText <$ (throwExitCode process =<< waitForProcess p) --- | Like 'System.Process.callProcess' but logs the combined output (stdout and stderr) +-- | Like 'System.Process.readProcess', but such that each of the child +-- processes' standard output streams (stdout and stderr) is logged, -- with the corresponding severity. -- --- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However --- some processes are known to spit out diagnostic or informative messages in stderr, in --- which case it is advisable to call it with a non-Error severity for stderr, like --- `callProcessAndLogOutput (Debug, Debug)`. +-- Usually, this function is called as @callProcessAndLogOutput (Debug, +-- Error)@. If the child process is known to print diagnostic or +-- informative messages to stderr, it is advisable to call +-- 'callProcessAndLogOutput' with a non-Error severity for stderr, for +-- example @callProcessAndLogOutput (Debug, Debug)@. callProcessAndLogOutput :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadMask m) - => (Severity, Severity) -> ProcessSpec -> m () + => (Severity, Severity) + -- ^ This tuple controls the severity of each output stream. Its @fst@ + -- is the severity of stdout; @snd@ is the severity of stderr. + -> ProcessSpec + -> m () callProcessAndLogOutput (sev_out, sev_err) process = void $ withProcess process $ \out err -> do stream <- liftIO $ join $ combineStream @@ -166,7 +178,8 @@ callProcessAndLogOutput (sev_out, sev_err) process = where combineStream s1 s2 = concurrentMerge [s1, s2] --- | Like 'System.Process.createProcess' but also logs (debug) the process being run +-- | Like 'System.Process.createProcess', but logging (with 'Debug' +-- severity) the process which was started. createProcess :: (MonadIO m, CliLog m) => ProcessSpec -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) @@ -175,7 +188,8 @@ createProcess procSpec = do putLog Debug $ "Creating process: " <> reconstructProcSpec procSpec liftIO $ Process.createProcess p --- | Like `System.Process.createProcess_` but also logs (debug) the process being run +-- | Like 'System.Process.createProcess_', but logging (with 'Debug' +-- severity) the process which was started. createProcess_ :: (MonadIO m, CliLog m) => String -> ProcessSpec -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) @@ -191,7 +205,8 @@ mkCreateProcess (ProcessSpec p override') = case override' of procEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (Process.env p) pure $ p { Process.env = Just $ Map.toAscList (override procEnv) } --- | Like `System.Process.callProcess` but also logs (debug) the process being run +-- | Like 'System.Process.callProcess', but logging (with 'Debug' +-- severity) the process which was started. callProcess :: (MonadIO m, CliLog m) => String -> [String] -> m () @@ -199,7 +214,8 @@ callProcess exe args = do putLog Debug $ "Calling process " <> T.pack exe <> " with args: " <> T.pack (show args) liftIO $ Process.callProcess exe args --- | Like `System.Process.callCommand` but also logs (debug) the command being run +-- | Like 'System.Process.callCommand', but logging (with 'Debug' +-- severity) the process which was started. callCommand :: (MonadIO m, CliLog m) => String -> m () @@ -219,11 +235,12 @@ withProcess process f = (\case (_, Just out, Just err, p) -> do f out err - (out, err) <$ (exitCodeToException process =<< waitForProcess p) + (out, err) <$ (throwExitCode process =<< waitForProcess p) _ -> error "withProcess: createProcess did not provide handles for CreatePipe as expected" ) --- | Runs a process to completion failing if it does not exit cleanly. +-- | Runs a process to completion, aborting the computation (using +-- 'throwExitCode') in case of a non-'ExitSuccess' exit status. runProcess_ :: (MonadIO m, CliLog m, CliThrow e m, MonadMask m, AsProcessFailure e) => ProcessSpec -> m () @@ -231,7 +248,7 @@ runProcess_ process = bracketOnError (createProcess process) (liftIO . Process.cleanupProcess) - (\(_, _, _, ph) -> exitCodeToException process =<< waitForProcess ph) + (\(_, _, _, ph) -> throwExitCode process =<< waitForProcess ph) -- Create an input stream from the file handle, associating each item with the given severity. streamHandle :: Severity -> Handle -> IO (InputStream (Severity, BSC.ByteString)) @@ -250,9 +267,10 @@ streamToLog stream = fix $ \loop -> do waitForProcess :: MonadIO m => ProcessHandle -> m ExitCode waitForProcess = liftIO . Process.waitForProcess --- | Converts an 'ExitCode' to an exception when it's non-zero. -exitCodeToException :: (CliThrow e m, AsProcessFailure e) => ProcessSpec -> ExitCode -> m () -exitCodeToException spec = \case +-- | Aborts the computation (using 'throwError') when given a +-- non-'ExitSuccess' 'ExitCode'. +throwExitCode :: (CliThrow e m, AsProcessFailure e) => ProcessSpec -> ExitCode -> m () +throwExitCode spec = \case ExitSuccess -> pure () ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess spec) code diff --git a/src/Cli/Extras/Spinner.hs b/src/Cli/Extras/Spinner.hs index 46f944f..ee9c64e 100644 --- a/src/Cli/Extras/Spinner.hs +++ b/src/Cli/Extras/Spinner.hs @@ -61,7 +61,7 @@ withSpinner' msg mkTrail action = do -- Add this log to the spinner stack, and start a spinner if it is top-level. modifyStack pushSpinner >>= \case True -> do -- Top-level spinner; fork a thread to manage output of anything on the stack - ctrleThread <- fork $ allowUserToMakeLoggingVerbose enquiryCode + ctrleThread <- fork $ allowUserToMakeLoggingVerbose enquiryCode "Ctrl+E" cliConf <- getCliConfig let theme = _cliConfig_theme cliConf spinner = coloredSpinner $ _cliTheme_spinner theme @@ -118,7 +118,7 @@ renderSpinnerStack renderSpinnerStack theme mark = L.intersperse space . go . L.reverse where go [] = [] - go (x:[]) = mark : [x] + go [x] = mark : [x] go (x:xs) = arrow : x : go xs arrow = TerminalString_Colorized Blue $ _cliTheme_arrow theme space = TerminalString_Normal " " diff --git a/src/Cli/Extras/TerminalString.hs b/src/Cli/Extras/TerminalString.hs index 7dee349..22a6f1c 100644 --- a/src/Cli/Extras/TerminalString.hs +++ b/src/Cli/Extras/TerminalString.hs @@ -70,7 +70,9 @@ putStrWithSGR sgr h withNewLine s = liftIO $ bracket_ (hSetSGR h sgr) reset $ T. reset = hSetSGR h [Reset] >> newline -- New line should come *after* reset (to reset cursor color). newline = when withNewLine $ T.hPutStrLn h "" --- | Code for https://en.wikipedia.org/wiki/Enquiry_character +-- | Code for https://en.wikipedia.org/wiki/Enquiry_character. On VT-100 +-- descendants (most modern UNIX terminal emulators), an ENQ character +-- can be generated by pressing Ctrl+E. enquiryCode :: String enquiryCode = "\ENQ" diff --git a/src/Cli/Extras/Types.hs b/src/Cli/Extras/Types.hs index ee87910..e5f66ac 100644 --- a/src/Cli/Extras/Types.hs +++ b/src/Cli/Extras/Types.hs @@ -56,7 +56,6 @@ newtype DieT e m a = DieT { unDieT :: ReaderT (e -> (Text, ExitCode)) (LoggingT instance MonadTrans (DieT e) where lift = DieT . lift . lift --- | Error printer is private to DieT instance MonadReader r m => MonadReader r (DieT e m) where ask = DieT $ lift $ ask local = (\f (DieT a) -> DieT $ f a) . mapReaderT . local