refactor param seeking

CmdLine.hs

@@ -8,15 +8,9 @@
 module CmdLine (parseCmd) where
 
 import System.Console.GetOpt
-import Control.Monad.State (liftIO)
-import System.Directory
-import System.Posix.Files
-import Control.Monad (filterM, when)
+import Control.Monad (when)
 
-import qualified GitRepo as Git
 import qualified Annex
-import Locations
-import qualified Backend
 import Types
 
 import Command
@@ -37,37 +31,35 @@ import qualified Command.PreCommit
 
 subCmds :: [SubCommand]
 subCmds =
-	[ SubCommand "add" path		[withFilesNotInGit Command.Add.start,
-					 withFilesUnlocked Command.Add.start]
+	[ SubCommand "add" path		Command.Add.seek
 		"add files to annex"
-	, SubCommand "get" path		[withFilesInGit Command.Get.start]
+	, SubCommand "get" path		Command.Get.seek
 		"make content of annexed files available"
-	, SubCommand "drop" path	[withFilesInGit Command.Drop.start]
+	, SubCommand "drop" path	Command.Drop.seek
 		"indicate content of files not currently wanted"
-	, SubCommand "move" path	[withFilesInGit Command.Move.start]
+	, SubCommand "move" path	Command.Move.seek
 		"transfer content of files to/from another repository"
-	, SubCommand "unlock" path	[withFilesInGit Command.Unlock.start]
+	, SubCommand "unlock" path	Command.Unlock.seek
 		"unlock files for modification"
-	, SubCommand "edit" path	[withFilesInGit Command.Unlock.start]
+	, SubCommand "edit" path	Command.Unlock.seek
 		"same as unlock"
-	, SubCommand "lock" path	[withFilesUnlocked Command.Lock.start]
+	, SubCommand "lock" path	Command.Lock.seek
 		"undo unlock command"
-	, SubCommand "init" desc	[withDescription Command.Init.start]
+	, SubCommand "init" desc	Command.Init.seek
 		"initialize git-annex with repository description"
-	, SubCommand "unannex" path	[withFilesInGit Command.Unannex.start]
+	, SubCommand "unannex" path	Command.Unannex.seek
 		"undo accidential add command"
-	, SubCommand "pre-commit" path	[withFilesToBeCommitted Command.Fix.start,
-					 withUnlockedFilesToBeCommitted Command.PreCommit.start]
+	, SubCommand "pre-commit" path	Command.PreCommit.seek
 		"run by git pre-commit hook"
-	, SubCommand "fromkey" key	[withFilesMissing Command.FromKey.start]
+	, SubCommand "fromkey" key	Command.FromKey.seek
 		"adds a file using a specific key"
-	, SubCommand "dropkey"	key	[withKeys Command.DropKey.start]
+	, SubCommand "dropkey"	key	Command.DropKey.seek
 		"drops annexed content for specified keys"
-	, SubCommand "setkey" key	[withTempFile Command.SetKey.start]
+	, SubCommand "setkey" key	Command.SetKey.seek
 		"sets annexed content for a key using a temp file"
-	, SubCommand "fix" path		[withFilesInGit Command.Fix.start]
+	, SubCommand "fix" path		Command.Fix.seek
 		"fix up symlinks to point to annexed content"
-	, SubCommand "fsck" nothing	[withNothing Command.Fsck.start]
+	, SubCommand "fsck" nothing	Command.Fsck.seek
 		"check annex for problems"
 	]
 	where
@@ -116,67 +108,6 @@ usage = usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs
 		indent l = "  " ++ l
 		pad n s = replicate (n - length s) ' '
 
-{- These functions find appropriate files or other things based on a
-   user's parameters, and run a specified action on them. -}
-withFilesInGit :: SubCmdSeekStrings
-withFilesInGit a params = do
-	repo <- Annex.gitRepo
-	files <- liftIO $ mapM (Git.inRepo repo) params
-	return $ map a $ filter notState $ foldl (++) [] files
-withFilesMissing :: SubCmdSeekStrings
-withFilesMissing a params = do
-	files <- liftIO $ filterM missing params
-	return $ map a $ filter notState files
-	where
-		missing f = do
-			e <- doesFileExist f
-			return $ not e
-withFilesNotInGit :: SubCmdSeekBackendFiles
-withFilesNotInGit a params = do
-	repo <- Annex.gitRepo
-	newfiles <- liftIO $ mapM (Git.notInRepo repo) params
-	backendPairs a $ filter notState $ foldl (++) [] newfiles
-withFilesUnlocked :: SubCmdSeekBackendFiles
-withFilesUnlocked a params = do
-	-- unlocked files have changed type from a symlink to a regular file
-	repo <- Annex.gitRepo
-	typechangedfiles <- liftIO $ mapM (Git.typeChangedFiles repo) params
-	unlockedfiles <- liftIO $ filterM notSymlink $ foldl (++) [] typechangedfiles
-	backendPairs a $ filter notState unlockedfiles
-backendPairs :: SubCmdSeekBackendFiles
-backendPairs a files = do
-	pairs <- Backend.chooseBackends files
-	return $ map a pairs
-withDescription :: SubCmdSeekStrings
-withDescription a params = return [a $ unwords params]
-withFilesToBeCommitted :: SubCmdSeekStrings
-withFilesToBeCommitted a params = do
-	repo <- Annex.gitRepo
-	tocommit <- liftIO $ mapM (Git.stagedFiles repo) params
-	return $ map a $ filter notState $ foldl (++) [] tocommit
-withUnlockedFilesToBeCommitted :: SubCmdSeekStrings
-withUnlockedFilesToBeCommitted a params = do
-	repo <- Annex.gitRepo
-	typechangedfiles <- liftIO $ mapM (Git.typeChangedStagedFiles repo) params
-	unlockedfiles <- liftIO $ filterM notSymlink $ foldl (++) [] typechangedfiles
-	return $ map a $ filter notState unlockedfiles
-withKeys :: SubCmdSeekStrings
-withKeys a params = return $ map a params
-withTempFile :: SubCmdSeekStrings
-withTempFile a params = return $ map a params
-withNothing :: SubCmdSeekNothing
-withNothing a _ = return [a]
-
-{- filter out files from the state directory -}
-notState :: FilePath -> Bool
-notState f = stateLoc /= take (length stateLoc) f
-	
-{- filter out symlinks -}	
-notSymlink :: FilePath -> IO Bool
-notSymlink f = do
-	s <- liftIO $ getSymbolicLinkStatus f
-	return $ not $ isSymbolicLink s
-
 {- Parses command line and returns two lists of actions to be 
  - run in the Annex monad. The first actions configure it
  - according to command line options, while the second actions

Command.hs

@@ -1,4 +1,4 @@
-{- git-annex command types
+{- git-annex commands
  -
  - Copyright 2010 Joey Hess <joey@kitenet.net>
  -
@@ -7,10 +7,17 @@
 
 module Command where
 
+import Control.Monad.State (liftIO)
+import System.Directory
+import System.Posix.Files
+import Control.Monad (filterM)
+
 import Types
 import qualified Backend
 import Messages
 import qualified Annex
+import qualified GitRepo as Git
+import Locations
 
 {- A subcommand runs in four stages.
  -
@@ -87,3 +94,64 @@ isAnnexed file a = do
 	case (r) of
 		Just v -> a v
 		Nothing -> return Nothing
+
+{- These functions find appropriate files or other things based on a
+   user's parameters, and run a specified action on them. -}
+withFilesInGit :: SubCmdSeekStrings
+withFilesInGit a params = do
+	repo <- Annex.gitRepo
+	files <- liftIO $ mapM (Git.inRepo repo) params
+	return $ map a $ filter notState $ foldl (++) [] files
+withFilesMissing :: SubCmdSeekStrings
+withFilesMissing a params = do
+	files <- liftIO $ filterM missing params
+	return $ map a $ filter notState files
+	where
+		missing f = do
+			e <- doesFileExist f
+			return $ not e
+withFilesNotInGit :: SubCmdSeekBackendFiles
+withFilesNotInGit a params = do
+	repo <- Annex.gitRepo
+	newfiles <- liftIO $ mapM (Git.notInRepo repo) params
+	backendPairs a $ filter notState $ foldl (++) [] newfiles
+withFilesUnlocked :: SubCmdSeekBackendFiles
+withFilesUnlocked a params = do
+	-- unlocked files have changed type from a symlink to a regular file
+	repo <- Annex.gitRepo
+	typechangedfiles <- liftIO $ mapM (Git.typeChangedFiles repo) params
+	unlockedfiles <- liftIO $ filterM notSymlink $ foldl (++) [] typechangedfiles
+	backendPairs a $ filter notState unlockedfiles
+backendPairs :: SubCmdSeekBackendFiles
+backendPairs a files = do
+	pairs <- Backend.chooseBackends files
+	return $ map a pairs
+withDescription :: SubCmdSeekStrings
+withDescription a params = return [a $ unwords params]
+withFilesToBeCommitted :: SubCmdSeekStrings
+withFilesToBeCommitted a params = do
+	repo <- Annex.gitRepo
+	tocommit <- liftIO $ mapM (Git.stagedFiles repo) params
+	return $ map a $ filter notState $ foldl (++) [] tocommit
+withUnlockedFilesToBeCommitted :: SubCmdSeekStrings
+withUnlockedFilesToBeCommitted a params = do
+	repo <- Annex.gitRepo
+	typechangedfiles <- liftIO $ mapM (Git.typeChangedStagedFiles repo) params
+	unlockedfiles <- liftIO $ filterM notSymlink $ foldl (++) [] typechangedfiles
+	return $ map a $ filter notState unlockedfiles
+withKeys :: SubCmdSeekStrings
+withKeys a params = return $ map a params
+withTempFile :: SubCmdSeekStrings
+withTempFile a params = return $ map a params
+withNothing :: SubCmdSeekNothing
+withNothing a _ = return [a]
+
+{- filter out files from the state directory -}
+notState :: FilePath -> Bool
+notState f = stateLoc /= take (length stateLoc) f
+	
+{- filter out symlinks -}	
+notSymlink :: FilePath -> IO Bool
+notSymlink f = do
+	s <- liftIO $ getSymbolicLinkStatus f
+	return $ not $ isSymbolicLink s

Command/Add.hs

@@ -18,6 +18,10 @@ import Types
 import Core
 import Messages
 
+{- Add acts on both files not checked into git yet, and unlocked files. -}
+seek :: [SubCmdSeek]
+seek = [withFilesNotInGit start, withFilesUnlocked start]
+
 {- The add subcommand annexes a file, storing it in a backend, and then
  - moving it into the annex directory and setting up the symlink pointing
  - to its content. -}

Command/Drop.hs

@@ -16,6 +16,9 @@ import Types
 import Core
 import Messages
 
+seek :: [SubCmdSeek]
+seek = [withFilesInGit start]
+
 {- Indicates a file's content is not wanted anymore, and should be removed
  - if it's safe to do so. -}
 start :: SubCmdStartString

Command/DropKey.hs

@@ -15,6 +15,9 @@ import Types
 import Core
 import Messages
 
+seek :: [SubCmdSeek]
+seek = [withKeys start]
+
 {- Drops cached content for a key. -}
 start :: SubCmdStartString
 start keyname = do

Command/Fix.hs

@@ -17,6 +17,9 @@ import Utility
 import Core
 import Messages
 
+seek :: [SubCmdSeek]
+seek = [withFilesInGit start]
+
 {- Fixes the symlink to an annexed file. -}
 start :: SubCmdStartString
 start file = isAnnexed file $ \(key, _) -> do

Command/FromKey.hs

@@ -20,6 +20,9 @@ import Types
 import Core
 import Messages
 
+seek :: [SubCmdSeek]
+seek = [withFilesMissing start]
+
 {- Adds a file pointing at a manually-specified key -}
 start :: SubCmdStartString
 start file = do

Command/Fsck.hs

@@ -14,6 +14,9 @@ import Types
 import Core
 import Messages
 
+seek :: [SubCmdSeek]
+seek = [withNothing start]
+
 {- Checks the whole annex for problems. -}
 start :: SubCmdStart
 start = do

Command/Get.hs

@@ -13,6 +13,9 @@ import Types
 import Core
 import Messages
 
+seek :: [SubCmdSeek]
+seek = [withFilesInGit start]
+
 {- Gets an annexed file from one of the backends. -}
 start :: SubCmdStartString
 start file = isAnnexed file $ \(key, backend) -> do

Command/Init.hs

@@ -18,6 +18,9 @@ import UUID
 import Version
 import Messages
 
+seek :: [SubCmdSeek]
+seek = [withDescription start]
+
 {- Stores description for the repository etc. -}
 start :: SubCmdStartString
 start description = do

Command/Lock.hs

@@ -15,6 +15,9 @@ import Messages
 import qualified Annex
 import qualified GitRepo as Git
 
+seek :: [SubCmdSeek]
+seek = [withFilesUnlocked start]
+
 {- Undo unlock -}
 start :: SubCmdStartBackendFile
 start (file, _) = do

Command/Move.hs

@@ -11,7 +11,7 @@ import Control.Monad.State (liftIO)
 import Monad (when)
 
 import Command
-import Command.Drop
+import qualified Command.Drop
 import qualified Annex
 import Locations
 import LocationLog
@@ -22,6 +22,9 @@ import qualified Remotes
 import UUID
 import Messages
 
+seek :: [SubCmdSeek]
+seek = [withFilesInGit start]
+
 {- Move a file either --to or --from a repository.
  -
  - This only operates on the cached file content; it does not involve

Command/PreCommit.hs

@@ -14,9 +14,14 @@ import qualified Annex
 import qualified Backend
 import qualified GitRepo as Git
 import qualified Command.Add
+import qualified Command.Fix
+
+{- The pre-commit hook needs to fix symlinks to all files being committed.
+ - And, it needs to inject unlocked files into the annex. -}
+seek :: [SubCmdSeek]
+seek = [withFilesToBeCommitted Command.Fix.start,
+	withUnlockedFilesToBeCommitted start]
 
-{- Run by git pre-commit hook; passed unlocked files that are being
- - committed. -}
 start :: SubCmdStartString
 start file = return $ Just $ perform file
 

Command/SetKey.hs

@@ -19,6 +19,9 @@ import Types
 import Core
 import Messages
 
+seek :: [SubCmdSeek]
+seek = [withTempFile start]
+
 {- Sets cached content for a key. -}
 start :: SubCmdStartString
 start file = do

Command/Unannex.hs

@@ -20,6 +20,9 @@ import Core
 import qualified GitRepo as Git
 import Messages
 
+seek :: [SubCmdSeek]
+seek = [withFilesInGit start]
+
 {- The unannex subcommand undoes an add. -}
 start :: SubCmdStartString
 start file = isAnnexed file $ \(key, backend) -> do

Command/Unlock.hs

@@ -18,6 +18,9 @@ import Locations
 import Utility
 import Core
 
+seek :: [SubCmdSeek]
+seek = [withFilesInGit start]
+
 {- The unlock subcommand replaces the symlink with a copy of the file's
  - content. -}
 start :: SubCmdStartString

debian/changelog

@@ -1,14 +1,15 @@
-git-annex (0.05) UNRELEASED; urgency=low
+git-annex (0.05) unstable; urgency=low
 
   * Optimize both pre-commit and lock subcommands to not call git diff
-    on every file being committed or locked.
+    on every file being committed/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.
+    git-annex 0.04 pre-commit to sometimes corrupt filename being read
+    from git ls-files 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
+ -- Joey Hess <joeyh@debian.org>  Thu, 11 Nov 2010 18:31:09 -0400
 
 git-annex (0.04) unstable; urgency=low