bug#57673: [PATCH] Parse --help messages for pcomplete

[Augusto Stoffel <arstoffel@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 816 bytes --]

Hi Stefan,

I've attached a new iteration of the patch.  I think the git completion
should be pretty usable (but certainly can be refined in the future).
I'm also satisfied with the parser, please have a look if you are
interested.

Next I'd like to think now of a good way to add batches of simpler
commands, say all GNU coreutils.  This would entail repeating variations
of

   (defun pcomplete/gpg ()
     "Completion for the GNU Privacy Guard."
     (while (if (pcomplete-match "\\`-" 0)
                (pcomplete-here (pcomplete-from-help "gpg --help"
                                                     :narrow-end "^ -se"))
              (pcomplete-here (pcomplete-entries)))))

over and over, so I was wondering if it makes sense to add a macro to
help here.  See a suggestion at the end of pcomplete.el.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-pcomplete-Generate-completions-from-help-messages.patch --]
[-- Type: text/x-patch, Size: 22479 bytes --]

From d0b150d8ae742eb5bf329287e73b751f7ab2e2ca Mon Sep 17 00:00:00 2001
From: Augusto Stoffel <arstoffel@gmail.com>
Date: Thu, 8 Sep 2022 11:09:42 +0200
Subject: [PATCH] pcomplete: Generate completions from --help messages

---
 lisp/pcmpl-git.el            | 110 +++++++++++++++++++++++++++
 lisp/pcmpl-gnu.el            |  30 ++++++++
 lisp/pcmpl-rpm.el            |  44 ++++++++++-
 lisp/pcmpl-x.el              |  17 +++++
 lisp/pcomplete.el            | 142 +++++++++++++++++++++++++++++++++++
 test/lisp/pcomplete-tests.el | 100 ++++++++++++++++++++++++
 6 files changed, 442 insertions(+), 1 deletion(-)
 create mode 100644 lisp/pcmpl-git.el
 create mode 100644 test/lisp/pcomplete-tests.el

