ENH Improve progress bar

1. Better ETA estimates: ignore first 10 seconds
2. Better infrastructure for outputing transient messages to the console

NGLess/Output.hs

@@ -19,14 +19,15 @@ module Output
     , writeOutputTSV
     , writeOutputTo
     , outputConfiguration
+    , writeTransientMsg
     ) where
 
 import           Text.Printf (printf)
 import           System.IO (hFlush, hPutStr, hPutStrLn, hIsTerminalDevice, stdout, stderr, Handle)
 import           System.IO.Unsafe (unsafePerformIO)
 import           System.IO.SafeWrite (withOutputFile)
 import           Data.Maybe (maybeToList, fromMaybe, isJust)
-import           Data.IORef (IORef, newIORef, modifyIORef, readIORef)
+import           Data.IORef (IORef, newIORef, modifyIORef, readIORef, writeIORef)
 import           Data.List (sort)
 import           Data.Aeson ((.=))
 import qualified Data.Aeson as Aeson
@@ -37,7 +38,7 @@ import           Data.Time.Format (formatTime, defaultTimeLocale)
 import qualified System.Console.ANSI as ANSI
 import           Control.Monad (forM_, when, unless)
 import           Control.Monad.IO.Class (liftIO)
-import           Control.Monad.Extra (whenJust)
+import           Control.Monad.Extra (whenJust, whenM)
 import           Numeric (showFFloat)
 import           Control.Arrow (first)
 import qualified Data.Text as T
@@ -148,6 +149,10 @@ savedOutput :: IORef SavedOutput
 {-# NOINLINE savedOutput #-}
 savedOutput = unsafePerformIO (newIORef (SavedOutput [] [] []))
 
+lineClearNeeded :: IORef Bool
+{-# NOINLINE lineClearNeeded #-}
+lineClearNeeded = unsafePerformIO (newIORef False)
+
 lookupNrSeqs :: FilePath -> NGLessIO (Maybe Int)
 lookupNrSeqs fname = do
     SavedOutput{..} <- liftIO $ readIORef savedOutput
@@ -193,25 +198,18 @@ traceStatus s = do
     outputListLno' TraceOutput [s]
     traceSet <- nConfTrace <$> nglConfiguration
     unless traceSet $ do
-        outputTo <- nConfOutputTo <$> nglConfiguration
-        let outputHandle = case outputTo of
-                NGLOutStdout -> stdout
-                NGLOutStderr -> stderr
-        isTerm <- liftIO $ hIsTerminalDevice outputHandle
+        writeTransientMsg s
         doColor <- isDoColor
         verb <- nConfVerbosity <$> nglConfiguration
-        when (shouldPrint isTerm InfoOutput verb) $
-            liftIO $ do
-                let c = colorFor InfoOutput
-                    st = if doColor
-                            then ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Dull c]
-                            else ""
-                    rst = if doColor
-                            then ANSI.setSGRCode [ANSI.Reset]
-                            else ""
-                hPutStr outputHandle (st ++ s ++ "..." ++ rst)
-                hFlush outputHandle
-                hPutStr outputHandle "\r"
+        when (shouldPrint True InfoOutput verb) $ do
+            let c = colorFor InfoOutput
+                st = if doColor
+                        then ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Dull c]
+                        else ""
+                rst = if doColor
+                        then ANSI.setSGRCode [ANSI.Reset]
+                        else ""
+            writeTransientMsg (st ++ s ++ rst)
 
 isDoColor :: NGLessIO Bool
 isDoColor = do
@@ -256,7 +254,28 @@ output !ot !lno !msg = do
                 lineStr = if lno > 0
                                 then printf " Line %s" (show lno)
                                 else "" :: String
+            clearTransientIfNeeded outputHandle
             hPutStrLn outputHandle $ printf "%s[%s]%s: %s%s" st tstr lineStr msg rst
