diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi index 46a2291b74d..6ed43bcb790 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 96e05a902d6..b87ca81faea 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 08bf7441df0..b5e4cb41fdf 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 3941455efc9..3753326a19a 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 80b73033d68..21047ad5541 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 50dce5ee285..9b0d2a10f6b 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 bbbe70c5ea8..5ece5047a86 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 00000000000..da7f68f5231 --- /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 +;; 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 . + +;;; 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 00000000000..e6e71a8e4fd --- /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 . + +;;; 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