Newer
Older
- Licensed under the GNU AGPL version 3 or higher.
parseCmd,
prepRunCommand,
import qualified Options.Applicative as O
Joey Hess
committed
import qualified Options.Applicative.Help as H
Joey Hess
committed
import Control.Exception (throw)
import Annex.Common
import qualified Git.Config
import Annex.Action
import Annex.Environment
import Types.Messages
{- Parses input arguments, finds a matching Command, and runs it. -}
dispatch :: Bool -> Bool -> CmdParams -> [Command] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO ()
dispatch addonok fuzzyok allargs allcmds fields getgitrepo progname progdesc =
go addonok allcmds $
findAddonCommand subcommandname >>= \case
Nothing -> go False allcmds noop
Just c -> go addonok (c:allcmds) $
findAllAddonCommands >>= \cs ->
go False (cs++allcmds) noop
where
go p allcmds' cont =
let (fuzzy, cmds) = selectCmd fuzzyok allcmds' subcommandname
in if not p || (not fuzzy && not (null cmds))
then dispatch' subcommandname args fuzzy cmds allargs allcmds' fields getgitrepo progname progdesc
else cont
(subcommandname, args) = subCmdName allargs
dispatch' :: (Maybe String) -> CmdParams -> Bool -> [Command] -> CmdParams -> [Command] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO ()
dispatch' subcommandname args fuzzy cmds allargs allcmds fields getgitrepo progname progdesc = do
Joey Hess
committed
setupConsole
go =<< tryNonAsync getgitrepo
where
go (Right g) = do
state <- Annex.new g
Annex.eval state $ do
checkEnvironment
forM_ fields $ uncurry Annex.setField
(cmd, seek, globalconfig) <- parsewith False cmdparser
(\a -> inRepo $ a . Just)
(liftIO . O.handleParseResult)
prepRunCommand cmd globalconfig
performCommandAction cmd seek $
shutdown $ cmdnocommit cmd
go (Left norepo) = do
let ingitrepo = \a -> a =<< Git.Config.global
-- Parse command line with full cmdparser first,
-- so that help can be displayed for bad parses
-- even when not run in a repo.
res <- parsewith False cmdparser ingitrepo return
case res of
Failure _ -> void (O.handleParseResult res)
_ -> do
-- Parse command line in norepo mode.
(_, a, _globalconfig) <- parsewith True
(fromMaybe (throw norepo) . cmdnorepo)
ingitrepo
O.handleParseResult
a
parsewith secondrun getparser ingitrepo handleresult =
case parseCmd progname progdesc allargs allcmds getparser of
O.Failure _ -> do
-- parse failed, so fall back to
-- fuzzy matching, or to showing usage
when (fuzzy && not secondrun) $
ingitrepo autocorrect
handleresult (parseCmd progname progdesc correctedargs allcmds getparser)
res -> handleresult res
where
autocorrect = Git.AutoCorrect.prepare (fromJust subcommandname) cmdname cmds
name
| fuzzy = case cmds of
Joey Hess
committed
(c:_) -> Just (cmdname c)
Joey Hess
committed
correctedargs = case name of
Nothing -> allargs
Just n -> n:args
{- Parses command line, selecting one of the commands from the list. -}
parseCmd :: String -> String -> CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v, GlobalSetter)
parseCmd progname progdesc allargs allcmds getparser =
pinfo = O.info (O.helper <*> subcmds) (O.progDescDoc (Just intro))
subcmds = O.hsubparser $ mconcat $ map mkcommand allcmds
Joey Hess
committed
mkcommand c = O.command (cmdname c) $ O.info (mkparser c) $ O.fullDesc
<> O.header (synopsis (progname ++ " " ++ cmdname c) (cmddesc c))
<> O.footer ("For details, run: " ++ progname ++ " help " ++ cmdname c)
<*> getparser c
Joey Hess
committed
synopsis n d = n ++ " - " ++ d
intro = mconcat $ concatMap (\l -> [H.text l, H.line])
(synopsis progname progdesc : commandList allcmds)
- Does fuzzy matching if necessary, which may result in multiple Commands. -}
selectCmd :: Bool -> [Command] -> Maybe String -> (Bool, [Command])
selectCmd fuzzyok cmds (Just n)
| not (null exactcmds) = (False, exactcmds)
| fuzzyok && not (null inexactcmds) = (True, inexactcmds)
| otherwise = (False, [])
where
exactcmds = filter (\c -> cmdname c == n) cmds
inexactcmds = Git.AutoCorrect.fuzzymatches n cmdname cmds
{- Parses command line params far enough to find the subcommand name. -}
subCmdName :: CmdParams -> (Maybe String, CmdParams)
subCmdName argv = (name, args)
where
(name, args) = findname argv []
findname [] c = (Nothing, reverse c)
findname (a:as) c
| "-" `isPrefixOf` a = findname as (a:c)
| otherwise = (Just a, reverse c ++ as)
prepRunCommand :: Command -> GlobalSetter -> Annex ()
prepRunCommand cmd globalconfig = do
Annex.setOutput QuietOutput
getParsed globalconfig
whenM (annexDebug <$> Annex.getGitConfig) $
liftIO enableDebugOutput
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
findAddonCommand :: Maybe String -> IO (Maybe Command)
findAddonCommand Nothing = return Nothing
findAddonCommand (Just subcommandname) =
searchPath c >>= \case
Nothing -> return Nothing
Just p -> return (Just (mkAddonCommand p subcommandname))
where
c = "git-annex-" ++ subcommandname
findAllAddonCommands :: IO [Command]
findAllAddonCommands = return [] -- TODO
mkAddonCommand :: FilePath -> String -> Command
mkAddonCommand p subcommandname = Command
{ cmdcheck = []
, cmdnocommit = True
, cmdnomessages = True
, cmdname = subcommandname
, cmdparamdesc = "[PARAMS]"
, cmdsection = SectionAddOn
, cmddesc = "addon command"
, cmdglobaloptions = []
, cmdinfomod = O.forwardOptions
, cmdparser = parse
, cmdnorepo = Just parse
}
where
parse :: (Monad m, MonadIO m) => Parser (m ())
parse = (liftIO . run) <$> cmdParams "PARAMS"
run ps = withCreateProcess (proc p ps) $ \_ _ _ pid ->
exitWith =<< waitForProcess pid