mirror of
https://github.com/ilyakooo0/optparse-applicative.git
synced 2024-11-27 11:56:20 +03:00
Merge disambiguation feature (#8).
This commit is contained in:
commit
b110838cdb
@ -14,8 +14,8 @@ import Options.Applicative.Common
|
||||
import Options.Applicative.Internal
|
||||
import Options.Applicative.Types
|
||||
|
||||
bashCompletionParser :: Parser a -> Parser ParserFailure
|
||||
bashCompletionParser parser = complParser
|
||||
bashCompletionParser :: Parser a -> ParserPrefs -> Parser ParserFailure
|
||||
bashCompletionParser parser pprefs = complParser
|
||||
where
|
||||
failure opts = ParserFailure
|
||||
{ errMessage = \progn -> unlines <$> opts progn
|
||||
@ -23,15 +23,15 @@ bashCompletionParser parser = complParser
|
||||
|
||||
complParser = asum
|
||||
[ failure <$>
|
||||
( bashCompletionQuery parser
|
||||
<$> (many . strOption) (long "bash-completion-word")
|
||||
<*> option (long "bash-completion-index") )
|
||||
( bashCompletionQuery parser pprefs
|
||||
<$> (many . strOption) (long "bash-completion-word" & internal)
|
||||
<*> option (long "bash-completion-index" & internal) )
|
||||
, failure <$>
|
||||
(bashCompletionScript <$>
|
||||
strOption (long "bash-completion-script")) ]
|
||||
strOption (long "bash-completion-script" & internal)) ]
|
||||
|
||||
bashCompletionQuery :: Parser a -> [String] -> Int -> String -> IO [String]
|
||||
bashCompletionQuery parser ws i _ = case runCompletion compl of
|
||||
bashCompletionQuery :: Parser a -> ParserPrefs -> [String] -> Int -> String -> IO [String]
|
||||
bashCompletionQuery parser pprefs ws i _ = case runCompletion compl pprefs of
|
||||
Just (Left (SomeParser p)) -> list_options p
|
||||
Just (Right c) -> run_completer c
|
||||
_ -> return []
|
||||
|
@ -72,6 +72,7 @@ module Options.Applicative.Builder (
|
||||
-- * Builder for 'ParserPrefs'
|
||||
PrefsMod,
|
||||
multiSuffix,
|
||||
disambiguate,
|
||||
prefs
|
||||
) where
|
||||
|
||||
@ -418,11 +419,15 @@ instance Monoid PrefsMod where
|
||||
multiSuffix :: String -> PrefsMod
|
||||
multiSuffix s = PrefsMod $ \p -> p { prefMultiSuffix = s }
|
||||
|
||||
disambiguate :: PrefsMod
|
||||
disambiguate = PrefsMod $ \p -> p { prefDisambiguate = True }
|
||||
|
||||
prefs :: PrefsMod -> ParserPrefs
|
||||
prefs m = applyPrefsMod m base
|
||||
where
|
||||
base = ParserPrefs
|
||||
{ prefMultiSuffix = "" }
|
||||
{ prefMultiSuffix = ""
|
||||
, prefDisambiguate = False }
|
||||
|
||||
-- convenience shortcuts
|
||||
|
||||
|
@ -39,8 +39,6 @@ module Options.Applicative.Common (
|
||||
evalParser,
|
||||
|
||||
-- * Low-level utilities
|
||||
runP,
|
||||
setContext,
|
||||
mapParser,
|
||||
treeMapParser,
|
||||
optionNames
|
||||
@ -48,6 +46,7 @@ module Options.Applicative.Common (
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Monoid
|
||||
|
||||
@ -59,6 +58,11 @@ optionNames (OptReader names _) = names
|
||||
optionNames (FlagReader names _) = names
|
||||
optionNames _ = []
|
||||
|
||||
isOptionPrefix :: OptName -> OptName -> Bool
|
||||
isOptionPrefix (OptShort x) (OptShort y) = x == y
|
||||
isOptionPrefix (OptLong x) (OptLong y) = x `isPrefixOf` y
|
||||
isOptionPrefix _ _ = False
|
||||
|
||||
-- | Create a parser composed of a single option.
|
||||
liftOpt :: Option a -> Parser a
|
||||
liftOpt = OptP
|
||||
@ -74,11 +78,11 @@ instance Monoid MatchResult where
|
||||
|
||||
type Matcher m a = [String] -> m (a, [String])
|
||||
|
||||
optMatches :: MonadP m => OptReader a -> String -> Maybe (Matcher m a)
|
||||
optMatches opt arg = case opt of
|
||||
optMatches :: MonadP m => Bool -> OptReader a -> String -> Maybe (Matcher m a)
|
||||
optMatches disambiguate opt arg = case opt of
|
||||
OptReader names rdr
|
||||
| Just (arg1, val) <- parsed
|
||||
, arg1 `elem` names
|
||||
, has_name arg1 names
|
||||
-> Just $ \args -> do
|
||||
let mb_args = uncons $ maybeToList val ++ args
|
||||
(arg', args') <- maybe (missingArgP (crCompleter rdr)) return mb_args
|
||||
@ -87,7 +91,7 @@ optMatches opt arg = case opt of
|
||||
| otherwise -> Nothing
|
||||
FlagReader names x
|
||||
| Just (arg1, Nothing) <- parsed
|
||||
, arg1 `elem` names
|
||||
, has_name arg1 names
|
||||
-> Just $ \args -> return (x, args)
|
||||
ArgReader rdr
|
||||
| Just result <- crReader rdr arg
|
||||
@ -110,26 +114,36 @@ optMatches opt arg = case opt of
|
||||
[a] -> Just (OptShort a, Nothing)
|
||||
(a : rest) -> Just (OptShort a, Just rest)
|
||||
| otherwise = Nothing
|
||||
has_name a
|
||||
| disambiguate = any (isOptionPrefix a)
|
||||
| otherwise = elem a
|
||||
|
||||
stepParser :: MonadP m => Parser a -> String -> [String] -> m (Parser a, [String])
|
||||
stepParser (NilP _) _ _ = empty
|
||||
stepParser (OptP opt) arg args
|
||||
| Just matcher <- optMatches (optMain opt) arg
|
||||
= do (r, args') <- matcher args
|
||||
return (pure r, args')
|
||||
| otherwise = empty
|
||||
stepParser (MultP p1 p2) arg args = msum
|
||||
[ do (p1', args') <- stepParser p1 arg args
|
||||
return (p1' <*> p2, args')
|
||||
, do (p2', args') <- stepParser p2 arg args
|
||||
return (p1 <*> p2', args') ]
|
||||
stepParser (AltP p1 p2) arg args = msum
|
||||
[ stepParser p1 arg args
|
||||
, stepParser p2 arg args ]
|
||||
stepParser (BindP p k) arg args = do
|
||||
(p', args') <- stepParser p arg args
|
||||
x <- liftMaybe $ evalParser p'
|
||||
return (k x, args')
|
||||
stepParser :: MonadP m => ParserPrefs -> Parser a -> String -> [String] -> [m (Parser a, [String])]
|
||||
stepParser _ (NilP _) _ _ = []
|
||||
stepParser prefs (OptP opt) arg args =
|
||||
case optMatches disambiguate (optMain opt) arg of
|
||||
Just matcher -> pure $ do
|
||||
(r, args') <- matcher args
|
||||
return (pure r, args')
|
||||
Nothing -> empty
|
||||
where
|
||||
disambiguate = prefDisambiguate prefs
|
||||
&& optVisibility opt > Internal
|
||||
stepParser prefs (MultP p1 p2) arg args = msum
|
||||
[ flip map (stepParser prefs p1 arg args) $ \m ->
|
||||
do (p1', args') <- m
|
||||
return (p1' <*> p2, args')
|
||||
, flip map (stepParser prefs p2 arg args) $ \m ->
|
||||
do (p2', args') <- m
|
||||
return (p1 <*> p2', args') ]
|
||||
stepParser prefs (AltP p1 p2) arg args = msum
|
||||
[ stepParser prefs p1 arg args
|
||||
, stepParser prefs p2 arg args ]
|
||||
stepParser prefs (BindP p k) arg args =
|
||||
flip map (stepParser prefs p arg args) $ \m -> do
|
||||
(p', args') <- m
|
||||
x <- liftMaybe $ evalParser p'
|
||||
return (k x, args')
|
||||
|
||||
-- | Apply a 'Parser' to a command line, and return a result and leftover
|
||||
-- arguments. This function returns an error if any parsing error occurs, or
|
||||
@ -138,12 +152,21 @@ runParser :: MonadP m => Parser a -> [String] -> m (a, [String])
|
||||
runParser p args = case args of
|
||||
[] -> maybe (exitP p) return result
|
||||
(arg : argt) -> do
|
||||
x <- tryP (stepParser p arg argt)
|
||||
prefs <- getPrefs
|
||||
x <- tryP $ do_step prefs arg argt
|
||||
case x of
|
||||
Left e -> liftMaybe result <|> errorP e
|
||||
Right (p', args') -> runParser p' args'
|
||||
where
|
||||
result = (,) <$> evalParser p <*> pure args
|
||||
do_step prefs arg argt
|
||||
| prefDisambiguate prefs
|
||||
= case parses of
|
||||
[m] -> m
|
||||
_ -> empty
|
||||
| otherwise
|
||||
= msum parses
|
||||
where parses = stepParser prefs p arg argt
|
||||
|
||||
runParserFully :: MonadP m => Parser a -> [String] -> m a
|
||||
runParserFully p args = do
|
||||
|
@ -6,6 +6,7 @@ module Options.Applicative.Extra (
|
||||
helper,
|
||||
execParser,
|
||||
execParserPure,
|
||||
customExecParser,
|
||||
usage,
|
||||
ParserFailure(..),
|
||||
) where
|
||||
@ -63,7 +64,7 @@ execParserPure :: ParserPrefs -- ^ Global preferences for this parser
|
||||
-> [String] -- ^ Program arguments
|
||||
-> Either ParserFailure a
|
||||
execParserPure pprefs pinfo args =
|
||||
case runP p of
|
||||
case runP p pprefs of
|
||||
(Right r, _) -> case r of
|
||||
Result a -> Right a
|
||||
Extra failure -> Left failure
|
||||
@ -93,7 +94,8 @@ execParserPure pprefs pinfo args =
|
||||
with_context NullContext i f = f [] i
|
||||
with_context (Context n i) _ f = f n i
|
||||
|
||||
parser' = (Extra <$> bashCompletionParser parser) <|> (Result <$> parser)
|
||||
parser' = (Extra <$> bashCompletionParser parser pprefs)
|
||||
<|> (Result <$> parser)
|
||||
p = runParserFully parser' args
|
||||
|
||||
-- | Generate option summary.
|
||||
|
@ -19,6 +19,7 @@ import Control.Applicative
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Error
|
||||
import Control.Monad.Trans.Reader
|
||||
import Control.Monad.Trans.Writer
|
||||
import Data.Maybe
|
||||
import Data.Monoid
|
||||
@ -28,13 +29,14 @@ import Options.Applicative.Types
|
||||
class (Alternative m, MonadPlus m) => MonadP m where
|
||||
setContext :: Maybe String -> ParserInfo a -> m ()
|
||||
setParser :: Maybe String -> Parser a -> m ()
|
||||
getPrefs :: m ParserPrefs
|
||||
|
||||
missingArgP :: Completer -> m a
|
||||
tryP :: m a -> m (Either String a)
|
||||
errorP :: String -> m a
|
||||
exitP :: Parser b -> m a
|
||||
|
||||
type P = ErrorT String (Writer Context)
|
||||
type P = ErrorT String (WriterT Context (Reader ParserPrefs))
|
||||
|
||||
data Context where
|
||||
Context :: [String] -> ParserInfo a -> Context
|
||||
@ -52,6 +54,7 @@ instance Monoid Context where
|
||||
instance MonadP P where
|
||||
setContext name = lift . tell . Context (maybeToList name)
|
||||
setParser _ _ = return ()
|
||||
getPrefs = lift . lift $ ask
|
||||
|
||||
missingArgP _ = empty
|
||||
tryP p = lift $ runErrorT p
|
||||
@ -61,8 +64,8 @@ instance MonadP P where
|
||||
liftMaybe :: MonadPlus m => Maybe a -> m a
|
||||
liftMaybe = maybe mzero return
|
||||
|
||||
runP :: P a -> (Either String a, Context)
|
||||
runP = runWriter . runErrorT
|
||||
runP :: P a -> ParserPrefs -> (Either String a, Context)
|
||||
runP = runReader . runWriterT . runErrorT
|
||||
|
||||
uncons :: [a] -> Maybe (a, [a])
|
||||
uncons [] = Nothing
|
||||
@ -97,19 +100,20 @@ instance Monad ComplResult where
|
||||
ComplParser p -> ComplParser p
|
||||
ComplOption c -> ComplOption c
|
||||
|
||||
type Completion = ErrorT String ComplResult
|
||||
type Completion = ErrorT String (ReaderT ParserPrefs ComplResult)
|
||||
|
||||
instance MonadP Completion where
|
||||
setContext _ _ = return ()
|
||||
setParser _ _ = return ()
|
||||
getPrefs = lift ask
|
||||
|
||||
missingArgP = lift . ComplOption
|
||||
missingArgP = lift . lift . ComplOption
|
||||
tryP p = catchError (Right <$> p) (return . Left)
|
||||
exitP = lift . ComplParser . SomeParser
|
||||
exitP = lift . lift . ComplParser . SomeParser
|
||||
errorP = throwError
|
||||
|
||||
runCompletion :: Completion r -> Maybe (Either SomeParser Completer)
|
||||
runCompletion c = case runErrorT c of
|
||||
runCompletion :: Completion r -> ParserPrefs -> Maybe (Either SomeParser Completer)
|
||||
runCompletion c prefs = case runReaderT (runErrorT c) prefs of
|
||||
ComplResult _ -> Nothing
|
||||
ComplParser p' -> Just $ Left p'
|
||||
ComplOption compl -> Just $ Right compl
|
||||
|
@ -45,6 +45,7 @@ data ParserInfo a = ParserInfo
|
||||
-- | Global preferences for a top-level 'Parser'.
|
||||
data ParserPrefs = ParserPrefs
|
||||
{ prefMultiSuffix :: String -- ^ metavar suffix for multiple options
|
||||
, prefDisambiguate :: Bool -- ^ automatically disambiguate abbreviations
|
||||
}
|
||||
|
||||
data OptName = OptShort !Char
|
||||
|
@ -142,5 +142,27 @@ case_many_args = do
|
||||
Left _ -> assertFailure "unexpected parse error"
|
||||
Right xs -> nargs @=? length xs
|
||||
|
||||
case_disambiguate :: Assertion
|
||||
case_disambiguate = do
|
||||
let p = flag' (1 :: Int) (long "foo")
|
||||
<|> flag' 2 (long "bar")
|
||||
<|> flag' 3 (long "baz")
|
||||
i = info p idm
|
||||
result = execParserPure (prefs disambiguate) i ["--f"]
|
||||
case result of
|
||||
Left _ -> assertFailure "unexpected parse error"
|
||||
Right val -> 1 @=? val
|
||||
|
||||
case_ambiguous :: Assertion
|
||||
case_ambiguous = do
|
||||
let p = flag' (1 :: Int) (long "foo")
|
||||
<|> flag' 2 (long "bar")
|
||||
<|> flag' 3 (long "baz")
|
||||
i = info p idm
|
||||
result = execParserPure (prefs disambiguate) i ["--ba"]
|
||||
case result of
|
||||
Left _ -> return ()
|
||||
Right val -> assertFailure $ "unexpected result " ++ show val
|
||||
|
||||
main :: IO ()
|
||||
main = $(defaultMainGenerator)
|
||||
|
Loading…
Reference in New Issue
Block a user