diff --git a/lisp/pcmpl-git.el b/lisp/pcmpl-git.el
new file mode 100644
index 0000000000..1ff82f2b81
--- /dev/null
+++ b/lisp/pcmpl-git.el
@@ -0,0 +1,110 @@
+;;; pcmpl-git.el --- Completions for Git -*- lexical-binding: t -*-
+
+;; Copyright (C) 2022 Free Software Foundation, Inc.
+
+;; Package: pcomplete
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This library provides completion rules for the Git program.
+
+;;; Code:
+
+(require 'pcomplete)
+(require 'vc-git)
+
+(defun pcmpl-git--expand-flags (args)
+  "In the list of ARGS, expand arguments of the form --[no-]flag."
+  (mapcan (lambda (arg) (if (string-search "[no-]" arg)
+                            (list (string-replace "[no-]" "" arg)
+                                  (string-replace "[no-]" "no-" arg))
+                          (list arg)))
+          args))
+
+(defun pcmpl-git--tracked-file-predicate (&rest args)
+  "Return a predicate function determining if a file is tracked by Git.
+ARGS are passed to the `git ls-files' command."
+  (when-let ((files (mapcar #'expand-file-name
+                            (ignore-errors
+                              (apply #'process-lines
+                                     vc-git-program "ls-files" args)))))
+    (lambda (file)
+      (setq file (expand-file-name file))
+      (if (string-suffix-p "/" file)
+          (seq-some (lambda (f) (string-prefix-p file f))
+                    files)
+        (member file files)))))
+
+(defun pcmpl-git--remote-refs (remote)
+  "List the locally known Git revisions from REMOTE."
+  (delq nil
+        (mapcar
+         (let ((re (concat "\\`" (regexp-quote remote) "/\\(.*\\)")))
+           (lambda (s) (when (string-match re s) (match-string 1 s))))
+         (vc-git-revision-table nil))))
+
+;;;###autoload
+(defun pcomplete/git ()
+  "Completion for the `git' command."
+  (let ((subcmds (pcomplete-from-help `(,vc-git-program "help" "-a")
+                                      :margin "^\\( +\\)[a-z]"
+                                      :argument "[[:alnum:]-]+")))
+    (while (not (member (pcomplete-arg 1) subcmds))
+      (pcomplete-here (completion-table-merge
+                       subcmds
+                       ;; Global switches and their file arguments
+                       (pcomplete-from-help `(,vc-git-program "help")
+                                            :margin "\\(\\[\\)-"
+                                            :separator " | "
+                                            :description "\\`")
+                       (when (pcomplete-match "\\-")
+                         (pcomplete-entries)))))
+    (let ((subcmd (pcomplete-arg 1)))
+      (while (pcase subcmd
+               ((guard (pcomplete-match "\\`-" 0))
+                (pcomplete-here
+                 (pcmpl-git--expand-flags
+                  (pcomplete-from-help `(,vc-git-program "help" ,subcmd)
+                                       :argument
+                                       "-+\\(?:\\[no-\\]\\)?[a-z-]+=?"))))
+               ;; Complete modified tracked files
+               ((or "add" "commit" "restore")
+                (pcomplete-here
+                 (pcomplete-entries nil
+                                    (pcmpl-git--tracked-file-predicate "-m"))))
+               ;; Complete all tracked files
+               ((or "mv" "rm" "grep" "status")
+                (pcomplete-here
+                 (pcomplete-entries nil (pcmpl-git--tracked-file-predicate))))
+               ;; Complete revisions
+               ((or "branch" "merge" "rebase" "switch")
+                (pcomplete-here (vc-git-revision-table nil)))
+               ;; Complete revisions and tracked files
+               ;; TODO: diff and log accept revision ranges
+               ((or "checkout" "reset" "show" "diff" "log")
+                (pcomplete-here
+                 (completion-table-in-turn
+                  (vc-git-revision-table nil)
+                  (pcomplete-entries nil (pcmpl-git--tracked-file-predicate)))))
+               ;; Complete remotes and their revisions
+               ((or "fetch" "pull" "push")
+                (pcomplete-here (process-lines vc-git-program "remote"))
+                (pcomplete-here (pcmpl-git--remote-refs (pcomplete-arg 1)))))))))
+
+(provide 'pcmpl-git)
+;;; pcmpl-git.el ends here
diff --git a/lisp/pcmpl-gnu.el b/lisp/pcmpl-gnu.el
index 3c9bf1ec9d..f957e7cbb4 100644
--- a/lisp/pcmpl-gnu.el
+++ b/lisp/pcmpl-gnu.el
@@ -394,6 +394,36 @@ pcomplete/find
     (while (pcomplete-here (pcomplete-dirs) nil #'identity))))
 
 ;;;###autoload
+(defun pcomplete/awk ()
+  "Completion for the `awk' command."
+  (while (pcomplete-here
+          (completion-table-in-turn
+           (pcomplete-from-help "awk --help"
+                                :margin "\t"
+                                :separator "  +"
+                                :description "\0"
+                                :metavar "[=a-z]+")
+           (pcomplete-entries)))))
+
+;;;###autoload
+(defun pcomplete/gpg ()
+  "Completion for the GNU Privacy Guard."
+  (while (pcomplete-here
+          (completion-table-in-turn
+           (pcomplete-from-help "gpg --help" :narrow-end "^ -se")
+           (pcomplete-entries)))))
+
+;; This is going to get tedious pretty quickly, how about introducing
+;; a macro for the simple cases?
+(define-simple-pcomplete awk "awk --help"
+                         :margin "\t"
+                         :separator "  +"
+                         :description "\0"
+                         :metavar "[=a-z]+")
+(define-simple-pcomplete gpg "gpg --help"  :narrow-end "^ -se")
+(define-simple-pcomplete ls "ls --help")
+(define-simple-pcomplete grep "grep --help")
+
 (defalias 'pcomplete/gdb 'pcomplete/xargs)
 
 ;;; pcmpl-gnu.el ends here
diff --git a/lisp/pcmpl-rpm.el b/lisp/pcmpl-rpm.el
index f7925d9d9e..7c602d0f9b 100644
--- a/lisp/pcmpl-rpm.el
+++ b/lisp/pcmpl-rpm.el
@@ -21,7 +21,8 @@
 
 ;;; Commentary:
 
-;; These functions provide completion rules for the `rpm' command.
+;; These functions provide completion rules for the `rpm' command and
+;; related tools.
 
 ;;; Code:
 
@@ -378,6 +379,47 @@ pcomplete/rpm
        (t
 	(error "You must select a mode: -q, -i, -U, --verify, etc"))))))
 
+;;; DNF
+
+(defvar pcmpl-rpm-dnf-cache-file "/var/cache/dnf/packages.db"
+  "Location of the DNF cache.")
+
+(defun pcmpl-rpm--dnf-packages (status)
+  (when (and (file-exists-p pcmpl-rpm-dnf-cache-file)
+             (executable-find "sqlite3"))
+    (with-temp-message
+        "Getting list of packages..."
+      (process-lines "sqlite3" "-batch" "-init" "/dev/null"
+                     pcmpl-rpm-dnf-cache-file
+                     (pcase-exhaustive status
+                       ('available "select pkg from available")
+                       ('installed "select pkg from installed")
+                       ('not-installed "\
+select pkg from available \
+where pkg not in (select pkg from installed)"))))))
+
+;;;###autoload
+(defun pcomplete/dnf ()
+  "Completion for the `dnf' command."
+  (let ((subcmds (pcomplete-from-help "dnf help"
+                                      :margin "^\\(\\)[a-z-]+  "
+                                      :argument "[a-z-]+")))
+    (while (not (member (pcomplete-arg 1) subcmds))
+      (pcomplete-here (completion-table-merge
+                       subcmds
+                       (pcomplete-from-help "dnf help"))))
+    (let ((subcmd (pcomplete-arg 1)))
+      (while (pcase subcmd
+               ((guard (pcomplete-match "\\`-" 0))
+                (pcomplete-here
+                 (pcomplete-from-help `("dnf" "help" ,subcmd))))
+               ((or "downgrade" "reinstall" "remove")
+                (pcomplete-here (pcmpl-rpm--dnf-packages 'installed)))
+               ((or "install" "mark" "reinstall" "upgrade")
+                (pcomplete-here (pcmpl-rpm--dnf-packages 'not-installed)))
+               ((or "builddep" "changelog" "info" "list" "repoquery" "updateinfo")
+                (pcomplete-here (pcmpl-rpm--dnf-packages 'available))))))))
+
 (provide 'pcmpl-rpm)
 
 ;;; pcmpl-rpm.el ends here
diff --git a/lisp/pcmpl-x.el b/lisp/pcmpl-x.el
index 261a3d4e27..78963410ee 100644
--- a/lisp/pcmpl-x.el
+++ b/lisp/pcmpl-x.el
@@ -321,5 +321,22 @@ pcomplete/bcc32
 ;;;###autoload
 (defalias 'pcomplete/bcc 'pcomplete/bcc32)
 
+;;;###autoload
+(defun pcomplete/rclone ()
+  "Completion for the `rclone' command."
+  (let ((subcmds (pcomplete-from-help "rclone help"
+                                      :margin "^  "
+                                      :argument "[a-z]+"
+                                      :narrow-start "\n\n")))
+    (while (not (member (pcomplete-arg 1) subcmds))
+      (pcomplete-here (completion-table-merge
+                       subcmds
+                       (pcomplete-from-help "rclone help flags"))))
+    (let ((subcmd (pcomplete-arg 1)))
+      (while (if (pcomplete-match "\\`-" 0)
+                 (pcomplete-here (pcomplete-from-help
+                                  `("rclone" ,subcmd "--help")))
+               (pcomplete-here (pcomplete-entries)))))))
+
 (provide 'pcmpl-x)
 ;;; pcmpl-x.el ends here
diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el
index 15b9880df8..3bf0e2be2c 100644
--- a/lisp/pcomplete.el
+++ b/lisp/pcomplete.el
@@ -119,6 +119,9 @@
 ;;; Code:
 
 (require 'comint)
+(eval-when-compile
+  (require 'cl-lib)
+  (require 'rx))
 
 (defgroup pcomplete nil
   "Programmable completion."
@@ -485,6 +488,14 @@ pcomplete-completions-at-point
           (when completion-ignore-case
             (setq table (completion-table-case-fold table)))
           (list beg (point) table
+                :annotation-function
+                (lambda (cand)
+                  (when (stringp cand)
+                    (get-text-property 0 'pcomplete-annotation cand)))
+                :company-docsig
+                (lambda (cand)
+                  (when (stringp cand)
+                    (get-text-property 0 'pcomplete-help cand)))
                 :predicate pred
                 :exit-function
 		;; If completion is finished, add a terminating space.
@@ -1332,6 +1343,137 @@ pcomplete-read-host-names
       (pcomplete-read-hosts pcomplete-hosts-file 'pcomplete--host-name-cache
                    'pcomplete--host-name-cache-timestamp)))
 
+;;; Parsing help messages
+
+(defvar pcomplete-from-help (make-hash-table :test #'equal)
+  "Memoization table for function `pcomplete-from-help'.")
+
+(cl-defun pcomplete-from-help (command
+                               &rest args
+                               &key
+                               (margin (rx bol (+ " ")))
+                               (argument (rx "-" (+ (any "-" alnum)) (? "=")))
+                               (metavar (rx (? " ")
+                                            (or (+ (any alnum "_-"))
+                                                (seq "[" (+? nonl) "]")
+                                                (seq "<" (+? nonl) ">")
+                                                (seq "{" (+? nonl) "}"))))
+                               (separator (rx ", " symbol-start))
+                               (description (rx (* nonl)
+                                                (* "\n" (>= 9 " ") (* nonl))))
+                               narrow-start
+                               narrow-end)
+  "Parse output of COMMAND into a list of completion candidates.
+
+COMMAND can be a list (program name and arguments) or a string to
+be executed in a shell.  It should print a help message.
+
+A list of arguments is collected after each match of MARGIN.
+Each argument should match ARGUMENT, possibly followed by a match
+of METAVAR.  If a match of SEPARATOR follows, then more
+argument-metavar pairs are collected.  Finally, a match of
+DESCRIPTION is collected.
+
+Keyword ARGS:
+
+MARGIN: regular expression after which argument descriptions are
+  to be found.  Parsing continues at the end of the first match
+  group, or at the end of the entire match.
+
+ARGUMENT: regular expression matching an argument name.  The
+  first match group (or the entire match if missing) is collected
+  as the argument name.  Parsing continues at the end of the
+  second matching group (or first group, or entire match).
+
+METAVAR: regular expression matching an argument parameter name.
+  The first match group (or the entire match if missing) is
+  collected as the parameter name and used as completion
+  annotation.  Parsing continues at the end of the second
+  matching group (or first group, or entire match).
+
+SEPARATOR: regular expression matching the separator between
+  arguments.  Parsing continues at the end of the first match
+  group, or at the end of the match.
+
+DESCRIPTION: regular expression matching the description of an
+  argument.  The first match group (or the entire match if
+  missing) is collected as the parameter name and used as
+  completion help.  Parsing continues at the end of the first
+  matching group or entire match.
+
+NARROW-START, NARROW-END: if non-nil, parsing of help message is
+  narrowed to the region between the (end of) the first match of
+  these regular expressions."
+  (with-memoization (gethash (cons command args) pcomplete-from-help)
+    (with-temp-buffer
+      (let ((default-directory (expand-file-name "~/"))
+            (command (if (stringp command)
+                         (list shell-file-name
+                               shell-command-switch
+                               command)
+                       command))
+            i result)
+        (apply #'call-process (car command) nil t nil (cdr command))
+        (goto-char (point-min))
+        (narrow-to-region (or (and narrow-start
+                                   (re-search-forward narrow-start nil t)
+                                   (or (match-beginning 1) (match-beginning 0)))
+                              (point-min))
+                          (or (and narrow-end
+                                   (re-search-forward narrow-end nil t)
+                                   (or (match-beginning 1) (match-beginning 0)))
+                              (point-max)))
+        (goto-char (point-min))
+        (while (re-search-forward margin nil t)
+          (goto-char (or (match-end 1) (match-end 0)))
+          (setq i 0)
+          (while (and (or (zerop i)
+                          (and (looking-at separator)
+                               (goto-char (or (match-end 1)
+                                              (match-end 0)))))
+                      (looking-at argument))
+            (setq i (1+ i))
+            (goto-char (seq-some #'match-end '(2 1 0)))
+            (push (or (match-string 1) (match-string 0)) result)
+            (when (looking-at metavar)
+              (goto-char (seq-some #'match-end '(2 1 0)))
+              (put-text-property 0 1
+                                 'pcomplete-annotation
+                                 (or (match-string 1) (match-string 0))
+                                 (car result))))
+          (when (looking-at description)
+            (goto-char (seq-some #'match-end '(2 1 0)))
+            (let ((help (string-clean-whitespace
+                         (or (match-string 1) (match-string 0))))
+                  (items (take i result)))
+              (while items
+                (put-text-property 0 1 'pcomplete-help help
+                                   (pop items))))))
+        (nreverse result)))))
+
+(defun pcomplete--simple-command (command args)
+  "Helper function for `define-simple-pcomplete'."
+  (while (pcomplete-here
+          (completion-table-merge
+           (apply #'pcomplete-from-help command args)
+           (pcomplete-entries)))))
+
+;; What do you think of a macro like this?
+(defmacro define-simple-pcomplete (name command &rest args)
+  "Create `pcomplete' completions for a simple command.
+COMMAND and ARGS are as in `pcomplete-from-help'.  Completion
+candidates for this command will include the parsed arguments as
+well as files."
+  (let* ((namestr (symbol-name name))
+         (docstring (if-let ((i (string-search "/" namestr)))
+                       (format "Completions for the `%s' command in `%s'."
+                               (substring namestr 0 i)
+                               (substring namestr i))
+                     (format "Completions for the `%s' command." namestr))))
+    `(defun ,(intern (concat "pcomplete/" namestr)) ()
+       ,docstring
+       (pcomplete--simple-command ,command ',args))))
+
 (provide 'pcomplete)
 
 ;;; pcomplete.el ends here
diff --git a/test/lisp/pcomplete-tests.el b/test/lisp/pcomplete-tests.el
new file mode 100644
index 0000000000..00a82502f3
--- /dev/null
+++ b/test/lisp/pcomplete-tests.el
@@ -0,0 +1,100 @@
+;;; pcomplete-tests.el --- Tests for pcomplete.el  -*- lexical-binding: t -*-
+
+;; Copyright (C) 2022 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+(require 'pcomplete)
+
+(ert-deftest pcomplete-test-parse-gpg-help ()
+  (cl-letf ((pcomplete-from-help (make-hash-table :test #'equal))
+            ((symbol-function 'call-process)
+             (lambda (&rest _) (insert "\
+gpg (GnuPG) 2.3.7
+
+Commands:
+
+ -s, --sign                         make a signature
+     --clear-sign                   make a clear text signature
+ -b, --detach-sign                  make a detached signature
+     --tofu-policy VALUE            set the TOFU policy for a key
+
+Options to specify keys:
+ -r, --recipient USER-ID            encrypt for USER-ID
+ -u, --local-user USER-ID           use USER-ID to sign or decrypt
+
+(See the man page for a complete listing of all commands and options)
+
+Examples:
+
+ -se -r Bob [file]          sign and encrypt for user Bob
+ --clear-sign [file]        make a clear text signature
+"))))
+    (should
+     (equal-including-properties
+      (pcomplete-from-help "gpg --help" :narrow-end "^ -se")
+      '(#("-s" 0 1 (pcomplete-help "make a signature"))
+        #("--sign" 0 1 (pcomplete-help "make a signature"))
+        #("--clear-sign" 0 1 (pcomplete-help "make a clear text signature"))
+        #("-b" 0 1 (pcomplete-help "make a detached signature"))
+        #("--detach-sign" 0 1 (pcomplete-help "make a detached signature"))
+        #("--tofu-policy" 0 1
+          (pcomplete-help "set the TOFU policy for a key" pcomplete-annotation " VALUE"))
+        #("-r" 0 1 (pcomplete-help "encrypt for USER-ID"))
+        #("--recipient" 0 1
+          (pcomplete-help "encrypt for USER-ID" pcomplete-annotation " USER-ID"))
+        #("-u" 0 1
+          (pcomplete-help "use USER-ID to sign or decrypt"))
+        #("--local-user" 0 1
+          (pcomplete-help "use USER-ID to sign or decrypt" pcomplete-annotation " USER-ID")))))))
+
+(ert-deftest pcomplete-test-parse-git-help ()
+  (cl-letf ((pcomplete-from-help (make-hash-table :test #'equal))
+            ((symbol-function 'call-process)
+             (lambda (&rest _) (insert "\
+usage: git [-v | --version] [-h | --help] [-C <path>] [-c <name>=<value>]
+           [--exec-path[=<path>]] [--html-path] [--man-path] [--info-path]
+           [-p | --paginate | -P | --no-pager] [--no-replace-objects] [--bare]
+           [--git-dir=<path>] [--work-tree=<path>] [--namespace=<name>]
+           [--super-prefix=<path>] [--config-env=<name>=<envvar>]
+           <command> [<args>]
+"))))
+    (should
+     (equal-including-properties
+      (pcomplete-from-help "git help"
+                           :margin "\\(\\[\\)-"
+                           :separator " | "
+                           :description "\\`")
+      '("-v" "--version" "-h" "--help"
+        #("-C" 0 1 (pcomplete-annotation " <path>"))
+        #("-c" 0 1 (pcomplete-annotation " <name>"))
+        #("--exec-path" 0 1 (pcomplete-annotation "[=<path>]"))
+        "--html-path" "--man-path" "--info-path"
+        "-p" "--paginate" "-P" "--no-pager"
+        "--no-replace-objects" "--bare"
+        #("--git-dir=" 0 1 (pcomplete-annotation "<path>"))
+        #("--work-tree=" 0 1 (pcomplete-annotation "<path>"))
+        #("--namespace=" 0 1 (pcomplete-annotation "<name>"))
+        #("--super-prefix=" 0 1 (pcomplete-annotation "<path>"))
+        #("--config-env=" 0 1 (pcomplete-annotation "<name>")))))))
+
+(provide 'pcomplete-tests)
+;;; pcomplete-tests.el ends here
-- 
2.37.3