rework command dispatching for add and pre-commit

Both subcommands do two different operations on different sets of files, so
allowing a subcommand to perform a list of operations cleans things up.

CmdLine.hs

@@ -17,6 +17,7 @@ import qualified Annex
 import Locations
 import qualified Backend
 import Types
+import Core
 
 import Command
 import qualified Command.Add
@@ -36,35 +37,37 @@ import qualified Command.PreCommit
 
 subCmds :: [SubCommand]
 subCmds =
-	[ SubCommand "add" path	(withFilesToAdd Command.Add.start)
+	[ SubCommand "add" path		[withFilesNotInGit Command.Add.start,
+					 withFilesUnlocked Command.Add.start]
 		"add files to annex"
-	, SubCommand "get" path	(withFilesInGit Command.Get.start)
+	, SubCommand "get" path		[withFilesInGit Command.Get.start]
 		"make content of annexed files available"
-	, SubCommand "drop" path	(withFilesInGit Command.Drop.start)
+	, SubCommand "drop" path	[withFilesInGit Command.Drop.start]
 		"indicate content of files not currently wanted"
-	, SubCommand "move" path	(withFilesInGit Command.Move.start)
+	, SubCommand "move" path	[withFilesInGit Command.Move.start]
 		"transfer content of files to/from another repository"
-	, SubCommand "unlock" path	(withFilesInGit Command.Unlock.start)
+	, SubCommand "unlock" path	[withFilesInGit Command.Unlock.start]
 		"unlock files for modification"
-	, SubCommand "edit" path	(withFilesInGit Command.Unlock.start)
+	, SubCommand "edit" path	[withFilesInGit Command.Unlock.start]
 		"same as unlock"
-	, SubCommand "lock" path	(withFilesInGit Command.Lock.start)
+	, SubCommand "lock" path	[withFilesUnlocked Command.Lock.start]
 		"undo unlock command"
-	, SubCommand "init" desc	(withDescription Command.Init.start)
+	, SubCommand "init" desc	[withDescription Command.Init.start]
 		"initialize git-annex with repository description"
-	, SubCommand "unannex" path	(withFilesInGit Command.Unannex.start)
+	, SubCommand "unannex" path	[withFilesInGit Command.Unannex.start]
 		"undo accidential add command"
-	, SubCommand "pre-commit" path (withFilesToBeCommitted Command.PreCommit.start)
+	, SubCommand "pre-commit" path	[withFilesToBeCommitted Command.Fix.start,
+					 withUnlockedFilesToBeCommitted Command.PreCommit.start]
 		"run by git pre-commit hook"
-	, SubCommand "fromkey" key	(withFilesMissing Command.FromKey.start)
+	, SubCommand "fromkey" key	[withFilesMissing Command.FromKey.start]
 		"adds a file using a specific key"
-	, SubCommand "dropkey"	key	(withKeys Command.DropKey.start)
+	, SubCommand "dropkey"	key	[withKeys Command.DropKey.start]
 		"drops annexed content for specified keys"
-	, SubCommand "setkey" key	(withTempFile Command.SetKey.start)
+	, SubCommand "setkey" key	[withTempFile Command.SetKey.start]
 		"sets annexed content for a key using a temp file"
-	, SubCommand "fix" path	(withFilesInGit Command.Fix.start)
+	, SubCommand "fix" path		[withFilesInGit Command.Fix.start]
 		"fix up symlinks to point to annexed content"
-	, SubCommand "fsck" nothing	(withNothing Command.Fsck.start)
+	, SubCommand "fsck" nothing	[withNothing Command.Fsck.start]
 		"check annex for problems"
 	]
 	where
@@ -128,12 +131,17 @@ withFilesMissing a params = do
 		missing f = do
 			e <- doesFileExist f
 			return $ not e
-withFilesToAdd :: SubCmdSeekBackendFiles
+withFilesNotInGit :: SubCmdSeekBackendFiles
-withFilesToAdd a params = do
+withFilesNotInGit a params = do
 	repo <- Annex.gitRepo
 	newfiles <- liftIO $ mapM (Git.notInRepo repo) params
-	unlockedfiles <- liftIO $ mapM (Git.typeChangedFiles repo) params
+	backendPairs a $ foldl (++) [] newfiles
-	let files = foldl (++) [] $ newfiles ++ unlockedfiles
+withFilesUnlocked :: SubCmdSeekBackendFiles
+withFilesUnlocked a params = do
+	unlocked <- mapM unlockedFiles params
+	backendPairs a $ foldl (++) [] unlocked
+backendPairs :: SubCmdSeekBackendFiles
+backendPairs a files = do
 	pairs <- Backend.chooseBackends files
 	return $ map a $ filter (\(f,_) -> notState f) pairs
 withDescription :: SubCmdSeekStrings
@@ -141,8 +149,15 @@ withDescription a params = return [a $ unwords params]
 withFilesToBeCommitted :: SubCmdSeekStrings
 withFilesToBeCommitted a params = do
 	repo <- Annex.gitRepo
-	files <- liftIO $ mapM (Git.stagedFiles repo) params
+	tocommit <- liftIO $ mapM (Git.stagedFiles repo) params
-	return $ map a $ filter notState $ foldl (++) [] files
+	return $ map a $ filter notState $ foldl (++) [] tocommit
+withUnlockedFilesToBeCommitted :: SubCmdSeekStrings
+withUnlockedFilesToBeCommitted a params = do
+	repo <- Annex.gitRepo
+	unlocked <- mapM unlockedFiles params
+	tocommit <- liftIO $ mapM (Git.stagedFiles repo) $
+		filter notState $ foldl (++) [] unlocked
+	return $ map a $ foldl (++) [] tocommit
 withKeys :: SubCmdSeekStrings
 withKeys a params = return $ map a params
 withTempFile :: SubCmdSeekStrings

Command.hs

@@ -41,7 +41,7 @@ type SubCmdSeekNothing = SubCmdStart -> SubCmdSeek
 data SubCommand = SubCommand {
 	subcmdname :: String,
 	subcmdparams :: String,
-	subcmdseek :: SubCmdSeek,
+	subcmdseek :: [SubCmdSeek],
 	subcmddesc :: String
 }
 
@@ -49,8 +49,8 @@ data SubCommand = SubCommand {
  - the parameters passed to it. -}
 prepSubCmd :: SubCommand -> AnnexState -> [String] -> IO [Annex Bool]
 prepSubCmd SubCommand { subcmdseek = seek } state params = do
-	list <- Annex.eval state $ seek params
+	lists <- Annex.eval state $ mapM (\s -> s params) seek
-	return $ map doSubCmd list
+	return $ map doSubCmd $ foldl (++) [] lists
 
 {- Runs a subcommand through the start, perform and cleanup stages -}
 doSubCmd :: SubCmdStart -> SubCmdCleanup

Command/Lock.hs

@@ -9,23 +9,17 @@ module Command.Lock where
 
 import Control.Monad.State (liftIO)
 import System.Directory
-import System.Posix.Files
 
-import Types
 import Command
 import Messages
 import qualified Annex
 import qualified GitRepo as Git
 
 {- Undo unlock -}
-start :: SubCmdStartString
+start :: SubCmdStartBackendFile
-start file = do
+start (file, _) = do
-	locked <- isLocked file
+	showStart "lock" file
-	if locked
+	return $ Just $ perform file
-		then return Nothing
-		else do
-			showStart "lock" file
-			return $ Just $ perform file
 
 perform :: FilePath -> SubCmdPerform
 perform file = do
@@ -36,17 +30,3 @@ perform file = do
 	-- checkout the symlink
 	liftIO $ Git.run g ["checkout", "--", file]
 	return $ Just $ return True -- no cleanup needed
-
-{- Checks if a file is unlocked for edit. -}
-isLocked :: FilePath -> Annex Bool
-isLocked file = do
-	-- check if it's a symlink first, as that's cheapest
-	s <- liftIO $ getSymbolicLinkStatus file
-	if (isSymbolicLink s)
-		then return True -- Symlinked files are always locked.
-		else do
-			-- Not a symlink, so see if the type has changed,
-			-- if so it is presumed to have been unlocked.
-			g <- Annex.gitRepo
-			typechanged <- liftIO $ Git.typeChangedFiles g file
-			return $ not $ elem file typechanged

Command/PreCommit.hs

@@ -8,34 +8,32 @@
 module Command.PreCommit where
 
 import Control.Monad.State (liftIO)
-import Control.Monad (when, unless)
 
 import Command
 import qualified Annex
 import qualified Backend
 import qualified GitRepo as Git
-import qualified Command.Fix
-import qualified Command.Lock
 import qualified Command.Add
 
-{- Run by git pre-commit hook. -}
+{- Run by git pre-commit hook; passed unlocked files that are being
+ - committed. -}
 start :: SubCmdStartString
-start file = do
+start file = return $ Just $ perform file
-	-- If a file is unlocked for edit, add its new content to the
-	-- annex. -}
-	locked <- Command.Lock.isLocked file
-	when (not locked) $ do
-		pairs <- Backend.chooseBackends [file]
-		ok <- doSubCmd $ Command.Add.start $ pairs !! 0
-		unless (ok) $ do
-			error $ "failed to add " ++ file ++ "; canceling commit"
-		-- git commit will have staged the file's content;
-		-- drop that and run command queued by Add.state to
-		-- stage the symlink
-		g <- Annex.gitRepo
-		liftIO $ Git.run g ["reset", "-q", "--", file]
-		Annex.queueRun
 
