clean up check selection code

This new approach allows filtering out checks from the default set that are
not appropriate for a command, rather than having to list every check
that is appropriate. It also reduces some boilerplate.

Haskell does not define Eq for functions, so I had to go a long way around
with each check having a unique id. Meh.

CmdLine.hs

@@ -38,10 +38,10 @@ parseCmd argv header cmds options = do
 	when (null params) $ error $ "missing command" ++ usagemsg
 	case lookupCmd (head params) of
 		[] -> error $ "unknown command" ++ usagemsg
-		[command] -> do
+		[cmd] -> do
 			_ <- sequence flags
-			checkCommand command
+			checkCommand cmd
-			prepCommand command (drop 1 params)
+			prepCommand cmd (drop 1 params)
 		_ -> error "internal error: multiple matching commands"
 	where
 		getopt = case getOpt Permute options argv of

Command.hs

@@ -24,7 +24,9 @@ import Init
  -
  - a. The check stage runs checks, that error out if
  -    anything prevents the command from running. -}
-type CommandCheck = Annex ()
+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
@@ -43,9 +45,9 @@ type CommandPerform = Annex (Maybe CommandCleanup)
 type CommandCleanup = Annex Bool
 
 data Command = Command {
+	cmdcheck :: [CommandCheck],
 	cmdname :: String,
 	cmdparams :: String,
-	cmdcheck :: CommandCheck,
 	cmdseek :: [CommandSeek],
 	cmddesc :: String
 }
@@ -58,9 +60,9 @@ next a = return $ Just a
 stop :: Annex (Maybe a)
 stop = return Nothing
 
-{- Checks that the command can be run in the current environment. -}
+{- Generates a command with the common checks. -}
-checkCommand :: Command -> Annex ()
+command :: String -> String -> [CommandSeek] -> String -> Command
-checkCommand Command { cmdcheck = check } = check
+command = Command commonChecks
 
 {- Prepares a list of actions to run to perform a command, based on
  - the parameters passed to it. -}
@@ -232,22 +234,33 @@ autoCopies key vs numcopiesattr a = do
 			if length have `vs` needed then a else stop
 		else a
 
-{- Checks -}
+{- Common checks for commands, and an interface to selectively remove them,
-defaultChecks :: CommandCheck
+ - or add others. -}
-defaultChecks = noFrom >> noTo >> needsRepo
+commonChecks :: [CommandCheck]
+commonChecks = [fromOpt, toOpt, repoExists]
 
-noChecks :: CommandCheck
+repoExists :: CommandCheck
-noChecks = return ()
+repoExists = CommandCheck 0 ensureInitialized
 
-needsRepo :: CommandCheck
+fromOpt :: CommandCheck
-needsRepo = ensureInitialized
+fromOpt = CommandCheck 1 $ do
-
-noFrom :: CommandCheck
-noFrom = do
 	v <- Annex.getState Annex.fromremote
 	unless (v == Nothing) $ error "cannot use --from with this command"
 
-noTo :: CommandCheck
+toOpt :: CommandCheck
-noTo = do
+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/Add.hs

@@ -18,8 +18,8 @@ import Annex.Content
 import Utility.Touch
 import Backend
 
-command :: [Command]
+def :: [Command]
-command = [Command "add" paramPaths defaultChecks seek "add files to annex"]
+def = [command "add" paramPaths seek "add files to annex"]
 
 {- Add acts on both files not checked into git yet, and unlocked files. -}
 seek :: [CommandSeek]

Command/AddUrl.hs

@@ -19,9 +19,8 @@ import qualified Backend.URL
 import Annex.Content
 import Logs.Web
 
-command :: [Command]
+def :: [Command]
-command = [Command "addurl" (paramRepeating paramUrl) defaultChecks seek
+def = [command "addurl" (paramRepeating paramUrl) seek "add urls to annex"]
-	"add urls to annex"]
 
 seek :: [CommandSeek]
 seek = [withStrings start]

Command/ConfigList.hs

@@ -11,9 +11,9 @@ import Common.Annex
 import Command
 import Annex.UUID
 
-command :: [Command]
+def :: [Command]
-command = [Command "configlist" paramNothing defaultChecks seek
+def = [command "configlist" paramNothing seek
-		"outputs relevant git configuration"]
+	"outputs relevant git configuration"]
 
 seek :: [CommandSeek]
 seek = [withNothing start]

