diff --git a/CHANGELOG.md b/CHANGELOG.md index 81c4d2e2..baadf1f5 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.17.0.0 (1 Feb 2022) - Make tabulation width configurable in usage texts. diff --git a/src/Options/Applicative.hs b/src/Options/Applicative.hs index de467e45..24504cb4 100644 --- a/src/Options/Applicative.hs +++ b/src/Options/Applicative.hs @@ -213,6 +213,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 7a9a1109..29c2bf5b 100644 --- a/src/Options/Applicative/BashCompletion.hs +++ b/src/Options/Applicative/BashCompletion.hs @@ -67,9 +67,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 @@ -94,12 +94,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 @@ -111,7 +111,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). @@ -148,7 +148,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 @@ -159,11 +159,21 @@ 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] + bashCompletionScript :: String -> String -> IO [String] bashCompletionScript prog progn = return + -- 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)" , "" @@ -171,7 +181,23 @@ bashCompletionScript prog progn = return , " 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 ] @@ -205,11 +231,23 @@ fishCompletionScript prog progn = return , " 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" @@ -219,11 +257,15 @@ fishCompletionScript prog progn = return zshCompletionScript :: String -> String -> IO [String] zshCompletionScript prog progn = return + -- 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)" @@ -231,24 +273,41 @@ zshCompletionScript prog progn = return , " 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 4ae75df3..1fa562f4 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