Merge disambiguation feature (#8).

This commit is contained in:
Paolo Capriotti 2012-08-05 02:39:13 +01:00
commit b110838cdb
7 changed files with 102 additions and 45 deletions

View File

@ -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 []

View File

@ -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

View File

@ -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

View File

@ -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.

View File

@ -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

View File

@ -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

View File

@ -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)