Haddock clean-up

src/Cli/Extras.hs

@@ -39,7 +39,7 @@ module Cli.Extras
   , callProcessAndLogOutput
   , createProcess
   , createProcess_
-  , exitCodeToException
+  , throwExitCode
   , overCreateProcess
   , proc
   , readCreateProcessWithExitCode

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

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,15 +205,17 @@ 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 ()
 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,19 +235,20 @@ 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 ()
 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
 

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

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"
 

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