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

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

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)

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
+

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"

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 = 

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)

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

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

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