From 7b6deb1109d315fffb2e8a856340f022ed3db249 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 8 Jun 2021 12:48:30 -0400 Subject: [PATCH] display scanning message whenever reconcileStaged has enough files to chew on Clear visible progress bar first. Removed showSideActionAfter because it can't be used in reconcileStaged (import loop). Instead, it counts the number of files it processes and displays it after it's seen a sufficient to know it's taking a while. Sponsored-by: Dartmouth College's Datalad project --- Annex/Concurrent.hs | 20 -------------- Annex/WorkTree.hs | 4 +-- Database/Keys.hs | 26 ++++++++++++++++--- Messages.hs | 8 +++--- Messages/Progress.hs | 21 +++++++++++---- Messages/Serialized.hs | 3 ++- Types/Messages.hs | 2 ++ Utility/Metered.hs | 3 ++- ...reconcileStaged_is_taking_a_long_time.mdwn | 2 ++ 9 files changed, 53 insertions(+), 36 deletions(-) diff --git a/Annex/Concurrent.hs b/Annex/Concurrent.hs index cb22b6a463..1701120da2 100644 --- a/Annex/Concurrent.hs +++ b/Annex/Concurrent.hs @@ -100,23 +100,3 @@ mergeState st = do uncurry addCleanupAction Annex.Queue.mergeFrom st' changeState $ \s -> s { errcounter = errcounter s + errcounter st' } - -{- Display a message, only when the action runs for a long enough - - amount of time. - - - - The action should not display any other messages, progress, etc; - - if it did there could be some scrambling of the display since the - - message display could happen at the same time as other output, - - or after it. - -} -showSideActionAfter :: Microseconds -> String -> Annex a -> Annex a -showSideActionAfter t m a = do - waiter <- liftIO $ async $ unboundDelay t - let display = liftIO (waitCatch waiter) >>= \case - Left _ -> return () - Right _ -> showSideAction m - displayer <- liftIO . async =<< forkState display - let cleanup = do - liftIO $ cancel waiter - join (liftIO (wait displayer)) - a `finally` cleanup diff --git a/Annex/WorkTree.hs b/Annex/WorkTree.hs index 33d9094872..9a3dd50777 100644 --- a/Annex/WorkTree.hs +++ b/Annex/WorkTree.hs @@ -15,8 +15,6 @@ import Annex.Content import Annex.ReplaceFile import Annex.CurrentBranch import Annex.InodeSentinal -import Annex.Concurrent -import Utility.ThreadScheduler import Utility.InodeCache import Git.FilePath import Git.CatFile @@ -81,7 +79,7 @@ ifAnnexed file yes no = maybe no yes =<< lookupKey file - as-is. -} scanAnnexedFiles :: Bool -> Annex () -scanAnnexedFiles initscan = showSideActionAfter oneSecond "scanning for annexed files" $ do +scanAnnexedFiles initscan = do -- This gets the keys database populated with all annexed files, -- by running Database.Keys.reconcileStaged. Database.Keys.runWriter (const noop) diff --git a/Database/Keys.hs b/Database/Keys.hs index 3c0e3bede3..6cbfecda14 100644 --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} module Database.Keys ( DbHandle, @@ -403,7 +404,7 @@ reconcileStaged qh = do proct <- liftIO $ async $ procthread mdreader catfeeder `finally` void catcloser - dbchanged <- dbwriter False catreader + dbchanged <- dbwriter False largediff catreader -- Flush database changes now -- so other processes can see them. when dbchanged $ @@ -420,8 +421,27 @@ reconcileStaged qh = do Just _ -> procthread mdreader catfeeder Nothing -> return () - dbwriter dbchanged catreader = liftIO catreader >>= \case + dbwriter dbchanged n catreader = liftIO catreader >>= \case Just (ka, content) -> do changed <- ka (parseLinkTargetOrPointerLazy =<< content) - dbwriter (dbchanged || changed) catreader + !n' <- countdownToMessage n + dbwriter (dbchanged || changed) n' catreader Nothing -> return dbchanged + + -- When the diff is large, the scan can take a while, + -- so let the user know what's going on. + countdownToMessage n + | n < 1 = return 0 + | n == 1 = do + showSideAction "scanning for annexed files" + return 0 + | otherwise = return (pred n) + + -- How large is large? Too large and there will be a long + -- delay before the message is shown; too short and the message + -- will clutter things up unncessarily. It's uncommon for 1000 + -- files to change in the index, and processing that many files + -- takes less than half a second, so that seems about right. + largediff :: Int + largediff = 1000 + diff --git a/Messages.hs b/Messages.hs index 81c96a764f..563bd7e815 100644 --- a/Messages.hs +++ b/Messages.hs @@ -124,12 +124,14 @@ showSideAction m = Annex.getState Annex.output >>= go where go st | sideActionBlock st == StartBlock = do - p + go' st let st' = st { sideActionBlock = InBlock } Annex.changeState $ \s -> s { Annex.output = st' } | sideActionBlock st == InBlock = return () - | otherwise = p - p = outputMessage JSON.none $ encodeBS' $ "(" ++ m ++ "...)\n" + | otherwise = go' st + go' st = do + liftIO $ clearProgressMeter st + outputMessage JSON.none $ encodeBS' $ "(" ++ m ++ "...)\n" showStoringStateAction :: Annex () showStoringStateAction = showSideAction "recording state in git" diff --git a/Messages/Progress.hs b/Messages/Progress.hs index da60716e64..397aebbb37 100644 --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -11,6 +11,7 @@ module Messages.Progress where import Common +import qualified Annex import Messages import Utility.Metered import Types @@ -66,7 +67,7 @@ instance MeterSize KeySizer where {- Shows a progress meter while performing an action. - The action is passed the meter and a callback to use to update the meter. - --} + -} metered :: MeterSize sizer => Maybe MeterUpdate @@ -75,28 +76,38 @@ metered -> Annex a metered othermeter sizer a = withMessageState $ \st -> do sz <- getMeterSize sizer - metered' st othermeter sz showOutput a + metered' st setclear othermeter sz showOutput a + where + setclear c = Annex.changeState $ \st -> st + { Annex.output = (Annex.output st) { clearProgressMeter = c } } metered' :: (Monad m, MonadIO m, MonadMask m) => MessageState + -> (IO () -> m ()) + -- ^ This should set clearProgressMeter when progress meters + -- are being displayed; not needed when outputType is not + -- NormalOutput. -> Maybe MeterUpdate -> Maybe TotalSize -> m () -- ^ this should run showOutput -> (Meter -> MeterUpdate -> m a) -> m a -metered' st othermeter msize showoutput a = go st +metered' st setclear othermeter msize showoutput a = go st where go (MessageState { outputType = QuietOutput }) = nometer go (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do showoutput meter <- liftIO $ mkMeter msize $ displayMeterHandle stdout bandwidthMeter + let clear = clearMeterHandle meter stdout + setclear clear m <- liftIO $ rateLimitMeterUpdate consoleratelimit meter $ updateMeter meter r <- a meter (combinemeter m) - liftIO $ clearMeterHandle meter stdout + setclear noop + liftIO clear return r go (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) = withProgressRegion st $ \r -> do @@ -149,7 +160,7 @@ metered' st othermeter msize showoutput a = go st jsonratelimit = 0.1 minratelimit = min consoleratelimit jsonratelimit - + {- Poll file size to display meter. -} meteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a meteredFile file combinemeterupdate key a = diff --git a/Messages/Serialized.hs b/Messages/Serialized.hs index ff2517a901..bf1d09578a 100644 --- a/Messages/Serialized.hs +++ b/Messages/Serialized.hs @@ -65,9 +65,10 @@ relaySerializedOutput getso sendsor meterreport runannex = go Nothing loop st Left BeginProgressMeter -> do ost <- runannex (Annex.getState Annex.output) + let setclear = const noop -- Display a progress meter while running, until -- the meter ends or a final value is returned. - metered' ost Nothing Nothing (runannex showOutput) + metered' ost setclear Nothing Nothing (runannex showOutput) (\meter meterupdate -> loop (Just (meter, meterupdate))) >>= \case Right r -> return (Right r) diff --git a/Types/Messages.hs b/Types/Messages.hs index 593207be35..e80dc86d63 100644 --- a/Types/Messages.hs +++ b/Types/Messages.hs @@ -47,6 +47,7 @@ data MessageState = MessageState , consoleRegionErrFlag :: Bool , jsonBuffer :: Maybe Aeson.Object , promptLock :: MVar () -- left full when not prompting + , clearProgressMeter :: IO () } newMessageState :: IO MessageState @@ -60,6 +61,7 @@ newMessageState = do , consoleRegionErrFlag = False , jsonBuffer = Nothing , promptLock = promptlock + , clearProgressMeter = return () } -- | When communicating with a child process over a pipe while it is diff --git a/Utility/Metered.hs b/Utility/Metered.hs index 4683c13d6d..a7c9c37d7f 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -425,7 +425,8 @@ displayMeterHandle h rendermeter v msize old new = do hPutStr h ('\r':s ++ padding) hFlush h --- | Clear meter displayed by displayMeterHandle. +-- | Clear meter displayed by displayMeterHandle. May be called before +-- outputting something else, followed by more calls to displayMeterHandle. clearMeterHandle :: Meter -> Handle -> IO () clearMeterHandle (Meter _ _ v _) h = do olds <- readMVar v diff --git a/doc/todo/display_when_reconcileStaged_is_taking_a_long_time.mdwn b/doc/todo/display_when_reconcileStaged_is_taking_a_long_time.mdwn index 20b645d6e5..e89aa7b084 100644 --- a/doc/todo/display_when_reconcileStaged_is_taking_a_long_time.mdwn +++ b/doc/todo/display_when_reconcileStaged_is_taking_a_long_time.mdwn @@ -26,6 +26,8 @@ with the progress display in view: (scanning annexed files...) add newfile ok +> [[done]] --[[Joey]] + It might also be possible to make reconcileStaged run a less expensive scan in this case, eg the scan it did before [[!commit 428c91606b434512d1986622e751c795edf4df44]]. In this case, it -- 2.30.2