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
parent
4018e5f6f1
commit
a2ba701056
104 changed files with 435 additions and 370 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue