[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master 601737d750 1/3: Add support for user-customizable icons
|
From: |
Lars Ingebrigtsen |
|
Subject: |
master 601737d750 1/3: Add support for user-customizable icons |
|
Date: |
Thu, 28 Jul 2022 08:39:46 -0400 (EDT) |
branch: master
commit 601737d7506727d66953a65e68105cf7eb3ee044
Author: Lars Ingebrigtsen <larsi@gnus.org>
Commit: Lars Ingebrigtsen <larsi@gnus.org>
Add support for user-customizable icons
* doc/emacs/custom.texi (Specific Customization): Mention it.
* doc/emacs/display.texi (Icons): New node.
* doc/lispref/display.texi (Icons): New node.
* lisp/button.el (buttonize):
(button--properties, buttonize-region): Allow not overriding faces.
* lisp/cus-edit.el (custom-save-all): Save icons.
(custom-icon): New widget.
(custom-icon-value-create, custom-toggle-hide-icon)
(custom--icons-widget-value, custom-icon-set): Helper functions
for the widget.
(customize-icon): Main command.
(custom-icon-state-set, custom-icon-state): Helper functions.
(custom-theme-set-icons): Function to be used by theme writers.
(custom-set-icons): Function to be used in .emacs.
(custom-save-icons): New function.
* lisp/custom.el (custom-push-theme): Add icons.
* lisp/emacs-lisp/icons.el: New file.
* test/lisp/emacs-lisp/icons-tests.el: Add some tests.
---
doc/emacs/custom.texi | 3 +
doc/emacs/display.texi | 33 +++++
doc/lispref/display.texi | 156 +++++++++++++++++++
etc/NEWS | 5 +
lisp/button.el | 14 +-
lisp/cus-edit.el | 288 +++++++++++++++++++++++++++++++++++-
lisp/custom.el | 2 +-
lisp/emacs-lisp/icons.el | 265 +++++++++++++++++++++++++++++++++
test/lisp/emacs-lisp/icons-tests.el | 63 ++++++++
9 files changed, 822 insertions(+), 7 deletions(-)
diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi
index 46a2291b74..6ed43bcb79 100644
--- a/doc/emacs/custom.texi
+++ b/doc/emacs/custom.texi
@@ -511,6 +511,9 @@ Set up a customization buffer for just one user option,
@var{option}.
@item M-x customize-face @key{RET} @var{face} @key{RET}
Set up a customization buffer for just one face, @var{face}.
+@item M-x customize-icon @key{RET} @var{face} @key{RET}
+Set up a customization buffer for just one icon, @var{icon}.
+
@item M-x customize-group @key{RET} @var{group} @key{RET}
Set up a customization buffer for just one group, @var{group}.
diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi
index 96e05a902d..b87ca81fae 100644
--- a/doc/emacs/display.texi
+++ b/doc/emacs/display.texi
@@ -24,6 +24,7 @@ the text is displayed.
* Faces:: How to change the display style using faces.
* Colors:: Specifying colors for faces.
* Standard Faces:: The main predefined faces.
+* Icons:: How to change how icons look.
* Text Scale:: Increasing or decreasing text size in a buffer.
* Font Lock:: Minor mode for syntactic highlighting using faces.
* Highlight Interactively:: Tell Emacs what text to highlight.
@@ -851,6 +852,38 @@ This face is used to display on text-mode terminals the
menu item that
would be selected if you click a mouse or press @key{RET}.
@end table
+@node Icons
+@section Icons
+
+Emacs sometimes displays clickable buttons (or other informative
+icons), and the look of these can be customized by the user.
+
+@vindex icon-preference
+The main customization point here is the @code{icon-preference} user
+option. By using this, you can tell Emacs your overall preferences
+for icons. This is a list of icon types, and the first icon type
+that's supported will be used. The supported types are:
+
+@table @code
+@item image
+Use an image for the icon.
+
+@item emoji
+Use a colorful emoji for the icon.
+
+@item symbol
+Use a monochrome symbol for the icon.
+
+@item text
+Use a simple text for the icon.
+@end table
+
+In addition, each individual icon can be customized with @kbd{M-x
+customize-icon}, and themes can further alter the looks of the icons.
+
+To get a quick description of an icon, use the @kbd{M-x describe-icon}
+command.
+
@node Text Scale
@section Text Scale
diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index 08bf7441df..b5e4cb41fd 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -27,6 +27,7 @@ that Emacs presents to the user.
* Window Dividers:: Separating windows visually.
* Display Property:: Images, margins, text size, etc.
* Images:: Displaying images in Emacs buffers.
+* Icons:: Displaying icons in Emacs buffers.
* Xwidgets:: Displaying native widgets in Emacs buffers.
* Buttons:: Adding clickable buttons to Emacs buffers.
* Abstract Display:: Emacs's Widget for Object Collections.
@@ -6979,6 +6980,161 @@ bytes. An image of size 200x100 with 24 bits per color
will have a
cache size of 60000 bytes, for instance.
@end defun
+@node Icons
+@section Icons
+
+Emacs sometimes uses buttons (for clicking on) or small graphics (to
+illustrate something). Since Emacs is available on a wide variety of
+systems with different capabilities, and users have different
+preferences, Emacs provides a facility to handle this in a convenient
+way, allowing customization, graceful degradation, accessibility, as
+well as themability: @dfn{Icons}.
+
+The central macro here is @code{define-icon}, and here's a simple
+example:
+
+@lisp
+(define-icon outline-open button
+ '((image "right.svg" "open.xpm" "open.pbm" :height line)
+ (emoji "▶️")
+ (symbol "▶" "➤")
+ (text "open" :face icon-button))
+ "Icon used for buttons for opening a section in outline buffers."
+ :version "29.1"
+ :help-echo "Open this section")
+@end lisp
+
+This is used in tandem with the @code{icon-preference} user option, as
+well as run-time checks for what the current Emacs frame can actually
+display.
+
+The macro in this example defines @code{outline-open} as an icon, and
+inherits properties from the icon called @code{button} (so this is
+meant as a clickable button to be inserted in a buffer). We then get
+a list of @dfn{icon types} along with the actual icon shapes
+themselves. In addition, there's a doc string and various keywords
+that contain additional information and properties.
+
+When instantiating an icon you use @code{icon-string}, and this will
+consult the current Customize theming, and the @code{icon-preference}
+user option, and finally what the Emacs is able to actually display.
+If @code{icon-preference} is @code{(image emoji symbol text)} (i.e.,
+allowing all of these forms of icons), in this case,
+@code{icon-string} will first check that Emacs is able to display
+images at all, and then whether it has support for each of those
+different image formats. If that fails, Emacs will check whether
+Emacs can display emojis (in the current frame). If that fails, it'll
+check whether it can display the symbol in question. If that fails,
+it'll use the plain text version.
+
+For instance, if @code{icon-preference} doesn't contain @code{image}
+or @code{emoji}, it'll skip those entries.
+
+Code can confidently call @code{icon-string} in all circumstances and
+be confident that something readable will appear on the screen, no
+matter whether the user is on a graphical terminal or a text terminal,
+and no matter which features Emacs was built with.
+
+@defmac define-icon name parent specs doc &rest keywords
+@var{name} should be a symbol, and is the name of the resulting
+keyword. @code{icon-string} can later be used to instantiate the
+icon.
+
+This icon will inherit specs from @var{parent}, and recursively from
+the parent's parents, and so on, and the lowest descendent element
+wins.
+
+@var{specs} is a list of specifications. The first element of each
+specification is the type, and the rest is something that can be used
+as an icon of that type, and then optionally followed by a keyword
+list. The following types are available:
+
+@table @code
+@item image
+In this case, there may be many images listed as candidates. Emacs
+will choose the first one that the current Emacs instance can show.
+If an image listed is an absolute file name, it's used as is, but it's
+otherwise looked up in the image load path.
+
+@item emoji
+This should be a (possibly colorful) emoji.
+
+@item symbol
+This should be a (monochrome) symbol.
+
+@item text
+Icons should also have a textual fallback. This can also be used for
+by the visually impaired: If @code{icon-preference} is just
+@code{(text)}, all icons will be replaced by text.
+@end table
+
+Various keywords may follow the list of icon specifications. For
+instance:
+
+@example
+(symbol "▶" "➤" :face icon-button)
+@end example
+
+Unknown keywords are ignored. The following keywords are allowed:
+
+@table @code
+@item :face
+The face to be used.
+
+@item :height
+This is only valid for @code{image} icons, and can be either a number
+(which specifies the height in pixels), or the symbol @code{line},
+which will use the default line height in the currently selected
+window.
+@end table
+
+@var{doc} should be a doc string.
+
+@var{keywords} is a list of keyword/value pairs. The following
+keywords are allowed:
+
+@table @code
+@item :version
+The (approximate) Emacs version this button first appeared. (This
+keyword is mandatory.)
+
+@item :group
+The customization group this icon belongs in. If not present, it is
+inferred.
+
+@item :help-echo
+The help string shown when hovering over the icon with the mouse
+pointer.
+@end table
+@end defmac
+
+@defun icon-string icon
+This function returns a string suitable for display in the current
+buffer for @var{icon}.
+@end defun
+
+@defun icon-elements icon
+Alternatively, you can get a ``deconstructed'' version of @var{icon}
+with this function. This returns a plist where the keys are
+@code{string}, @code{face} and @var{image}. (The latter is only
+present if the icon is represented by an image.) This can be useful
+if the icon isn't to be inserted directly in the buffer, but needs
+some sort of post-processing first.
+@end defun
+
+Icons can be customized with @kbd{M-x customize-icon}. Themes can
+specify changes to icons with, for instance:
+
+@lisp
+(custom-theme-set-icons
+ 'my-theme
+ '(outline-open ((image :height 100)
+ (text " OPEN ")))
+ '(outline-close ((image :height 100)
+ (text " CLOSE " :face warning))))
+@end lisp
+
+
@node Xwidgets
@section Embedded Native Widgets
@cindex xwidget
diff --git a/etc/NEWS b/etc/NEWS
index 3941455efc..3753326a19 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -2454,6 +2454,11 @@ patcomp.el, pc-mode.el, pc-select.el, s-region.el, and
sregex.el.
* Lisp Changes in Emacs 29.1
++++
+** Emacs now supports user-customizable and themable icons.
+These can be used for buttons in buffers and the like. See
+'(elisp)Icons' and '(emacs)Icons' for details.
+
+++
** New arguments MESSAGE and TIMEOUT of 'set-transient-map'.
MESSAGE specifies a message to display after activating the transient
diff --git a/lisp/button.el b/lisp/button.el
index 80b73033d6..21047ad554 100644
--- a/lisp/button.el
+++ b/lisp/button.el
@@ -623,12 +623,15 @@ itself will be used instead as the function argument.
If HELP-ECHO, use that as the `help-echo' property.
Also see `buttonize-region'."
- (apply #'propertize string
- (button--properties callback data help-echo)))
+ (let ((string
+ (apply #'propertize string
+ (button--properties callback data help-echo))))
+ ;; Add the face to the end so that it can be overridden.
+ (add-face-text-property 0 (length string) 'button t string)
+ string))
(defun button--properties (callback data help-echo)
- (list 'face 'button
- 'font-lock-face 'button
+ (list 'font-lock-face 'button
'mouse-face 'highlight
'help-echo help-echo
'button t
@@ -647,7 +650,8 @@ itself will be used instead as the function argument.
If HELP-ECHO, use that as the `help-echo' property.
Also see `buttonize'."
- (add-text-properties start end (button--properties callback data help-echo)))
+ (add-text-properties start end (button--properties callback data help-echo))
+ (add-face-text-property start end 'button t))
(provide 'button)
diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el
index 50dce5ee28..9b0d2a10f6 100644
--- a/lisp/cus-edit.el
+++ b/lisp/cus-edit.el
@@ -139,6 +139,7 @@
(require 'cus-face)
(require 'wid-edit)
+(require 'icons)
(defvar custom-versions-load-alist) ; from cus-load
(defvar recentf-exclude) ; from recentf.el
@@ -4849,7 +4850,8 @@ if only the first line of the docstring is shown."))
(print-escape-control-characters t))
(atomic-change-group
(custom-save-variables)
- (custom-save-faces)))
+ (custom-save-faces)
+ (custom-save-icons)))
(let ((file-precious-flag t))
(save-buffer))
(if old-buffer
@@ -5290,6 +5292,290 @@ if that value is non-nil."
(put 'Custom-mode 'mode-class 'special)
+;; Icons.
+
+(define-widget 'custom-icon 'custom
+ "A widget for displaying an icon.
+The following properties have special meanings for this widget:
+
+:hidden-states should be a list of widget states for which the
+ widget's initial contents are to be hidden.
+
+:custom-form should be a symbol describing how to display and
+ edit the variable---either `edit' (using edit widgets),
+ `lisp' (as a Lisp sexp), or `mismatch' (should not happen);
+ if nil, use the return value of `custom-variable-default-form'.
+
+:shown-value, if non-nil, should be a list whose `car' is the
+ variable value to display in place of the current value.
+
+:custom-style describes the widget interface style; nil is the
+ default style, while `simple' means a simpler interface that
+ inhibits the magic custom-state widget."
+ :format "%v"
+ :help-echo "Alter or reset this icon."
+ :documentation-property #'icon-documentation
+ :custom-category 'option
+ :custom-state nil
+ :custom-form nil
+ :value-create 'custom-icon-value-create
+ :hidden-states '(standard)
+ :custom-set 'custom-icon-set
+ :custom-reset-current 'custom-redraw
+ :custom-reset-saved 'custom-variable-reset-saved)
+
+(defun custom-icon-value-create (widget)
+ "Here is where you edit the icon's specification."
+ (custom-load-widget widget)
+ (unless (widget-get widget :custom-form)
+ (widget-put widget :custom-form custom-variable-default-form))
+ (let* ((buttons (widget-get widget :buttons))
+ (children (widget-get widget :children))
+ (form (widget-get widget :custom-form))
+ (symbol (widget-get widget :value))
+ (tag (widget-get widget :tag))
+ (type '(repeat
+ (list (choice (const :tag "Images" image)
+ (const :tag "Colorful Emojis" emoji)
+ (const :tag "Monochrome Symbols" symbol)
+ (const :tag "Text Only" text))
+ (repeat string)
+ plist)))
+ (prefix (widget-get widget :custom-prefix))
+ (last (widget-get widget :custom-last))
+ (style (widget-get widget :custom-style))
+ (value (let ((shown-value (widget-get widget :shown-value)))
+ (cond (shown-value
+ (car shown-value))
+ (t (icon-complete-spec symbol nil t)))))
+ (state (or (widget-get widget :custom-state)
+ (if (memq (custom-icon-state symbol value)
+ (widget-get widget :hidden-states))
+ 'hidden))))
+
+ ;; Transform the spec into something that agrees with the type.
+ (setq value
+ (mapcar
+ (lambda (elem)
+ (list (car elem)
+ (icon-spec-values elem)
+ (icon-spec-keywords elem)))
+ value))
+
+ ;; Now we can create the child widget.
+ (cond ((eq custom-buffer-style 'tree)
+ (insert prefix (if last " `--- " " |--- "))
+ (push (widget-create-child-and-convert
+ widget 'custom-browse-variable-tag)
+ buttons)
+ (insert " " tag "\n")
+ (widget-put widget :buttons buttons))
+ ((eq state 'hidden)
+ ;; Indicate hidden value.
+ (push (widget-create-child-and-convert
+ widget 'custom-visibility
+ :help-echo "Show the value of this option."
+ :on-glyph "down"
+ :on "Hide"
+ :off-glyph "right"
+ :off "Show Value"
+ :action 'custom-toggle-hide-icon
+ nil)
+ buttons)
+ (insert " ")
+ (push (widget-create-child-and-convert
+ widget 'item
+ :format "%{%t%} "
+ :sample-face 'custom-variable-tag
+ :tag tag
+ :parent widget)
+ buttons))
+ (t
+ ;; Edit mode.
+ (push (widget-create-child-and-convert
+ widget 'custom-visibility
+ :help-echo "Hide or show this option."
+ :on "Hide"
+ :off "Show"
+ :on-glyph "down"
+ :off-glyph "right"
+ :action 'custom-toggle-hide-icon
+ t)
+ buttons)
+ (insert " ")
+ (let* ((format (widget-get type :format))
+ tag-format)
+ (unless (string-match ":\\s-?" format)
+ (error "Bad format"))
+ (setq tag-format (substring format 0 (match-end 0)))
+ (push (widget-create-child-and-convert
+ widget 'item
+ :format tag-format
+ :action 'custom-tag-action
+ :help-echo "Change specs of this face."
+ :mouse-down-action 'custom-tag-mouse-down-action
+ :button-face 'custom-variable-button
+ :sample-face 'custom-variable-tag
+ :tag tag)
+ buttons)
+ (push (widget-create-child-and-convert
+ widget type
+ :value value)
+ children))))
+ (unless (eq custom-buffer-style 'tree)
+ (unless (eq (preceding-char) ?\n)
+ (widget-insert "\n"))
+ ;; Create the magic button.
+ (unless (eq style 'simple)
+ (let ((magic (widget-create-child-and-convert
+ widget 'custom-magic nil)))
+ (widget-put widget :custom-magic magic)
+ (push magic buttons)))
+ (widget-put widget :buttons buttons)
+ ;; Insert documentation.
+ (widget-put widget :documentation-indent 3)
+ (unless (and (eq style 'simple)
+ (eq state 'hidden))
+ (widget-add-documentation-string-button
+ widget :visibility-widget 'custom-visibility))
+
+ ;; Update the rest of the properties.
+ (widget-put widget :custom-form form)
+ (widget-put widget :children children)
+ ;; Now update the state.
+ (if (eq state 'hidden)
+ (widget-put widget :custom-state state)
+ (custom-icon-state-set widget))
+ ;; See also.
+ (unless (eq state 'hidden)
+ (when (eq (widget-get widget :custom-level) 1)
+ (custom-add-parent-links widget))
+ (custom-add-see-also widget)))))
+
+(defun custom-toggle-hide-icon (visibility-widget &rest _ignore)
+ "Toggle the visibility of a `custom-icon' parent widget.
+By default, this signals an error if the parent has unsaved
+changes."
+ (let ((widget (widget-get visibility-widget :parent)))
+ (unless (eq (widget-type widget) 'custom-icon)
+ (error "Invalid widget type"))
+ (custom-load-widget widget)
+ (let ((state (widget-get widget :custom-state)))
+ (if (eq state 'hidden)
+ (widget-put widget :custom-state 'unknown)
+ ;; In normal interface, widget can't be hidden if modified.
+ (when (memq state '(invalid modified set))
+ (error "There are unsaved changes"))
+ (widget-put widget :custom-state 'hidden))
+ (custom-redraw widget)
+ (widget-setup))))
+
+(defun custom--icons-widget-value (widget)
+ ;; Transform back to the real format.
+ (mapcar
+ (lambda (elem)
+ (cons (nth 0 elem)
+ (append (nth 1 elem) (nth 2 elem))))
+ (widget-value widget)))
+
+(defun custom-icon-set (widget)
+ "Set the current spec for the icon being edited by WIDGET."
+ (let* ((state (widget-get widget :custom-state))
+ (child (car (widget-get widget :children)))
+ (symbol (widget-value widget))
+ val)
+ (when (eq state 'hidden)
+ (user-error "Cannot update hidden icon"))
+
+ (setq val (custom--icons-widget-value child))
+ (unless (equal val (icon-complete-spec symbol))
+ (custom-variable-backup-value widget))
+ (custom-push-theme 'theme-icon symbol 'user 'set val)
+ (custom-redraw-magic widget)))
+
+;;;###autoload
+(defun customize-icon (icon)
+ "Customize ICON."
+ (interactive
+ (let* ((v (symbol-at-point))
+ (default (and (iconp v) (symbol-name v)))
+ val)
+ (setq val (completing-read (format-prompt "Customize icon" default)
+ obarray 'iconp t nil nil default))
+ (list (if (equal val "")
+ (if (symbolp v) v nil)
+ (intern val)))))
+ (unless icon
+ (error "No icon specified"))
+ (custom-buffer-create (list (list icon 'custom-icon))
+ (format "*Customize Icon: %s*"
+ (custom-unlispify-tag-name icon))))
+
+(defun custom-icon-state-set (widget &optional state)
+ "Set the state of WIDGET to STATE."
+ (let ((value (custom--icons-widget-value
+ (car (widget-get widget :children)))))
+ (widget-put
+ widget :custom-state
+ (or state
+ (custom-icon-state (widget-value widget) value)))))
+
+(defun custom-icon-state (symbol value)
+ "Return the state of customize icon SYMBOL for VALUE.
+Possible return values are `standard', `saved', `set', `themed',
+and `changed'."
+ (cond
+ ((equal (icon-complete-spec symbol t t) value)
+ 'standard)
+ ((equal (icon-complete-spec symbol nil t) value)
+ (if (eq (caar (get symbol 'theme-icon)) 'user)
+ 'set
+ 'themed))
+ (t 'changed)))
+
+(defun custom-theme-set-icons (theme &rest specs)
+ "Apply a list of icon specs associated with THEME.
+THEME should be a symbol, and SPECS are icon name/spec pairs.
+See `define-icon' for details."
+ (custom-check-theme theme)
+ (pcase-dolist (`(,icon ,spec) specs)
+ (custom-push-theme 'theme-icon icon theme 'set spec)))
+
+(defun custom-set-icons (&rest args)
+ "Install user customizations of icon specs specified in ARGS.
+These settings are registered as theme `user'.
+The arguments should each be a list of the form:
+
+ (SYMBOL EXP)
+
+This stores EXP (without evaluating it) as the saved spec for SYMBOL."
+ (apply #'custom-theme-set-icons 'user args))
+
+;;;###autoload
+(defun custom-save-icons ()
+ "Save all customized icons in `custom-file'."
+ (save-excursion
+ (custom-save-delete 'custom-set-icons)
+ (let ((values nil))
+ (mapatoms
+ (lambda (symbol)
+ (let ((value (car-safe (get symbol 'theme-icon))))
+ (when (eq (car value) 'user)
+ (push (list symbol (cadr value)) values)))))
+ (ensure-empty-lines)
+ (insert "(custom-set-icons
+ ;; custom-set-icons was added by Custom.
+ ;; If you edit it by hand, you could mess it up, so be careful.
+ ;; Your init file should contain only one such instance.
+ ;; If there is more than one, they won't work right.\n")
+ (dolist (value (sort values (lambda (s1 s2)
+ (string< (car s1) (car s2)))))
+ (unless (bolp)
+ (insert "\n"))
+ (insert " '")
+ (prin1 value (current-buffer)))
+ (insert ")\n"))))
+
(provide 'cus-edit)
;;; cus-edit.el ends here
diff --git a/lisp/custom.el b/lisp/custom.el
index bbbe70c5ea..5ece5047a8 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -910,7 +910,7 @@ symbol `set', then VALUE is the value to use. If it is the
symbol
`reset', then SYMBOL will be removed from THEME (VALUE is ignored).
See `custom-known-themes' for a list of known themes."
- (unless (memq prop '(theme-value theme-face))
+ (unless (memq prop '(theme-value theme-face theme-icon))
(error "Unknown theme property"))
(let* ((old (get symbol prop))
(setting (assq theme old)) ; '(theme value)
diff --git a/lisp/emacs-lisp/icons.el b/lisp/emacs-lisp/icons.el
new file mode 100644
index 0000000000..da7f68f523
--- /dev/null
+++ b/lisp/emacs-lisp/icons.el
@@ -0,0 +1,265 @@
+;;; icons.el --- Handling icons -*- lexical-binding:t -*-
+
+;; Copyright (C) 2022 Free Software Foundation, Inc.
+
+;; Author: Lars Ingebrigtsen <larsi@gnus.org>
+;; Keywords: icons buttons
+
+;; 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:
+
+;; Todo: describe-icon
+
+;;; Code:
+
+(require 'cl-lib)
+
+(defface icon
+ '((t :underline nil))
+ "Face for buttons."
+ :version "29.1"
+ :group 'customize)
+
+(defface icon-button
+ '((((type x w32 ns haiku pgtk) (class color))
+ :inherit icon
+ :box (:line-width (3 . -1) :color "#404040" :style flat-button)
+ :background "#808080"
+ :foreground "black"))
+ "Face for buttons."
+ :version "29.1"
+ :group 'customize)
+
+(defcustom icon-preference '(image emoji symbol text)
+ "List of icon types to use, in order of preference.
+Emacs will choose the icon of the highest preference possible
+on the current display, and \"degrade\" gracefully to an icon
+type that's available."
+ :version "29.1"
+ :group 'customize
+ :type '(repeat (const :tag "Images" image)
+ (const :tag "Colorful Emojis" emoji)
+ (const :tag "Monochrome Symbols" symbol)
+ (const :tag "Text Only" text)))
+
+(defmacro define-icon (name parent specification documentation &rest keywords)
+ "Define an icon identified by NAME.
+If non-nil, inherit the specification from PARENT. Entries from
+SPECIFICATION will override inherited specifications.
+
+SPECIFICATION is an alist of entries where the first element is
+the type, and the rest are icons of that type. Valid types are
+`image', `emoji', `symbol' and `text'.
+
+KEYWORDS specify additional information. Valid keywords are:
+
+`:version': The first Emacs version to include this icon; this is
+mandatory.
+
+`:group': The customization group the icon belongs in; this is
+inferred if not present.
+
+`:help-echo': Informational text that explains what happens if
+the icon is used as a button and you click it."
+ (declare (indent 2))
+ (unless (symbolp name)
+ (error "NAME must be a symbol: %S" name))
+ (unless (plist-get keywords :version)
+ (error "There must be a :version keyword in `define-icon'"))
+ `(icons--register ',name ',parent ,specification ,documentation
+ ',keywords))
+
+(defun icons--register (name parent spec doc keywords)
+ (put name 'icon--properties (list parent spec doc keywords))
+ (custom-add-to-group
+ (or (plist-get keywords :group)
+ (custom-current-group))
+ name 'custom-icon))
+
+(defun icon-spec-keywords (spec)
+ (seq-drop-while (lambda (e) (not (keywordp e))) (cdr spec)))
+
+(defun icon-spec-values (spec)
+ (seq-take-while (lambda (e) (not (keywordp e))) (cdr spec)))
+
+(defun iconp (object)
+ "Return nil if OBJECT is not an icon.
+If OBJECT is an icon, return the icon properties."
+ (get object 'icon--properties))
+
+(defun icon-documentation (icon)
+ "Return the documentation for ICON."
+ (let ((props (iconp icon)))
+ (unless props
+ (user-error "%s is not a valid icon" icon))
+ (nth 2 props)))
+
+(defun icons--spec (icon)
+ (nth 1 (iconp icon)))
+
+(defun icons--copy-spec (spec)
+ (mapcar #'copy-sequence spec))
+
+(defun icon-complete-spec (icon &optional inhibit-theme inhibit-inheritance)
+ "Return the merged spec for ICON."
+ (pcase-let ((`(,parent ,spec _ _) (iconp icon)))
+ ;; We destructively modify `spec' when merging, so copy it.
+ (setq spec (icons--copy-spec spec))
+ ;; Let the Customize theme override.
+ (unless inhibit-theme
+ (when-let ((theme-spec (cadr (car (get icon 'theme-icon)))))
+ (setq spec (icons--merge-spec (icons--copy-spec theme-spec) spec))))
+ ;; Inherit from the parent spec (recursively).
+ (unless inhibit-inheritance
+ (while parent
+ (let ((parent-props (get parent 'icon--properties)))
+ (when parent-props
+ (setq spec (icons--merge-spec spec (cadr parent-props))))
+ (setq parent (car parent-props)))))
+ spec))
+
+(defun icon-string (name)
+ "Return a string suitable for display in the current buffer for icon NAME."
+ (let ((props (iconp name)))
+ (unless props
+ (user-error "%s is not a valid icon" name))
+ (pcase-let ((`(_ ,spec _ ,keywords) props))
+ (setq spec (icon-complete-spec name))
+ ;; We now have a full spec, so check the intersection of what
+ ;; the user wants and what this Emacs is capable of showing.
+ (let ((icon-string
+ (catch 'found
+ (dolist (type icon-preference)
+ (let* ((type-spec (assq type spec))
+ ;; Find the keywords at the end of the section
+ ;; (if any).
+ (type-keywords (icon-spec-keywords type-spec)))
+ ;; Go through all the variations in this section
+ ;; and return the first one we can display.
+ (dolist (icon (icon-spec-values type-spec))
+ (when-let ((result
+ (icons--create type icon type-keywords)))
+ (throw 'found
+ (if-let ((face (plist-get type-keywords :face)))
+ (propertize result 'face face)
+ result)))))))))
+ (unless icon-string
+ (error "Couldn't find any way to display the %s icon" name))
+ (when-let ((help (plist-get keywords :help-echo)))
+ (setq icon-string (propertize icon-string 'help-echo help)))
+ (propertize icon-string 'rear-nonsticky t)))))
+
+(defun icon-elements (name)
+ "Return the elements of icon NAME.
+The elements are represented as a plist where the keys are
+`string', `face' and `display'. The `image' element is only
+present if the icon is represented by an image."
+ (let ((string (icon-string name)))
+ (list 'face (get-text-property 0 'face string)
+ 'image (get-text-property 0 'display string)
+ 'string (substring-no-properties string))))
+
+(defun icons--merge-spec (merged parent-spec)
+ (dolist (elem parent-spec)
+ (let ((current (assq (car elem) merged)))
+ (if (not current)
+ ;; Just add the entry.
+ (push elem merged)
+ ;; See if there are any keywords to inherit.
+ (let ((parent-keywords (icon-spec-keywords elem))
+ (current-keywords (icon-spec-keywords current)))
+ (while parent-keywords
+ (unless (plist-get (car parent-keywords) current-keywords)
+ (nconc current (take 2 parent-keywords))
+ (setq parent-keywords (cddr parent-keywords))))))))
+ merged)
+
+(cl-defmethod icons--create ((_type (eql 'image)) icon keywords)
+ (let ((file (if (file-name-absolute-p icon)
+ icon
+ (image-search-load-path icon))))
+ (and (display-graphic-p)
+ (image-supported-file-p file)
+ (propertize
+ " " 'display
+ (if-let ((height (plist-get keywords :height)))
+ (create-image file
+ nil nil
+ :height (if (eq height 'line)
+ (window-default-line-height)
+ height)
+ :scale 1)
+ (create-image file))))))
+
+(cl-defmethod icons--create ((_type (eql 'emoji)) icon _keywords)
+ (when-let ((font (and (display-multi-font-p)
+ (car (internal-char-font nil ?😀)))))
+ (and (font-has-char-p font (aref icon 0))
+ icon)))
+
+(cl-defmethod icons--create ((_type (eql 'symbol)) icon _keywords)
+ (and (cl-every #'char-displayable-p icon)
+ icon))
+
+(cl-defmethod icons--create ((_type (eql 'text)) icon _keywords)
+ icon)
+
+(define-icon button nil
+ '((image :face icon-button)
+ (emoji "🔵" :face icon)
+ (symbol "●" :face icon-button)
+ (text "button" :face icon-button))
+ "Base icon for buttons."
+ :version "29.1")
+
+;;;###autoload
+(defun describe-icon (icon)
+ "Pop to a buffer to describe ICON."
+ (interactive
+ (list (intern (completing-read "Describe icon: " obarray 'iconp t))))
+ (let ((help-buffer-under-preparation t))
+ (help-setup-xref (list #'describe-icon icon)
+ (called-interactively-p 'interactive))
+ (with-help-window (help-buffer)
+ (with-current-buffer standard-output
+ (insert "Icon: " (symbol-name icon) "\n\n")
+ (insert "Documentation:\n"
+ (substitute-command-keys (icon-documentation icon)))
+ (ensure-empty-lines)
+ (let ((spec (icon-complete-spec icon))
+ (plain (icon-complete-spec icon t t)))
+ (insert "Specification including inheritance and theming:\n")
+ (icons--describe-spec spec)
+ (unless (equal spec plain)
+ (insert "\nSpecification not including inheritance and theming:\n")
+ (icons--describe-spec plain)))))))
+
+(defun icons--describe-spec (spec)
+ (dolist (elem spec)
+ (let ((type (car elem))
+ (values (icon-spec-values elem))
+ (keywords (icon-spec-keywords elem)))
+ (when (or values keywords)
+ (insert (format "\nType: %s\n" type))
+ (dolist (value values)
+ (insert (format " %s\n" value)))
+ (while keywords
+ (insert (format " %s: %s\n" (pop keywords) (pop keywords))))))))
+
+(provide 'icons)
+
+;;; icons.el ends here
diff --git a/test/lisp/emacs-lisp/icons-tests.el
b/test/lisp/emacs-lisp/icons-tests.el
new file mode 100644
index 0000000000..e6e71a8e4f
--- /dev/null
+++ b/test/lisp/emacs-lisp/icons-tests.el
@@ -0,0 +1,63 @@
+;;; icons-tests.el --- Tests for icons.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 'icons)
+(require 'ert)
+(require 'ert-x)
+(require 'cus-edit)
+
+(define-icon icon-test1 nil
+ '((symbol ">")
+ (text "great"))
+ "Test icon"
+ :version "29.1")
+
+(define-icon icon-test2 icon-test1
+ '((text "child"))
+ "Test icon"
+ :version "29.1")
+
+(deftheme test-icons-theme "")
+
+(ert-deftest test-icon-theme ()
+ (let ((icon-preference '(image emoji symbol text)))
+ (should (equal (icon-string 'icon-test1) ">")))
+ (let ((icon-preference '(text)))
+ (should (equal (icon-string 'icon-test1) "great")))
+ (custom-theme-set-icons
+ 'test-icons-theme
+ '(icon-test1 ((symbol "<") (text "less"))))
+ (let ((icon-preference '(image emoji symbol text)))
+ (should (equal (icon-string 'icon-test1) ">"))
+ (enable-theme 'test-icons-theme)
+ (should (equal (icon-string 'icon-test1) "<"))))
+
+(ert-deftest test-icon-inheretance ()
+ (let ((icon-preference '(image emoji symbol text)))
+ (should (equal (icon-string 'icon-test2) ">")))
+ (let ((icon-preference '(text)))
+ (should (equal (icon-string 'icon-test2) "child"))))
+
+;;; icons-tests.el ends here