-	-- Fix symlinks as they are committed, this ensures the
+perform :: FilePath -> SubCmdPerform
-	-- relative links are not broken when moved around.
+perform file = do
-	Command.Fix.start file
+	pairs <- Backend.chooseBackends [file]
+	ok <- doSubCmd $ Command.Add.start $ pairs !! 0
+	if ok
+		then return $ Just $ cleanup file
+		else error $ "failed to add " ++ file ++ "; canceling commit"
+
+cleanup :: FilePath -> SubCmdCleanup
+cleanup file = do
+	-- git commit will have staged the file's content;
+	-- drop that and run command queued by Add.state to
+	-- stage the symlink
+	g <- Annex.gitRepo
+	liftIO $ Git.run g ["reset", "-q", "--", file]
+	Annex.queueRun
+	return True

Core.hs

@@ -224,6 +224,20 @@ getKeysReferenced = do
 	keypairs <- mapM Backend.lookupFile files
 	return $ map fst $ catMaybes keypairs
 
+{- Passed a location (a directory or a single file, returns
+ - files there that are unlocked for editing. -}
+unlockedFiles :: FilePath -> Annex [FilePath]
+unlockedFiles l = do
+	-- unlocked files have changed type from a symlink to a regular file
+	g <- Annex.gitRepo
+	typechangedfiles <- liftIO $ Git.typeChangedFiles g l
+	unlockedfiles <- filterM notsymlink typechangedfiles
+	return unlockedfiles
+	where
+		notsymlink f = do
+			s <- liftIO $ getSymbolicLinkStatus f
+			return $ not $ isSymbolicLink s
+
 {- Uses the annex.version git config setting to automate upgrades. -}
 autoUpgrade :: Annex ()
 autoUpgrade = do

debian/changelog

@@ -1,6 +1,12 @@
 git-annex (0.05) UNRELEASED; urgency=low
 
-  * Optimize both pre-commit and lock subcommands.
+  * Optimize both pre-commit and lock subcommands to not call git diff
+    on every file being committed or locked.
+    (This actually also works around a bug in ghc 6.12.1, that caused
+    git-annex 0.04 pre-commit to sometimes corrupt filenames and fail.
+    The excessive number of calls made by pre-commit exposed the ghc bug.
+    Thanks Josh Triplett for the debugging.)
+  * Build with -O3.
 
  -- Joey Hess <joeyh@debian.org>  Thu, 11 Nov 2010 14:52:05 -0400