Skip to content

Commit

Permalink
Revert "Merge pull request #454 from pcapriotti/topic/command-disambi…
Browse files Browse the repository at this point in the history
…guation"

This reverts the PVP incompatible changes to 0.17.0 made to the
master branch.
  • Loading branch information
HuwCampbell committed May 23, 2023
1 parent 2b3b129 commit ae82a50
Show file tree
Hide file tree
Showing 10 changed files with 40 additions and 94 deletions.
7 changes: 0 additions & 7 deletions CHANGELOG.md
Original file line number Diff line number Diff line change
Expand Up @@ -10,13 +10,6 @@

- Add `simpleVersioner` utility for adding a '--version' option to a parser.

- Allow commands to be disambiguated in a similar manner to flags when the
`disambiguate` modifier is used.

This is a potentially breaking change as the internal `CmdReader` constructor
has been adapted so it is able to be inspected to a greater degree to support
finding submatches.

- Improve documentation.

## Version 0.17.0.0 (1 Feb 2022)
Expand Down
26 changes: 14 additions & 12 deletions src/Options/Applicative/BashCompletion.hs
Original file line number Diff line number Diff line change
Expand Up @@ -114,11 +114,11 @@ bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl ppre
-> return []
| otherwise
-> run_completer (crCompleter rdr)
CmdReader _ ns
CmdReader _ ns p
| argumentIsUnreachable reachability
-> return []
| otherwise
-> return . with_cmd_help $ filter (is_completion . fst) ns
-> return . add_cmd_help p $ filter_names ns

-- When doing enriched completions, add any help specified
-- to the completion variables (tab separated).
Expand All @@ -133,18 +133,17 @@ bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl ppre

-- When doing enriched completions, add the command description
-- to the completion variables (tab separated).
with_cmd_help :: Functor f => f (String, ParserInfo a) -> f String
with_cmd_help =
case richness of
Standard ->
fmap fst
Enriched _ len ->
fmap $ \(cmd, cmdInfo) ->
let h = unChunk (infoProgDesc cmdInfo)
in maybe cmd (\h' -> cmd ++ "\t" ++ render_line len h') h
add_cmd_help :: Functor f => (String -> Maybe (ParserInfo a)) -> f String -> f String
add_cmd_help p = case richness of
Standard ->
id
Enriched _ len ->
fmap $ \cmd ->
let h = p cmd >>= unChunk . infoProgDesc
in maybe cmd (\h' -> cmd ++ "\t" ++ render_line len h') h

show_names :: [OptName] -> [String]
show_names = filter is_completion . map showOption
show_names = filter_names . map showOption

-- We only want to show a single line in the completion results description.
-- If there was a line break, it would come across as a different completion
Expand All @@ -155,6 +154,9 @@ bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl ppre
[x] -> x
x : _ -> x ++ "..."

filter_names :: [String] -> [String]
filter_names = filter is_completion

run_completer :: Completer -> IO [String]
run_completer c = runCompleter c (fromMaybe "" (listToMaybe ws''))

Expand Down
4 changes: 2 additions & 2 deletions src/Options/Applicative/Builder.hs
Original file line number Diff line number Diff line change
Expand Up @@ -282,8 +282,8 @@ subparser :: Mod CommandFields a -> Parser a
subparser m = mkParser d g rdr
where
Mod _ d g = metavar "COMMAND" `mappend` m
(groupName, cmds) = mkCommand m
rdr = CmdReader groupName cmds
(groupName, cmds, subs) = mkCommand m
rdr = CmdReader groupName cmds subs

-- | Builder for an argument parser.
argument :: ReadM a -> Mod ArgumentFields a -> Parser a
Expand Down
4 changes: 2 additions & 2 deletions src/Options/Applicative/Builder/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -152,8 +152,8 @@ baseProps = OptProperties
, propShowGlobal = True
}

mkCommand :: Mod CommandFields a -> (Maybe String, [(String, ParserInfo a)])
mkCommand m = (group, cmds)
mkCommand :: Mod CommandFields a -> (Maybe String, [String], String -> Maybe (ParserInfo a))
mkCommand m = (group, map fst cmds, (`lookup` cmds))
where
Mod f _ _ = m
CommandFields cmds group = f (CommandFields [] Nothing)
Expand Down
17 changes: 6 additions & 11 deletions src/Options/Applicative/Common.hs
Original file line number Diff line number Diff line change
Expand Up @@ -166,29 +166,24 @@ searchArg prefs arg =
searchParser $ \opt -> do
when (isArg (optMain opt)) cut
case optMain opt of
CmdReader _ cs -> do
subp <- hoistList (cmdMatches cs)
case prefBacktrack prefs of
NoBacktrack -> lift $ do
CmdReader _ _ f ->
case (f arg, prefBacktrack prefs) of
(Just subp, NoBacktrack) -> lift $ do
args <- get <* put []
fmap pure . lift $ enterContext arg subp *> runParserInfo subp args <* exitContext

