started converting to use optparse-applicative

This is a work in progress. It compiles and is able to do basic command
dispatch, including git autocorrection, while using optparse-applicative
for the core commandline parsing.

* Many commands are temporarily disabled before conversion.
* Options are not wired in yet.
* cmdnorepo actions don't work yet.

Also, removed the [Command] list, which was only used in one place.
This commit is contained in:
Joey Hess 2015-07-08 12:33:27 -04:00
parent 4018e5f6f1
commit a2ba701056
104 changed files with 435 additions and 370 deletions

View file

@ -22,11 +22,11 @@ import Data.Either
{- Runs a command, starting with the check stage, and then
- the seek stage. Finishes by running the continutation, and
- then showing a count of any failures. -}
performCommandAction :: Command -> CmdParams -> Annex () -> Annex ()
performCommandAction Command { cmdseek = seek, cmdcheck = c, cmdname = name } params cont = do
performCommandAction :: Command -> CommandSeek -> Annex () -> Annex ()
performCommandAction Command { cmdcheck = c, cmdname = name } seek cont = do
mapM_ runCheck c
Annex.changeState $ \s -> s { Annex.errcounter = 0 }
seek params
seek
finishCommandActions
cont
showerrcount =<< Annex.getState Annex.errcounter

View file

@ -16,6 +16,7 @@ import Utility.Env
import Annex.Ssh
import qualified Command.Add
{-
import qualified Command.Unannex
import qualified Command.Drop
import qualified Command.Move
@ -116,15 +117,18 @@ import qualified Command.TestRemote
#ifdef WITH_EKG
import System.Remote.Monitoring
#endif
-}
cmds :: [Command]
cmds = concat
cmds =
[ Command.Add.cmd
{-
, Command.Get.cmd
, Command.Drop.cmd
, Command.Move.cmd
, Command.Copy.cmd
, Command.Unlock.cmd
, Command.Unlock.editcmd
, Command.Lock.cmd
, Command.Sync.cmd
, Command.Mirror.cmd
@ -217,6 +221,7 @@ cmds = concat
, Command.FuzzTest.cmd
, Command.TestRemote.cmd
#endif
-}
]
header :: String

View file

