Allow completers to disable unwanted shell behaviors

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.

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,

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"
   ]

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