Backtrack -> fmap pure . lift . StateT $ \args ->
(Just subp, Backtrack) -> fmap pure . lift . StateT $ \args ->
enterContext arg subp *> runParser (infoPolicy subp) CmdStart (infoParser subp) args <* exitContext

SubparserInline -> lift $ do
(Just subp, SubparserInline) -> lift $ do
lift $ enterContext arg subp
return $ infoParser subp

(Nothing, _) -> mzero
ArgReader rdr ->
fmap pure . lift . lift $ runReadM (crReader rdr) arg
_ -> mzero

where
cmdMatches cs
| prefDisambiguate prefs = snd <$> filter (isPrefixOf arg . fst) cs
| otherwise = maybeToList (lookup arg cs)

stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String
-> Parser a -> NondetT (StateT Args m) (Parser a)
stepParser pprefs AllPositionals arg p =
Expand Down
8 changes: 4 additions & 4 deletions src/Options/Applicative/Extra.hs
Original file line number Diff line number Diff line change
Expand Up @@ -89,8 +89,8 @@ hsubparser :: Mod CommandFields a -> Parser a
hsubparser m = mkParser d g rdr
where
Mod _ d g = metavar "COMMAND" `mappend` m
(groupName, cmds) = mkCommand m
rdr = CmdReader groupName ((fmap . fmap) add_helper cmds)
(groupName, cmds, subs) = mkCommand m
rdr = CmdReader groupName cmds (fmap add_helper . subs)
add_helper pinfo = pinfo
{ infoParser = infoParser pinfo <**> helper }

Expand Down Expand Up @@ -317,10 +317,10 @@ parserFailure pprefs pinfo msg ctx0 = ParserFailure $ \progn ->
OptReader ns _ _ -> fmap showOption ns
FlagReader ns _ -> fmap showOption ns
ArgReader _ -> []
CmdReader _ ns | argumentIsUnreachable reachability
CmdReader _ ns _ | argumentIsUnreachable reachability
-> []
| otherwise
-> fst <$> ns
-> ns
_
-> mempty

