diff --git a/CHANGELOG.md b/CHANGELOG.md index 56375351..29d83d5a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/src/Options/Applicative/BashCompletion.hs b/src/Options/Applicative/BashCompletion.hs index 4a041c2f..6f49b35e 100644 --- a/src/Options/Applicative/BashCompletion.hs +++ b/src/Options/Applicative/BashCompletion.hs @@ -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). @@ -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 @@ -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'')) diff --git a/src/Options/Applicative/Builder.hs b/src/Options/Applicative/Builder.hs index ec7809c0..e205b979 100644 --- a/src/Options/Applicative/Builder.hs +++ b/src/Options/Applicative/Builder.hs @@ -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 diff --git a/src/Options/Applicative/Builder/Internal.hs b/src/Options/Applicative/Builder/Internal.hs index 39ab8a49..e5bc4b63 100644 --- a/src/Options/Applicative/Builder/Internal.hs +++ b/src/Options/Applicative/Builder/Internal.hs @@ -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) diff --git a/src/Options/Applicative/Common.hs b/src/Options/Applicative/Common.hs index 91e03cd7..46d2b730 100644 --- a/src/Options/Applicative/Common.hs +++ b/src/Options/Applicative/Common.hs @@ -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 = diff --git a/src/Options/Applicative/Extra.hs b/src/Options/Applicative/Extra.hs index 97ed572d..766d3d31 100644 --- a/src/Options/Applicative/Extra.hs +++ b/src/Options/Applicative/Extra.hs @@ -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 } @@ -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 diff --git a/src/Options/Applicative/Help/Core.hs b/src/Options/Applicative/Help/Core.hs index 54c37032..451cb878 100644 --- a/src/Options/Applicative/Help/Core.hs +++ b/src/Options/Applicative/Help/Core.hs @@ -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 @@ -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 diff --git a/src/Options/Applicative/Internal.hs b/src/Options/Applicative/Internal.hs index b4831447..d5b854e7 100644 --- a/src/Options/Applicative/Internal.hs +++ b/src/Options/Applicative/Internal.hs @@ -18,7 +18,6 @@ module Options.Applicative.Internal , ListT , takeListT , runListT - , hoistList , NondetT , cut @@ -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 @@ -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 @@ -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 diff --git a/src/Options/Applicative/Types.hs b/src/Options/Applicative/Types.hs index a556f2a8..0644676b 100644 --- a/src/Options/Applicative/Types.hs +++ b/src/Options/Applicative/Types.hs @@ -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 diff --git a/tests/test.hs b/tests/test.hs index ecbe1e28..e6ce5db9 100644 --- a/tests/test.hs +++ b/tests/test.hs @@ -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 = (,) @@ -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)