From 659c01810c869e11a5fd876db434d3f482e8f33a Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Tue, 23 Feb 2021 18:50:07 +0100 Subject: [PATCH 1/5] Control addition of space after completion in bash and zsh (cherry picked from commit 7c3b764eae24ce8872db5e96f2ae04e4b4b5d0fd) --- CHANGELOG.md | 7 ++ src/Options/Applicative.hs | 2 + src/Options/Applicative/BashCompletion.hs | 109 ++++++++++++++----- src/Options/Applicative/Builder/Completer.hs | 4 +- src/Options/Applicative/Types.hs | 35 +++++- tests/test.hs | 19 ++-- 6 files changed, 140 insertions(+), 36 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d397e8c2..dadbd9f5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +## Next + +- Add `mkCompleterWithOptions`, allowing completers to + request that no space is added after the completion. + This is useful in situations where not all completions + can be computed efficiently, or when they are too many. + ## Version 0.18.1.0 (29 May 2023) - Change pretty printer layout algorithm used. diff --git a/src/Options/Applicative.hs b/src/Options/Applicative.hs index fa042f31..4d84e033 100644 --- a/src/Options/Applicative.hs +++ b/src/Options/Applicative.hs @@ -214,6 +214,8 @@ module Options.Applicative ( -- convenience, to use 'bashCompleter' and 'listCompleter' as a 'Mod'. Completer, mkCompleter, + CompletionItem(..), + mkCompleterWithOptions, listIOCompleter, listCompleter, diff --git a/src/Options/Applicative/BashCompletion.hs b/src/Options/Applicative/BashCompletion.hs index e4b6356c..2f53f9b6 100644 --- a/src/Options/Applicative/BashCompletion.hs +++ b/src/Options/Applicative/BashCompletion.hs @@ -73,9 +73,9 @@ bashCompletionParser pinfo pprefs = complParser bashCompletionQuery :: ParserInfo a -> ParserPrefs -> Richness -> [String] -> Int -> String -> IO [String] bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl pprefs of Just (Left (SomeParser p, a)) - -> list_options a p + -> render_items <$> list_options a p Just (Right c) - -> run_completer c + -> render_items <$> run_completer c Nothing -> return [] where @@ -100,12 +100,12 @@ bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl ppre opt_completions argPolicy reachability opt = case optMain opt of OptReader ns _ _ | argPolicy /= AllPositionals - -> return . add_opt_help opt $ show_names ns + -> return . fmap defaultCompletionItem . add_opt_help opt $ show_names ns | otherwise -> return [] FlagReader ns _ | argPolicy /= AllPositionals - -> return . add_opt_help opt $ show_names ns + -> return . fmap defaultCompletionItem . add_opt_help opt $ show_names ns | otherwise -> return [] ArgReader rdr @@ -117,7 +117,7 @@ bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl ppre | argumentIsUnreachable reachability -> return [] | otherwise - -> return . with_cmd_help $ filter (is_completion . fst) ns + -> return . fmap defaultCompletionItem . with_cmd_help $ filter (is_completion . fst) ns -- When doing enriched completions, add any help specified -- to the completion variables (tab separated). @@ -154,7 +154,7 @@ bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl ppre [x] -> x x : _ -> x ++ "..." - run_completer :: Completer -> IO [String] + run_completer :: Completer -> IO [CompletionItem] run_completer c = runCompleter c (fromMaybe "" (listToMaybe ws'')) (ws', ws'') = splitAt i ws @@ -165,12 +165,22 @@ bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl ppre w:_ -> isPrefixOf w _ -> const True + render_items :: [CompletionItem] -> [String] + render_items = concatMap render_item + + render_item :: CompletionItem -> [String] + render_item CompletionItem { ciOptions = opts, ciValue = val } = + [ "%addspace" | cioAddSpace opts ] + ++ ["%value", val] + -- | Generated bash shell completion script bashCompletionScript :: String -> String -> String bashCompletionScript prog progn = unlines + -- compopt: see complete -o at https://www.gnu.org/software/bash/manual/html_node/Programmable-Completion-Builtins.html [ "_" ++ progn ++ "()" , "{" , " local CMDLINE" + , " local value_mode=false" , " local IFS=$'\\n'" , " CMDLINE=(--bash-completion-index $COMP_CWORD)" , "" @@ -178,7 +188,23 @@ bashCompletionScript prog progn = unlines , " CMDLINE=(${CMDLINE[@]} --bash-completion-word $arg)" , " done" , "" - , " COMPREPLY=( $(" ++ prog ++ " \"${CMDLINE[@]}\") )" + , " compopt -o nospace" + , " COMPREPLY=()" + , " for ln in $(" ++ prog ++ " \"${CMDLINE[@]}\"); do" + , " if $value_mode; then" + , " COMPREPLY+=($ln)" + , " value_mode=false" + , " else" + , " case $ln in" + , " %value)" + , " value_mode=true" + , " ;;" + , " %addspace)" + , " compopt +o nospace" + , " ;;" + , " esac" + , " fi" + , " done" , "}" , "" , "complete -o filenames -F _" ++ progn ++ " " ++ progn ] @@ -214,11 +240,23 @@ fishCompletionScript prog progn = unlines , " for arg in $cl" , " set tmpline $tmpline --bash-completion-word $arg" , " end" - , " for opt in (" ++ prog ++ " $tmpline)" - , " if test -d $opt" - , " echo -E \"$opt/\"" + , " set -l value_mode false" + , " for ln in (" ++ prog ++ " $tmpline)" + , " if $value_mode" + , " if test -d $ln" + , " echo -E \"$ln/\"" + , " else" + , " echo -E \"$ln\"" + , " end" + , " set value_mode false" , " else" - , " echo -E \"$opt\"" + , " switch $ln" + , " case '%value'" + , " set value_mode true" + -- Ignore %addspace, because fish does not let us remove the end + -- space. Dynamic control has not been implemented as of 2020, see + -- https://github.com/fish-shell/fish-shell/issues/6928#issuecomment-618012509 + , " end" , " end" , " end" , "end" @@ -229,11 +267,15 @@ fishCompletionScript prog progn = unlines -- | Generated zsh shell completion script zshCompletionScript :: String -> String -> String zshCompletionScript prog progn = unlines + -- compadd: http://zsh.sourceforge.net/Doc/Release/Completion-Widgets.html#Completion-Builtin-Commands [ "#compdef " ++ progn , "" , "local request" , "local completions" , "local word" + , "local value_mode=false" + , "local addspace=false" + , "local files=false" , "local index=$((CURRENT - 1))" , "" , "request=(--bash-completion-enriched --bash-completion-index $index)" @@ -241,24 +283,41 @@ zshCompletionScript prog progn = unlines , " request=(${request[@]} --bash-completion-word $arg)" , "done" , "" - , "IFS=$'\\n' completions=($( " ++ prog ++ " \"${request[@]}\" ))" + , "IFS=$'\\n' completionLines=($( " ++ prog ++ " \"${request[@]}\" ))" + , "" + , "for word in $completionLines; do" + , " if $value_mode; then" + , " local -a parts args" , "" - , "for word in $completions; do" - , " local -a parts" + , " # Split the line at a tab if there is one." + , " IFS=$'\\t' parts=($( echo $word ))" , "" - , " # Split the line at a tab if there is one." - , " IFS=$'\\t' parts=($( echo $word ))" + , " if $addspace; then" + , " args+=( -S' ' )" + , " fi" , "" - , " if [[ -n $parts[2] ]]; then" - , " if [[ $word[1] == \"-\" ]]; then" - , " local desc=(\"$parts[1] ($parts[2])\")" - , " compadd -d desc -- $parts[1]" - , " else" - , " local desc=($(print -f \"%-019s -- %s\" $parts[1] $parts[2]))" - , " compadd -l -d desc -- $parts[1]" - , " fi" + , " if [[ -n $parts[2] ]]; then" + , " if [[ $word[1] == \"-\" ]]; then" + , " local desc=(\"$parts[1] ($parts[2])\")" + , " compadd $args -d desc -- $parts[1]" + , " else" + , " local desc=($(print -f \"%-019s -- %s\" $parts[1] $parts[2]))" + , " compadd $args -l -d desc -- $parts[1]" + , " fi" + , " else" + , " compadd $args -f -- $word" + , " fi" + , " value_mode=false" + , " addspace=false" , " else" - , " compadd -f -- $word" + , " case $word in" + , " %value)" + , " value_mode=true" + , " ;;" + , " %addspace)" + , " addspace=true" + , " ;;" + , " esac" , " fi" , "done" ] diff --git a/src/Options/Applicative/Builder/Completer.hs b/src/Options/Applicative/Builder/Completer.hs index 5da556e7..4161cd1b 100644 --- a/src/Options/Applicative/Builder/Completer.hs +++ b/src/Options/Applicative/Builder/Completer.hs @@ -22,7 +22,7 @@ import Options.Applicative.Types -- | Create a 'Completer' from an IO action listIOCompleter :: IO [String] -> Completer -listIOCompleter ss = Completer $ \s -> +listIOCompleter ss = mkCompleter $ \s -> filter (isPrefixOf s) <$> ss -- | Create a 'Completer' from a constant @@ -38,7 +38,7 @@ listCompleter = listIOCompleter . pure -- for a complete list. bashCompleter :: String -> Completer #ifdef MIN_VERSION_process -bashCompleter action = Completer $ \word -> do +bashCompleter action = mkCompleter $ \word -> do let cmd = unwords ["compgen", "-A", action, "--", requote word] result <- tryIO $ readProcess "bash" ["-c", cmd] "" return . lines . either (const []) id $ result diff --git a/src/Options/Applicative/Types.hs b/src/Options/Applicative/Types.hs index a556f2a8..e1647d0b 100644 --- a/src/Options/Applicative/Types.hs +++ b/src/Options/Applicative/Types.hs @@ -22,6 +22,10 @@ module Options.Applicative.Types ( ParserM(..), Completer(..), mkCompleter, + mkCompleterWithOptions, + CompletionItem(..), + defaultCompletionItem, + CompletionItemOptions(..), CompletionResult(..), ParserFailure(..), ParserResult(..), @@ -306,13 +310,40 @@ instance Alternative Parser where many = fromM . manyM some = fromM . someM +data CompletionItem = CompletionItem { + ciOptions :: CompletionItemOptions, + ciValue :: String +} +defaultCompletionItem :: String -> CompletionItem +defaultCompletionItem = CompletionItem mempty + +data CompletionItemOptions = CompletionItemOptions { + -- | Whether to add a space after the completion. Defaults to 'True'. + -- + -- Set this value to 'False' if the completion is only a prefix of the final + -- valid values. + cioAddSpace :: Bool +} +instance Semigroup CompletionItemOptions where + a <> b = + CompletionItemOptions { + cioAddSpace = cioAddSpace a && cioAddSpace b + } +instance Monoid CompletionItemOptions where + mempty = CompletionItemOptions True + mappend = (<>) + -- | A shell complete function. newtype Completer = Completer - { runCompleter :: String -> IO [String] } + { runCompleter :: String -> IO [CompletionItem] } -- | Smart constructor for a 'Completer' mkCompleter :: (String -> IO [String]) -> Completer -mkCompleter = Completer +mkCompleter f = Completer (fmap (map (CompletionItem mempty)) . f) + +-- | Smart constructor for a 'Completer' +mkCompleterWithOptions :: (String -> IO [CompletionItem]) -> Completer +mkCompleterWithOptions = Completer instance Semigroup Completer where (Completer c1) <> (Completer c2) = diff --git a/tests/test.hs b/tests/test.hs index 4c888dca..128c4c36 100644 --- a/tests/test.hs +++ b/tests/test.hs @@ -318,6 +318,11 @@ prop_ambiguous = once $ result = execParserPure (prefs disambiguate) i ["--ba"] in assertError result (\_ -> property succeeded) +completionValues :: [String] -> [String] +completionValues ("%value" : v : more) = v : completionValues more +completionValues (('%':_) : more) = completionValues more +completionValues (a:_) = error ("Unexpected non-% line in completions: " <> a) +completionValues [] = [] prop_disambiguate_in_same_subparsers :: Property prop_disambiguate_in_same_subparsers = once $ @@ -371,7 +376,7 @@ prop_completion = once . ioProperty $ in case result of CompletionInvoked (CompletionResult err) -> do completions <- lines <$> err "test" - return $ ["--foo", "--bar"] === completions + return $ ["--foo", "--bar"] === completionValues completions Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed @@ -386,7 +391,7 @@ prop_completion_opt_after_double_dash = once . ioProperty $ , "--bash-completion-word", "--"] in case result of CompletionInvoked (CompletionResult err) -> do - completions <- lines <$> err "test" + completions <- completionValues . lines <$> err "test" return $ ["bar"] === completions Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed @@ -401,7 +406,7 @@ prop_completion_only_reachable = once . ioProperty $ result = run i ["--bash-completion-index", "0"] in case result of CompletionInvoked (CompletionResult err) -> do - completions <- lines <$> err "test" + completions <- completionValues . lines <$> err "test" return $ ["reachable"] === completions Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed @@ -418,7 +423,7 @@ prop_completion_only_reachable_deep = once . ioProperty $ , "--bash-completion-word", "seen" ] in case result of CompletionInvoked (CompletionResult err) -> do - completions <- lines <$> err "test" + completions <- completionValues . lines <$> err "test" return $ ["now-reachable"] === completions Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed @@ -433,7 +438,7 @@ prop_completion_multi = once . ioProperty $ , "--bash-completion-word", "nope" ] in case result of CompletionInvoked (CompletionResult err) -> do - completions <- lines <$> err "test" + completions <- completionValues . lines <$> err "test" return $ ["reachable"] === completions Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed @@ -447,7 +452,7 @@ prop_completion_rich = once . ioProperty $ result = run i ["--bash-completion-enriched", "--bash-completion-index", "0"] in case result of CompletionInvoked (CompletionResult err) -> do - completions <- lines <$> err "test" + completions <- completionValues . lines <$> err "test" return $ ["--foo\tFo?", "--bar\tBa?"] === completions Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed @@ -464,7 +469,7 @@ prop_completion_rich_lengths = once . ioProperty $ , "--bash-completion-command-desc-length=30"] in case result of CompletionInvoked (CompletionResult err) -> do - completions <- lines <$> err "test" + completions <- completionValues . lines <$> err "test" return $ ["--foo\tFoo...", "--bar\tBar..."] === completions Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed From 133c5632fd36db82a0e23fc88c873f5f242b116c Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Tue, 23 Feb 2021 19:14:52 +0100 Subject: [PATCH 2/5] Control special file/directory behavior in completions (cherry picked from commit ba0d981f4344134ab1363f92896099fc0e392152) --- src/Options/Applicative/BashCompletion.hs | 10 +++++++++- src/Options/Applicative/Types.hs | 12 +++++++++--- 2 files changed, 18 insertions(+), 4 deletions(-) diff --git a/src/Options/Applicative/BashCompletion.hs b/src/Options/Applicative/BashCompletion.hs index 2f53f9b6..49ad3c64 100644 --- a/src/Options/Applicative/BashCompletion.hs +++ b/src/Options/Applicative/BashCompletion.hs @@ -171,6 +171,7 @@ bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl ppre render_item :: CompletionItem -> [String] render_item CompletionItem { ciOptions = opts, ciValue = val } = [ "%addspace" | cioAddSpace opts ] + ++ [ "%files" | cioFiles opts ] ++ ["%value", val] -- | Generated bash shell completion script @@ -188,7 +189,7 @@ bashCompletionScript prog progn = unlines , " CMDLINE=(${CMDLINE[@]} --bash-completion-word $arg)" , " done" , "" - , " compopt -o nospace" + , " compopt -o nospace +o filenames" , " COMPREPLY=()" , " for ln in $(" ++ prog ++ " \"${CMDLINE[@]}\"); do" , " if $value_mode; then" @@ -202,6 +203,9 @@ bashCompletionScript prog progn = unlines , " %addspace)" , " compopt +o nospace" , " ;;" + , " %files)" + , " compopt -o filenames" + , " ;;" , " esac" , " fi" , " done" @@ -309,6 +313,7 @@ zshCompletionScript prog progn = unlines , " fi" , " value_mode=false" , " addspace=false" + , " files=false" , " else" , " case $word in" , " %value)" @@ -317,6 +322,9 @@ zshCompletionScript prog progn = unlines , " %addspace)" , " addspace=true" , " ;;" + , " %files)" + , " files=true" + , " ;;" , " esac" , " fi" , "done" diff --git a/src/Options/Applicative/Types.hs b/src/Options/Applicative/Types.hs index e1647d0b..1541989e 100644 --- a/src/Options/Applicative/Types.hs +++ b/src/Options/Applicative/Types.hs @@ -322,15 +322,21 @@ data CompletionItemOptions = CompletionItemOptions { -- -- Set this value to 'False' if the completion is only a prefix of the final -- valid values. - cioAddSpace :: Bool + cioAddSpace :: Bool, + + -- | Whether to treat the completions as file names (if they exists) and + -- add a trailing slash to completions that are directories. + -- Defaults to 'True' + cioFiles :: Bool } instance Semigroup CompletionItemOptions where a <> b = CompletionItemOptions { - cioAddSpace = cioAddSpace a && cioAddSpace b + cioAddSpace = cioAddSpace a && cioAddSpace b, + cioFiles = cioFiles a && cioFiles b } instance Monoid CompletionItemOptions where - mempty = CompletionItemOptions True + mempty = CompletionItemOptions True True mappend = (<>) -- | A shell complete function. From fa008aa2d50f405b7e9e21628429f38ab4d04430 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 1 Mar 2021 16:58:58 +0100 Subject: [PATCH 3/5] Add completion protocol version for backcompat (cherry picked from commit af10154bd6802ba024c9f3bacdcd32204530cca1) --- src/Options/Applicative/BashCompletion.hs | 48 +++++++++++++++++------ tests/test.hs | 20 ++++------ 2 files changed, 42 insertions(+), 26 deletions(-) diff --git a/src/Options/Applicative/BashCompletion.hs b/src/Options/Applicative/BashCompletion.hs index 49ad3c64..cff22498 100644 --- a/src/Options/Applicative/BashCompletion.hs +++ b/src/Options/Applicative/BashCompletion.hs @@ -24,6 +24,16 @@ import Options.Applicative.Types import Options.Applicative.Help.Pretty import Options.Applicative.Help.Chunk +-- | Which features are supported by the calling shell +-- completion integration script +data Features = Features + { richness :: Richness + , protocolVersion :: Int + } + +currentProtocolVerson :: Int +currentProtocolVerson = 1 + -- | Provide basic or rich command completions data Richness = Standard @@ -42,6 +52,19 @@ bashCompletionParser pinfo pprefs = complParser CompletionResult $ \progn -> unlines <$> opts progn + featuresParser :: Parser Features + featuresParser = Features <$> richnessParser <*> protocolVersionParser + + protocolVersionParser :: Parser Int + protocolVersionParser = option auto (long "optparse-completion-version" `mappend` value 0) + + richnessParser :: Parser Richness + richnessParser = + flag' Enriched (long "bash-completion-enriched" `mappend` internal) + <*> option auto (long "bash-completion-option-desc-length" `mappend` internal `mappend` value 40) + <*> option auto (long "bash-completion-command-desc-length" `mappend` internal `mappend` value 40) + <|> pure Standard + scriptRequest = CompletionResult . fmap pure @@ -53,14 +76,11 @@ bashCompletionParser pinfo pprefs = complParser -- the `desc-length` options. -- zsh commands can go on a single line, so they might -- want to be longer. - <$> ( flag' Enriched (long "bash-completion-enriched" `mappend` internal) - <*> option auto (long "bash-completion-option-desc-length" `mappend` internal `mappend` value 40) - <*> option auto (long "bash-completion-command-desc-length" `mappend` internal `mappend` value 40) - <|> pure Standard - ) + <$> featuresParser <*> (many . strOption) (long "bash-completion-word" `mappend` internal) - <*> option auto (long "bash-completion-index" `mappend` internal) ) + <*> option auto (long "bash-completion-index" `mappend` internal) + ) , scriptRequest . bashCompletionScript <$> strOption (long "bash-completion-script" `mappend` internal) @@ -70,8 +90,8 @@ bashCompletionParser pinfo pprefs = complParser strOption (long "zsh-completion-script" `mappend` internal) ] -bashCompletionQuery :: ParserInfo a -> ParserPrefs -> Richness -> [String] -> Int -> String -> IO [String] -bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl pprefs of +bashCompletionQuery :: ParserInfo a -> ParserPrefs -> Features -> [String] -> Int -> String -> IO [String] +bashCompletionQuery pinfo pprefs features ws i _ = case runCompletion compl pprefs of Just (Left (SomeParser p, a)) -> render_items <$> list_options a p Just (Right c) @@ -122,7 +142,7 @@ bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl ppre -- When doing enriched completions, add any help specified -- to the completion variables (tab separated). add_opt_help :: Functor f => Option a -> f String -> f String - add_opt_help opt = case richness of + add_opt_help opt = case richness features of Standard -> id Enriched len _ -> @@ -134,7 +154,7 @@ bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl ppre -- to the completion variables (tab separated). with_cmd_help :: Functor f => f (String, ParserInfo a) -> f String with_cmd_help = - case richness of + case richness features of Standard -> fmap fst Enriched _ len -> @@ -169,6 +189,8 @@ bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl ppre render_items = concatMap render_item render_item :: CompletionItem -> [String] + render_item CompletionItem { ciValue = val } + | protocolVersion features < 1 = [val] render_item CompletionItem { ciOptions = opts, ciValue = val } = [ "%addspace" | cioAddSpace opts ] ++ [ "%files" | cioFiles opts ] @@ -183,7 +205,7 @@ bashCompletionScript prog progn = unlines , " local CMDLINE" , " local value_mode=false" , " local IFS=$'\\n'" - , " CMDLINE=(--bash-completion-index $COMP_CWORD)" + , " CMDLINE=(--bash-completion-index $COMP_CWORD --optparse-completion-version " ++ show currentProtocolVerson ++ ")" , "" , " for arg in ${COMP_WORDS[@]}; do" , " CMDLINE=(${CMDLINE[@]} --bash-completion-word $arg)" @@ -240,7 +262,7 @@ fishCompletionScript prog progn = unlines , " # Hack around fish issue #3934" , " set -l cn (commandline --tokenize --cut-at-cursor --current-process)" , " set -l cn (count $cn)" - , " set -l tmpline --bash-completion-enriched --bash-completion-index $cn" + , " set -l tmpline --bash-completion-enriched --bash-completion-index $cn --optparse-completion-version " ++ show currentProtocolVerson , " for arg in $cl" , " set tmpline $tmpline --bash-completion-word $arg" , " end" @@ -282,7 +304,7 @@ zshCompletionScript prog progn = unlines , "local files=false" , "local index=$((CURRENT - 1))" , "" - , "request=(--bash-completion-enriched --bash-completion-index $index)" + , "request=(--bash-completion-enriched --bash-completion-index $index --optparse-completion-version " ++ show currentProtocolVerson ++ ")" , "for arg in ${words[@]}; do" , " request=(${request[@]} --bash-completion-word $arg)" , "done" diff --git a/tests/test.hs b/tests/test.hs index 128c4c36..57f4ead4 100644 --- a/tests/test.hs +++ b/tests/test.hs @@ -318,12 +318,6 @@ prop_ambiguous = once $ result = execParserPure (prefs disambiguate) i ["--ba"] in assertError result (\_ -> property succeeded) -completionValues :: [String] -> [String] -completionValues ("%value" : v : more) = v : completionValues more -completionValues (('%':_) : more) = completionValues more -completionValues (a:_) = error ("Unexpected non-% line in completions: " <> a) -completionValues [] = [] - 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") @@ -376,7 +370,7 @@ prop_completion = once . ioProperty $ in case result of CompletionInvoked (CompletionResult err) -> do completions <- lines <$> err "test" - return $ ["--foo", "--bar"] === completionValues completions + return $ ["--foo", "--bar"] === completions Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed @@ -391,7 +385,7 @@ prop_completion_opt_after_double_dash = once . ioProperty $ , "--bash-completion-word", "--"] in case result of CompletionInvoked (CompletionResult err) -> do - completions <- completionValues . lines <$> err "test" + completions <- lines <$> err "test" return $ ["bar"] === completions Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed @@ -406,7 +400,7 @@ prop_completion_only_reachable = once . ioProperty $ result = run i ["--bash-completion-index", "0"] in case result of CompletionInvoked (CompletionResult err) -> do - completions <- completionValues . lines <$> err "test" + completions <- lines <$> err "test" return $ ["reachable"] === completions Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed @@ -423,7 +417,7 @@ prop_completion_only_reachable_deep = once . ioProperty $ , "--bash-completion-word", "seen" ] in case result of CompletionInvoked (CompletionResult err) -> do - completions <- completionValues . lines <$> err "test" + completions <- lines <$> err "test" return $ ["now-reachable"] === completions Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed @@ -438,7 +432,7 @@ prop_completion_multi = once . ioProperty $ , "--bash-completion-word", "nope" ] in case result of CompletionInvoked (CompletionResult err) -> do - completions <- completionValues . lines <$> err "test" + completions <- lines <$> err "test" return $ ["reachable"] === completions Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed @@ -452,7 +446,7 @@ prop_completion_rich = once . ioProperty $ result = run i ["--bash-completion-enriched", "--bash-completion-index", "0"] in case result of CompletionInvoked (CompletionResult err) -> do - completions <- completionValues . lines <$> err "test" + completions <- lines <$> err "test" return $ ["--foo\tFo?", "--bar\tBa?"] === completions Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed @@ -469,7 +463,7 @@ prop_completion_rich_lengths = once . ioProperty $ , "--bash-completion-command-desc-length=30"] in case result of CompletionInvoked (CompletionResult err) -> do - completions <- completionValues . lines <$> err "test" + completions <- lines <$> err "test" return $ ["--foo\tFoo...", "--bar\tBar..."] === completions Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed From 77d724897b6349328274aa28e26e04c1fa83db48 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 1 Mar 2021 17:25:13 +0100 Subject: [PATCH 4/5] Test v1 completion protocol (cherry picked from commit 9934680993727f41dc2e6867d92f0d6074d53725) --- src/Options/Applicative.hs | 1 + src/Options/Applicative/BashCompletion.hs | 6 +++++ tests/test.hs | 30 +++++++++++++++++++++++ 3 files changed, 37 insertions(+) diff --git a/src/Options/Applicative.hs b/src/Options/Applicative.hs index 4d84e033..ea4f4b6e 100644 --- a/src/Options/Applicative.hs +++ b/src/Options/Applicative.hs @@ -215,6 +215,7 @@ module Options.Applicative ( Completer, mkCompleter, CompletionItem(..), + CompletionItemOptions(..), mkCompleterWithOptions, listIOCompleter, diff --git a/src/Options/Applicative/BashCompletion.hs b/src/Options/Applicative/BashCompletion.hs index cff22498..20874994 100644 --- a/src/Options/Applicative/BashCompletion.hs +++ b/src/Options/Applicative/BashCompletion.hs @@ -31,6 +31,12 @@ data Features = Features , protocolVersion :: Int } +-- | Version of the output format that the shell integration script +-- expects optparse-applicative to write to stdout. +-- +-- Version increases should be rare, because most changes +-- can be handled by adding a new % keyword. Unknown keywords +-- are ignored by the shell integration scripts. currentProtocolVerson :: Int currentProtocolVerson = 1 diff --git a/tests/test.hs b/tests/test.hs index 57f4ead4..2507276a 100644 --- a/tests/test.hs +++ b/tests/test.hs @@ -468,6 +468,36 @@ prop_completion_rich_lengths = once . ioProperty $ Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed +prop_completion_v1_default :: Property +prop_completion_v1_default = once . ioProperty $ + let p :: Parser String + p = strArgument (completer (mkCompleterWithOptions (pure (pure [CompletionItem mempty "reachable"])))) + i = info p idm + result = run i [ "--optparse-completion-version", "1" + , "--bash-completion-index=0" + ] + in case result of + CompletionInvoked (CompletionResult err) -> do + completions <- lines <$> err "test" + return $ ["%addspace", "%files", "%value", "reachable"] === completions + Failure _ -> return $ counterexample "unexpected failure" failed + Success val -> return $ counterexample ("unexpected result " ++ show val) failed + +prop_completion_v1_minimal :: Property +prop_completion_v1_minimal = once . ioProperty $ + let p :: Parser String + p = strArgument (completer (mkCompleterWithOptions (pure (pure [CompletionItem (mempty { cioAddSpace = False, cioFiles = False }) "reachable"])))) + i = info p idm + result = run i [ "--optparse-completion-version", "1" + , "--bash-completion-index=0" + ] + in case result of + CompletionInvoked (CompletionResult err) -> do + completions <- lines <$> err "test" + return $ ["%value", "reachable"] === completions + Failure _ -> return $ counterexample "unexpected failure" failed + Success val -> return $ counterexample ("unexpected result " ++ show val) failed + prop_bind_usage :: Property prop_bind_usage = once $ let p :: Parser [String] From 15ce2aae46196c5e787dff7002a314debc817c57 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Mon, 1 Mar 2021 17:55:35 +0100 Subject: [PATCH 5/5] CompletionItemOptions: make mempty minimal, add legacyCompletionItemOptions (cherry picked from commit 6df28c2547ccfa012dfa8bb5afbebf9e3c72536b) --- src/Options/Applicative/BashCompletion.hs | 6 +-- src/Options/Applicative/Types.hs | 48 +++++++++++++++++------ tests/test.hs | 8 ++-- 3 files changed, 42 insertions(+), 20 deletions(-) diff --git a/src/Options/Applicative/BashCompletion.hs b/src/Options/Applicative/BashCompletion.hs index 20874994..02eb7af4 100644 --- a/src/Options/Applicative/BashCompletion.hs +++ b/src/Options/Applicative/BashCompletion.hs @@ -126,12 +126,12 @@ bashCompletionQuery pinfo pprefs features ws i _ = case runCompletion compl ppre opt_completions argPolicy reachability opt = case optMain opt of OptReader ns _ _ | argPolicy /= AllPositionals - -> return . fmap defaultCompletionItem . add_opt_help opt $ show_names ns + -> return . fmap legacyCompletionItem . add_opt_help opt $ show_names ns | otherwise -> return [] FlagReader ns _ | argPolicy /= AllPositionals - -> return . fmap defaultCompletionItem . add_opt_help opt $ show_names ns + -> return . fmap legacyCompletionItem . add_opt_help opt $ show_names ns | otherwise -> return [] ArgReader rdr @@ -143,7 +143,7 @@ bashCompletionQuery pinfo pprefs features ws i _ = case runCompletion compl ppre | argumentIsUnreachable reachability -> return [] | otherwise - -> return . fmap defaultCompletionItem . with_cmd_help $ filter (is_completion . fst) ns + -> return . fmap legacyCompletionItem . with_cmd_help $ filter (is_completion . fst) ns -- When doing enriched completions, add any help specified -- to the completion variables (tab separated). diff --git a/src/Options/Applicative/Types.hs b/src/Options/Applicative/Types.hs index 1541989e..2ec355f7 100644 --- a/src/Options/Applicative/Types.hs +++ b/src/Options/Applicative/Types.hs @@ -21,11 +21,12 @@ module Options.Applicative.Types ( Parser(..), ParserM(..), Completer(..), - mkCompleter, mkCompleterWithOptions, + mkCompleter, CompletionItem(..), - defaultCompletionItem, + legacyCompletionItem, CompletionItemOptions(..), + legacyCompletionItemOptions, CompletionResult(..), ParserFailure(..), ParserResult(..), @@ -314,43 +315,64 @@ data CompletionItem = CompletionItem { ciOptions :: CompletionItemOptions, ciValue :: String } -defaultCompletionItem :: String -> CompletionItem -defaultCompletionItem = CompletionItem mempty +-- | A set of defaults that includes the bells and whistles that +-- were previously added by the shell. +-- +-- For the minimal shell behavior, use @'CompletionItem' mempty@ +-- +-- This adds spaces to unambiguous completions (@'cioAddSpace' = True@) and +-- treats the completions as files (@'cioFiles' = True@). +legacyCompletionItem :: String -> CompletionItem +legacyCompletionItem = CompletionItem CompletionItemOptions { cioAddSpace = True, cioFiles = True } data CompletionItemOptions = CompletionItemOptions { - -- | Whether to add a space after the completion. Defaults to 'True'. + -- | Whether to add a space after the completion. -- -- Set this value to 'False' if the completion is only a prefix of the final -- valid values. + -- + -- 'mempty': 'False'. + -- + -- 'legacyCompletionItemOptions': 'True'. + -- cioAddSpace :: Bool, -- | Whether to treat the completions as file names (if they exists) and -- add a trailing slash to completions that are directories. - -- Defaults to 'True' + -- + -- 'mempty': 'False'. + -- + -- 'legacyCompletionItemOptions': 'True'. + -- cioFiles :: Bool } +-- | Combines field-wise. Uses '||' for fields that have 'False' for 'mempty'. instance Semigroup CompletionItemOptions where a <> b = CompletionItemOptions { - cioAddSpace = cioAddSpace a && cioAddSpace b, - cioFiles = cioFiles a && cioFiles b + cioAddSpace = cioAddSpace a || cioAddSpace b, + cioFiles = cioFiles a || cioFiles b } +-- | 'mempty' is minimal. See per-field docs. instance Monoid CompletionItemOptions where - mempty = CompletionItemOptions True True + mempty = CompletionItemOptions False False mappend = (<>) +legacyCompletionItemOptions :: CompletionItemOptions +legacyCompletionItemOptions = CompletionItemOptions { cioAddSpace = True, cioFiles = True } + -- | A shell complete function. newtype Completer = Completer { runCompleter :: String -> IO [CompletionItem] } --- | Smart constructor for a 'Completer' -mkCompleter :: (String -> IO [String]) -> Completer -mkCompleter f = Completer (fmap (map (CompletionItem mempty)) . f) - -- | Smart constructor for a 'Completer' mkCompleterWithOptions :: (String -> IO [CompletionItem]) -> Completer mkCompleterWithOptions = Completer +-- | Smart constructor for a 'Completer' via 'legacyCompletionItem'. +mkCompleter :: (String -> IO [String]) -> Completer +mkCompleter f = Completer (fmap (map legacyCompletionItem) . f) + instance Semigroup Completer where (Completer c1) <> (Completer c2) = Completer $ \s -> (++) <$> c1 s <*> c2 s diff --git a/tests/test.hs b/tests/test.hs index 2507276a..628837aa 100644 --- a/tests/test.hs +++ b/tests/test.hs @@ -468,10 +468,10 @@ prop_completion_rich_lengths = once . ioProperty $ Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed -prop_completion_v1_default :: Property -prop_completion_v1_default = once . ioProperty $ +prop_completion_v1_legacy :: Property +prop_completion_v1_legacy = once . ioProperty $ let p :: Parser String - p = strArgument (completer (mkCompleterWithOptions (pure (pure [CompletionItem mempty "reachable"])))) + p = strArgument (completer (mkCompleterWithOptions (pure (pure [legacyCompletionItem "reachable"])))) i = info p idm result = run i [ "--optparse-completion-version", "1" , "--bash-completion-index=0" @@ -486,7 +486,7 @@ prop_completion_v1_default = once . ioProperty $ prop_completion_v1_minimal :: Property prop_completion_v1_minimal = once . ioProperty $ let p :: Parser String - p = strArgument (completer (mkCompleterWithOptions (pure (pure [CompletionItem (mempty { cioAddSpace = False, cioFiles = False }) "reachable"])))) + p = strArgument (completer (mkCompleterWithOptions (pure (pure [CompletionItem mempty "reachable"])))) i = info p idm result = run i [ "--optparse-completion-version", "1" , "--bash-completion-index=0"