big subcommand dispatch rework

not quite done.. head hurts

Commands.hs

@@ -27,82 +27,54 @@ import Core
 import qualified Remotes
 import qualified TypeInternals
 
-{- A subcommand can take one of several kinds of input parameters. -}
+{- A subcommand runs in four stages. Each stage can return the next stage
-data SubCmdInput = FilesInGit FilePath | FilesNotInGit FilePath |
-	FilesMissing FilePath | Description String | Keys String |
-	Tempfile FilePath | FilesToBeCommitted FilePath
-
-{- A subcommand runs in three stages. Each stage can return the next stage
  - to run.
  -
- - 1. The start stage is run before anything is printed about the
+ - 0. The parse stage takes the parameters passed to the subcommand,
- -   subcommand, is passed some input, and can early abort it
+ -    looks through the repo to find the ones that are relevant
- -   if the input does not make sense. It should run quickly and
+ -    to that subcommand (ie, new files to add), and returns a list of
- -   should not modify Annex state.
+ -    start stage actions to run. -}
- -
+type SubCmdParse = [String] -> Git.Repo -> IO [SubCmdStart]
- - 2. The perform stage is run after a message is printed about the subcommand
+{- 1. The start stage is run before anything is printed about the
- -    being run, and it should be where the bulk of the work happens.
+  -   subcommand, is passed some input, and can early abort it
- -
+  -   if the input does not make sense. It should run quickly and
- - 3. The cleanup stage is run only if the perform stage succeeds, and it
+  -   should not modify Annex state. -}
- -    returns the overall success/fail of the subcommand.
- -}
 type SubCmdStart = Annex (Maybe SubCmdPerform)
+{- 2. The perform stage is run after a message is printed about the subcommand
+ -    being run, and it should be where the bulk of the work happens. -}
 type SubCmdPerform = Annex (Maybe SubCmdCleanup)
+{- 3. The cleanup stage is run only if the perform stage succeeds, and it
+ -    returns the overall success/fail of the subcommand. -}
 type SubCmdCleanup = Annex Bool
 
