125 lines
4.4 KiB
Haskell
125 lines
4.4 KiB
Haskell
{- git-annex command line parsing and dispatch
|
||
-
|
||
- Copyright 2010-2015 Joey Hess <id@joeyh.name>
|
||
-
|
||
- Licensed under the GNU GPL version 3 or higher.
|
||
-}
|
||
|
||
module CmdLine (
|
||
dispatch,
|
||
usage,
|
||
) where
|
||
|
||
import qualified Options.Applicative as O
|
||
import qualified Options.Applicative.Help as H
|
||
import qualified Control.Exception as E
|
||
import Control.Exception (throw)
|
||
|
||
import Annex.Common
|
||
import qualified Annex
|
||
import qualified Git
|
||
import qualified Git.AutoCorrect
|
||
import qualified Git.Config
|
||
import Annex.Action
|
||
import Annex.Environment
|
||
import Command
|
||
import Types.Messages
|
||
|
||
{- Runs the passed command line. -}
|
||
dispatch :: Bool -> CmdParams -> [Command] -> [GlobalOption] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO ()
|
||
dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progdesc = do
|
||
setupConsole
|
||
go =<< (E.try getgitrepo :: IO (Either E.SomeException Git.Repo))
|
||
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)
|
||
when (cmdnomessages cmd) $ do
|
||
Annex.setOutput QuietOutput
|
||
Annex.changeState $ \s -> s
|
||
{ Annex.output = (Annex.output s) { implicitMessages = False } }
|
||
getParsed globalconfig
|
||
whenM (annexDebug <$> Annex.getGitConfig) $
|
||
liftIO enableDebugOutput
|
||
startup
|
||
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 globaloptions 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 globaloptions correctedargs allcmds getparser)
|
||
res -> handleresult res
|
||
where
|
||
autocorrect = Git.AutoCorrect.prepare (fromJust inputcmdname) cmdname cmds
|
||
(fuzzy, cmds, inputcmdname, args) = findCmd fuzzyok allargs allcmds
|
||
name
|
||
| fuzzy = case cmds of
|
||
(c:_) -> Just (cmdname c)
|
||
_ -> inputcmdname
|
||
| otherwise = inputcmdname
|
||
correctedargs = case name of
|
||
Nothing -> allargs
|
||
Just n -> n:args
|
||
|
||
{- Parses command line, selecting one of the commands from the list. -}
|
||
parseCmd :: String -> String -> [GlobalOption] -> CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v, GlobalSetter)
|
||
parseCmd progname progdesc globaloptions allargs allcmds getparser =
|
||
O.execParserPure (O.prefs O.idm) pinfo allargs
|
||
where
|
||
pinfo = O.info (O.helper <*> subcmds) (O.progDescDoc (Just intro))
|
||
subcmds = O.hsubparser $ mconcat $ map mkcommand allcmds
|
||
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)
|
||
mkparser c = (,,)
|
||
<$> pure c
|
||
<*> getparser c
|
||
<*> combineGlobalOptions globaloptions
|
||
synopsis n d = n ++ " - " ++ d
|
||
intro = mconcat $ concatMap (\l -> [H.text l, H.line])
|
||
(synopsis progname progdesc : commandList allcmds)
|
||
|
||
{- Parses command line params far enough to find the Command to run, and
|
||
- returns the remaining params.
|
||
- Does fuzzy matching if necessary, which may result in multiple Commands. -}
|
||
findCmd :: Bool -> CmdParams -> [Command] -> (Bool, [Command], Maybe String, CmdParams)
|
||
findCmd fuzzyok argv cmds
|
||
| not (null exactcmds) = ret (False, exactcmds)
|
||
| fuzzyok && not (null inexactcmds) = ret (True, inexactcmds)
|
||
| otherwise = ret (False, [])
|
||
where
|
||
ret (fuzzy, matches) = (fuzzy, matches, name, args)
|
||
(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)
|
||
exactcmds = filter (\c -> name == Just (cmdname c)) cmds
|
||
inexactcmds = case name of
|
||
Nothing -> []
|
||
Just n -> Git.AutoCorrect.fuzzymatches n cmdname cmds
|