+            writeIORef lineClearNeeded False
+
+writeTransientMsg :: String -> NGLessIO ()
+writeTransientMsg m = do
+    outputTo <- nConfOutputTo <$> nglConfiguration
+    let outputHandle = case outputTo of
+            NGLOutStdout -> stdout
+            NGLOutStderr -> stderr
+    liftIO $ whenM (hIsTerminalDevice outputHandle) $ do
+        clearTransientIfNeeded outputHandle
+        hPutStr outputHandle m
+        ANSI.hSetCursorColumn outputHandle 0
+        hFlush outputHandle
+        writeIORef lineClearNeeded True
+
+clearTransientIfNeeded :: Handle -> IO ()
+clearTransientIfNeeded h =
+    whenM (readIORef lineClearNeeded) $
+        ANSI.hClearLine h
+
 
 colorFor :: OutputType -> ANSI.Color
 colorFor TraceOutput   = ANSI.White

NGLess/StandardModules/Mappers/Bwa.hs

@@ -15,7 +15,7 @@ import           System.FilePath (splitExtension)
 import Control.Monad.IO.Class (liftIO, MonadIO(..))
 import qualified Data.ByteString as B
 
-import qualified Data.Conduit as C
+import qualified Conduit as C
 import Data.Conduit.Algorithms.Utils (awaitJust)
 import           Control.Monad.Extra (allM)
 import           Control.Concurrent (getNumCapabilities)
@@ -93,13 +93,13 @@ interleaveFQs' rs@(ReadSet pairs singles) = do
         Nothing -> return (interleaveFQs rs)
         Just ts -> return (interleaveFQs rs C..| progressFQ "Mapping FASTQ files" (4 * ts))
 
-progressFQ :: MonadIO m => String -> Int -> C.ConduitT B.ByteString B.ByteString m ()
+progressFQ :: String -> Int -> C.ConduitT B.ByteString B.ByteString NGLessIO ()
 progressFQ msg nlens = liftIO (mkProgressBar msg 80) >>= loop 0
   where
     loop !nln pbar = awaitJust $ \bs -> do
             let nln' = nln + B.count 10 bs
                 progress = fromIntegral nln' / fromIntegral nlens
-            pbar' <- liftIO (updateProgressBar pbar progress)
+            pbar' <- C.lift (updateProgressBar pbar progress)
             C.yield bs
             loop nln' pbar'
 

NGLess/Utils/Network.hs

@@ -10,7 +10,7 @@ module Utils.Network
 
 import           Control.Monad.IO.Class (liftIO, MonadIO(..))
 import           Control.Monad (void)
-import qualified Data.Conduit as C
+import Conduit qualified as C
 import qualified Data.Conduit.List as CL
 import           Data.Conduit ((.|))
 import qualified Data.Conduit.Tar as CTar
@@ -49,10 +49,10 @@ downloadFile url destPath = do
     let req' = req { HTTP.decompress = const False,
                     HTTP.requestHeaders = [("User-Agent", B8.pack $ "NGLess/"++versionStr)]
                     }
-    r <- liftIO $ HTTPSimple.withResponse req' $ \res ->
+    r <- HTTPSimple.withResponse req' $ \res ->
         case HTTPSimple.getResponseStatusCode res of
             200 -> do
-                C.runConduitRes $
+                C.runConduit $
                     HTTP.responseBody res
                         .| case lookup "Content-Length" (HTTP.responseHeaders res) of
                             Nothing -> CL.map id
@@ -77,13 +77,13 @@ downloadExpandTar url destdir = do
         removeFile tarName
 
 
-printProgress :: MonadIO m => String -> Int -> C.ConduitT B.ByteString B.ByteString m ()
+printProgress :: String -> Int -> C.ConduitT B.ByteString B.ByteString NGLessIO ()
 printProgress msg csize = liftIO (mkProgressBar msg 40) >>= loop 0
   where
     loop !len pbar = awaitJust $ \bs -> do
             let len' = len + B.length bs
                 progress = fromIntegral len' / fromIntegral csize
-            pbar' <- liftIO (updateProgressBar pbar progress)
+            pbar' <- C.lift $ updateProgressBar pbar progress
             C.yield bs
             loop len' pbar'
 

NGLess/Utils/ProgressBar.hs

