converted copy and move

Got a little tricky..

CmdLine/GitAnnex.hs

@@ -15,15 +15,14 @@ import Command
 import Utility.Env
 import Annex.Ssh
 
+import qualified Command.Help
 import qualified Command.Add
 import qualified Command.Unannex
-import qualified Command.Fsck
-{-
-import qualified Command.Help
 import qualified Command.Drop
 import qualified Command.Move
 import qualified Command.Copy
 import qualified Command.Get
+import qualified Command.Fsck
 import qualified Command.LookupKey
 import qualified Command.ContentLocation
 import qualified Command.ExamineKey
@@ -117,18 +116,16 @@ import qualified Command.TestRemote
 #ifdef WITH_EKG
 import System.Remote.Monitoring
 #endif
--}
 
 cmds :: [Command]
 cmds = 
-	[ Command.Add.cmd
+	[ Command.Help.cmd
-	, Command.Fsck.cmd
+	, Command.Add.cmd
-{-
-	, Command.Help.cmd
 	, Command.Get.cmd
 	, Command.Drop.cmd
 	, Command.Move.cmd
 	, Command.Copy.cmd
+	, Command.Fsck.cmd
 	, Command.Unlock.cmd
 	, Command.Unlock.editcmd
 	, Command.Lock.cmd
@@ -221,7 +218,6 @@ cmds =
 	, Command.FuzzTest.cmd
 	, Command.TestRemote.cmd
 #endif
--}
 	]
 
 run :: [String] -> IO ()

CmdLine/GitAnnex/Options.hs

@@ -5,6 +5,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE FlexibleInstances #-}
+
 module CmdLine.GitAnnex.Options where
 
 import System.Console.GetOpt
@@ -54,6 +56,54 @@ gitAnnexOptions = commonOptions ++
 		>>= pure . (\r -> r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] })
 		>>= Annex.changeGitRepo
 
+-- Some values cannot be fully parsed without performing an action.
+-- The action may be expensive, so it's best to call finishParse on such a
+-- value before using getParsed repeatedly.
+data DeferredParse a = DeferredParse (Annex a) | ReadyParse a
+
+class DeferredParseClass a where
+	finishParse :: a -> Annex a
+
+getParsed :: DeferredParse a -> Annex a
+getParsed (DeferredParse a) = a
+getParsed (ReadyParse a) = pure a
+
+instance DeferredParseClass (DeferredParse a) where
+	finishParse (DeferredParse a) = ReadyParse <$> a
+	finishParse (ReadyParse a) = pure (ReadyParse a)
+
+instance DeferredParseClass (Maybe (DeferredParse a)) where
+	finishParse Nothing = pure Nothing
+	finishParse (Just v) = Just <$> finishParse v
+
+parseRemoteOption :: Parser RemoteName -> Parser (DeferredParse Remote)
+parseRemoteOption p = DeferredParse . (fromJust <$$> Remote.byNameWithUUID) . Just <$> p
+
+data FromToOptions
+	= FromRemote (DeferredParse Remote)
+	| ToRemote (DeferredParse Remote)
+
+instance DeferredParseClass FromToOptions where
+	finishParse (FromRemote v) = FromRemote <$> finishParse v
+	finishParse (ToRemote v) = ToRemote <$> finishParse v
+
+parseFromToOptions :: Parser FromToOptions
+parseFromToOptions = 
+	(FromRemote <$> parseFromOption) 
+	<|> (ToRemote <$> parseToOption)
+
+parseFromOption :: Parser (DeferredParse Remote)
+parseFromOption = parseRemoteOption $ strOption
+	( long "from" <> short 'f' <> metavar paramRemote
+	<> help "source remote"
+	)
+
+parseToOption :: Parser (DeferredParse Remote)
+parseToOption = parseRemoteOption $ strOption
+	( long "to" <> short 't' <> metavar paramRemote
+	<> help "destination remote"
+	)
+
 -- Options for acting on keys, rather than work tree files.
 data KeyOptions
 	= WantAllKeys
@@ -150,15 +200,6 @@ combiningOptions =
 	longopt o = Option [] [o] $ NoArg $ Limit.addToken o
 	shortopt o = Option o [] $ NoArg $ Limit.addToken o
 
-fromOption :: Option
-fromOption = fieldOption ['f'] "from" paramRemote "source remote"
-
-toOption :: Option
-toOption = fieldOption ['t'] "to" paramRemote "destination remote"
-
-fromToOptions :: [Option]
-fromToOptions = [fromOption, toOption]
-
 jsonOption :: Option
 jsonOption = Option ['j'] ["json"] (NoArg (Annex.setOutput JSONOutput))
 	"enable JSON output"

Command.hs

@@ -32,6 +32,7 @@ import CmdLine.Usage as ReExported
 import CmdLine.Action as ReExported
 import CmdLine.Option as ReExported
 import CmdLine.GitAnnex.Options as ReExported
+import Options.Applicative as ReExported hiding (command)
 
 import qualified Options.Applicative as O
 

