assistant: generate better commits for renames

5 files changed, 92 insertions, 51 deletions

diff --git a/Assistant/Changes.hs b/Assistant/Changes.hs
index 9114f5124..60372f316 100644
--- a/Assistant/Changes.hs
+++ b/Assistant/Changes.hs
@@ -12,6 +12,7 @@ import Assistant.Types.Changes
 import Utility.TSet
 
 import Data.Time.Clock
+import Control.Concurrent.STM
 
 {- Handlers call this when they made a change that needs to get committed. -}
 madeChange :: FilePath -> ChangeInfo -> Assistant (Maybe Change)
@@ -27,13 +28,17 @@ pendingAddChange f = Just <$> (PendingAddChange <$> liftIO getCurrentTime <*> pu
 {- Gets all unhandled changes.
  - Blocks until at least one change is made. -}
 getChanges :: Assistant [Change]
-getChanges = getTSet <<~ changeChan
+getChanges = (atomically . getTSet) <<~ changeChan
+
+{- Gets all unhandled changes, without blocking. -}
+getAnyChanges :: Assistant [Change]
+getAnyChanges = (atomically . readTSet) <<~ changeChan
 
 {- Puts unhandled changes back into the channel.
  - Note: Original order is not preserved. -}
 refillChanges :: [Change] -> Assistant ()
-refillChanges cs = flip putTSet cs <<~ changeChan
+refillChanges cs = (atomically . flip putTSet cs) <<~ changeChan
 
 {- Records a change in the channel. -}
 recordChange :: Change -> Assistant ()
-recordChange c = flip putTSet1 c <<~ changeChan
+recordChange c = (atomically . flip putTSet1 c) <<~ changeChan
diff --git a/Assistant/Commits.hs b/Assistant/Commits.hs
index 79555fee5..f4e908e0d 100644
--- a/Assistant/Commits.hs
+++ b/Assistant/Commits.hs
@@ -9,19 +9,20 @@ module Assistant.Commits where
 
 import Assistant.Common
 import Assistant.Types.Commits
-
 import Utility.TSet
 
+import Control.Concurrent.STM
+
 {- Gets all unhandled commits.
  - Blocks until at least one commit is made. -}
 getCommits :: Assistant [Commit]
-getCommits = getTSet <<~ commitChan
+getCommits = (atomically . getTSet) <<~ commitChan
 
 {- Puts unhandled commits back into the channel.
  - Note: Original order is not preserved. -}
 refillCommits :: [Commit] -> Assistant ()
-refillCommits cs = flip putTSet cs <<~ commitChan
+refillCommits cs = (atomically . flip putTSet cs) <<~ commitChan
 
 {- Records a commit in the channel. -}
 recordCommit :: Assistant ()
-recordCommit = flip putTSet1 Commit <<~ commitChan
+recordCommit = (atomically . flip putTSet1 Commit) <<~ commitChan
diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs
index 2450861e6..b336f650b 100644
--- a/Assistant/Threads/Committer.hs
+++ b/Assistant/Threads/Committer.hs
@@ -38,6 +38,7 @@ import Data.Time.Clock
 import Data.Tuple.Utils
 import qualified Data.Set as S
 import Data.Either
+import Control.Concurrent
 
 {- This thread makes git commits at appropriate times. -}
 commitThread :: NamedThread
@@ -45,34 +46,81 @@ commitThread = namedThread "Committer" $ do
 	delayadd <- liftAnnex $
 		maybe delayaddDefault (return . Just . Seconds)
 			=<< annexDelayAdd <$> Annex.getGitConfig
-	runEvery (Seconds 1) <~> do
-		-- We already waited one second as a simple rate limiter.
-		-- Next, wait until at least one change is available for
-		-- processing.
-		changes <- getChanges
-		-- Now see if now's a good time to commit.
-		time <- liftIO getCurrentTime
-		if shouldCommit time changes
+	waitChangeTime $ \(changes, time) -> do
+		readychanges <- handleAdds delayadd changes
+		if shouldCommit time readychanges
 			then do
-				readychanges <- handleAdds delayadd changes
-				if shouldCommit time readychanges
-					then do
-						debug
-							[ "committing"
-							, show (length readychanges)
-							, "changes"
-							]
-						void $ alertWhile commitAlert $
-							liftAnnex commitStaged
-						recordCommit
-						mapM_ checkChangeContent readychanges
-					else refill readychanges
-			else refill changes
+				debug
+					[ "committing"
+					, show (length readychanges)
+					, "changes"
+					]
+				void $ alertWhile commitAlert $
+					liftAnnex commitStaged
+				recordCommit
+				mapM_ checkChangeContent readychanges
+			else refill readychanges
+
+refill :: [Change] -> Assistant ()	
+refill [] = noop
+refill cs = do
+	debug ["delaying commit of", show (length cs), "changes"]
+	refillChanges cs
+
+{- Wait for one or more changes to arrive to be committed. -}
+waitChangeTime :: (([Change], UTCTime) -> Assistant ()) -> Assistant ()
+waitChangeTime a = runEvery (Seconds 1) <~> do
+	-- We already waited one second as a simple rate limiter.
+	-- Next, wait until at least one change is available for
+	-- processing.
+	changes <- getChanges
+	-- See if now's a good time to commit.
+	now <- liftIO getCurrentTime
+	case (shouldCommit now changes, lonelychange changes) of
+		(True, False) -> a (changes, now)
+		(True, True) -> do
+			-- Wait for other, related changes to arrive.
+			liftIO $ humanImperceptibleDelay
+			-- Don't block, but are there any?
+			morechanges <- getAnyChanges
+			let allchanges = changes++morechanges
+			a (allchanges, now)
+		_ -> refill changes
+  where
+	{- Did we perhaps only get one of the AddChange and RmChange pair
+	 - that make up a rename? -}
+	lonelychange [(PendingAddChange _ _)] = True
+	lonelychange [(Change { changeInfo = i })] | i == RmChange = True
+	lonelychange _ = False
+
+{- An amount of time that is hopefully imperceptably short for humans,
+ - while long enough for a computer to get some work done. 
+ - Note that 0.001 is a little too short for rename change batching to
+ - work. -}
+humanImperceptibleInterval :: NominalDiffTime
+humanImperceptibleInterval = 0.01
+
+humanImperceptibleDelay :: IO ()
+humanImperceptibleDelay = threadDelay $
+	truncate $ humanImperceptibleInterval * fromIntegral oneSecond
+
+{- Decide if now is a good time to make a commit.
+ - Note that the list of changes has an undefined order.
+ -
+ - Current strategy: If there have been 10 changes within the past second,
+ - a batch activity is taking place, so wait for later.
+ -}
+shouldCommit :: UTCTime -> [Change] -> Bool
+shouldCommit now changes
+	| len == 0 = False
+	| len > 10000 = True -- avoid bloating queue too much
+	| length recentchanges < 10 = True
+	| otherwise = False -- batch activity
   where
-	refill [] = noop
-	refill cs = do
-		debug ["delaying commit of", show (length cs), "changes"]
-		refillChanges cs
+	len = length changes
+	thissecond c = timeDelta c <= 1
+	recentchanges = filter thissecond changes
+	timeDelta c = now `diffUTCTime` changeTime c
 
 commitStaged :: Annex Bool
 commitStaged = do
@@ -105,22 +153,6 @@ commitStaged = do
 		| otherwise = Param "--allow-empty-message" 
 			: Param "-m" : Param "" : ps
 
-{- Decide if now is a good time to make a commit.
- - Note that the list of changes has an undefined order.
- -
- - Current strategy: If there have been 10 changes within the past second,
- - a batch activity is taking place, so wait for later.
- -}
-shouldCommit :: UTCTime -> [Change] -> Bool
-shouldCommit now changes
-	| len == 0 = False
-	| len > 10000 = True -- avoid bloating queue too much
-	| length (filter thisSecond changes) < 10 = True
-	| otherwise = False -- batch activity
-  where
-	len = length changes
-	thisSecond c = now `diffUTCTime` changeTime c <= 1
-
 {- OSX needs a short delay after a file is added before locking it down,
  - when using a non-direct mode repository, as pasting a file seems to
  - try to set file permissions or otherwise access the file after closing
diff --git a/Assistant/Types/Changes.hs b/Assistant/Types/Changes.hs
index d4e1b28bc..ee797b8fe 100644
--- a/Assistant/Types/Changes.hs
+++ b/Assistant/Types/Changes.hs
@@ -12,6 +12,7 @@ import Types.Key
 import Utility.TSet
 
 import Data.Time.Clock
+import Control.Concurrent.STM
 
 data ChangeInfo = AddChange Key | LinkChange (Maybe Key) | RmChange | RmDirChange
 	deriving (Show, Eq)
@@ -40,7 +41,7 @@ data Change
 	deriving (Show)
 
 newChangeChan :: IO ChangeChan
-newChangeChan = newTSet
+newChangeChan = atomically newTSet
 
 isPendingAddChange :: Change -> Bool
 isPendingAddChange (PendingAddChange {}) = True
diff --git a/Assistant/Types/Commits.hs b/Assistant/Types/Commits.hs
index bb17c578b..12dab8da8 100644
--- a/Assistant/Types/Commits.hs
+++ b/Assistant/Types/Commits.hs
@@ -9,9 +9,11 @@ module Assistant.Types.Commits where
 
 import Utility.TSet
 
+import Control.Concurrent.STM
+
 type CommitChan = TSet Commit
 
 data Commit = Commit
 
 newCommitChan :: IO CommitChan
-newCommitChan = newTSet
+newCommitChan = atomically newTSet