From 6cd47f59326ebff625e75a96acf3ee300acf27ee Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Mon, 8 Jan 2024 22:43:26 +0100 Subject: [PATCH] Improve 'read-face-name' * doc/lispref/display.texi (Face Functions): Use '@lisp' for Elisp example. Document 'read-face-name' and 'read-face-name-sample-text'. * etc/NEWS: Announce 'read-face-name-sample-text' as a user option. * lisp/faces.el (read-face-name-sample-text): Make it a user option. (completion-face-name-affixation, read-face-name-sort-aliases-last) (completion-face-name-table): New functions. (read-face-name): Simplify. --- doc/lispref/display.texi | 28 ++++++- etc/NEWS | 10 ++- lisp/faces.el | 169 ++++++++++++++++++++------------------- 3 files changed, 121 insertions(+), 86 deletions(-) diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 10cf5ce89e2..240ca3215e8 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -3552,9 +3552,9 @@ define a face alias by giving the alias symbol the @code{face-alias} property, with a value of the target face name. The following example makes @code{modeline} an alias for the @code{mode-line} face. -@example +@lisp (put 'modeline 'face-alias 'mode-line) -@end example +@end lisp @defmac define-obsolete-face-alias obsolete-face current-face when This macro defines @code{obsolete-face} as an alias for @@ -3564,6 +3564,30 @@ when @code{obsolete-face} was made obsolete (usually a version number string). @end defmac +@defun read-face-name prompt &optional default multiple +This function reads a face name in the minibuffer, with completion. +Arguments @var{prompt} and @var{default} are the minibuffer prompt and +default value, respectively. If optional argument @var{multiple} is +non-@code{nil}, this function reads multiple face names at once, and +returns them as a list. To input multiple face names, separate them +in the minibuffer with @code{crm-separator} (by default, a comma). +@xref{Minibuffer Completion}. Commands that prompt the user for a +face name, such as @code{describe-face}, use this function to do so. +@end defun + +@cindex face samples, in completion +@defopt read-face-name-sample-text +This user option controls display of @dfn{face samples} in the +@file{*Completions*} buffer of @code{read-face-name}. If this user +option is non-@code{nil}, @code{read-face-name} shows alongside each +candidate face name a sample text with that face. If +@code{read-face-name-sample-text} is a string, @code{read-face-name} +uses that string as the sample text. If it is a non-@code{nil} value +that is not a string, the face names act as their own sample +text---@code{read-face-name} fontifies each face name in the +@file{*Completions*} buffer with the face that it refers to. +@end defopt + @node Auto Faces @subsection Automatic Face Assignment @cindex automatic face assignment diff --git a/etc/NEWS b/etc/NEWS index 957bcc0a150..191108ca1d6 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1248,10 +1248,18 @@ Now, calling '(thing-at-point 'url)' when point is on a bug reference will return the URL for that bug. +++ -*** New user option 'rcirc-log-time-format' +*** New user option 'rcirc-log-time-format'. This allows for rcirc logs to use a custom timestamp format, than the chat buffers use by default. ++++ +*** New user option 'read-face-name-sample-text'. +This user option lets you customize the sample text that +'read-face-name' and commands that invoke 'read-face-name', such as +'M-x describe-face', use to visually display faces in the +"*Completions*" buffer. By default this is set to the string +"SAMPLE", which retains compatibility with Emacs 29. + ** Customize +++ diff --git a/lisp/faces.el b/lisp/faces.el index d5120f42b92..b774070c613 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -1096,92 +1096,95 @@ of the default face. Value is FACE." ;;; Interactively modifying faces. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar crm-separator) ; from crm.el +(defcustom read-face-name-sample-text "SAMPLE" + "Sample text to fontify and display next to face name completion candidates. + +If this user option is a string, as it is by default, +\(specifically, it defaults to the string \"SAMPLE\"), +`read-face-name' displays that string next to each face name in +the *Completions* buffer, fontifying each sample text with the +candidate face it appears besides, so you can see how it looks. + +If this is non-nil and not a string, `read-face-name' fontifies +the face names themselves with the faces they denote, so each +face name acts as its own sample text. + +If this is nil, `read-face-name' does not show face samples in +the *Completions* buffer." + :version "30.1" + :type '(choice string + (const :tag "No sample text" nil) + (const :tag "Use face names" t)) + :group 'faces) + +(defun completion-face-name-affixation (names) + "Return completion affixations for face name list NAMES. -(defconst read-face-name-sample-text "SAMPLE" - "Text string to display as the sample text for `read-face-name'.") +The affixation that this function performs depends on the value +of `read-face-name-sample-text', which see." + (mapcar + (cond + ((stringp read-face-name-sample-text) + (let ((max-name (seq-max (mapcar #'string-width names)))) + (lambda (name) + (list name + "" + (concat + (propertize " " 'display `(space :align-to ,(+ max-name 4))) + (propertize read-face-name-sample-text 'face name)))))) + (read-face-name-sample-text + (lambda (name) (list (propertize name 'face name) "" ""))) + (t + (lambda (name) (list name "" "")))) + names)) + +(defun read-face-name-sort-aliases-last (names) + "Sort face names that are aliases after non-alias faces in list NAMES." + (sort names + (lambda (l r) + (let ((la (get (intern l) 'face-alias)) + (ra (get (intern r) 'face-alias))) + (if la + (and ra (string-lessp l r)) + (or ra (string-lessp l r))))))) + +(defun completion-face-name-table (string pred action) + "Completion table for face names. + +See Info node `(elisp)Programmed Completion' for the meaning of +STRING, PRED and ACTION." + (if (eq action 'metadata) + `(metadata + (category . face) + (display-sort-function . read-face-name-sort-aliases-last) + (cycle-sort-function . read-face-name-sort-aliases-last) + ,@(when read-face-name-sample-text + '((affixation-function . completion-face-name-affixation)))) + (complete-with-action action obarray string + (if pred + (lambda (cand) + (and (facep cand) (funcall pred cand))) + #'facep)))) (defun read-face-name (prompt &optional default multiple) - "Read one or more face names, prompting with PROMPT. -PROMPT should not end in a space or a colon. - -If DEFAULT is non-nil, it should be a face (a symbol) or a face -name (a string). It can also be a list of faces or face names. - -If MULTIPLE is non-nil, the return value from this function is a -list of faces. Otherwise a single face is returned. - -If the user enter the empty string at the prompt, DEFAULT is -returned after a possible transformation according to MULTIPLE. -That is, if DEFAULT is a list and MULTIPLE is nil, the first -element of DEFAULT is returned. If DEFAULT isn't a list, but -MULTIPLE is non-nil, a one-element list containing DEFAULT is -returned. Otherwise, DEFAULT is returned verbatim." - (let (defaults) - (setq default (ensure-list default)) - (when default - (setq default - (if multiple - (mapconcat (lambda (f) (if (symbolp f) (symbol-name f) f)) - default ", ") - ;; If we only want one, and the default is more than one, - ;; discard the unwanted ones and use them only in the - ;; "future history" retrieved via `M-n M-n ...'. - (setq defaults default default (car default)) - (if (symbolp default) - (symbol-name default) - default)))) - (when (and default (not multiple)) - (require 'crm) - ;; For compatibility with `completing-read-multiple' use `crm-separator' - ;; to define DEFAULT if MULTIPLE is nil. - (setq default (car (split-string default crm-separator t)))) - - ;; Older versions of `read-face-name' did not append ": " to the - ;; prompt, so there are third party libraries that have that in the - ;; prompt. If so, remove it. - (setq prompt (replace-regexp-in-string ": ?\\'" "" prompt)) - (let ((prompt (if default - (format-prompt prompt default) - (format "%s: " prompt))) - (completion-extra-properties - `(:affixation-function - ,(lambda (faces) - (mapcar - (lambda (face) - (list face - (concat (propertize read-face-name-sample-text - 'face face) - "\t") - "")) - faces)))) - aliasfaces nonaliasfaces faces) - ;; Build up the completion tables. - (mapatoms (lambda (s) - (if (facep s) - (if (get s 'face-alias) - (push (symbol-name s) aliasfaces) - (push (symbol-name s) nonaliasfaces))))) - (if multiple - (progn - (dolist (face (completing-read-multiple - prompt - (completion-table-in-turn nonaliasfaces aliasfaces) - nil t nil 'face-name-history default)) - ;; Ignore elements that are not faces - ;; (for example, because DEFAULT was "all faces") - (if (facep face) (push (if (stringp face) - (intern face) - face) - faces))) - (nreverse faces)) - (let ((face (completing-read - prompt - (completion-table-in-turn nonaliasfaces aliasfaces) - nil t nil 'face-name-history defaults))) - (when (facep face) (if (stringp face) - (intern face) - face))))))) + "Read and return a face name (as a symbol), prompting with PROMPT. + +Optional argument DEFAULT is the default value (or list of +default values) in the minibuffer. + +You can insert multiple face names in the minibuffer, separated +by the value of `crm-separator' (normally, a comma). By default, +this function returns only the first face name and ignores +everything after the first separator, but if optional argument +MULTIPLE is non-nil, this function returns all of the face names +in your input as a list of face names." + (let* ((default (when default (symbol-name default))) + (faces + (mapcar #'intern + (completing-read-multiple + (format-prompt prompt default) #'completion-face-name-table + nil t nil 'face-name-history default)))) + (if multiple faces (car faces)))) ;; Not defined without X, but behind window-system test. (defvar x-bitmap-file-path) -- 2.39.5