refactoring and cleanup

No code changes.

Checks.hs

@@ -0,0 +1,45 @@
+{- git-annex command checks
+ -
+ - Common sanity checks for commands, and an interface to selectively
+ - remove them, or add others.
+ - 
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Checks where
+
+import Common.Annex
+import Types.Command
+import Init
+import qualified Annex
+
+commonChecks :: [CommandCheck]
+commonChecks = [fromOpt, toOpt, repoExists]
+
+repoExists :: CommandCheck
+repoExists = CommandCheck 0 ensureInitialized
+
+fromOpt :: CommandCheck
+fromOpt = CommandCheck 1 $ do
+	v <- Annex.getState Annex.fromremote
+	unless (v == Nothing) $ error "cannot use --from with this command"
+
+toOpt :: CommandCheck
+toOpt = CommandCheck 2 $ do
+	v <- Annex.getState Annex.toremote
+	unless (v == Nothing) $ error "cannot use --to with this command"
+
+checkCommand :: Command -> Annex ()
+checkCommand Command { cmdcheck = c } = sequence_ $ map runCheck c
+
+dontCheck :: CommandCheck -> Command -> Command
+dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c
+
+addCheck :: Annex () -> Command -> Command
+addCheck check cmd = mutateCheck cmd $
+	\c -> CommandCheck (length c + 100) check : c
+
+mutateCheck :: Command -> ([CommandCheck] -> [CommandCheck]) -> Command
+mutateCheck cmd@(Command { cmdcheck = c }) a = cmd { cmdcheck = a c }

CmdLine.hs

@@ -20,7 +20,6 @@ import qualified Annex.Queue
 import qualified Git
 import Annex.Content
 import Command
-import Options
 
 {- Runs the passed command line. -}
 dispatch :: [String] -> [Command] -> [Option] -> String -> Git.Repo -> IO ()

Command.hs

@@ -5,52 +5,38 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Command where
+module Command (
+	module Types.Command,
+	module Seek,
+	module Checks,
+	module Options,
+	command,
+	next,
+	stop,
+	prepCommand,
+	doCommand,
+	notAnnexed,
+	isAnnexed,
+	notBareRepo,
+	isBareRepo,
+	autoCopies
+) where
 
 import Common.Annex
 import qualified Backend
 import qualified Annex
 import qualified Git
-import qualified Git.LsFiles as LsFiles
+import Types.Command
-import Types.Key
 import Logs.Trust
 import Logs.Location
 import Config
-import Backend
+import Seek
-import Limit
+import Checks
-import Init
+import Options
 
-{- A command runs in these stages.
+{- Generates a command with the common checks. -}
- -
+command :: String -> String -> [CommandSeek] -> String -> Command
- - a. The check stage runs checks, that error out if
+command = Command commonChecks
- -    anything prevents the command from running. -}
-data CommandCheck = CommandCheck { idCheck :: Int, runCheck :: Annex () }
-instance Eq CommandCheck where
-	a == b = idCheck a == idCheck b
-{- b. The seek stage takes the parameters passed to the command,
- -    looks through the repo to find the ones that are relevant
- -    to that command (ie, new files to add), and generates
- -    a list of start stage actions. -}
-type CommandSeek = [String] -> Annex [CommandStart]
-{- c. The start stage is run before anything is printed about the
-  -   command, is passed some input, and can early abort it
-  -   if the input does not make sense. It should run quickly and
-  -   should not modify Annex state. -}
-type CommandStart = Annex (Maybe CommandPerform)
-{- d. The perform stage is run after a message is printed about the command
- -    being run, and it should be where the bulk of the work happens. -}
-type CommandPerform = Annex (Maybe CommandCleanup)
-{- e. The cleanup stage is run only if the perform stage succeeds, and it
- -    returns the overall success/fail of the command. -}
-type CommandCleanup = Annex Bool
-
-data Command = Command {
-	cmdcheck :: [CommandCheck],
-	cmdname :: String,
-	cmdparams :: String,
-	cmdseek :: [CommandSeek],
-	cmddesc :: String
-}
 
 {- For start and perform stages to indicate what step to run next. -}
 next :: a -> Annex (Maybe a)
@@ -60,15 +46,14 @@ next a = return $ Just a
 stop :: Annex (Maybe a)
 stop = return Nothing
 
-{- Generates a command with the common checks. -}
-command :: String -> String -> [CommandSeek] -> String -> Command
-command = Command commonChecks
-
 {- Prepares a list of actions to run to perform a command, based on
  - the parameters passed to it. -}
 prepCommand :: Command -> [String] -> Annex [Annex Bool]
-prepCommand Command { cmdseek = seek } params =
+prepCommand cmd ps = return . map doCommand =<< seekCommand cmd ps
-	return . map doCommand . concat =<< mapM (\s -> s params) seek
+
+{- Runs a command through the seek stage. -}
+seekCommand :: Command -> [String] -> Annex [CommandStart]
+seekCommand Command { cmdseek = seek } ps = concat <$> mapM (\s -> s ps) seek
 
 {- Runs a command through the start, perform and cleanup stages -}
 doCommand :: CommandStart -> CommandCleanup
@@ -81,147 +66,20 @@ doCommand = start
 		success = return True
 		failure = showEndFail >> return False
 
-{- These functions find appropriate files or other things based on a
-   user's parameters, and prepare actions operating on them. -}
-withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek
-withFilesInGit a params = do
-	repo <- gitRepo
-	runFiltered a $ liftIO $ runPreserveOrder (LsFiles.inRepo repo) params
-withAttrFilesInGit :: String -> ((FilePath, String) -> CommandStart) -> CommandSeek
-withAttrFilesInGit attr a params = do
-	repo <- gitRepo
-	files <- liftIO $ runPreserveOrder (LsFiles.inRepo repo) params
-	runFilteredGen a fst $ liftIO $ Git.checkAttr repo attr files
-withNumCopies :: (FilePath -> Maybe Int -> CommandStart) -> CommandSeek
-withNumCopies a params = withAttrFilesInGit "annex.numcopies" go params
-	where
-		go (file, v) = a file (readMaybe v)
-withBackendFilesInGit :: (BackendFile -> CommandStart) -> CommandSeek
-withBackendFilesInGit a params = do
-	repo <- gitRepo
-	files <- liftIO $ runPreserveOrder (LsFiles.inRepo repo) params
-	backendPairs a files
-withFilesMissing :: (String -> CommandStart) -> CommandSeek
-withFilesMissing a params = runFiltered a $ liftIO $ filterM missing params
-	where
-		missing = liftM not . doesFileExist
-withFilesNotInGit :: (BackendFile -> CommandStart) -> CommandSeek
-withFilesNotInGit a params = do
-	repo <- gitRepo
-	force <- Annex.getState Annex.force
-	newfiles <- liftIO $ runPreserveOrder (LsFiles.notInRepo repo force) params
-	backendPairs a newfiles
-withWords :: ([String] -> CommandStart) -> CommandSeek
-withWords a params = return [a params]
-withStrings :: (String -> CommandStart) -> CommandSeek
-withStrings a params = return $ map a params
-withFilesToBeCommitted :: (String -> CommandStart) -> CommandSeek
-withFilesToBeCommitted a params = do
-	repo <- gitRepo
-	runFiltered a $
-		liftIO $ runPreserveOrder (LsFiles.stagedNotDeleted repo) params
-withFilesUnlocked :: (BackendFile -> CommandStart) -> CommandSeek
-withFilesUnlocked = withFilesUnlocked' LsFiles.typeChanged
-withFilesUnlockedToBeCommitted :: (BackendFile -> CommandStart) -> CommandSeek
-withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged
-withFilesUnlocked' :: (Git.Repo -> [FilePath] -> IO [FilePath]) -> (BackendFile -> CommandStart) -> CommandSeek
-withFilesUnlocked' typechanged a params = do
-	-- unlocked files have changed type from a symlink to a regular file
-	repo <- gitRepo
-	typechangedfiles <- liftIO $ runPreserveOrder (typechanged repo) params
-	unlockedfiles <- liftIO $ filterM notSymlink $
-		map (\f -> Git.workTree repo ++ "/" ++ f) typechangedfiles
-	backendPairs a unlockedfiles
-withKeys :: (Key -> CommandStart) -> CommandSeek
-withKeys a params = return $ map (a . parse) params
-	where
-		parse p = fromMaybe (error "bad key") $ readKey p
-withNothing :: CommandStart -> CommandSeek
-withNothing a [] = return [a]
-withNothing _ _ = error "This command takes no parameters."
-
-runFiltered :: (FilePath -> Annex (Maybe a)) -> Annex [FilePath] -> Annex [Annex (Maybe a)]
-runFiltered a = runFilteredGen a id
-
-backendPairs :: (BackendFile -> CommandStart) -> CommandSeek
-backendPairs a fs = runFilteredGen a snd (Backend.chooseBackends fs)
-
-runFilteredGen :: (b -> Annex (Maybe a)) -> (b -> FilePath) -> Annex [b] -> Annex [Annex (Maybe a)]
-runFilteredGen a d fs = do
-	matcher <- Limit.getMatcher
-	runActions (proc matcher) fs
-	where
-		proc matcher v = do
-			let f = d v
-			ok <- matcher f
-			if ok then a v else stop
-
-runActions :: (b -> Annex (Maybe a)) -> Annex [b] -> Annex [Annex (Maybe a)]
-runActions a fs = liftM (map a) fs
-
 notAnnexed :: FilePath -> Annex (Maybe a) -> Annex (Maybe a)
 notAnnexed file a = maybe a (const $ return Nothing) =<< Backend.lookupFile file
 
 isAnnexed :: FilePath -> ((Key, Backend Annex) -> Annex (Maybe a)) -> Annex (Maybe a)
 isAnnexed file a = maybe (return Nothing) a =<< Backend.lookupFile file
 
-isBareRepo :: Annex Bool
-isBareRepo = Git.repoIsLocalBare <$> gitRepo
-
 notBareRepo :: Annex a -> Annex a
 notBareRepo a = do
 	whenM isBareRepo $
 		error "You cannot run this subcommand in a bare repository."
 	a
 
-notSymlink :: FilePath -> IO Bool
+isBareRepo :: Annex Bool
-notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f
+isBareRepo = Git.repoIsLocalBare <$> gitRepo
-
-{- Descriptions of params used in usage messages. -}
-paramPaths :: String
-paramPaths = paramOptional $ paramRepeating paramPath -- most often used
-paramPath :: String
-paramPath = "PATH"
-paramKey :: String
-paramKey = "KEY"
-paramDesc :: String
-paramDesc = "DESC"
-paramUrl :: String
-paramUrl = "URL"
-paramNumber :: String
-paramNumber = "NUMBER"
-paramRemote :: String
-paramRemote = "REMOTE"
-paramGlob :: String
-paramGlob = "GLOB"
-paramName :: String
-paramName = "NAME"
-paramUUID :: String
-paramUUID = "UUID"
-paramType :: String
-paramType = "TYPE"
-paramKeyValue :: String
-paramKeyValue = "K=V"
-paramNothing :: String
-paramNothing = ""
-paramRepeating :: String -> String
-paramRepeating s = s ++ " ..."
-paramOptional :: String -> String
-paramOptional s = "[" ++ s ++ "]"
-paramPair :: String -> String -> String
-paramPair a b = a ++ " " ++ b
-
-{- The Key specified by the --key parameter. -}
-cmdlineKey :: Annex Key
-cmdlineKey  = do
-	k <- Annex.getState Annex.defaultkey
-	case k of
-		Nothing -> nokey
-		Just "" -> nokey
-		Just kstring -> maybe badkey return $ readKey kstring
-	where
-		nokey = error "please specify the key with --key"
-		badkey = error "bad key"
 
 {- Used for commands that have an auto mode that checks the number of known
  - copies of a key.
@@ -238,34 +96,3 @@ autoCopies key vs numcopiesattr a = do
 			(_, have) <- trustPartition UnTrusted =<< keyLocations key
 			if length have `vs` needed then a else stop
 		else a
-
-{- Common checks for commands, and an interface to selectively remove them,
- - or add others. -}
-commonChecks :: [CommandCheck]
-commonChecks = [fromOpt, toOpt, repoExists]
-
-repoExists :: CommandCheck
-repoExists = CommandCheck 0 ensureInitialized
-
-fromOpt :: CommandCheck
-fromOpt = CommandCheck 1 $ do
-	v <- Annex.getState Annex.fromremote
-	unless (v == Nothing) $ error "cannot use --from with this command"
-
-toOpt :: CommandCheck
-toOpt = CommandCheck 2 $ do
-	v <- Annex.getState Annex.toremote
-	unless (v == Nothing) $ error "cannot use --to with this command"
-
-checkCommand :: Command -> Annex ()
-checkCommand Command { cmdcheck = c } = sequence_ $ map runCheck c
-
-dontCheck :: CommandCheck -> Command -> Command
-dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c
-
-addCheck :: Annex () -> Command -> Command
-addCheck check cmd = mutateCheck cmd $
-	\c -> CommandCheck (length c + 100) check : c
-
-mutateCheck :: Command -> ([CommandCheck] -> [CommandCheck]) -> Command
-mutateCheck cmd@(Command { cmdcheck = c }) a = cmd { cmdcheck = a c }

Command/FromKey.hs

@@ -12,6 +12,7 @@ import Command
 import qualified Annex.Queue
 import Annex.Content
 import Types.Key
+import Config
 
 def :: [Command]
 def = [command "fromkey" paramPath seek "adds a file using a specific key"]

Command/Fsck.hs

@@ -49,7 +49,7 @@ withBarePresentKeys a params = isBareRepo >>= go
 		go True = do
 			unless (null params) $ do
 				error "fsck should be run without parameters in a bare repository"
-			runActions a loggedKeys
+			prepStart a loggedKeys
 
 startBare :: Key -> CommandStart
 startBare key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of

Command/SetKey.hs

@@ -11,6 +11,7 @@ import Common.Annex
 import Command
 import Logs.Location
 import Annex.Content
+import Config
 
 def :: [Command]
 def = [command "setkey" paramPath seek

Config.hs

@@ -10,6 +10,7 @@ module Config where
 import Common.Annex
 import qualified Git
 import qualified Annex
+import Types.Key (readKey)
 
 type ConfigKey = String
 
@@ -92,3 +93,14 @@ getNumCopies v =
 			return $ read $ Git.configGet g config "1"
 		config = "annex.numcopies"
 
+{- The Key specified by the --key parameter. -}
+cmdlineKey :: Annex Key
+cmdlineKey  = do
+	k <- Annex.getState Annex.defaultkey
+	case k of
+		Nothing -> nokey
+		Just "" -> nokey
+		Just kstring -> maybe badkey return $ readKey kstring
+	where
+		nokey = error "please specify the key with --key"
+		badkey = error "bad key"

GitAnnex.hs

@@ -13,7 +13,6 @@ import Common.Annex
 import qualified Git
 import CmdLine
 import Command
-import Options
 import Types.TrustLevel
 import qualified Annex
 import qualified Remote

Options.hs

@@ -1,6 +1,6 @@
-{- git-annex dashed options
+{- git-annex command-line options
  -
- - Copyright 2010 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -12,7 +12,6 @@ import System.Log.Logger
 
 import Common.Annex
 import qualified Annex
-import Command
 import Limit
 
 {- Each dashed command-line option results in generation of an action
@@ -59,3 +58,37 @@ matcherOptions =
 	where
 		longopt o = Option [] [o] $ NoArg $ addToken o
 		shortopt o = Option o [] $ NoArg $ addToken o
+
+{- Descriptions of params used in usage messages. -}
+paramPaths :: String
+paramPaths = paramOptional $ paramRepeating paramPath -- most often used
+paramPath :: String
+paramPath = "PATH"
+paramKey :: String
+paramKey = "KEY"
+paramDesc :: String
+paramDesc = "DESC"
+paramUrl :: String
+paramUrl = "URL"
+paramNumber :: String
+paramNumber = "NUMBER"
+paramRemote :: String
+paramRemote = "REMOTE"
+paramGlob :: String
+paramGlob = "GLOB"
+paramName :: String
+paramName = "NAME"
+paramUUID :: String
+paramUUID = "UUID"
+paramType :: String
+paramType = "TYPE"
+paramKeyValue :: String
+paramKeyValue = "K=V"
+paramNothing :: String
+paramNothing = ""
+paramRepeating :: String -> String
+paramRepeating s = s ++ " ..."
+paramOptional :: String -> String
+paramOptional s = "[" ++ s ++ "]"
+paramPair :: String -> String -> String
+paramPair a b = a ++ " " ++ b

Seek.hs

@@ -0,0 +1,117 @@
+{- git-annex command seeking
+ - 
+ - These functions find appropriate files or other things based on
+ - the values a user passes to a command, and prepare actions operating
+ - on them.
+ -
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Seek where
+
+import Common.Annex
+import Types.Command
+import Types.Key
+import Backend
+import qualified Annex
+import qualified Git
+import qualified Git.LsFiles as LsFiles
+import qualified Limit
+
+withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek
+withFilesInGit a params = do
+	repo <- gitRepo
+	prepFiltered a $ liftIO $ runPreserveOrder (LsFiles.inRepo repo) params
+
+withAttrFilesInGit :: String -> ((FilePath, String) -> CommandStart) -> CommandSeek
+withAttrFilesInGit attr a params = do
+	repo <- gitRepo
+	files <- liftIO $ runPreserveOrder (LsFiles.inRepo repo) params
+	prepFilteredGen a fst $ liftIO $ Git.checkAttr repo attr files
+
+withNumCopies :: (FilePath -> Maybe Int -> CommandStart) -> CommandSeek
+withNumCopies a params = withAttrFilesInGit "annex.numcopies" go params
+	where
+		go (file, v) = a file (readMaybe v)
+
+withBackendFilesInGit :: (BackendFile -> CommandStart) -> CommandSeek
+withBackendFilesInGit a params = do
+	repo <- gitRepo
+	files <- liftIO $ runPreserveOrder (LsFiles.inRepo repo) params
+	prepBackendPairs a files
+
+withFilesMissing :: (String -> CommandStart) -> CommandSeek
+withFilesMissing a params = prepFiltered a $ liftIO $ filterM missing params
+	where
+		missing = liftM not . doesFileExist
+
+withFilesNotInGit :: (BackendFile -> CommandStart) -> CommandSeek
+withFilesNotInGit a params = do
+	repo <- gitRepo
+	force <- Annex.getState Annex.force
+	newfiles <- liftIO $ runPreserveOrder (LsFiles.notInRepo repo force) params
+	prepBackendPairs a newfiles
+
+withWords :: ([String] -> CommandStart) -> CommandSeek
+withWords a params = return [a params]
+
+withStrings :: (String -> CommandStart) -> CommandSeek
+withStrings a params = return $ map a params
+
+withFilesToBeCommitted :: (String -> CommandStart) -> CommandSeek
+withFilesToBeCommitted a params = do
+	repo <- gitRepo
+	prepFiltered a $
+		liftIO $ runPreserveOrder (LsFiles.stagedNotDeleted repo) params
+
+withFilesUnlocked :: (BackendFile -> CommandStart) -> CommandSeek
+withFilesUnlocked = withFilesUnlocked' LsFiles.typeChanged
+
+withFilesUnlockedToBeCommitted :: (BackendFile -> CommandStart) -> CommandSeek
+withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged
+
+withFilesUnlocked' :: (Git.Repo -> [FilePath] -> IO [FilePath]) -> (BackendFile -> CommandStart) -> CommandSeek
+withFilesUnlocked' typechanged a params = do
+	-- unlocked files have changed type from a symlink to a regular file
+	repo <- gitRepo
+	typechangedfiles <- liftIO $ runPreserveOrder (typechanged repo) params
+	unlockedfiles <- liftIO $ filterM notSymlink $
+		map (\f -> Git.workTree repo ++ "/" ++ f) typechangedfiles
+	prepBackendPairs a unlockedfiles
+
+withKeys :: (Key -> CommandStart) -> CommandSeek
+withKeys a params = return $ map (a . parse) params
+	where
+		parse p = fromMaybe (error "bad key") $ readKey p
+
+withNothing :: CommandStart -> CommandSeek
+withNothing a [] = return [a]
+withNothing _ _ = error "This command takes no parameters."
+
+
+prepFiltered :: (FilePath -> CommandStart) -> Annex [FilePath] -> Annex [CommandStart]
+prepFiltered a = prepFilteredGen a id
+
+prepBackendPairs :: (BackendFile -> CommandStart) -> CommandSeek
+prepBackendPairs a fs = prepFilteredGen a snd (chooseBackends fs)
+
+prepFilteredGen :: (b -> CommandStart) -> (b -> FilePath) -> Annex [b] -> Annex [CommandStart]
+prepFilteredGen a d fs = do
+	matcher <- Limit.getMatcher
+	prepStart (proc matcher) fs
+	where
+		proc matcher v = do
+			let f = d v
+			ok <- matcher f
+			if ok then a v else return Nothing
+
+{- Generates a list of CommandStart actions that will be run to perform a
+ - command, using a list (ie of files) coming from an action. The list
+ - will be produced and consumed lazily. -}
+prepStart :: (b -> CommandStart) -> Annex [b] -> Annex [CommandStart]
+prepStart a fs = liftM (map a) fs
+
+notSymlink :: FilePath -> IO Bool
+notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f

Types/Command.hs

@@ -0,0 +1,45 @@
+{- git-annex command data types
+ -
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Types.Command where
+
+import Types
+
+{- A command runs in these stages.
+ -
+ - a. The check stage runs checks, that error out if
+ -    anything prevents the command from running. -}
+data CommandCheck = CommandCheck { idCheck :: Int, runCheck :: Annex () }
+{- b. The seek stage takes the parameters passed to the command,
+ -    looks through the repo to find the ones that are relevant
+ -    to that command (ie, new files to add), and generates
+ -    a list of start stage actions. -}
+type CommandSeek = [String] -> Annex [CommandStart]
+{- c. The start stage is run before anything is printed about the
+  -   command, is passed some input, and can early abort it
+  -   if the input does not make sense. It should run quickly and
+  -   should not modify Annex state. -}
+type CommandStart = Annex (Maybe CommandPerform)
+{- d. The perform stage is run after a message is printed about the command
+ -    being run, and it should be where the bulk of the work happens. -}
+type CommandPerform = Annex (Maybe CommandCleanup)
+{- e. The cleanup stage is run only if the perform stage succeeds, and it
+ -    returns the overall success/fail of the command. -}
+type CommandCleanup = Annex Bool
+
+{- A command is defined by specifying these things. -}
+data Command = Command {
+	cmdcheck :: [CommandCheck],
+	cmdname :: String,
+	cmdparams :: String,
+	cmdseek :: [CommandSeek],
+	cmddesc :: String
+}
+
+{- CommandCheck functions can be compared using their unique id. -}
+instance Eq CommandCheck where
+	a == b = idCheck a == idCheck b

git-annex-shell.hs

@@ -12,7 +12,6 @@ import Common.Annex
 import qualified Git
 import CmdLine
 import Command
-import Options
 import Annex.UUID
 
 import qualified Command.ConfigList