| 1 | ;;; face-remap.el --- Functions for managing `face-remapping-alist' -*- lexical-binding: t -*- |
| 2 | ;; |
| 3 | ;; Copyright (C) 2008-2014 Free Software Foundation, Inc. |
| 4 | ;; |
| 5 | ;; Author: Miles Bader <miles@gnu.org> |
| 6 | ;; Keywords: faces, face remapping, display, user commands |
| 7 | ;; |
| 8 | ;; This file is part of GNU Emacs. |
| 9 | ;; |
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 11 | ;; it under the terms of the GNU General Public License as published by |
| 12 | ;; the Free Software Foundation, either version 3 of the License, or |
| 13 | ;; (at your option) any later version. |
| 14 | ;; |
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 18 | ;; GNU General Public License for more details. |
| 19 | ;; |
| 20 | ;; You should have received a copy of the GNU General Public License |
| 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 22 | ;; |
| 23 | |
| 24 | ;;; Commentary: |
| 25 | |
| 26 | ;; |
| 27 | ;; This file defines some simple operations that can be used for |
| 28 | ;; maintaining the `face-remapping-alist' in a cooperative way. This is |
| 29 | ;; especially important for the `default' face. |
| 30 | ;; |
| 31 | ;; Each face-remapping definition in `face-remapping-alist' added by |
| 32 | ;; this code uses the form: |
| 33 | ;; |
| 34 | ;; (face RELATIVE_SPECS_1 RELATIVE_SPECS_2 ... BASE_SPECS) |
| 35 | ;; |
| 36 | ;; The "specs" values are a lists of face names or face attribute-value |
| 37 | ;; pairs, and are merged together, with earlier values taking precedence. |
| 38 | ;; |
| 39 | ;; The RELATIVE_SPECS_* values are added by `face-remap-add-relative' |
| 40 | ;; (and removed by `face-remap-remove-relative', and are intended for |
| 41 | ;; face "modifications" (such as increasing the size). Typical users of |
| 42 | ;; relative specs would be minor modes. |
| 43 | ;; |
| 44 | ;; BASE_SPECS is the lowest-priority value, and by default is just the |
| 45 | ;; face name, which causes the global definition of that face to be used. |
| 46 | ;; |
| 47 | ;; A non-default value of BASE_SPECS may also be set using |
| 48 | ;; `face-remap-set-base'. Because this _overwrites_ the default |
| 49 | ;; value inheriting from the global face definition, it is up to the |
| 50 | ;; caller of face-remap-set-base to add such inheritance if it is |
| 51 | ;; desired. A typical use of face-remap-set-base would be a major |
| 52 | ;; mode setting face remappings, e.g., of the default face. |
| 53 | ;; |
| 54 | ;; All modifications cause face-remapping-alist to be made buffer-local. |
| 55 | ;; |
| 56 | |
| 57 | |
| 58 | ;;; Code: |
| 59 | |
| 60 | \f |
| 61 | ;; ---------------------------------------------------------------- |
| 62 | ;; Utility functions |
| 63 | |
| 64 | ;; Names of face attributes corresponding to lisp face-vector positions. |
| 65 | ;; This variable should probably be defined in C code where the actual |
| 66 | ;; definitions are available. |
| 67 | ;; |
| 68 | (defvar internal-lisp-face-attributes |
| 69 | [nil |
| 70 | :family :foundry :swidth :height :weight :slant :underline :inverse |
| 71 | :foreground :background :stipple :overline :strike :box |
| 72 | :font :inherit :fontset :vector]) |
| 73 | |
| 74 | (defun face-attrs-more-relative-p (attrs1 attrs2) |
| 75 | "Return true if ATTRS1 contains a greater number of relative |
| 76 | face-attributes than ATTRS2. A face attribute is considered |
| 77 | relative if `face-attribute-relative-p' returns non-nil. |
| 78 | |
| 79 | ATTRS1 and ATTRS2 may be any value suitable for a `face' text |
| 80 | property, including face names, lists of face names, |
| 81 | face-attribute plists, etc. |
| 82 | |
| 83 | This function can be used as a predicate with `sort', to sort |
| 84 | face lists so that more specific faces are located near the end." |
| 85 | (unless (vectorp attrs1) |
| 86 | (setq attrs1 (face-attributes-as-vector attrs1))) |
| 87 | (unless (vectorp attrs2) |
| 88 | (setq attrs2 (face-attributes-as-vector attrs2))) |
| 89 | (let ((rel1-count 0) (rel2-count 0)) |
| 90 | (dotimes (i (length attrs1)) |
| 91 | (let ((attr (aref internal-lisp-face-attributes i))) |
| 92 | (when attr |
| 93 | (when (face-attribute-relative-p attr (aref attrs1 i)) |
| 94 | (setq rel1-count (+ rel1-count 1))) |
| 95 | (when (face-attribute-relative-p attr (aref attrs2 i)) |
| 96 | (setq rel2-count (+ rel2-count 1)))))) |
| 97 | (< rel1-count rel2-count))) |
| 98 | |
| 99 | (defun face-remap-order (entry) |
| 100 | "Order ENTRY so that more relative face specs are near the beginning. |
| 101 | The list structure of ENTRY may be destructively modified." |
| 102 | (setq entry (nreverse entry)) |
| 103 | (setcdr entry (sort (cdr entry) 'face-attrs-more-relative-p)) |
| 104 | (nreverse entry)) |
| 105 | |
| 106 | ;;;###autoload |
| 107 | (defun face-remap-add-relative (face &rest specs) |
| 108 | "Add a face remapping entry of FACE to SPECS in the current buffer. |
| 109 | Return a cookie which can be used to delete this remapping with |
| 110 | `face-remap-remove-relative'. |
| 111 | |
| 112 | The remaining arguments, SPECS, should form a list of faces. |
| 113 | Each list element should be either a face name or a property list |
| 114 | of face attribute/value pairs. If more than one face is listed, |
| 115 | that specifies an aggregate face, in the same way as in a `face' |
| 116 | text property, except for possible priority changes noted below. |
| 117 | |
| 118 | The face remapping specified by SPECS takes effect alongside the |
| 119 | remappings from other calls to `face-remap-add-relative' for the |
| 120 | same FACE, as well as the normal definition of FACE (at lowest |
| 121 | priority). This function tries to sort multiple remappings for |
| 122 | the same face, so that remappings specifying relative face |
| 123 | attributes are applied after remappings specifying absolute face |
| 124 | attributes. |
| 125 | |
| 126 | The base (lowest priority) remapping may be set to something |
| 127 | other than the normal definition of FACE via `face-remap-set-base'." |
| 128 | (while (and (consp specs) (null (cdr specs))) |
| 129 | (setq specs (car specs))) |
| 130 | (make-local-variable 'face-remapping-alist) |
| 131 | (let ((entry (assq face face-remapping-alist))) |
| 132 | (when (null entry) |
| 133 | (setq entry (list face face)) ; explicitly merge with global def |
| 134 | (push entry face-remapping-alist)) |
| 135 | (let ((faces (cdr entry))) |
| 136 | (if (symbolp faces) |
| 137 | (setq faces (list faces))) |
| 138 | (setcdr entry (face-remap-order (cons specs faces))) |
| 139 | ;; Force redisplay of this buffer. |
| 140 | (force-mode-line-update)) |
| 141 | (cons face specs))) |
| 142 | |
| 143 | (defun face-remap-remove-relative (cookie) |
| 144 | "Remove a face remapping previously added by `face-remap-add-relative'. |
| 145 | COOKIE should be the return value from that function." |
| 146 | (let ((remapping (assq (car cookie) face-remapping-alist))) |
| 147 | (when remapping |
| 148 | (let ((updated-entries (remq (cdr cookie) (cdr remapping)))) |
| 149 | (unless (eq updated-entries (cdr remapping)) |
| 150 | (setcdr remapping updated-entries) |
| 151 | (when (or (null updated-entries) |
| 152 | (and (eq (car-safe updated-entries) (car cookie)) |
| 153 | (null (cdr updated-entries)))) |
| 154 | (setq face-remapping-alist |
| 155 | (remq remapping face-remapping-alist)) |
| 156 | ;; Force redisplay of this buffer. |
| 157 | (force-mode-line-update)) |
| 158 | (cdr cookie)))))) |
| 159 | |
| 160 | ;;;###autoload |
| 161 | (defun face-remap-reset-base (face) |
| 162 | "Set the base remapping of FACE to the normal definition of FACE. |
| 163 | This causes the remappings specified by `face-remap-add-relative' |
| 164 | to apply on top of the normal definition of FACE." |
| 165 | (let ((entry (assq face face-remapping-alist))) |
| 166 | (when entry |
| 167 | ;; If there's nothing except a base remapping, we simply remove |
| 168 | ;; the entire remapping entry, as setting the base to the default |
| 169 | ;; would be the same as the global definition. Otherwise, we |
| 170 | ;; modify the base remapping. |
| 171 | (if (null (cddr entry)) ; nothing except base remapping |
| 172 | (setq face-remapping-alist ; so remove entire entry |
| 173 | (remq entry face-remapping-alist)) |
| 174 | (setcar (last entry) face)) |
| 175 | ;; Force redisplay of this buffer. |
| 176 | (force-mode-line-update)))) ; otherwise, just inherit global def |
| 177 | |
| 178 | ;;;###autoload |
| 179 | (defun face-remap-set-base (face &rest specs) |
| 180 | "Set the base remapping of FACE in the current buffer to SPECS. |
| 181 | This causes the remappings specified by `face-remap-add-relative' |
| 182 | to apply on top of the face specification given by SPECS. |
| 183 | |
| 184 | The remaining arguments, SPECS, should form a list of faces. |
| 185 | Each list element should be either a face name or a property list |
| 186 | of face attribute/value pairs, like in a `face' text property. |
| 187 | |
| 188 | If SPECS is empty, call `face-remap-reset-base' to use the normal |
| 189 | definition of FACE as the base remapping; note that this is |
| 190 | different from SPECS containing a single value `nil', which means |
| 191 | not to inherit from the global definition of FACE at all." |
| 192 | (while (and (consp specs) (not (null (car specs))) (null (cdr specs))) |
| 193 | (setq specs (car specs))) |
| 194 | (if (or (null specs) |
| 195 | (and (eq (car specs) face) (null (cdr specs)))) ; default |
| 196 | ;; Set entry back to default |
| 197 | (face-remap-reset-base face) |
| 198 | ;; Set the base remapping |
| 199 | (make-local-variable 'face-remapping-alist) |
| 200 | (let ((entry (assq face face-remapping-alist))) |
| 201 | (if entry |
| 202 | (setcar (last entry) specs) ; overwrite existing base entry |
| 203 | (push (list face specs) face-remapping-alist))) |
| 204 | ;; Force redisplay of this buffer. |
| 205 | (force-mode-line-update))) |
| 206 | |
| 207 | \f |
| 208 | ;; ---------------------------------------------------------------- |
| 209 | ;; text-scale-mode |
| 210 | |
| 211 | (defcustom text-scale-mode-step 1.2 |
| 212 | "Scale factor used by `text-scale-mode'. |
| 213 | Each positive or negative step scales the default face height by this amount." |
| 214 | :group 'display |
| 215 | :type 'number |
| 216 | :version "23.1") |
| 217 | |
| 218 | ;; current remapping cookie for text-scale-mode |
| 219 | (defvar text-scale-mode-remapping nil) |
| 220 | (make-variable-buffer-local 'text-scale-mode-remapping) |
| 221 | |
| 222 | ;; Lighter displayed for text-scale-mode in mode-line minor-mode list |
| 223 | (defvar text-scale-mode-lighter "+0") |
| 224 | (make-variable-buffer-local 'text-scale-mode-lighter) |
| 225 | |
| 226 | ;; Number of steps that text-scale-mode will increase/decrease text height |
| 227 | (defvar text-scale-mode-amount 0) |
| 228 | (make-variable-buffer-local 'text-scale-mode-amount) |
| 229 | |
| 230 | (define-minor-mode text-scale-mode |
| 231 | "Minor mode for displaying buffer text in a larger/smaller font. |
| 232 | With a prefix argument ARG, enable the mode if ARG is positive, |
| 233 | and disable it otherwise. If called from Lisp, enable the mode |
| 234 | if ARG is omitted or nil. |
| 235 | |
| 236 | The amount of scaling is determined by the variable |
| 237 | `text-scale-mode-amount': one step scales the global default |
| 238 | face size by the value of the variable `text-scale-mode-step' |
| 239 | \(a negative amount shrinks the text). |
| 240 | |
| 241 | The `text-scale-increase', `text-scale-decrease', and |
| 242 | `text-scale-set' functions may be used to interactively modify |
| 243 | the variable `text-scale-mode-amount' (they also enable or |
| 244 | disable `text-scale-mode' as necessary)." |
| 245 | :lighter (" " text-scale-mode-lighter) |
| 246 | (when text-scale-mode-remapping |
| 247 | (face-remap-remove-relative text-scale-mode-remapping)) |
| 248 | (setq text-scale-mode-lighter |
| 249 | (format (if (>= text-scale-mode-amount 0) "+%d" "%d") |
| 250 | text-scale-mode-amount)) |
| 251 | (setq text-scale-mode-remapping |
| 252 | (and text-scale-mode |
| 253 | (face-remap-add-relative 'default |
| 254 | :height |
| 255 | (expt text-scale-mode-step |
| 256 | text-scale-mode-amount)))) |
| 257 | (force-window-update (current-buffer))) |
| 258 | |
| 259 | ;;;###autoload |
| 260 | (defun text-scale-set (level) |
| 261 | "Set the scale factor of the default face in the current buffer to LEVEL. |
| 262 | If LEVEL is non-zero, `text-scale-mode' is enabled, otherwise it is disabled. |
| 263 | |
| 264 | LEVEL is a number of steps, with 0 representing the default size. |
| 265 | Each step scales the height of the default face by the variable |
| 266 | `text-scale-mode-step' (a negative number decreases the height by |
| 267 | the same amount)." |
| 268 | (interactive "p") |
| 269 | (setq text-scale-mode-amount level) |
| 270 | (text-scale-mode (if (zerop text-scale-mode-amount) -1 1))) |
| 271 | |
| 272 | ;;;###autoload |
| 273 | (defun text-scale-increase (inc) |
| 274 | "Increase the height of the default face in the current buffer by INC steps. |
| 275 | If the new height is other than the default, `text-scale-mode' is enabled. |
| 276 | |
| 277 | Each step scales the height of the default face by the variable |
| 278 | `text-scale-mode-step' (a negative number of steps decreases the |
| 279 | height by the same amount). As a special case, an argument of 0 |
| 280 | will remove any scaling currently active." |
| 281 | (interactive "p") |
| 282 | (setq text-scale-mode-amount |
| 283 | (if (= inc 0) 0 (+ (if text-scale-mode text-scale-mode-amount 0) inc))) |
| 284 | (text-scale-mode (if (zerop text-scale-mode-amount) -1 1))) |
| 285 | |
| 286 | ;;;###autoload |
| 287 | (defun text-scale-decrease (dec) |
| 288 | "Decrease the height of the default face in the current buffer by DEC steps. |
| 289 | See `text-scale-increase' for more details." |
| 290 | (interactive "p") |
| 291 | (text-scale-increase (- dec))) |
| 292 | |
| 293 | ;;;###autoload (define-key ctl-x-map [(control ?+)] 'text-scale-adjust) |
| 294 | ;;;###autoload (define-key ctl-x-map [(control ?-)] 'text-scale-adjust) |
| 295 | ;;;###autoload (define-key ctl-x-map [(control ?=)] 'text-scale-adjust) |
| 296 | ;;;###autoload (define-key ctl-x-map [(control ?0)] 'text-scale-adjust) |
| 297 | ;;;###autoload |
| 298 | (defun text-scale-adjust (inc) |
| 299 | "Adjust the height of the default face by INC. |
| 300 | |
| 301 | INC may be passed as a numeric prefix argument. |
| 302 | |
| 303 | The actual adjustment made depends on the final component of the |
| 304 | key-binding used to invoke the command, with all modifiers removed: |
| 305 | |
| 306 | +, = Increase the default face height by one step |
| 307 | - Decrease the default face height by one step |
| 308 | 0 Reset the default face height to the global default |
| 309 | |
| 310 | After adjusting, continue to read input events and further adjust |
| 311 | the face height as long as the input event read |
| 312 | \(with all modifiers removed) is one of the above characters. |
| 313 | |
| 314 | Each step scales the height of the default face by the variable |
| 315 | `text-scale-mode-step' (a negative number of steps decreases the |
| 316 | height by the same amount). As a special case, an argument of 0 |
| 317 | will remove any scaling currently active. |
| 318 | |
| 319 | This command is a special-purpose wrapper around the |
| 320 | `text-scale-increase' command which makes repetition convenient |
| 321 | even when it is bound in a non-top-level keymap. For binding in |
| 322 | a top-level keymap, `text-scale-increase' or |
| 323 | `text-scale-decrease' may be more appropriate." |
| 324 | (interactive "p") |
| 325 | (let ((ev last-command-event) |
| 326 | (echo-keystrokes nil)) |
| 327 | (let* ((base (event-basic-type ev)) |
| 328 | (step |
| 329 | (pcase base |
| 330 | ((or ?+ ?=) inc) |
| 331 | (?- (- inc)) |
| 332 | (?0 0) |
| 333 | (t inc)))) |
| 334 | (text-scale-increase step) |
| 335 | ;; (unless (zerop step) |
| 336 | (message "Use +,-,0 for further adjustment") |
| 337 | (set-transient-map |
| 338 | (let ((map (make-sparse-keymap))) |
| 339 | (dolist (mods '(() (control))) |
| 340 | (dolist (key '(?- ?+ ?= ?0)) ;; = is often unshifted +. |
| 341 | (define-key map (vector (append mods (list key))) |
| 342 | (lambda () (interactive) (text-scale-adjust (abs inc)))))) |
| 343 | map))))) ;; ) |
| 344 | |
| 345 | \f |
| 346 | ;; ---------------------------------------------------------------- |
| 347 | ;; buffer-face-mode |
| 348 | |
| 349 | (defcustom buffer-face-mode-face 'variable-pitch |
| 350 | "The face specification used by `buffer-face-mode'. |
| 351 | It may contain any value suitable for a `face' text property, |
| 352 | including a face name, a list of face names, a face-attribute |
| 353 | plist, etc." |
| 354 | :type '(choice (face) |
| 355 | (repeat :tag "List of faces" face) |
| 356 | (plist :tag "Face property list")) |
| 357 | :group 'display |
| 358 | :version "23.1") |
| 359 | |
| 360 | ;; current remapping cookie for buffer-face-mode |
| 361 | (defvar buffer-face-mode-remapping nil) |
| 362 | (make-variable-buffer-local 'buffer-face-mode-remapping) |
| 363 | |
| 364 | ;;;###autoload |
| 365 | (define-minor-mode buffer-face-mode |
| 366 | "Minor mode for a buffer-specific default face. |
| 367 | With a prefix argument ARG, enable the mode if ARG is positive, |
| 368 | and disable it otherwise. If called from Lisp, enable the mode |
| 369 | if ARG is omitted or nil. When enabled, the face specified by the |
| 370 | variable `buffer-face-mode-face' is used to display the buffer text." |
| 371 | :lighter " BufFace" |
| 372 | (when buffer-face-mode-remapping |
| 373 | (face-remap-remove-relative buffer-face-mode-remapping)) |
| 374 | (setq buffer-face-mode-remapping |
| 375 | (and buffer-face-mode |
| 376 | (face-remap-add-relative 'default buffer-face-mode-face))) |
| 377 | (force-window-update (current-buffer))) |
| 378 | |
| 379 | ;;;###autoload |
| 380 | (defun buffer-face-set (&rest specs) |
| 381 | "Enable `buffer-face-mode', using face specs SPECS. |
| 382 | Each argument in SPECS should be a face, i.e. either a face name |
| 383 | or a property list of face attributes and values. If more than |
| 384 | one face is listed, that specifies an aggregate face, like in a |
| 385 | `face' text property. If SPECS is nil or omitted, disable |
| 386 | `buffer-face-mode'. |
| 387 | |
| 388 | This function makes the variable `buffer-face-mode-face' buffer |
| 389 | local, and sets it to FACE." |
| 390 | (interactive (list (read-face-name "Set buffer face" (face-at-point t)))) |
| 391 | (while (and (consp specs) (null (cdr specs))) |
| 392 | (setq specs (car specs))) |
| 393 | (if (null specs) |
| 394 | (buffer-face-mode 0) |
| 395 | (set (make-local-variable 'buffer-face-mode-face) specs) |
| 396 | (buffer-face-mode t))) |
| 397 | |
| 398 | ;;;###autoload |
| 399 | (defun buffer-face-toggle (&rest specs) |
| 400 | "Toggle `buffer-face-mode', using face specs SPECS. |
| 401 | Each argument in SPECS should be a face, i.e. either a face name |
| 402 | or a property list of face attributes and values. If more than |
| 403 | one face is listed, that specifies an aggregate face, like in a |
| 404 | `face' text property. |
| 405 | |
| 406 | If `buffer-face-mode' is already enabled, and is currently using |
| 407 | the face specs SPECS, then it is disabled; if `buffer-face-mode' |
| 408 | is disabled, or is enabled and currently displaying some other |
| 409 | face, then is left enabled, but the face changed to reflect SPECS. |
| 410 | |
| 411 | This function will make the variable `buffer-face-mode-face' |
| 412 | buffer local, and set it to SPECS." |
| 413 | (interactive (list buffer-face-mode-face)) |
| 414 | (while (and (consp specs) (null (cdr specs))) |
| 415 | (setq specs (car specs))) |
| 416 | (if (or (null specs) |
| 417 | (and buffer-face-mode (equal buffer-face-mode-face specs))) |
| 418 | (buffer-face-mode 0) |
| 419 | (set (make-local-variable 'buffer-face-mode-face) specs) |
| 420 | (buffer-face-mode t))) |
| 421 | |
| 422 | (defun buffer-face-mode-invoke (specs arg &optional interactive) |
| 423 | "Enable or disable `buffer-face-mode' using face specs SPECS. |
| 424 | ARG controls whether the mode is enabled or disabled, and is |
| 425 | interpreted in the usual manner for minor-mode commands. |
| 426 | |
| 427 | SPECS can be any value suitable for a `face' text property, |
| 428 | including a face name, a plist of face attributes and values, |
| 429 | or a list of faces. |
| 430 | |
| 431 | If INTERACTIVE is non-nil, display a message describing the |
| 432 | result. |
| 433 | |
| 434 | This is a wrapper function which calls `buffer-face-set' or |
| 435 | `buffer-face-toggle' (depending on ARG), and prints a status |
| 436 | message in the echo area. In many cases one of those functions |
| 437 | may be more appropriate." |
| 438 | (let ((last-message (current-message))) |
| 439 | (if (or (eq arg 'toggle) (not arg)) |
| 440 | (buffer-face-toggle specs) |
| 441 | (buffer-face-set (and (> (prefix-numeric-value arg) 0) specs))) |
| 442 | (when interactive |
| 443 | (unless (and (current-message) |
| 444 | (not (equal last-message (current-message)))) |
| 445 | (message "Buffer-Face mode %sabled" |
| 446 | (if buffer-face-mode "en" "dis")))))) |
| 447 | |
| 448 | \f |
| 449 | ;; ---------------------------------------------------------------- |
| 450 | ;; variable-pitch-mode |
| 451 | |
| 452 | ;;;###autoload |
| 453 | (defun variable-pitch-mode (&optional arg) |
| 454 | "Variable-pitch default-face mode. |
| 455 | An interface to `buffer-face-mode' which uses the `variable-pitch' face. |
| 456 | Besides the choice of face, it is the same as `buffer-face-mode'." |
| 457 | (interactive (list (or current-prefix-arg 'toggle))) |
| 458 | (buffer-face-mode-invoke 'variable-pitch arg |
| 459 | (called-interactively-p 'interactive))) |
| 460 | |
| 461 | |
| 462 | (provide 'face-remap) |
| 463 | |
| 464 | ;;; face-remap.el ends here |