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
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
import Annex.ReplaceFile
import Annex.CurrentBranch
import Annex.InodeSentinal
-import Annex.Concurrent
-import Utility.ThreadScheduler
import Utility.InodeCache
import Git.FilePath
import Git.CatFile
- 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)
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE BangPatterns #-}
module Database.Keys (
DbHandle,
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 $
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
+
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"
module Messages.Progress where
import Common
+import qualified Annex
import Messages
import Utility.Metered
import Types
{- 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
-> 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
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 =
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)
, consoleRegionErrFlag :: Bool
, jsonBuffer :: Maybe Aeson.Object
, promptLock :: MVar () -- left full when not prompting
+ , clearProgressMeter :: IO ()
}
newMessageState :: IO MessageState
, consoleRegionErrFlag = False
, jsonBuffer = Nothing
, promptLock = promptlock
+ , clearProgressMeter = return ()
}
-- | When communicating with a child process over a pipe while it is
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
(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
projects / git-annex.git / commitdiff