Command/Copy.hs

@@ -10,8 +10,9 @@ module Command.Copy where
 import Command
 import qualified Command.Move
 
-command :: [Command]
+def :: [Command]
-command = [Command "copy" paramPaths needsRepo seek
+def = [dontCheck toOpt $ dontCheck fromOpt $ 
+	command "copy" paramPaths seek
 	"copy content of files to/from another repository"]
 
 seek :: [CommandSeek]

Command/Describe.hs

@@ -12,8 +12,8 @@ import Command
 import qualified Remote
 import Logs.UUID
 
-command :: [Command]
+def :: [Command]
-command = [Command "describe" (paramPair paramRemote paramDesc) defaultChecks seek
+def = [command "describe" (paramPair paramRemote paramDesc) seek
 	"change description of a repository"]
 
 seek :: [CommandSeek]

Command/Drop.hs

@@ -17,8 +17,8 @@ import Logs.Trust
 import Annex.Content
 import Config
 
-command :: [Command]
+def :: [Command]
-command = [Command "drop" paramPaths (noTo >> needsRepo) seek
+def = [dontCheck fromOpt $ command "drop" paramPaths seek
 	"indicate content of files not currently wanted"]
 
 seek :: [CommandSeek]

Command/DropKey.hs

@@ -13,8 +13,8 @@ import qualified Annex
 import Logs.Location
 import Annex.Content
 
-command :: [Command]
+def :: [Command]
-command = [Command "dropkey" (paramRepeating paramKey) defaultChecks seek
+def = [command "dropkey" (paramRepeating paramKey) seek
 	"drops annexed content for specified keys"] 
 
 seek :: [CommandSeek]

Command/DropUnused.hs

@@ -19,8 +19,8 @@ import Types.Key
 
 type UnusedMap = M.Map String Key
 
-command :: [Command]
+def :: [Command]
-command = [Command "dropunused" (paramRepeating paramNumber) (noTo >> needsRepo)
+def = [dontCheck fromOpt $ command "dropunused" (paramRepeating paramNumber)
 	seek "drop unused file content"]
 
 seek :: [CommandSeek]

Command/Find.hs

@@ -12,8 +12,8 @@ import Command
 import Annex.Content
 import Limit
 
-command :: [Command]
+def :: [Command]
-command = [Command "find" paramPaths defaultChecks seek "lists available files"]
+def = [command "find" paramPaths seek "lists available files"]
 
 seek :: [CommandSeek]
 seek = [withFilesInGit start]

Command/Fix.hs

@@ -12,8 +12,8 @@ import Command
 import qualified Annex.Queue
 import Annex.Content
 
-command :: [Command]
+def :: [Command]
-command = [Command "fix" paramPaths defaultChecks seek
+def = [command "fix" paramPaths seek
 	"fix up symlinks to point to annexed content"]
 
 seek :: [CommandSeek]

Command/FromKey.hs

@@ -13,9 +13,8 @@ import qualified Annex.Queue
 import Annex.Content
 import Types.Key
 
-command :: [Command]
+def :: [Command]
-command = [Command "fromkey" paramPath defaultChecks seek
+def = [command "fromkey" paramPath seek "adds a file using a specific key"]
-	"adds a file using a specific key"]
 
 seek :: [CommandSeek]
 seek = [withFilesMissing start]

Command/Fsck.hs

@@ -20,8 +20,8 @@ import Utility.DataUnits
 import Utility.FileMode
 import Config
 
-command :: [Command]
+def :: [Command]
-command = [Command "fsck" paramPaths defaultChecks seek "check for problems"]
+def = [command "fsck" paramPaths seek "check for problems"]
 
 seek :: [CommandSeek]
 seek = [withNumCopies start]

Command/Get.hs

@@ -14,9 +14,9 @@ import qualified Remote
 import Annex.Content
 import qualified Command.Move
 
-command :: [Command]
+def :: [Command]
-command = [Command "get" paramPaths (noTo >> needsRepo) seek
+def = [dontCheck fromOpt $ command "get" paramPaths seek
-		"make content of annexed files available"]
+	"make content of annexed files available"]
 
 seek :: [CommandSeek]
 seek = [withNumCopies start]

Command/InAnnex.hs

@@ -11,9 +11,9 @@ import Common.Annex
 import Command
 import Annex.Content
 
-command :: [Command]
+def :: [Command]
-command = [Command "inannex" (paramRepeating paramKey) defaultChecks seek
+def = [command "inannex" (paramRepeating paramKey) seek
-		"checks if keys are present in the annex"]
+	"checks if keys are present in the annex"]
 
 seek :: [CommandSeek]
 seek = [withKeys start]

Command/Init.hs

@@ -13,8 +13,9 @@ import Annex.UUID
 import Logs.UUID
 import Init
 	
-command :: [Command]
+def :: [Command]
-command = [Command "init" paramDesc noChecks seek "initialize git-annex"]
+def = [dontCheck repoExists $
+	command "init" paramDesc seek "initialize git-annex"]
 
 seek :: [CommandSeek]
 seek = [withWords start]

Command/InitRemote.hs

@@ -16,10 +16,10 @@ import qualified Logs.Remote
 import qualified Types.Remote as R
 import Annex.UUID
 
-command :: [Command]
+def :: [Command]
-command = [Command "initremote"
+def = [command "initremote"
-	(paramPair paramName $ 	paramOptional $ paramRepeating paramKeyValue)
+	(paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)
-	defaultChecks seek "sets up a special (non-git) remote"]
+	seek "sets up a special (non-git) remote"]
 
 seek :: [CommandSeek]
 seek = [withWords start]

Command/Lock.hs

@@ -12,8 +12,8 @@ import Command
 import qualified Annex.Queue
 import Backend
 	
-command :: [Command]
+def :: [Command]
-command = [Command "lock" paramPaths defaultChecks seek "undo unlock command"]
+def = [command "lock" paramPaths seek "undo unlock command"]
 
 seek :: [CommandSeek]
 seek = [withFilesUnlocked start, withFilesUnlockedToBeCommitted start]

Command/Map.hs

@@ -22,9 +22,9 @@ import qualified Utility.Dot as Dot
 -- a link from the first repository to the second (its remote)
 data Link = Link Git.Repo Git.Repo
 
-command :: [Command]
+def :: [Command]
-command = [Command "map" paramNothing noChecks seek
+def = [dontCheck repoExists $
-	"generate map of repositories"]
+	command "map" paramNothing seek "generate map of repositories"]
 
 seek :: [CommandSeek]
 seek = [withNothing start]

Command/Merge.hs

@@ -11,8 +11,8 @@ import Common.Annex
 import Command
 import qualified Annex.Branch
 
-command :: [Command]
+def :: [Command]
-command = [Command "merge" paramNothing defaultChecks seek
+def = [command "merge" paramNothing seek
 		"auto-merge remote changes into git-annex branch"]
 
 seek :: [CommandSeek]

Command/Migrate.hs

@@ -16,9 +16,8 @@ import qualified Command.Add
 import Backend
 import Logs.Web
 
-command :: [Command]
+def :: [Command]
-command = [Command "migrate" paramPaths defaultChecks seek
+def = [command "migrate" paramPaths seek "switch data to different backend"]
-	"switch data to different backend"]
 
 seek :: [CommandSeek]
 seek = [withBackendFilesInGit start]

Command/Move.hs

@@ -15,8 +15,9 @@ import Annex.Content
 import qualified Remote
 import Annex.UUID
 
-command :: [Command]
+def :: [Command]
-command = [Command "move" paramPaths needsRepo seek
+def = [dontCheck toOpt $ dontCheck fromOpt $
+	command "move" paramPaths seek
 	"move content of files to/from another repository"]
 
 seek :: [CommandSeek]

Command/PreCommit.hs

@@ -12,9 +12,8 @@ import qualified Command.Add
 import qualified Command.Fix
 import Backend
 
-command :: [Command]
+def :: [Command]
-command = [Command "pre-commit" paramPaths defaultChecks seek
+def = [command "pre-commit" paramPaths seek "run by git pre-commit hook"]
-	"run by git pre-commit hook"]
 
 {- The pre-commit hook needs to fix symlinks to all files being committed.
  - And, it needs to inject unlocked files into the annex. -}

Command/RecvKey.hs

@@ -13,8 +13,8 @@ import CmdLine
 import Annex.Content
 import Utility.RsyncFile
 
-command :: [Command]
+def :: [Command]
-command = [Command "recvkey" paramKey defaultChecks seek
+def = [command "recvkey" paramKey seek
 	"runs rsync in server mode to receive content"]
 
 seek :: [CommandSeek]

Command/Semitrust.hs

@@ -12,8 +12,8 @@ import Command
 import qualified Remote
 import Logs.Trust
 
-command :: [Command]
+def :: [Command]
-command = [Command "semitrust" (paramRepeating paramRemote) defaultChecks seek
+def = [command "semitrust" (paramRepeating paramRemote) seek
 	"return repository to default trust level"]
 
 seek :: [CommandSeek]

Command/SendKey.hs

@@ -12,8 +12,8 @@ import Command
 import Annex.Content
 import Utility.RsyncFile
 
-command :: [Command]
+def :: [Command]
-command = [Command "sendkey" paramKey defaultChecks seek
+def = [command "sendkey" paramKey seek
 	"runs rsync in server mode to send content"]
 
 seek :: [CommandSeek]

Command/SetKey.hs

@@ -12,8 +12,8 @@ import Command
 import Logs.Location
 import Annex.Content
 
-command :: [Command]
+def :: [Command]
-command = [Command "setkey" paramPath defaultChecks seek
+def = [command "setkey" paramPath seek
 	"sets annexed content for a key using a temp file"]
 
 seek :: [CommandSeek]

Command/Status.hs

@@ -38,8 +38,8 @@ data StatInfo = StatInfo
 -- a state monad for running Stats in
 type StatState = StateT StatInfo Annex
 
-command :: [Command]
+def :: [Command]
-command = [Command "status" paramNothing defaultChecks seek
+def = [command "status" paramNothing seek
 	"shows status information about the annex"]
 
 seek :: [CommandSeek]

Command/Trust.hs

@@ -12,9 +12,8 @@ import Command
 import qualified Remote
 import Logs.Trust
 
-command :: [Command]
+def :: [Command]
-command = [Command "trust" (paramRepeating paramRemote) defaultChecks seek
+def = [command "trust" (paramRepeating paramRemote) seek "trust a repository"]
-	"trust a repository"]
 
 seek :: [CommandSeek]
 seek = [withWords start]

Command/Unannex.hs

@@ -17,9 +17,8 @@ import Annex.Content
 import qualified Git
 import qualified Git.LsFiles as LsFiles
 
-command :: [Command]
+def :: [Command]
-command = [Command "unannex" paramPaths defaultChecks seek
+def = [command "unannex" paramPaths seek "undo accidential add command"]
-	"undo accidential add command"]
 
 seek :: [CommandSeek]
 seek = [withFilesInGit start]

Command/Uninit.hs

@@ -18,8 +18,8 @@ import Init
 import qualified Annex.Branch
 import Annex.Content
 
-command :: [Command]
+def :: [Command]
-command = [Command "uninit" paramPaths (check >> defaultChecks) seek 
+def = [addCheck check $ command "uninit" paramPaths seek 
         "de-initialize git-annex and clean out repository"]
 
 check :: Annex ()

Command/Unlock.hs

@@ -13,13 +13,13 @@ import Annex.Content
 import Utility.CopyFile
 import Utility.FileMode
 
-command :: [Command]
+def :: [Command]
-command =
+def =
 	[ c "unlock" "unlock files for modification"
 	, c "edit" "same as unlock"
 	]
 	where
-		c n = Command n paramPaths defaultChecks seek
+		c n = command n paramPaths seek
 
 seek :: [CommandSeek]
 seek = [withFilesInGit start]

Command/Untrust.hs

@@ -12,8 +12,8 @@ import Command
 import qualified Remote
 import Logs.Trust
 
-command :: [Command]
+def :: [Command]
-command = [Command "untrust" (paramRepeating paramRemote) defaultChecks seek
+def = [command "untrust" (paramRepeating paramRemote) seek
 	"do not trust a repository"]
 
 seek :: [CommandSeek]

Command/Unused.hs

@@ -27,8 +27,8 @@ import qualified Remote
 import qualified Annex.Branch
 import Annex.CatFile
 
-command :: [Command]
+def :: [Command]
-command = [Command "unused" paramNothing (noTo >> needsRepo) seek
+def = [dontCheck fromOpt $ command "unused" paramNothing seek
 	"look for unused file content"]
 
 seek :: [CommandSeek]

Command/Upgrade.hs

@@ -12,9 +12,9 @@ import Command
 import Upgrade
 import Annex.Version
 
-command :: [Command]
+def :: [Command]
-command = [Command "upgrade" paramNothing noChecks seek
+def = [dontCheck repoExists $ -- because an old version may not seem to exist
-	"upgrade repository layout"]
+	command "upgrade" paramNothing seek "upgrade repository layout"]
 
 seek :: [CommandSeek]
 seek = [withNothing start]

Command/Version.hs

@@ -12,8 +12,9 @@ import Command
 import qualified Build.SysConfig as SysConfig
 import Annex.Version
 
-command :: [Command]
+def :: [Command]
-command = [Command "version" paramNothing noChecks seek "show version info"]
+def = [dontCheck repoExists $
+	command "version" paramNothing seek "show version info"]
 
 seek :: [CommandSeek]
 seek = [withNothing start]

Command/Whereis.hs

@@ -13,8 +13,8 @@ import Command
 import Remote
 import Logs.Trust
 
-command :: [Command]
+def :: [Command]
-command = [Command "whereis" paramPaths defaultChecks seek
+def = [command "whereis" paramPaths seek
 	"lists repositories that have file content"]
 
 seek :: [CommandSeek]

GitAnnex.hs

@@ -54,38 +54,38 @@ import qualified Command.Version
 
 cmds :: [Command]
 cmds = concat
-	[ Command.Add.command
+	[ Command.Add.def
-	, Command.Get.command
+	, Command.Get.def
-	, Command.Drop.command
+	, Command.Drop.def
-	, Command.Move.command
+	, Command.Move.def
-	, Command.Copy.command
+	, Command.Copy.def
-	, Command.Unlock.command
+	, Command.Unlock.def
-	, Command.Lock.command
+	, Command.Lock.def
-	, Command.Init.command
+	, Command.Init.def
-	, Command.Describe.command
+	, Command.Describe.def
-	, Command.InitRemote.command
+	, Command.InitRemote.def
-	, Command.Unannex.command
+	, Command.Unannex.def
-	, Command.Uninit.command
+	, Command.Uninit.def
-	, Command.PreCommit.command
+	, Command.PreCommit.def
-	, Command.Trust.command
+	, Command.Trust.def
-	, Command.Untrust.command
+	, Command.Untrust.def
-	, Command.Semitrust.command
+	, Command.Semitrust.def
-	, Command.AddUrl.command
+	, Command.AddUrl.def
-	, Command.FromKey.command
+	, Command.FromKey.def
-	, Command.DropKey.command
+	, Command.DropKey.def
-	, Command.SetKey.command
+	, Command.SetKey.def
-	, Command.Fix.command
+	, Command.Fix.def
-	, Command.Fsck.command
+	, Command.Fsck.def
-	, Command.Unused.command
+	, Command.Unused.def
-	, Command.DropUnused.command
+	, Command.DropUnused.def
-	, Command.Find.command
+	, Command.Find.def
-	, Command.Whereis.command
+	, Command.Whereis.def
-	, Command.Merge.command
+	, Command.Merge.def
-	, Command.Status.command
+	, Command.Status.def
-	, Command.Migrate.command
+	, Command.Migrate.def
-	, Command.Map.command
+	, Command.Map.def
-	, Command.Upgrade.command
+	, Command.Upgrade.def
-	, Command.Version.command
+	, Command.Version.def
 	]
 
 options :: [Option]

git-annex-shell.hs

@@ -23,15 +23,15 @@ import qualified Command.SendKey
 
 cmds_readonly :: [Command]
 cmds_readonly = concat
-	[ Command.ConfigList.command
+	[ Command.ConfigList.def
-	, Command.InAnnex.command
+	, Command.InAnnex.def
-	, Command.SendKey.command
+	, Command.SendKey.def
 	]
 
 cmds_notreadonly :: [Command]
 cmds_notreadonly = concat
-	[ Command.RecvKey.command
+	[ Command.RecvKey.def
-	, Command.DropKey.command
+	, Command.DropKey.def
 	]
 
 cmds :: [Command]