From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Juri Linkov Newsgroups: gmane.emacs.devel Subject: Re: on helm substantial differences Date: Wed, 18 Nov 2020 21:13:40 +0200 Organization: LINKOV.NET Message-ID: <87ft56h6sr.fsf@mail.linkov.net> References: <87wnymda5g.fsf@mail.linkov.net> <87ima5he8j.fsf@mail.linkov.net> <87mtzfzt9a.fsf@mail.linkov.net> <87lfezd8r0.fsf@mail.linkov.net> <87k0uj58ub.fsf@mail.linkov.net> <87lfey28us.fsf@tcd.ie> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="37385"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/28.0.50 (x86_64-pc-linux-gnu) Cc: spacibba@aol.com, Jean Louis , andreyk.mad@gmail.com, emacs-devel@gnu.org, rudalics@gmx.at, Stefan Monnier , Gregory Heytings , Eli Zaretskii , Drew Adams To: "Basil L. Contovounesios" Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Wed Nov 18 21:01:16 2020 Return-path: Envelope-to: ged-emacs-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1kfTdj-0009co-T7 for ged-emacs-devel@m.gmane-mx.org; Wed, 18 Nov 2020 21:01:16 +0100 Original-Received: from localhost ([::1]:42240 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kfTdi-0005cA-Ou for ged-emacs-devel@m.gmane-mx.org; Wed, 18 Nov 2020 15:01:14 -0500 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:51072) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kfTcN-0004m8-C3 for emacs-devel@gnu.org; Wed, 18 Nov 2020 14:59:51 -0500 Original-Received: from relay3-d.mail.gandi.net ([217.70.183.195]:43455) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kfTcK-0006n4-Fp; Wed, 18 Nov 2020 14:59:51 -0500 X-Originating-IP: 91.129.97.46 Original-Received: from mail.gandi.net (m91-129-97-46.cust.tele2.ee [91.129.97.46]) (Authenticated sender: juri@linkov.net) by relay3-d.mail.gandi.net (Postfix) with ESMTPSA id DA37060003; Wed, 18 Nov 2020 19:59:33 +0000 (UTC) In-Reply-To: <87lfey28us.fsf@tcd.ie> (Basil L. Contovounesios's message of "Wed, 18 Nov 2020 11:38:19 +0000") Received-SPF: pass client-ip=217.70.183.195; envelope-from=juri@linkov.net; helo=relay3-d.mail.gandi.net X-detected-operating-system: by eggs.gnu.org: First seen = 2020/11/18 14:59:46 X-ACL-Warn: Detected OS = Linux 3.11 and newer [fuzzy] X-Spam_score_int: -18 X-Spam_score: -1.9 X-Spam_bar: - X-Spam_report: (-1.9 / 5.0 requ) BAYES_00=-1.9, RCVD_IN_MSPIKE_H3=0.001, RCVD_IN_MSPIKE_WL=0.001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.23 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Original-Sender: "Emacs-devel" Xref: news.gmane.io gmane.emacs.devel:259382 Archived-At: --=-=-= Content-Type: text/plain >> - (+ (string-width (car s)) >> - (string-width (cadr s))) >> + (cl-reduce #'+ (mapcar #'string-width s)) > > Nit: If you're calling mapcar anyway, why not simply (apply #'+ 0 ...)? Thanks, fixed. Now the patch also adds a new user option 'completions-detailed'. An option separate from 'completions-format' is needed in case when a completion function doesn't provide :affix-function, so there is a need to fall back to the customized value of 'completions-format'. --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=completions-detailed.patch diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 170f497541..de4005d6cd 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -127,16 +127,45 @@ help-enable-completion-autoload :version "26.3") (defun help--symbol-completion-table (string pred action) - (when help-enable-completion-autoload - (let ((prefixes (radix-tree-prefixes (help-definition-prefixes) string))) - (help--load-prefixes prefixes))) - (let ((prefix-completions - (and help-enable-completion-autoload - (mapcar #'intern (all-completions string definition-prefixes))))) - (complete-with-action action obarray string - (if pred (lambda (sym) - (or (funcall pred sym) - (memq sym prefix-completions))))))) + (if (eq action 'metadata) + (when completions-detailed + '(metadata + (affix-function + . (lambda (completions) + (mapcar (lambda (c) + (let* ((s (intern c)) + (doc (condition-case nil (documentation s) (error nil))) + (doc (and doc (substring doc 0 (string-match "\n" doc))))) + (list c (concat (cond ((commandp s) + "c") + ((eq (car-safe (symbol-function s)) 'macro) + "m") + ((fboundp s) + "f") + ((custom-variable-p s) + "u") ; user option + ((boundp s) + "v") + ((facep s) + "a") + ((and (fboundp 'cl-find-class) + (cl-find-class s)) + "t") ; CL type + (" ")) + " ") + (if doc (format " -- %s" doc) "")))) + completions))))) + + (when help-enable-completion-autoload + (let ((prefixes (radix-tree-prefixes (help-definition-prefixes) string))) + (help--load-prefixes prefixes))) + (let ((prefix-completions + (and help-enable-completion-autoload + (mapcar #'intern (all-completions string definition-prefixes))))) + (complete-with-action action obarray string + (if pred (lambda (sym) + (or (funcall pred sym) + (memq sym prefix-completions)))))))) (defvar describe-function-orig-buffer nil "Buffer that was current when `describe-function' was invoked. diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 9d57a817b2..7e1d806059 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -83,7 +80,6 @@ ;; - add support for ** to pcm. ;; - Add vc-file-name-completion-table to read-file-name-internal. -;; - A feature like completing-help.el. ;;; Code: @@ -121,6 +117,9 @@ completion-metadata - `annotation-function': function to add annotations in *Completions*. Takes one argument (STRING), which is a possible completion and returns a string to append to STRING. +- `affix-function': function to prepend/append a prefix/suffix to entries. + Takes one argument (COMPLETIONS) and should return a list + of completions with a completion, its prefix and suffix. - `display-sort-function': function to sort entries in *Completions*. Takes one argument (COMPLETIONS) and should return a new list of completions. Can operate destructively. @@ -1669,7 +1668,7 @@ completion-in-region--single-word (#b000 nil) (_ t)))) -(defface completions-annotations '((t :inherit italic)) +(defface completions-annotations '((t :inherit (italic shadow))) "Face to use for annotations in the *Completions* buffer.") (defcustom completions-format 'horizontal @@ -1681,6 +1680,16 @@ completions-format :type '(choice (const horizontal) (const vertical)) :version "23.2") +(defcustom completions-detailed nil + "When non-nil, display completions vertically with one completion per row. +This option overrides another related option `completions-format'. +Some commands might provide a detailed view with more information added +to completions. When the used completion function doesn't provide +a detailed view via `affix-function', then fall back to the value +defined by `completions-format'." + :type 'boolean + :version "28.1") + (defun completion--insert-strings (strings) "Insert a list of STRINGS into the current buffer. Uses columns to keep the listing readable but compact. @@ -1689,8 +1698,7 @@ completion--insert-strings (let* ((length (apply #'max (mapcar (lambda (s) (if (consp s) - (+ (string-width (car s)) - (string-width (cadr s))) + (apply #'+ (mapcar #'string-width s)) (string-width s))) strings))) (window (get-buffer-window (current-buffer) 0)) @@ -1715,10 +1723,14 @@ completion--insert-strings ;; FIXME: `string-width' doesn't pay attention to ;; `display' properties. (let ((length (if (consp str) - (+ (string-width (car str)) - (string-width (cadr str))) + (apply #'+ (mapcar #'string-width str)) (string-width str)))) (cond + ((and completions-detailed (= (length str) 3)) + ;; Detailed view + ;; When `str' contains prefix and suffix this means + ;; that caller specified `affix-function'. + ) ((eq completions-format 'vertical) ;; Vertical format (when (> row rows) @@ -1754,14 +1766,27 @@ completion--insert-strings (if (not (consp str)) (put-text-property (point) (progn (insert str) (point)) 'mouse-face 'highlight) - (put-text-property (point) (progn (insert (car str)) (point)) - 'mouse-face 'highlight) - (let ((beg (point)) - (end (progn (insert (cadr str)) (point)))) - (put-text-property beg end 'mouse-face nil) - (font-lock-prepend-text-property beg end 'face - 'completions-annotations))) + (let* ((prefix (when (nth 2 str) (nth 1 str))) + (suffix (or (nth 2 str) (nth 1 str)))) + (when prefix + (let ((beg (point)) + (end (progn (insert prefix) (point)))) + (put-text-property beg end 'mouse-face nil) + (font-lock-prepend-text-property beg end 'face + 'completions-annotations))) + (put-text-property (point) (progn (insert (car str)) (point)) + 'mouse-face 'highlight) + (let ((beg (point)) + (end (progn (insert suffix) (point)))) + (put-text-property beg end 'mouse-face nil) + (font-lock-prepend-text-property beg end 'face + 'completions-annotations)))) (cond + ((and completions-detailed (= (length str) 3)) + ;; Detailed view + (when (zerop row) (setq truncate-lines t)) + (insert "\n") + (setq row (1+ row))) ((eq completions-format 'vertical) ;; Vertical format (if (> column 0) @@ -1880,6 +1905,9 @@ completion-extra-properties completion). The function can access the completion data via `minibuffer-completion-table' and related variables. +`:affix-function': Function to prepend/append a prefix/suffix to completions. + The function must accept one argument, a list of completions. + `:exit-function': Function to run after completion is performed. The function must accept two arguments, STRING and STATUS. @@ -1966,6 +1994,9 @@ minibuffer-completion-help (plist-get completion-extra-properties :annotation-function) completion-annotate-function)) + (xfun (or (completion-metadata-get all-md 'affix-function) + (plist-get completion-extra-properties + :affix-function))) (mainbuf (current-buffer)) ;; If the *Completions* buffer is shown in a new ;; window, mark it as softly-dedicated, so bury-buffer in @@ -2012,6 +2043,9 @@ minibuffer-completion-help (let ((ann (funcall afun s))) (if ann (list s ann) s))) completions))) + (when xfun + (setq completions + (funcall xfun completions))) (with-current-buffer standard-output (set (make-local-variable 'completion-base-position) --=-=-=--