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..ea4f4b6e 100644 --- a/src/Options/Applicative.hs +++ b/src/Options/Applicative.hs @@ -214,6 +214,9 @@ module Options.Applicative ( -- convenience, to use 'bashCompleter' and 'listCompleter' as a 'Mod'. Completer, mkCompleter, + CompletionItem(..), + CompletionItemOptions(..), + mkCompleterWithOptions, listIOCompleter, listCompleter, diff --git a/src/Options/Applicative/BashCompletion.hs b/src/Options/Applicative/BashCompletion.hs index e4b6356c..02eb7af4 100644 --- a/src/Options/Applicative/BashCompletion.hs +++ b/src/Options/Applicative/BashCompletion.hs @@ -24,6 +24,22 @@ 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 + } + +-- | 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 + -- | Provide basic or rich command completions data Richness = Standard @@ -42,6 +58,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 +82,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,12 +96,12 @@ 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)) - -> 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 +126,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 legacyCompletionItem . add_opt_help opt $ show_names ns | otherwise -> return [] FlagReader ns _ | argPolicy /= AllPositionals - -> return . add_opt_help opt $ show_names ns + -> return . fmap legacyCompletionItem . add_opt_help opt $ show_names ns | otherwise -> return [] ArgReader rdr @@ -117,12 +143,12 @@ 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 legacyCompletionItem . with_cmd_help $ filter (is_completion . fst) ns -- 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 +160,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 -> @@ -154,7 +180,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,20 +191,52 @@ 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 { ciValue = val } + | protocolVersion features < 1 = [val] + render_item CompletionItem { ciOptions = opts, ciValue = val } = + [ "%addspace" | cioAddSpace opts ] + ++ [ "%files" | cioFiles 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)" + , " CMDLINE=(--bash-completion-index $COMP_CWORD --optparse-completion-version " ++ show currentProtocolVerson ++ ")" , "" , " for arg in ${COMP_WORDS[@]}; do" , " CMDLINE=(${CMDLINE[@]} --bash-completion-word $arg)" , " done" , "" - , " COMPREPLY=( $(" ++ prog ++ " \"${CMDLINE[@]}\") )" + , " compopt -o nospace +o filenames" + , " 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" + , " ;;" + , " %files)" + , " compopt -o filenames" + , " ;;" + , " esac" + , " fi" + , " done" , "}" , "" , "complete -o filenames -F _" ++ progn ++ " " ++ progn ] @@ -210,15 +268,27 @@ 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" - , " 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,36 +299,61 @@ 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)" + , "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" , "" - , "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" + , " files=false" , " else" - , " compadd -f -- $word" + , " case $word in" + , " %value)" + , " value_mode=true" + , " ;;" + , " %addspace)" + , " addspace=true" + , " ;;" + , " %files)" + , " files=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..2ec355f7 100644 --- a/src/Options/Applicative/Types.hs +++ b/src/Options/Applicative/Types.hs @@ -21,7 +21,12 @@ module Options.Applicative.Types ( Parser(..), ParserM(..), Completer(..), + mkCompleterWithOptions, mkCompleter, + CompletionItem(..), + legacyCompletionItem, + CompletionItemOptions(..), + legacyCompletionItemOptions, CompletionResult(..), ParserFailure(..), ParserResult(..), @@ -306,13 +311,67 @@ instance Alternative Parser where many = fromM . manyM some = fromM . someM +data CompletionItem = CompletionItem { + ciOptions :: CompletionItemOptions, + ciValue :: String +} +-- | 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. + -- + -- 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. + -- + -- '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 + } +-- | 'mempty' is minimal. See per-field docs. +instance Monoid CompletionItemOptions where + mempty = CompletionItemOptions False False + mappend = (<>) + +legacyCompletionItemOptions :: CompletionItemOptions +legacyCompletionItemOptions = CompletionItemOptions { cioAddSpace = True, cioFiles = True } + -- | A shell complete function. newtype Completer = Completer - { runCompleter :: String -> IO [String] } + { runCompleter :: String -> IO [CompletionItem] } -- | 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 = Completer +mkCompleter f = Completer (fmap (map legacyCompletionItem) . f) instance Semigroup Completer where (Completer c1) <> (Completer c2) = diff --git a/tests/test.hs b/tests/test.hs index 4c888dca..628837aa 100644 --- a/tests/test.hs +++ b/tests/test.hs @@ -318,7 +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") @@ -469,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_legacy :: Property +prop_completion_v1_legacy = once . ioProperty $ + let p :: Parser String + p = strArgument (completer (mkCompleterWithOptions (pure (pure [legacyCompletionItem "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 "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]