Command/Copy.hs

@@ -15,34 +15,43 @@ import Annex.Wanted
 import Annex.NumCopies
 
 cmd :: Command
-cmd = withOptions copyOptions $
+cmd = command "copy" SectionCommon
-	command "copy" SectionCommon
+	"copy content of files to/from another repository"
-		"copy content of files to/from another repository"
+	paramPaths ((seek <=< finishParse) <$$> optParser)
-		paramPaths (withParams seek)
 
-copyOptions :: [Option]
+data CopyOptions = CopyOptions
-copyOptions = Command.Move.moveOptions ++ [autoOption]
+	{ moveOptions :: Command.Move.MoveOptions
+	, autoMode :: Bool
+	}
 
-seek :: CmdParams -> CommandSeek
+optParser :: CmdParamsDesc -> Parser CopyOptions
-seek ps = do
+optParser desc = CopyOptions
-	to <- getOptionField toOption Remote.byNameWithUUID
+	<$> Command.Move.optParser desc
-	from <- getOptionField fromOption Remote.byNameWithUUID
+	<*> parseAutoOption
-	auto <- getOptionFlag autoOption
+
-	withKeyOptions auto
+instance DeferredParseClass CopyOptions where
-		(Command.Move.startKey to from False)
+	finishParse v = CopyOptions
-		(withFilesInGit $ whenAnnexed $ start auto to from)
+		<$> finishParse (moveOptions v)
-		ps
+		<*> pure (autoMode v)
+
+seek :: CopyOptions -> CommandSeek
+seek o = withKeyOptions (Command.Move.keyOptions $ moveOptions o) (autoMode o)
+	(Command.Move.startKey (moveOptions o) False)
+	(withFilesInGit $ whenAnnexed $ start o)
+	(Command.Move.moveFiles $ moveOptions o)
 
 {- A copy is just a move that does not delete the source file.
  - However, auto mode avoids unnecessary copies, and avoids getting or
  - sending non-preferred content. -}
-start :: Bool -> Maybe Remote -> Maybe Remote -> FilePath -> Key -> CommandStart
+start :: CopyOptions -> FilePath -> Key -> CommandStart
-start auto to from file key = stopUnless shouldCopy $ 
+start o file key = stopUnless shouldCopy $ 
-	Command.Move.start to from False file key
+	Command.Move.start (moveOptions o) False file key
   where
 	shouldCopy
-		| auto = want <||> numCopiesCheck file key (<)
+		| autoMode o = want <||> numCopiesCheck file key (<)
 		| otherwise = return True
-	want = case to of
+	want = case Command.Move.fromToOptions (moveOptions o) of
-		Nothing -> wantGet False (Just key) (Just file)
+		ToRemote _ -> 
-		Just r -> wantSend False (Just key) (Just file) (Remote.uuid r)
+			wantGet False (Just key) (Just file)
+		FromRemote dest -> (Remote.uuid <$> getParsed dest) >>=
+			wantSend False (Just key) (Just file)

Command/Drop.hs

@@ -19,10 +19,8 @@ import Annex.NumCopies
 import Annex.Content
 import Annex.Wanted
 import Annex.Notification
-import Git.Types (RemoteName)
 
 import qualified Data.Set as S
-import Options.Applicative hiding (command)
 
 cmd :: Command
 cmd = command "drop" SectionCommon
@@ -31,9 +29,9 @@ cmd = command "drop" SectionCommon
 
 data DropOptions = DropOptions
 	{ dropFiles :: CmdParams
-	, dropFrom :: Maybe RemoteName
+	, dropFrom :: Maybe (DeferredParse Remote)
 	, autoMode :: Bool
-	, keyOptions :: KeyOptions
+	, keyOptions :: Maybe KeyOptions
 	}
 
 -- TODO: annexedMatchingOptions
@@ -41,12 +39,12 @@ data DropOptions = DropOptions
 optParser :: CmdParamsDesc -> Parser DropOptions
 optParser desc = DropOptions
 	<$> cmdParams desc
-	<*> parseDropFromOption
+	<*> optional parseDropFromOption
 	<*> parseAutoOption
-	<*> parseKeyOptions False
+	<*> optional (parseKeyOptions False)
 
-parseDropFromOption :: Parser (Maybe RemoteName)
+parseDropFromOption :: Parser (DeferredParse Remote)
-parseDropFromOption = optional $ strOption
+parseDropFromOption = parseRemoteOption $ strOption
 	( long "from" <> short 'f' <> metavar paramRemote
 	<> help "drop content from a remote"
 	)
@@ -62,7 +60,7 @@ start o file key = start' o key (Just file)
 
 start' :: DropOptions -> Key -> AssociatedFile -> CommandStart
 start' o key afile = do
-	from <- Remote.byNameWithUUID (dropFrom o)
+	from <- maybe (pure Nothing) (Just <$$> getParsed) (dropFrom o)
 	checkDropAuto (autoMode o) from afile key $ \numcopies ->
 		stopUnless (want from) $
 			case from of