-{- Runs a subcommand through its three stages. -}
-doSubCmd :: String -> SubCmdStart -> Annex Bool
-doSubCmd cmdname start = do
-	startres <- start :: Annex (Maybe SubCmdPerform)
-	case (startres) of
-		Nothing -> return True
-		Just perform -> do
-			--showStart cmdname param
-			performres <- perform :: Annex (Maybe SubCmdCleanup)
-			case (performres) of
-				Nothing -> do
-					showEndFail
-					return False
-				Just cleanup -> do
-					cleanupres <- cleanup
-					if (cleanupres)
-						then do
-							showEndOk
-							return True
-						else do
-							showEndFail
-							return False
-
-
 data SubCommand = SubCommand {
 	subcmdname :: String,
-	subcmdaction :: (SubCmdInput -> SubCmdStart),
+	subcmdparse :: SubCmdParse,
-	subcmdinput :: (String -> SubCmdInput),
 	subcmddesc :: String
 }
 subCmds :: [SubCommand]
 subCmds =  [
-	  (SubCommand "add"	addStart	FilesNotInGit
+	  (SubCommand "add"	(withFilesNotInGit addStart)
 		"add files to annex")
-	, (SubCommand "get"	getStart	FilesInGit
+	, (SubCommand "get"	(withFilesInGit getStart)
 		"make content of annexed files available")
-	, (SubCommand "drop"	dropStart	FilesInGit
+	, (SubCommand "drop"	(withFilesInGit dropStart)
 		"indicate content of files not currently wanted")
-	, (SubCommand "move"	moveStart	FilesInGit
+	, (SubCommand "move"	(withFilesInGit moveStart)
 		"transfer content of files to/from another repository")
-	, (SubCommand "init"	initStart	Description
+	, (SubCommand "init"	(withDescription initStart)
 		"initialize git-annex with repository description")
-	, (SubCommand "unannex"	unannexStart	FilesInGit
+	, (SubCommand "unannex"	(withFilesInGit unannexStart)
 		"undo accidential add command")
-	, (SubCommand "fix"	fixStart	FilesInGit
+	, (SubCommand "fix"	(withFilesInGit fixStart)
 		"fix up symlinks to point to annexed content")
-	, (SubCommand "pre-commit" fixStart	FilesToBeCommitted
+	, (SubCommand "pre-commit" (withFilesToBeCommitted fixStart)
 		"fix up symlinks before they are committed")
-	, (SubCommand "fromkey"	fromKeyStart	FilesMissing
+	, (SubCommand "fromkey"	(withFilesMissing fromKeyStart)
 		"adds a file using a specific key")
-	, (SubCommand "dropkey"	dropKeyStart	Keys
+	, (SubCommand "dropkey"	(withKeys dropKeyStart)
 		"drops annexed content for specified keys")
-	, (SubCommand "setkey"	setKeyStart	Tempfile
+	, (SubCommand "setkey"	(withTempFile setKeyStart)
 		"sets annexed content for a key using a temp file")
 	]
 
@@ -140,49 +112,66 @@ usage = usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs
 		showcmd c =
 			(subcmdname c) ++
 			(pad 11 (subcmdname c)) ++
-			(descSubCmdInput (subcmdinput c)) ++
-			(pad 13 (descSubCmdInput (subcmdinput c))) ++
 			(subcmddesc c)
 		indent l = "  " ++ l
 		pad n s = take (n - (length s)) $ repeat ' '
 
-{- Generate descriptions of wanted parameters for subcommands. -}
+{- Prepares a set of actions to run to perform a subcommand, based on
-descSubCmdInput :: (String -> SubCmdInput) -> String
-descSubCmdInput Description = "DESCRIPTION"
-descSubCmdInput Keys = "KEY ..."
-descSubCmdInput _ = "PATH ..."
-
-{- Prepares a set of actions to run to handle a subcommand, based on 
  - the parameters passed to it. -}
 prepSubCmd :: SubCommand -> Git.Repo -> [String] -> IO [Annex Bool]
-prepSubCmd SubCommand { subcmdname = name, subcmdaction = action,
+prepSubCmd SubCommand { subcmdname = name, subcmdparse = parse,
-		subcmdinput = input, subcmddesc = _ } repo params = do
+		subcmddesc = _ } repo params = do
-	input <- findInput input params repo
+	list <- parse params repo :: IO [SubCmdStart]
-	return $ map (doSubCmd name action) input
+	return map (\a -> doSubCmd name a) list
 
-{- Finds the type of parameters a subcommand wants, from among the passed
+{- Runs a subcommand through the perform and cleanup stages -}
- - parameter list. -}
+doSubCmd :: String -> SubCmdPerform -> SubCmdCleanup
-findInput :: (String -> SubCmdInput) -> [String] -> Git.Repo -> IO [SubCmdInput]
+doSubCmd cmdname perform = do
-findInput FilesNotInGit params repo = do
+	p <- perform
+	case (p) of
+		Nothing -> do
+			showEndFail
+			return False
+		Just cleanup -> do
+			c <- cleanup
+			if (c)
+				then do
+					showEndOk
+					return True
+				else do
+					showEndFail
+					return False
+
+{- These functions parse a user's parameters into a list of SubCmdStart
+   actions to perform. -}
+type ParseStrings = (String -> SubCmdStart) -> SubCmdParse
+withFilesNotInGit :: ParseStrings
+withFilesNotInGit a params repo = do
 	files <- mapM (Git.notInRepo repo) params
-	return $ map FilesNotInGit $ notState $ foldl (++) [] files
+	return $ map a $ notState $ foldl (++) [] files
-findInput FilesInGit params repo = do
+withFilesInGit :: ParseStrings
+withFilesInGit a params repo = do
 	files <- mapM (Git.inRepo repo) params
-	return $ map FilesInGit $ notState $ foldl (++) [] files
+	return $ map a $ notState $ foldl (++) [] files
-findInput FilesMissing params _ = do
+withFilesMissing :: ParseStrings
+withFilesMissing a params _ = do
 	files <- liftIO $ filterM missing params
-	return $ map FilesMissing $ notState $ files
+	return $ map a $ notState files
 	where
 		missing f = do
 			e <- doesFileExist f
 			return $ not e
-findInput Description params _ = do
+withDescription :: ParseStrings
-	return $ map Description $ [unwords params]
+withDescription a params _ = do
-findInput FilesToBeCommitted params repo = do
+	return $ [a $ unwords params]
+withFilesToBeCommitted :: ParseStrings
+withFilesToBeCommitted a params repo = do
 	files <- mapM (Git.stagedFiles repo) params
-	return $ map FilesToBeCommitted $ notState $ foldl (++) [] files
+	return $ map a $ notState $ foldl (++) [] files
-findInput Keys params _ = return $ map Keys params
+withKeys :: ParseStrings
-findInput Tempfile params _ = return $ map Tempfile params
+withKeys a params _ = return $ map a params
+withTempFile :: ParseStrings
+withTempFile a params _ = return $ map a params
 
 {- filter out files from the state directory -}
 notState :: [FilePath] -> [FilePath]
@@ -215,19 +204,19 @@ parseCmd argv state = do
 {- 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. -}
-addStart :: SubCmdInput -> SubCmdStart
+addStart :: FilePath -> SubCmdStart
-addStart (FilesNotInGit file) = notAnnexed file $ do
+addStart file = notAnnexed file $ do
 	s <- liftIO $ getSymbolicLinkStatus file
 	if ((isSymbolicLink s) || (not $ isRegularFile s))
 		then return Nothing
 		else return $ Just $ addPerform file
-addPerform :: FilePath -> Annex (Maybe SubCmdCleanup)
+addPerform :: FilePath -> SubCmdPerform
 addPerform file = do
 	stored <- Backend.storeFileKey file
 	case (stored) of
 		Nothing -> return Nothing
 		Just (key, _) -> return $ Just $ addCleanup file key
-addCleanup :: FilePath -> Key -> Annex Bool
+addCleanup :: FilePath -> Key -> SubCmdCleanup
 addCleanup file key = do
 	logStatus key ValuePresent
 	g <- Annex.gitRepo
@@ -240,10 +229,10 @@ addCleanup file key = do
 	return True
 
 {- The unannex subcommand undoes an add. -}
-unannexStart :: SubCmdInput -> SubCmdStart
+unannexStart :: FilePath -> SubCmdStart
-unannexStart (FilesInGit file) = isAnnexed file $ \(key, backend) -> do
+unannexStart file = isAnnexed file $ \(key, backend) -> do
 	return $ Just $ unannexPerform file key backend
-unannexPerform :: FilePath -> Key -> Backend -> Annex (Maybe SubCmdCleanup)
+unannexPerform :: FilePath -> Key -> Backend -> SubCmdPerform
 unannexPerform file key backend = do
 	-- force backend to always remove
 	Annex.flagChange "force" $ FlagBool True
@@ -251,7 +240,7 @@ unannexPerform file key backend = do
 	if (ok)
 		then return $ Just $ unannexCleanup file key
 		else return Nothing
-unannexCleanup :: FilePath -> Key -> Annex Bool
+unannexCleanup :: FilePath -> Key -> SubCmdCleanup
 unannexCleanup file key = do
 	logStatus key ValueMissing
 	g <- Annex.gitRepo
@@ -264,13 +253,13 @@ unannexCleanup file key = do
 	return True
 
 {- Gets an annexed file from one of the backends. -}
-getStart :: SubCmdInput -> Annex (Maybe SubCmdPerform)
+getStart :: FilePath -> SubCmdStart
-getStart (FilesInGit file) = isAnnexed file $ \(key, backend) -> do
+getStart file = isAnnexed file $ \(key, backend) -> do
 	inannex <- inAnnex key
 	if (inannex)
 		then return Nothing
 		else return $ Just $ getPerform key backend
-getPerform :: Key -> Backend -> Annex (Maybe SubCmdCleanup)
+getPerform :: Key -> Backend -> SubCmdPerform
 getPerform key backend = do
 	ok <- getViaTmp key (Backend.retrieveKeyFile backend key)
 	if (ok)
@@ -279,19 +268,19 @@ getPerform key backend = do
 
 {- Indicates a file's content is not wanted anymore, and should be removed
  - if it's safe to do so. -}
-dropStart :: SubCmdInput -> SubCmdStart
+dropStart :: FilePath -> SubCmdStart
-dropStart (FilesInGit file) = isAnnexed file $ \(key, backend) -> do
+dropStart file = isAnnexed file $ \(key, backend) -> do
 	inbackend <- Backend.hasKey key
 	if (not inbackend)
 		then return Nothing
 		else return $ Just $ dropPerform key backend
-dropPerform :: Key -> Backend -> Annex (Maybe SubCmdCleanup)
+dropPerform :: Key -> Backend -> SubCmdPerform
 dropPerform key backend = do
 	success <- Backend.removeKey backend key
 	if (success)
 		then return $ Just $ dropCleanup key
 		else return Nothing
-dropCleanup :: Key -> Annex Bool
+dropCleanup :: Key -> SubCmdCleanup
 dropCleanup key = do
 	logStatus key ValueMissing
 	inannex <- inAnnex key
@@ -304,8 +293,8 @@ dropCleanup key = do
 		else return True
 
 {- Drops cached content for a key. -}
-dropKeyStart :: SubCmdInput -> SubCmdStart
+dropKeyStart :: String -> SubCmdStart
-dropKeyStart (Keys keyname) = do
+dropKeyStart keyname = do
 	backends <- Backend.list
 	let key = genKey (backends !! 0) keyname
 	present <- inAnnex key
@@ -315,26 +304,26 @@ dropKeyStart (Keys keyname) = do
 		else if (not force)
 			then error "dropkey is can cause data loss; use --force if you're sure you want to do this"
 			else return $ Just $ dropKeyPerform key
-dropKeyPerform :: Key -> Annex (Maybe SubCmdCleanup)
+dropKeyPerform :: Key -> SubCmdPerform
 dropKeyPerform key = do
 	g <- Annex.gitRepo
 	let loc = annexLocation g key
 	liftIO $ removeFile loc
 	return $ Just $ dropKeyCleanup key
-dropKeyCleanup :: Key -> Annex Bool
+dropKeyCleanup :: Key -> SubCmdCleanup
 dropKeyCleanup key = do
 	logStatus key ValueMissing
 	return True
 
 {- Sets cached content for a key. -}
-setKeyStart :: SubCmdInput -> SubCmdStart
+setKeyStart :: FilePath -> SubCmdStart
-setKeyStart (Tempfile tmpfile) = do
+setKeyStart tmpfile = do
 	keyname <- Annex.flagGet "key"
 	when (null keyname) $ error "please specify the key with --key"
 	backends <- Backend.list
 	let key = genKey (backends !! 0) keyname
 	return $ Just $ setKeyPerform tmpfile key
-setKeyPerform :: FilePath -> Key -> Annex (Maybe SubCmdCleanup)
+setKeyPerform :: FilePath -> Key -> SubCmdPerform
 setKeyPerform tmpfile key = do
 	g <- Annex.gitRepo
 	let loc = annexLocation g key
@@ -342,40 +331,37 @@ setKeyPerform tmpfile key = do
 	if (not ok)
 		then error "mv failed!"
 		else return $ Just $ setKeyCleanup key
-setKeyCleanup :: Key -> Annex Bool
+setKeyCleanup :: Key -> SubCmdCleanup
 setKeyCleanup key = do
 	logStatus key ValuePresent
 	return True
 
 {- Fixes the symlink to an annexed file. -}
-fixStart :: SubCmdInput -> SubCmdStart
+fixStart :: FilePath -> SubCmdStart
-fixStart (FilesInGit file) = fixStart' file
+fixStart file = isAnnexed file $ \(key, _) -> do
-fixStart (FilesToBeCommitted file) = fixStart' file
-fixStart' :: FilePath -> SubCmdStart
-fixStart' file = isAnnexed file $ \(key, _) -> do
 	link <- calcGitLink file key
 	l <- liftIO $ readSymbolicLink file
 	if (link == l)
 		then return Nothing
 		else return $ Just $ fixPerform file link
-fixPerform :: FilePath -> FilePath -> Annex (Maybe SubCmdCleanup)
+fixPerform :: FilePath -> FilePath -> SubCmdPerform
 fixPerform file link = do
 	liftIO $ createDirectoryIfMissing True (parentDir file)
 	liftIO $ removeFile file
 	liftIO $ createSymbolicLink link file
 	return $ Just $ fixCleanup file
-fixCleanup :: FilePath -> Annex Bool
+fixCleanup :: FilePath -> SubCmdCleanup
 fixCleanup file = do
 	Annex.queue "add" [] file
 	return True
 
 {- Stores description for the repository etc. -}
-initStart :: SubCmdInput -> SubCmdStart
+initStart :: String -> SubCmdStart
-initStart (Description description) = do
+initStart description = do
 	when (null description) $ error $
 		"please specify a description of this repository\n" ++ usage
 	return $ Just $ initPerform description
-initPerform :: String -> Annex (Maybe SubCmdCleanup)
+initPerform :: String -> SubCmdPerform
 initPerform description = do
 	g <- Annex.gitRepo
 	u <- getUUID g
@@ -383,7 +369,7 @@ initPerform description = do
 	liftIO $ gitAttributes g
 	liftIO $ gitPreCommitHook g
 	return $ Just $ initCleanup
-initCleanup :: Annex Bool
+initCleanup :: SubCmdCleanup
 initCleanup = do
 	g <- Annex.gitRepo
 	logfile <- uuidLog
@@ -392,8 +378,8 @@ initCleanup = do
 	return True
 
 {- Adds a file pointing at a manually-specified key -}
-fromKeyStart :: SubCmdInput -> SubCmdStart
+fromKeyStart :: FilePath -> SubCmdStart
-fromKeyStart (FilesMissing file) = do
+fromKeyStart file = do
 	keyname <- Annex.flagGet "key"
 	when (null keyname) $ error "please specify the key with --key"
 	backends <- Backend.list
@@ -403,13 +389,13 @@ fromKeyStart (FilesMissing file) = do
 	unless (inbackend) $ error $
 		"key ("++keyname++") is not present in backend"
 	return $ Just $ fromKeyPerform file key
-fromKeyPerform :: FilePath -> Key -> Annex (Maybe SubCmdCleanup)
+fromKeyPerform :: FilePath -> Key -> SubCmdPerform
 fromKeyPerform file key = do
 	link <- calcGitLink file key
 	liftIO $ createDirectoryIfMissing True (parentDir file)
 	liftIO $ createSymbolicLink link file
 	return $ Just $ fromKeyCleanup file
-fromKeyCleanup :: FilePath -> Annex Bool
+fromKeyCleanup :: FilePath -> SubCmdCleanup
 fromKeyCleanup file = do
 	Annex.queue "add" [] file
 	return True
@@ -418,8 +404,8 @@ fromKeyCleanup file = do
  -
  - This only operates on the cached file content; it does not involve
  - moving data in the key-value backend. -}
-moveStart :: SubCmdInput -> SubCmdStart
+moveStart :: FilePath -> SubCmdStart
-moveStart (FilesInGit file) = do
+moveStart file = do
 	fromName <- Annex.flagGet "fromrepository"
 	toName <- Annex.flagGet "torepository"
 	case (fromName, toName) of
@@ -439,13 +425,13 @@ moveStart (FilesInGit file) = do
  - A file's content can be moved even if there are insufficient copies to
  - allow it to be dropped.
  -}
-moveToStart :: FilePath -> Annex (Maybe SubCmdPerform)
+moveToStart :: FilePath -> SubCmdStart
 moveToStart file = isAnnexed file $ \(key, _) -> do
 	ishere <- inAnnex key
 	if (not ishere)
 		then return Nothing -- not here, so nothing to do
 		else return $ Just $ moveToPerform key
-moveToPerform :: Key -> Annex (Maybe SubCmdCleanup)
+moveToPerform :: Key -> SubCmdPerform
 moveToPerform key = do
 	-- checking the remote is expensive, so not done in the start step
 	remote <- Remotes.commandLineRemote
@@ -462,7 +448,7 @@ moveToPerform key = do
 				then return $ Just $ moveToCleanup remote key tmpfile
 				else return Nothing -- failed
 		Right True -> return $ Just $ dropCleanup key
-moveToCleanup :: Git.Repo -> Key -> FilePath -> Annex Bool
+moveToCleanup :: Git.Repo -> Key -> FilePath -> SubCmdCleanup
 moveToCleanup remote key tmpfile = do
 	-- Tell remote to use the transferred content.
 	ok <- Remotes.runCmd remote "git-annex" ["setkey", "--quiet",
@@ -487,14 +473,14 @@ moveToCleanup remote key tmpfile = do
  - If the current repository already has the content, it is still removed
  - from the other repository.
  -}
-moveFromStart :: FilePath -> Annex (Maybe SubCmdPerform)
+moveFromStart :: FilePath -> SubCmdStart
 moveFromStart file = isAnnexed file $ \(key, _) -> do
 	remote <- Remotes.commandLineRemote
 	l <- Remotes.keyPossibilities key
 	if (not $ null $ filter (\r -> Remotes.same r remote) l)
 		then return $ Just $ moveFromPerform key
 		else return Nothing
-moveFromPerform :: Key -> Annex (Maybe SubCmdCleanup)
+moveFromPerform :: Key -> SubCmdPerform
 moveFromPerform key = do
 	remote <- Remotes.commandLineRemote
 	ishere <- inAnnex key
@@ -506,7 +492,7 @@ moveFromPerform key = do
 			if (ok)
 				then return $ Just $ moveFromCleanup remote key
 				else return Nothing -- fail
-moveFromCleanup :: Git.Repo -> Key -> Annex Bool
+moveFromCleanup :: Git.Repo -> Key -> SubCmdCleanup
 moveFromCleanup remote key = do
 	ok <- Remotes.runCmd remote "git-annex" ["dropkey", "--quiet", "--force",
 		"--backend=" ++ (backendName key),