[elpa] externals/marginalia 237a620 001/241: initial prototype

[Stefan Monnier]

branch: externals/marginalia
commit 237a6206cff95a15db5b29293ab0a4987eceeb41
Author: Daniel Mendler <mail@daniel-mendler.de>
Commit: Daniel Mendler <mail@daniel-mendler.de>

    initial prototype
---
 marginalia.el | 269 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 269 insertions(+)

diff --git a/marginalia.el b/marginalia.el
new file mode 100644
index 0000000..f49d179
--- /dev/null
+++ b/marginalia.el
@@ -0,0 +1,269 @@
+;;; marginalia.el --- Enrich existing commands with completion annotations -*- 
lexical-binding: t -*-
+
+;; Author: Omar Antolín Camarena, Daniel Mendler
+;; Maintainer: Omar Antolín Camarena, Daniel Mendler
+;; Created: 2020
+;; License: GPL-3.0-or-later
+;; Version: 0.1
+;; Package-Requires: ((emacs "26.1"))
+;; Homepage: https://github.com/minad/marginalia
+
+;; This file is not part of GNU Emacs.
+
+;; This program 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.
+
+;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Enrich existing commands with completion annotations
+
+;;; Code:
+
+(require 'subr-x)
+
+;;;; Customization
+
+(defgroup marginalia nil
+  "Enrich existing commands with completion annotations."
+  :group 'convenience
+  :prefix "marginalia-")
+
+(defface marginalia-key
+  '((t :inherit font-lock-keyword-face :weight normal))
+  "Face used to highlight keys in `marginalia-mode'."
+  :group 'marginalia)
+
+(defface marginalia-variable
+  '((t :inherit marginalia-key))
+  "Face used to highlight variable values in `marginalia-mode'."
+  :group 'marginalia)
+
+(defface marginalia-annotation
+  '((t :inherit completions-annotations :weight normal))
+  "Face used to highlight documentation string in `marginalia-mode'."
+  :group 'marginalia)
+
+(defcustom marginalia-annotation-width 80
+  "Width of annotation string."
+  :type 'integer
+  :group 'marginalia)
+
+(defcustom marginalia-annotate-alist
+  '((command . marginalia-annotate-command-binding)
+    (customize-group . marginalia-annotate-customize-group)
+    (variable . marginalia-annotate-variable)
+    (face . marginalia-annotate-face)
+    (symbol . marginalia-annotate-symbol)
+    (variable . marginalia-annotate-variable)
+    (package . marginalia-annotate-package))
+  "Associating categories with annotation functions for minibuffer completion.
+The annotation function must return a string,
+which is appended to the completion candidate.
+Annotations are only shown if `marginalia-mode' is enabled."
+  :type '(alist :key-type symbol :value-type function)
+  :group 'marginalia)
+
+(defcustom marginalia-category-alist
+  '((execute-extended-command . command)
+    (customize-face . face)
+    (customize-face-other-window . face)
+    (customize-group . customize-group)
+    (customize-group-other-window . customize-group)
+    (customize-option . variable)
+    (customize-option-other-window . variable)
+    (customize-set-variable . variable)
+    (customize-variable . variable)
+    (customize-variable-other-window . variable)
+    (describe-function . symbol)
+    (describe-variable . variable)
+    (describe-face . face)
+    (describe-symbol . symbol)
+    (helpful-callable . symbol)
+    (helpful-command . symbol)
+    (helpful-function . symbol)
+    (helpful-macro . symbol)
+    (helpful-symbol . symbol)
+    (helpful-variable . variable)
+    (describe-package . package)
+    (package-install . package)
+    (package-delete . package)
+    (package-reinstall . package))
+  "Associate commands with a completion category."
+  :type '(alist :key-type symbol :value-type symbol)
+  :group 'marginalia)
+
+;;;; Pre-declarations for external packages
+
+(defvar selectrum-highlight-candidates-function)
+(defvar package--builtins)
+(defvar package-alist)
+(defvar package-archive-contents)
+(declare-function package-desc-summary "package")
+(declare-function package--from-builtin "package")
+
+;;;; Marginalia mode
+
+(defvar marginalia--this-command nil
+  "Last command symbol saved in order to allow annotations.")
+
+(defun marginalia--truncate (str width)
+  "Truncate string STR to WIDTH."
+  (truncate-string-to-width (car (split-string str "\n")) width 0 32 "…"))
+
+(defun marginalia-annotate-command-binding (cand)
+  "Annotate command CAND with keybinding."
+  ;; Taken from Emacs 28, read-extended-command--annotation
+  (when-let* ((binding (where-is-internal (intern cand) overriding-local-map 
t))
+              (desc (and (not (stringp binding)) (key-description binding))))
+    (propertize (format " (%s)" desc) 'face 'marginalia-key)))
+
+(defun marginalia-annotate-command-full (cand)
+  "Annotate command CAND with the keybinding and its documentation string."
+  (concat
+   (marginalia-annotate-command-binding cand)
+   (marginalia-annotate-symbol cand)))
+
+(defun marginalia--annotation (ann)
+  "Format annotation string ANN."
+  (concat " "
+          (propertize
+           " "
+           'display
+           '(space :align-to (- right-fringe marginalia-annotation-width)))
+          (propertize (marginalia--truncate ann marginalia-annotation-width)
+                      'face 'marginalia-annotation)))
+
+(defun marginalia-annotate-symbol (cand)
+  "Annotate symbol CAND with its documentation string."
+  (when-let (doc (let ((sym (intern cand)))
+                   (cond
+                    ((fboundp sym) (ignore-errors (documentation sym)))
+                    ((facep sym) (documentation-property sym 
'face-documentation))
+                    (t (documentation-property sym 'variable-documentation)))))
+    (marginalia--annotation doc)))
+
+(defun marginalia-annotate-variable (cand)
+  "Annotate variable CAND with its documentation string."
+  (let ((sym (intern cand)))
+    (when-let (doc (documentation-property sym 'variable-documentation))
+      (concat " "
+              (propertize
+               " "
+               'display
+               '(space :align-to (- right-fringe marginalia-annotation-width 
30)))
+              (propertize (marginalia--truncate (format "%S" (if (boundp sym)
+                                                              (symbol-value 
sym)
+                                                            'unbound))
+                                             40)
+                          'face 'marginalia-variable)
+              "    "
+              (propertize (marginalia--truncate doc 
marginalia-annotation-width)
+                          'face 'marginalia-annotation)))))
+
+(defun marginalia-annotate-face (cand)
+  "Annotate face CAND with documentation string and face example."
+  (let ((sym (intern cand)))
+    (when-let (doc (documentation-property sym 'face-documentation))
+      (concat " "
+              (propertize
+               " "
+               'display
+               '(space :align-to (- right-fringe marginalia-annotation-width 
30)))
+              (propertize "abcdefghijklmNOPQRSTUVWXYZ" 'face sym)
+              "    "
+              (propertize (marginalia--truncate doc 
marginalia-annotation-width)
+                          'face 'marginalia-annotation)))))
+
+(defun marginalia-annotate-package (cand)
+  "Annotate package CAND with its description summary."
+  (when-let* ((pkg (intern (replace-regexp-in-string "-[[:digit:]\\.-]+$" "" 
cand)))
+              ;; taken from embark.el, originally `describe-package-1`
+              (desc (or (car (alist-get pkg package-alist))
+                        (if-let ((built-in (assq pkg package--builtins)))
+                            (package--from-builtin built-in)
+                          (car (alist-get pkg package-archive-contents))))))
+    (marginalia--annotation (package-desc-summary desc))))
+
+(defun marginalia-annotate-customize-group (cand)
+  "Annotate customization group CAND with its documentation string."
+  (when-let (doc (documentation-property (intern cand) 'group-documentation))
+    (marginalia--annotation doc)))
+
+(defun marginalia--annotate-candidates (candidates)
+  "Annotate CANDIDATES with richer information."
+  (if-let* ((cat (marginalia--category-type))
+            (annotate (alist-get cat marginalia-annotate-alist)))
+      (mapcar (lambda (cand) (concat cand (funcall annotate cand))) candidates)
+    candidates))
+
+(defun marginalia--completion-metadata-get (fun metadata prop)
+  "Advice for `completion-metadata-get'.
+Replaces the category and annotation function.
+FUN is the original function.
+METADATA is the metadata.
+PROP is the property which is looked up."
+  ;; TODO add more category classifiers from Embark
+  (pcase prop
+    ('annotation-function
+     (or (and (not (bound-and-true-p selectrum-mode)) ;; TODO Still using the 
selectrum-highlighting function
+              (when-let (cat (marginalia--category-type))
+                (alist-get cat marginalia-annotate-alist)))
+         (funcall fun metadata prop)))
+    ('category
+     (or (and marginalia--this-command
+              (alist-get marginalia--this-command marginalia-category-alist))
+         (funcall fun metadata prop)))
+    (_ (funcall fun metadata prop))))
+
+(defun marginalia--minibuffer-setup ()
+  "Setup minibuffer for `marginalia-mode'.
+Remember `this-command' for annotation and replace highlighting function."
+  (setq-local marginalia--this-command this-command)
+  (when (boundp 'selectrum-highlight-candidates-function)
+    (let ((orig selectrum-highlight-candidates-function))
+      (setq-local selectrum-highlight-candidates-function
+                  (lambda (input candidates)
+                    (marginalia--annotate-candidates (funcall orig input 
candidates)))))))
+
+(defun marginalia--metadata ()
+  "Return current minibuffer completion metadata."
+  (completion-metadata
+   (buffer-substring-no-properties (field-beginning) (point))
+   minibuffer-completion-table
+   minibuffer-completion-predicate))
+
+(defun marginalia--category-type ()
+  "Return minibuffer completion category per metadata."
+  (completion-metadata-get (marginalia--metadata) 'category))
+
+;;;###autoload
+(define-minor-mode marginalia-mode
+  "Annotate completion candidates with richer information."
+  :global t
+
+  ;; Reset first to get a clean slate.
+  (advice-remove #'completion-metadata-get 
#'marginalia--completion-metadata-get)
+  (remove-hook 'minibuffer-setup-hook #'marginalia--minibuffer-setup)
+
+  ;; Now add our tweaks.
+  (when marginalia-mode
+    ;; Ensure that we remember this-command in order to select the annotation 
function.
+    (add-hook 'minibuffer-setup-hook #'marginalia--minibuffer-setup)
+
+    ;; Replace the metadata function.
+    ;; TODO unfortunately annotations are not shown in the icomplete-vertical 
minibuffer it seem
+    ;; https://github.com/oantolin/icomplete-vertical/issues/16
+    (advice-add #'completion-metadata-get :around 
#'marginalia--completion-metadata-get)))
+
+(provide 'marginalia)
+;;; marginalia.el ends here