Refine 'help--keys-narrow-to-minor'

diff --git a/lisp/help.el b/lisp/help.el
index 028c0697caf2b1e88b1e8192b6d5cd5081d12cf5..ac35621d1e2d1040ec0cc0f27c469ffb20166e44 100644 (file)
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -537,11 +537,72 @@ a minor mode."
   (cons (lambda (cand) (eq (get-text-property 0 'source cand) 'global))
         "keymap=global"))
 
+;; (defun help--keys-narrow-to-minor ()
+;;   (cons (lambda (cand)
+;;           (memq (get-text-property 0 'source cand) minor-mode-list))
+;;         "keymap=minor"))
+
+(defvar crm-current-separator)
+
 (defun help--keys-narrow-to-minor ()
-  (cons (lambda (cand)
-          ;; TODO - Prompt for specific minor modes.
-          (memq (get-text-property 0 'source cand) minor-mode-list))
-        "keymap=minor"))
+  (let ((cands
+         (let* ((beg (minibuffer-prompt-end))
+                (end (point-max))
+                (input (buffer-substring beg end))
+                (all (completion-all-completions
+                      input
+                      minibuffer-completion-table
+                      minibuffer-completion-predicate
+                      (- (point) beg)
+                      (completion--field-metadata beg)))
+                (last (last all)))
+           (when (consp last) (setcdr last nil))
+           all))
+        (modes nil))
+    (dolist (cand cands)
+      (let ((source (get-text-property 0 'source cand)))
+        (unless (or (memq source '(global local))
+                    (memq source modes))
+          (push source modes))))
+    (let* ((names (mapcar
+                   (compose (apply-partially #'string-replace "-mode" "")
+                            #'symbol-name)
+                   modes))
+           (max (seq-max (cons 0 (mapcar #'string-width names))))
+           (choices
+            (mapcar
+             (lambda (choice) (intern (concat choice "-mode")))
+             (completing-read-multiple
+              "Restrict to mode: "
+              (completion-table-with-metadata
+               names
+               `((annotation-function
+                  . ,(lambda (cand)
+                       (let* ((sym (intern (concat cand "-mode")))
+                              (doc (ignore-errors (documentation sym))))
+                         (when doc
+                           (concat
+                            (make-string
+                             (- (+ max 2) (string-width cand)) ?\s)
+                            (propertize
+                             (substring doc 0 (string-search "\n" doc))
+                             'face 'completions-annotations))))))
+                 (sort-function
+                  . ,(lambda (unsorted)
+                       (sort unsorted :key
+                             (lambda (cand)
+                               ;; Put already selected candidates last.
+                               (list (member cand
+                                             (split-string
+                                              (minibuffer-contents)
+                                              crm-current-separator t))
+                                     cand)))))))
+              nil t))))
+      (cons
+       (lambda (cand) (memq (get-text-property 0 'source cand) choices))
+       (format (if (cdr choices)
+                   (format "keymap∈{%s}" (mapconcat #'symbol-name choices ","))
+                 (format "keymap=%s" (symbol-name (car choices)))))))))
 
 (defun help--read-keybinding (prefix keymaps bindings alist)
   "Read a keybinding among BINDINGS to complete PREFIX in KEYMAPS."