Mercurial > emacs
changeset 96041:c89004e8d9a9
Order multiple entries more cleverly in face-remap-add-relative
Revision: emacs@sv.gnu.org/emacs--devo--0--patch-1250
| author | Miles Bader <miles@gnu.org> |
|---|---|
| date | Tue, 17 Jun 2008 11:27:36 +0000 |
| parents | b656389af0fb |
| children | dfc9ab5fbea5 |
| files | lisp/ChangeLog lisp/face-remap.el |
| diffstat | 2 files changed, 52 insertions(+), 3 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Tue Jun 17 06:00:41 2008 +0000 +++ b/lisp/ChangeLog Tue Jun 17 11:27:36 2008 +0000 @@ -1,3 +1,9 @@ +2008-06-17 Miles Bader <miles@gnu.org> + + * face-remap.el (internal-lisp-face-attributes): New variable. + (face-attrs-more-relative-p, face-remap-order): New functions. + (face-remap-add-relative): Use `face-remap-order'. + 2008-06-17 Glenn Morris <rgm@gnu.org> * mouse.el (x-select-font): Declare.
--- a/lisp/face-remap.el Tue Jun 17 06:00:41 2008 +0000 +++ b/lisp/face-remap.el Tue Jun 17 11:27:36 2008 +0000 @@ -61,6 +61,48 @@ ;; ---------------------------------------------------------------- ;; Utility functions +;; Names of face attributes corresponding to lisp face-vector positions. +;; This variable should probably be defined in C code where the actual +;; definitions are available. +;; +(defvar internal-lisp-face-attributes + [nil + :family :foundry :swidth :height :weight :slant :underline :inverse + :foreground :background :stipple :overline :strike :box + :font :inherit :fontset :vector]) + +(defun face-attrs-more-relative-p (attrs1 attrs2) +"Return true if ATTRS1 contains a greater number of relative +face-attributes than ATTRS2. A face attribute is considered +relative if `face-attribute-relative-p' returns non-nil. + +ATTRS1 and ATTRS2 may be any value suitable for a `face' text +property, including face names, lists of face names, +face-attribute plists, etc. + +This function can be used as a predicate with `sort', to sort +face lists so that more specific faces are located near the end." + (unless (vectorp attrs1) + (setq attrs1 (face-attributes-as-vector attrs1))) + (unless (vectorp attrs2) + (setq attrs2 (face-attributes-as-vector attrs2))) + (let ((rel1-count 0) (rel2-count 0)) + (dotimes (i (length attrs1)) + (let ((attr (aref internal-lisp-face-attributes i))) + (when attr + (when (face-attribute-relative-p attr (aref attrs1 i)) + (setq rel1-count (+ rel1-count 1))) + (when (face-attribute-relative-p attr (aref attrs2 i)) + (setq rel2-count (+ rel2-count 1)))))) + (< rel1-count rel2-count))) + +(defun face-remap-order (entry) + "Order ENTRY so that more relative face specs are near the beginning. +The list structure of ENTRY may be destructively modified." + (setq entry (nreverse entry)) + (setcdr entry (sort (cdr entry) 'face-attrs-more-relative-p)) + (nreverse entry)) + ;;;### autoload (defun face-remap-add-relative (face &rest specs) "Add a face remapping entry of FACE to SPECS in the current buffer. @@ -72,8 +114,9 @@ including a face name, a list of face names, or a face-attribute property list. The attributes given by SPECS will be merged with any other currently active face remappings of FACE, and with the -global definition of FACE, with the most recently added relative -remapping taking precedence. +global definition of FACE. An attempt is made to sort multiple +entries so that entries with relative face-attributes are applied +after entries with absolute face-attributes. The base (lowest priority) remapping may be set to a specific value, instead of the default of the global face definition, @@ -83,7 +126,7 @@ (when (null entry) (setq entry (list face face)) ; explicitly merge with global def (push entry face-remapping-alist)) - (setcdr entry (cons specs (cdr entry))) + (setcdr entry (face-remap-order (cons specs (cdr entry)))) (cons face specs))) (defun face-remap-remove-relative (cookie)