@@ -8,15 +8,19 @@ module Utils.ProgressBar
     ) where
 
 import qualified Text.Printf as TP
-import           System.IO (stdout, hFlush, hIsTerminalDevice)
+import           System.IO (stdout, hIsTerminalDevice)
 import qualified Data.Time as Time
-import System.Console.ANSI.Codes qualified as ANSI
+import Control.Monad.IO.Class (liftIO)
+
+import NGLess
+import Output
 
 data ProgressBarData = ProgressBarData
     { pbarName      :: String
     , cur           :: !Rational
     , lastUpdated   :: !Time.UTCTime
     , started       :: !Time.UTCTime
+    , snapshot0     :: (Rational, Time.UTCTime)
     , width         :: !Int
     } deriving (Eq, Show)
 
@@ -28,27 +32,44 @@ type ProgressBar = Maybe ProgressBarData
 -- If the last update was less than 1 second ago, then nothing is updated
 updateProgressBar :: ProgressBar -- ^ previous progressbar
                   -> Rational -- ^ current fractional progress
-                  -> IO ProgressBar -- ^ new progressbar
+                  -> NGLessIO ProgressBar -- ^ new progressbar
 updateProgressBar Nothing _ = return Nothing
 updateProgressBar (Just bar) progress = do
-    now <- Time.getCurrentTime
+    now <- liftIO $ Time.getCurrentTime
     if (now `Time.diffUTCTime` lastUpdated bar) > 1 && (percent progress /= percent (cur bar))
         then do
+            {- Estimate ETA
+             -
+             - 1. We ignore the first 10 seconds (because often there is a burst of initial activity)
+             - 2. Then we take a snapshot (timestamp, progress at that point)
+             - 3. Ignore the subsequent 10 seconds (unless at least 10% of the process is done)
+             - 4. Estimate the speeed as the progress since the snapshot divided by the time
+             - 5. Add 5% because users prefer over-estimated
+             -}
             let elapsed = toRational $ Time.diffUTCTime now (started bar)
-                missing = (1 - progress) * elapsed / progress
+                (progressDelayed, startedDelayed) = snapshot0 bar
+                elapsedDelayed = toRational $ Time.diffUTCTime now startedDelayed
+                missing = (1 - progress) * elapsedDelayed / (progress - progressDelayed)
+
                 eta :: String
-                eta = if elapsed < 30 && progress < 0.1
-                                then "no ETA yet"
-                                else TP.printf "ETA: %s" (showSecs $ 1.05 * missing) -- Add 5% because people prefer over-estimates
-            putStr $ TP.printf "%s: %s %s (%s elapsed; %s)%s\r"
+                (eta, newDelayed) =
+                    if
+                        | elapsed < 10
+                            -> ("no ETA yet", snapshot0 bar)
+                        | elapsed == elapsedDelayed
+                            -> ("no ETA yet", (progress, now))
+                        | elapsed < 20 && progress < 0.1
+                            -> ("no ETA yet", snapshot0 bar)
+                        | otherwise
+                            -> (TP.printf "ETA: %s" (showSecs $ 1.05 * missing)
+                               ,snapshot0 bar)
+            writeTransientMsg $ TP.printf "%s: %s %s (%s elapsed; %s)"
                             (pbarName bar)
                             (drawProgressBar (width bar) progress)
                             (showPercentage progress)
                             (showSecs elapsed)
                             eta
-                            ANSI.clearFromCursorToLineEndCode
-            hFlush stdout
-            return . Just $ bar { cur = progress, lastUpdated = now }
+            return . Just $ bar { cur = progress, lastUpdated = now, snapshot0 = newDelayed }
         else return (Just bar)
 
 -- | create a new 'ProgressBar' object
@@ -60,7 +81,7 @@ mkProgressBar name w = do
     isTerm <- hIsTerminalDevice stdout
     now <- Time.getCurrentTime
     return $! if isTerm
-        then Just (ProgressBarData name (-1) now now w)
+        then Just (ProgressBarData name (-1) now now (0, now) w)
         else Nothing
 
 drawProgressBar :: Int -> Rational -> String