@ -16,7 +16,6 @@ import qualified Git.Config
import CmdLine
import Command
import Annex.UUID
import Annex (setField)
import CmdLine.GitAnnexShell.Fields
import Utility.UserInfo
import Remote.GCrypt (getGCryptUUID)
@ -34,7 +33,7 @@ import qualified Command.NotifyChanges
import qualified Command.GCryptSetup
cmds_readonly :: [Command]
cmds_readonly = concat
cmds_readonly =
[ gitAnnexShellCheck Command.ConfigList.cmd
, gitAnnexShellCheck Command.InAnnex.cmd
, gitAnnexShellCheck Command.SendKey.cmd
@ -43,7 +42,7 @@ cmds_readonly = concat
]
cmds_notreadonly :: [Command]
cmds_notreadonly = concat
cmds_notreadonly =
[ gitAnnexShellCheck Command.RecvKey.cmd
, gitAnnexShellCheck Command.DropKey.cmd
, gitAnnexShellCheck Command.Commit.cmd
@ -100,12 +99,10 @@ builtin cmd dir params = do
checkNotReadOnly cmd
checkDirectory $ Just dir
let (params', fieldparams, opts) = partitionParams params
fields = filter checkField $ parseFields fieldparams
cmds' = map (newcmd $ unwords opts) cmds
dispatch False (cmd : params') cmds' options fields header mkrepo
rsyncopts = ("RsyncOptions", unwords opts)
fields = rsyncopts : filter checkField (parseFields fieldparams)
dispatch False (cmd : params') cmds options fields header mkrepo
where
addrsyncopts opts seek k = setField "RsyncOptions" opts >> seek k
newcmd opts c = c { cmdseek = addrsyncopts opts (cmdseek c) }
mkrepo = do
r <- Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath
Git.Config.read r
@ -200,8 +197,8 @@ checkEnv var = do
{- Modifies a Command to check that it is run in either a git-annex
- repository, or a repository with a gcrypt-id set. -}
gitAnnexShellCheck :: [Command] -> [Command]
gitAnnexShellCheck = map $ addCheck okforshell . dontCheck repoExists
gitAnnexShellCheck :: Command -> Command
gitAnnexShellCheck = addCheck okforshell . dontCheck repoExists
where
okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $
error "Not a git-annex or gcrypt repository."

View file

@ -29,11 +29,11 @@ import Logs.Unused
import Annex.CatFile
import Annex.Content
withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek
withFilesInGit :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesInGit a params = seekActions $ prepFiltered a $
seekHelper LsFiles.inRepo params
withFilesInGitNonRecursive :: (FilePath -> CommandStart) -> CommandSeek
withFilesInGitNonRecursive :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesInGitNonRecursive a params = ifM (Annex.getState Annex.force)
( withFilesInGit a params
, if null params
@ -54,7 +54,7 @@ withFilesInGitNonRecursive a params = ifM (Annex.getState Annex.force)
_ -> needforce
needforce = error "Not recursively setting metadata. Use --force to do that."
withFilesNotInGit :: Bool -> (FilePath -> CommandStart) -> CommandSeek
withFilesNotInGit :: Bool -> (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesNotInGit skipdotfiles a params
| skipdotfiles = do
{- dotfiles are not acted on unless explicitly listed -}
@ -73,7 +73,7 @@ withFilesNotInGit skipdotfiles a params
go l = seekActions $ prepFiltered a $
return $ concat $ segmentPaths params l
withFilesInRefs :: (FilePath -> Key -> CommandStart) -> CommandSeek
withFilesInRefs :: (FilePath -> Key -> CommandStart) -> CmdParams -> CommandSeek
withFilesInRefs a = mapM_ go
where
go r = do
@ -87,7 +87,7 @@ withFilesInRefs a = mapM_ go
Just k -> whenM (matcher $ MatchingKey k) $
commandAction $ a f k
withPathContents :: ((FilePath, FilePath) -> CommandStart) -> CommandSeek
withPathContents :: ((FilePath, FilePath) -> CommandStart) -> CmdParams -> CommandSeek
withPathContents a params = do
matcher <- Limit.getMatcher
seekActions $ map a <$> (filterM (checkmatch matcher) =<< ps)
@ -103,27 +103,27 @@ withPathContents a params = do
, matchFile = relf
}
withWords :: ([String] -> CommandStart) -> CommandSeek
withWords :: ([String] -> CommandStart) -> CmdParams -> CommandSeek
withWords a params = seekActions $ return [a params]
withStrings :: (String -> CommandStart) -> CommandSeek
withStrings :: (String -> CommandStart) -> CmdParams -> CommandSeek
withStrings a params = seekActions $ return $ map a params
withPairs :: ((String, String) -> CommandStart) -> CommandSeek
withPairs :: ((String, String) -> CommandStart) -> CmdParams -> CommandSeek
withPairs a params = seekActions $ return $ map a $ pairs [] params
where
pairs c [] = reverse c
pairs c (x:y:xs) = pairs ((x,y):c) xs
pairs _ _ = error "expected pairs"
withFilesToBeCommitted :: (String -> CommandStart) -> CommandSeek
withFilesToBeCommitted :: (String -> CommandStart) -> CmdParams -> CommandSeek
withFilesToBeCommitted a params = seekActions $ prepFiltered a $
seekHelper LsFiles.stagedNotDeleted params
withFilesUnlocked :: (FilePath -> CommandStart) -> CommandSeek
withFilesUnlocked :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesUnlocked = withFilesUnlocked' LsFiles.typeChanged
withFilesUnlockedToBeCommitted :: (FilePath -> CommandStart) -> CommandSeek
withFilesUnlockedToBeCommitted :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged
{- Unlocked files have changed type from a symlink to a regular file.
@ -131,7 +131,7 @@ withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged
- Furthermore, unlocked files used to be a git-annex symlink,
- not some other sort of symlink.
-}
withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (FilePath -> CommandStart) -> CommandSeek
withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesUnlocked' typechanged a params = seekActions $
prepFiltered a unlockedfiles
where
@ -142,11 +142,11 @@ isUnlocked f = liftIO (notSymlink f) <&&>
(isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f)
{- Finds files that may be modified. -}
withFilesMaybeModified :: (FilePath -> CommandStart) -> CommandSeek
withFilesMaybeModified :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek
withFilesMaybeModified a params = seekActions $
prepFiltered a $ seekHelper LsFiles.modified params
withKeys :: (Key -> CommandStart) -> CommandSeek
withKeys :: (Key -> CommandStart) -> CmdParams -> CommandSeek
withKeys a params = seekActions $ return $ map (a . parse) params
where
parse p = fromMaybe (error "bad key") $ file2key p
@ -160,7 +160,7 @@ getOptionField option converter = converter <=< Annex.getField $ optionName opti
getOptionFlag :: Option -> Annex Bool
getOptionFlag option = Annex.getFlag (optionName option)
withNothing :: CommandStart -> CommandSeek
withNothing :: CommandStart -> CmdParams -> CommandSeek
withNothing a [] = seekActions $ return [a]
withNothing _ _ = error "This command takes no parameters."
@ -171,7 +171,7 @@ withNothing _ _ = error "This command takes no parameters."
-
- Otherwise falls back to a regular CommandSeek action on
- whatever params were passed. -}
withKeyOptions :: Bool -> (Key -> CommandStart) -> CommandSeek -> CommandSeek
withKeyOptions :: Bool -> (Key -> CommandStart) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek
withKeyOptions auto keyop = withKeyOptions' auto $ \getkeys -> do
matcher <- Limit.getMatcher
seekActions $ map (process matcher) <$> getkeys
@ -181,7 +181,7 @@ withKeyOptions auto keyop = withKeyOptions' auto $ \getkeys -> do
, return Nothing
)
withKeyOptions' :: Bool -> (Annex [Key] -> Annex ()) -> CommandSeek -> CommandSeek
withKeyOptions' :: Bool -> (Annex [Key] -> Annex ()) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek
withKeyOptions' auto keyop fallbackop params = do
bare <- fromRepo Git.repoIsLocalBare
allkeys <- Annex.getFlag "all"