Expand Down
9 changes: 5 additions & 4 deletions src/Options/Applicative/Help/Core.hs
Original file line number Diff line number Diff line change
Expand Up @@ -25,7 +25,7 @@ import Control.Monad (guard)
import Data.Function (on)
import Data.List (sort, intersperse, groupBy)
import Data.Foldable (any, foldl')
import Data.Maybe (catMaybes, fromMaybe)
import Data.Maybe (catMaybes, fromMaybe, maybeToList)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (mempty)
#endif
Expand Down Expand Up @@ -95,11 +95,12 @@ cmdDesc pprefs = mapParser desc
where
desc _ opt =
case optMain opt of
CmdReader gn cmds ->
CmdReader gn cmds p ->
(,) gn $
tabulate (prefTabulateFill pprefs)
[ (string nm, align (extractChunk (infoProgDesc cmd)))
| (nm, cmd) <- reverse cmds
[ (string cmd, align (extractChunk d))
| cmd <- reverse cmds,
d <- maybeToList . fmap infoProgDesc $ p cmd
]
_ -> mempty

Expand Down
11 changes: 4 additions & 7 deletions src/Options/Applicative/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -18,7 +18,6 @@ module Options.Applicative.Internal
, ListT
, takeListT
, runListT
, hoistList

, NondetT
, cut
Expand Down Expand Up @@ -173,6 +172,9 @@ bimapTStep :: (a -> b) -> (x -> y) -> TStep a x -> TStep b y
bimapTStep _ _ TNil = TNil
bimapTStep f g (TCons a x) = TCons (f a) (g x)

hoistList :: Monad m => [a] -> ListT m a
hoistList = foldr (\x xt -> ListT (return (TCons x xt))) mzero

takeListT :: Monad m => Int -> ListT m a -> ListT m a
takeListT 0 = const mzero
takeListT n = ListT . liftM (bimapTStep id (takeListT (n - 1))) . stepListT
Expand All @@ -190,7 +192,7 @@ instance Monad m => Functor (ListT m) where
. stepListT

instance Monad m => Applicative (ListT m) where
pure a = ListT (return (TCons a mzero))
pure = hoistList . pure
(<*>) = ap

instance Monad m => Monad (ListT m) where
Expand Down Expand Up @@ -261,8 +263,3 @@ disamb allow_amb xs = do
return $ case xs' of
[x] -> Just x
_ -> Nothing

hoistList :: Alternative m => [a] -> m a
hoistList = foldr cons empty
where
cons x xs = pure x <|> xs
4 changes: 2 additions & 2 deletions src/Options/Applicative/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -242,14 +242,14 @@ data OptReader a
-- ^ flag reader
| ArgReader (CReader a)
-- ^ argument reader
| CmdReader (Maybe String) [(String, ParserInfo a)]
| CmdReader (Maybe String) [String] (String -> Maybe (ParserInfo a))
-- ^ command reader

instance Functor OptReader where
fmap f (OptReader ns cr e) = OptReader ns (fmap f cr) e
fmap f (FlagReader ns x) = FlagReader ns (f x)
fmap f (ArgReader cr) = ArgReader (fmap f cr)
fmap f (CmdReader n cs) = CmdReader n ((fmap . fmap . fmap) f cs)
fmap f (CmdReader n cs g) = CmdReader n cs ((fmap . fmap) f . g)

-- | A @Parser a@ is an option parser returning a value of type 'a'.
data Parser a
Expand Down
44 changes: 1 addition & 43 deletions tests/test.hs
Original file line number Diff line number Diff line change
Expand Up @@ -318,49 +318,6 @@ prop_ambiguous = once $
result = execParserPure (prefs disambiguate) i ["--ba"]
in assertError result (\_ -> property succeeded)


prop_disambiguate_in_same_subparsers :: Property
prop_disambiguate_in_same_subparsers = once $
let p0 = subparser (command "oranges" (info (pure "oranges") idm) <> command "apples" (info (pure "apples") idm) <> metavar "B")
i = info (p0 <**> helper) idm
result = execParserPure (prefs disambiguate) i ["orang"]
in assertResult result ((===) "oranges")

prop_disambiguate_commands_in_separate_subparsers :: Property
prop_disambiguate_commands_in_separate_subparsers = once $
let p2 = subparser (command "oranges" (info (pure "oranges") idm) <> metavar "B")
p1 = subparser (command "apples" (info (pure "apples") idm) <> metavar "C")
p0 = p1 <|> p2
i = info (p0 <**> helper) idm
result = execParserPure (prefs disambiguate) i ["orang"]
in assertResult result ((===) "oranges")

prop_fail_ambiguous_commands_in_same_subparser :: Property
prop_fail_ambiguous_commands_in_same_subparser = once $
let p0 = subparser (command "oranges" (info (pure ()) idm) <> command "orangutans" (info (pure ()) idm) <> metavar "B")
i = info (p0 <**> helper) idm
result = execParserPure (prefs disambiguate) i ["orang"]
in assertError result (\_ -> property succeeded)

prop_fail_ambiguous_commands_in_separate_subparser :: Property
prop_fail_ambiguous_commands_in_separate_subparser = once $
let p2 = subparser (command "oranges" (info (pure ()) idm) <> metavar "B")
p1 = subparser (command "orangutans" (info (pure ()) idm) <> metavar "C")
p0 = p1 <|> p2
i = info (p0 <**> helper) idm
result = execParserPure (prefs disambiguate) i ["orang"]
in assertError result (\_ -> property succeeded)

prop_without_disambiguation_same_named_commands_should_parse_in_order :: Property
prop_without_disambiguation_same_named_commands_should_parse_in_order = once $
let p3 = subparser (command "b" (info (pure ()) idm) <> metavar "B")
p2 = subparser (command "a" (info (pure ()) idm) <> metavar "B")
p1 = subparser (command "a" (info (pure ()) idm) <> metavar "C")
p0 = (,,) <$> p1 <*> p2 <*> p3
i = info (p0 <**> helper) idm
result = execParserPure defaultPrefs i ["b", "a", "a"]
in assertResult result ((===) ((), (), ()))

prop_completion :: Property
prop_completion = once . ioProperty $
let p = (,)
Expand Down Expand Up @@ -946,6 +903,7 @@ prop_long_command_line_flow = once $
, "to fit the size of the terminal" ]) )
in checkHelpTextWith ExitSuccess (prefs (columns 50)) "formatting-long-subcommand" i ["hello-very-long-sub", "--help"]


---

deriving instance Arbitrary a => Arbitrary (Chunk a)
Expand Down

0 comments on commit ae82a50

Please sign in to comment.