Command/Fsck.hs

@@ -40,7 +40,6 @@ import qualified Database.Fsck as FsckDb
 
 import Data.Time.Clock.POSIX
 import System.Posix.Types (EpochTime)
-import Options.Applicative hiding (command)
 
 cmd :: Command
 cmd = command "fsck" SectionMaintenance

Command/Move.hs

@@ -18,36 +18,47 @@ import Annex.Transfer
 import Logs.Presence
 
 cmd :: Command
-cmd = withOptions moveOptions $ 
+cmd = command "move" SectionCommon
-	command "move" SectionCommon
+	"move content of files to/from another repository"
-		"move content of files to/from another repository"
+	paramPaths ((seek <=< finishParse) <$$> optParser)
-		paramPaths (withParams seek)
 
-moveOptions :: [Option]
+data MoveOptions = MoveOptions
-moveOptions = fromToOptions ++ [jobsOption] ++ keyOptions ++ annexedMatchingOptions
+	{ moveFiles :: CmdParams
+	, fromToOptions :: FromToOptions
+	, keyOptions :: Maybe KeyOptions
+	}
 
-seek :: CmdParams -> CommandSeek
+-- TODO: jobsOption, annexedMatchingOptions
-seek ps = do
-	to <- getOptionField toOption Remote.byNameWithUUID
-	from <- getOptionField fromOption Remote.byNameWithUUID
-	withKeyOptions False
-		(startKey to from True)
-		(withFilesInGit $ whenAnnexed $ start to from True)
-		ps
 
-start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> Key -> CommandStart
+optParser :: CmdParamsDesc -> Parser MoveOptions
-start to from move = start' to from move . Just
+optParser desc = MoveOptions
+	<$> cmdParams desc
+	<*> parseFromToOptions
+	<*> optional (parseKeyOptions False)
 
-startKey :: Maybe Remote -> Maybe Remote -> Bool -> Key -> CommandStart
+instance DeferredParseClass MoveOptions where
-startKey to from move = start' to from move Nothing
+	finishParse v = MoveOptions
+		<$> pure (moveFiles v)
+		<*> finishParse (fromToOptions v)
+		<*> pure (keyOptions v)
 
-start' :: Maybe Remote -> Maybe Remote -> Bool -> AssociatedFile -> Key -> CommandStart
+seek :: MoveOptions -> CommandSeek
-start' to from move afile key = do
+seek o = withKeyOptions (keyOptions o) False
-	case (from, to) of
+	(startKey o True)
-		(Nothing, Nothing) -> error "specify either --from or --to"
+	(withFilesInGit $ whenAnnexed $ start o True)
-		(Nothing, Just dest) -> toStart dest move afile key
+	(moveFiles o)
-		(Just src, Nothing) -> fromStart src move afile key
+
-		_ -> error "only one of --from or --to can be specified"
+start :: MoveOptions -> Bool -> FilePath -> Key -> CommandStart
+start o move = start' o move . Just
+
+startKey :: MoveOptions -> Bool -> Key -> CommandStart
+startKey o move = start' o move Nothing
+
+start' :: MoveOptions -> Bool -> AssociatedFile -> Key -> CommandStart
+start' o move afile key = 
+	case fromToOptions o of
+		FromRemote src -> fromStart move afile key =<< getParsed src
+		ToRemote dest -> toStart move afile key =<< getParsed dest
 
 showMoveAction :: Bool -> Key -> AssociatedFile -> Annex ()
 showMoveAction move = showStart' (if move then "move" else "copy")
@@ -61,8 +72,8 @@ showMoveAction move = showStart' (if move then "move" else "copy")
  - A file's content can be moved even if there are insufficient copies to
  - allow it to be dropped.
  -}
-toStart :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart
+toStart :: Bool -> AssociatedFile -> Key -> Remote -> CommandStart
-toStart dest move afile key = do
+toStart move afile key dest = do
 	u <- getUUID
 	ishere <- inAnnex key
 	if not ishere || u == Remote.uuid dest
@@ -124,8 +135,8 @@ toPerform dest move key afile fastcheck isthere =
  - If the current repository already has the content, it is still removed
  - from the remote.
  -}
-fromStart :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart
+fromStart :: Bool -> AssociatedFile -> Key -> Remote -> CommandStart
-fromStart src move afile key
+fromStart move afile key src
 	| move = go
 	| otherwise = stopUnless (not <$> inAnnex key) go
   where

Command/TransferInfo.hs

@@ -49,8 +49,8 @@ start (k:[]) = do
 				, transferUUID = u
 				, transferKey = key
 				}
-			info <- liftIO $ startTransferInfo file
+			tinfo <- liftIO $ startTransferInfo file
-			(update, tfile, _) <- mkProgressUpdater t info
+			(update, tfile, _) <- mkProgressUpdater t tinfo
 			liftIO $ mapM_ void
 				[ tryIO $ forever $ do
 					bytes <- readUpdate