face-remap.el 20.4 KB
Newer Older
1
;;; face-remap.el --- Functions for managing `face-remapping-alist'  -*- lexical-binding: t -*-
2
;;
Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 2008-2020 Free Software Foundation, Inc.
4 5
;;
;; Author: Miles Bader <miles@gnu.org>
Juri Linkov's avatar
Juri Linkov committed
6
;; Keywords: faces, face remapping, display, user commands
7 8 9 10 11 12 13 14 15 16 17 18 19 20
;;
;; 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
21
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38
;;

;;; Commentary:

;;
;; This file defines some simple operations that can be used for
;; maintaining the `face-remapping-alist' in a cooperative way.  This is
;; especially important for the `default' face.
;;
;; Each face-remapping definition in `face-remapping-alist' added by
;; this code uses the form:
;;
;;   (face RELATIVE_SPECS_1 RELATIVE_SPECS_2 ... BASE_SPECS)
;;
;; The "specs" values are a lists of face names or face attribute-value
;; pairs, and are merged together, with earlier values taking precedence.
;;
39 40
;; The RELATIVE_SPECS_* values are added by `face-remap-add-relative'
;; (and removed by `face-remap-remove-relative', and are intended for
41 42 43 44 45 46 47
;; face "modifications" (such as increasing the size).  Typical users of
;; relative specs would be minor modes.
;;
;; BASE_SPECS is the lowest-priority value, and by default is just the
;; face name, which causes the global definition of that face to be used.
;;
;; 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 51
;; caller of face-remap-set-base to add such inheritance if it is
;; desired.  A typical use of face-remap-set-base would be a major
52 53 54 55 56 57 58 59 60 61 62 63
;; mode setting face remappings, e.g., of the default face.
;;
;; All modifications cause face-remapping-alist to be made buffer-local.
;;


;;; Code:


;; ----------------------------------------------------------------
;; Utility functions

64 65 66
;; 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.
67
;; :vector must be always at the end as a guard
68 69 70
;;
(defvar internal-lisp-face-attributes
  [nil
71 72 73 74
   :family :foundry :width :height :weight :slant :underline
   :inverse-video
   :foreground :background :stipple :overline :strike-through :box
   :font :inherit :fontset :distant-foreground :extend :vector])
75 76

(defun face-attrs-more-relative-p (attrs1 attrs2)
77
  "Return true if ATTRS1 contains a greater number of relative
78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107
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))

108
;;;###autoload
109
(defun face-remap-add-relative (face &rest specs)
110
  "Add a face remapping entry of FACE to SPECS in the current buffer.
111
Return a cookie which can be used to delete this remapping with
112
`face-remap-remove-relative'.
113

114 115 116 117 118 119 120 121 122 123 124 125 126
The remaining arguments, SPECS, should form a list of faces.
Each list element should be either a face name or a property list
of face attribute/value pairs.  If more than one face is listed,
that specifies an aggregate face, in the same way as in a `face'
text property, except for possible priority changes noted below.

The face remapping specified by SPECS takes effect alongside the
remappings from other calls to `face-remap-add-relative' for the
same FACE, as well as the normal definition of FACE (at lowest
priority).  This function tries to sort multiple remappings for
the same face, so that remappings specifying relative face
attributes are applied after remappings specifying absolute face
attributes.
127 128 129

The base (lowest priority) remapping may be set to something
other than the normal definition of FACE via `face-remap-set-base'."
130 131
  (while (and (consp specs) (null (cdr specs)))
    (setq specs (car specs)))
132 133 134 135 136
  (make-local-variable 'face-remapping-alist)
  (let ((entry (assq face face-remapping-alist)))
    (when (null entry)
      (setq entry (list face face))	; explicitly merge with global def
      (push entry face-remapping-alist))
137 138 139
    (let ((faces (cdr entry)))
      (if (symbolp faces)
	  (setq faces (list faces)))
140 141 142
      (setcdr entry (face-remap-order (cons specs faces)))
      ;; Force redisplay of this buffer.
      (force-mode-line-update))
143 144
    (cons face specs)))

145 146
(defun face-remap-remove-relative (cookie)
  "Remove a face remapping previously added by `face-remap-add-relative'.
147 148 149 150 151 152 153 154 155 156
COOKIE should be the return value from that function."
  (let ((remapping (assq (car cookie) face-remapping-alist)))
    (when remapping
      (let ((updated-entries (remq (cdr cookie) (cdr remapping))))
	(unless (eq updated-entries (cdr remapping))
	  (setcdr remapping updated-entries)
	  (when (or (null updated-entries)
		    (and (eq (car-safe updated-entries) (car cookie))
			 (null (cdr updated-entries))))
	    (setq face-remapping-alist
157 158 159
		  (remq remapping face-remapping-alist))
	    ;; Force redisplay of this buffer.
	    (force-mode-line-update))
160 161
	  (cdr cookie))))))

162
;;;###autoload
163
(defun face-remap-reset-base (face)
164 165 166
  "Set the base remapping of FACE to the normal definition of FACE.
This causes the remappings specified by `face-remap-add-relative'
to apply on top of the normal definition of FACE."
167 168 169 170 171 172 173 174 175
  (let ((entry (assq face face-remapping-alist)))
    (when entry
      ;; If there's nothing except a base remapping, we simply remove
      ;; the entire remapping entry, as setting the base to the default
      ;; would be the same as the global definition.  Otherwise, we
      ;; modify the base remapping.
      (if (null (cddr entry))		; nothing except base remapping
	  (setq face-remapping-alist	; so remove entire entry
		(remq entry face-remapping-alist))
176 177 178
	(setcar (last entry) face))
      ;; Force redisplay of this buffer.
      (force-mode-line-update))))  ; otherwise, just inherit global def
179

180
;;;###autoload
181
(defun face-remap-set-base (face &rest specs)
182
  "Set the base remapping of FACE in the current buffer to SPECS.
183
This causes the remappings specified by `face-remap-add-relative'
184 185 186 187 188
to apply on top of the face specification given by SPECS.

The remaining arguments, SPECS, should form a list of faces.
Each list element should be either a face name or a property list
of face attribute/value pairs, like in a `face' text property.
189 190 191

If SPECS is empty, call `face-remap-reset-base' to use the normal
definition of FACE as the base remapping; note that this is
192
different from SPECS containing a single value nil, which means
193
not to inherit from the global definition of FACE at all."
194 195
  (while (and (consp specs) (not (null (car specs))) (null (cdr specs)))
    (setq specs (car specs)))
196 197 198
  (if (or (null specs)
	  (and (eq (car specs) face) (null (cdr specs)))) ; default
      ;; Set entry back to default
199
      (face-remap-reset-base face)
200 201 202 203 204
    ;; Set the base remapping
    (make-local-variable 'face-remapping-alist)
    (let ((entry (assq face face-remapping-alist)))
      (if entry
	  (setcar (last entry) specs)	; overwrite existing base entry
205 206 207
	(push (list face specs) face-remapping-alist)))
    ;; Force redisplay of this buffer.
    (force-mode-line-update)))
208

209 210 211 212 213 214 215 216

;; ----------------------------------------------------------------
;; text-scale-mode

(defcustom text-scale-mode-step 1.2
  "Scale factor used by `text-scale-mode'.
Each positive or negative step scales the default face height by this amount."
  :group 'display
217 218
  :type 'number
  :version "23.1")
219 220 221 222 223 224 225 226 227 228 229 230 231

;; current remapping cookie for text-scale-mode
(defvar text-scale-mode-remapping nil)
(make-variable-buffer-local 'text-scale-mode-remapping)

;; Lighter displayed for text-scale-mode in mode-line minor-mode list
(defvar text-scale-mode-lighter "+0")
(make-variable-buffer-local 'text-scale-mode-lighter)

;; Number of steps that text-scale-mode will increase/decrease text height
(defvar text-scale-mode-amount 0)
(make-variable-buffer-local 'text-scale-mode-amount)

232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253
(defvar text-scale-remap-header-line nil
  "If non-nil, text scaling may change font size of header lines too.")
(make-variable-buffer-local 'text-scale-header-line)

(defun face-remap--clear-remappings ()
  (dolist (remapping
           ;; This is a bit messy to stay backwards compatible.
           ;; In the future, this can be simplified to just use
           ;; `text-scale-mode-remapping'.
           (if (consp (car-safe text-scale-mode-remapping))
               text-scale-mode-remapping
             (list text-scale-mode-remapping)))
    (face-remap-remove-relative remapping))
  (setq text-scale-mode-remapping nil))

(defun face-remap--remap-face (sym)
  (push (face-remap-add-relative sym
                       :height
                       (expt text-scale-mode-step
                             text-scale-mode-amount))
        text-scale-mode-remapping))

254
(define-minor-mode text-scale-mode
255
  "Minor mode for displaying buffer text in a larger/smaller font.
256 257

The amount of scaling is determined by the variable
258 259 260 261
`text-scale-mode-amount': one step scales the global default
face size by the value of the variable `text-scale-mode-step'
\(a negative amount shrinks the text).

Miles Bader's avatar
Miles Bader committed
262 263 264
The `text-scale-increase', `text-scale-decrease', and
`text-scale-set' functions may be used to interactively modify
the variable `text-scale-mode-amount' (they also enable or
265 266 267 268
disable `text-scale-mode' as necessary).

If `text-scale-remap-header-line' is non-nil, also change
the font size of the header line."
269
  :lighter (" " text-scale-mode-lighter)
270
  (face-remap--clear-remappings)
271 272 273
  (setq text-scale-mode-lighter
	(format (if (>= text-scale-mode-amount 0) "+%d" "%d")
		text-scale-mode-amount))
274 275 276 277
  (when text-scale-mode
    (face-remap--remap-face 'default)
    (when text-scale-remap-header-line
      (face-remap--remap-face 'header-line)))
278 279
  (force-window-update (current-buffer)))

280 281 282 283 284 285 286 287 288 289 290
(defun text-scale--refresh (symbol newval operation where)
  "Watcher for `text-scale-remap-header-line'.
See `add-variable-watcher'."
  (when (and (eq symbol 'text-scale-remap-header-line)
             (eq operation 'set)
             text-scale-mode)
    (with-current-buffer where
      (let ((text-scale-remap-header-line newval))
        (text-scale-mode 1)))))
(add-variable-watcher 'text-scale-remap-header-line #'text-scale--refresh)

291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307
(defun text-scale-min-amount ()
  "Return the minimum amount of text-scaling we allow."
  ;; When the resulting pixel-height of characters will become smaller
  ;; than 1 pixel, we can expect trouble from the display engine.
  ;; E.g., it requires that the character glyph's ascent is
  ;; non-negative.
  (log (/ 1.0 (frame-char-height)) text-scale-mode-step))

(defun text-scale-max-amount ()
  "Return the maximum amount of text-scaling we allow."
  ;; The display engine uses a 16-bit short for pixel-width of
  ;; characters, thus the 0xffff limitation.  It also makes no sense
  ;; to have characters wider than the display.
  (log (/ (min (display-pixel-width) #xffff)
          (frame-char-width))
       text-scale-mode-step))

Miles Bader's avatar
Miles Bader committed
308 309 310 311 312 313 314 315 316 317
;;;###autoload
(defun text-scale-set (level)
  "Set the scale factor of the default face in the current buffer to LEVEL.
If LEVEL is non-zero, `text-scale-mode' is enabled, otherwise it is disabled.

LEVEL is a number of steps, with 0 representing the default size.
Each step scales the height of the default face by the variable
`text-scale-mode-step' (a negative number decreases the height by
the same amount)."
  (interactive "p")
318 319
  (setq text-scale-mode-amount
        (max (min level (text-scale-max-amount)) (text-scale-min-amount)))
Miles Bader's avatar
Miles Bader committed
320 321
  (text-scale-mode (if (zerop text-scale-mode-amount) -1 1)))

322
;;;###autoload
323
(defun text-scale-increase (inc)
324 325 326 327 328 329 330
  "Increase the height of the default face in the current buffer by INC steps.
If the new height is other than the default, `text-scale-mode' is enabled.

Each step scales the height of the default face by the variable
`text-scale-mode-step' (a negative number of steps decreases the
height by the same amount).  As a special case, an argument of 0
will remove any scaling currently active."
331
  (interactive "p")
332 333 334 335 336 337 338
  (let* ((current-value (if text-scale-mode text-scale-mode-amount 0))
         (new-value (if (= inc 0) 0 (+ current-value inc))))
    (if (or (> new-value (text-scale-max-amount))
            (< new-value (text-scale-min-amount)))
        (user-error "Cannot %s the default face height more than it already is"
                    (if (> inc 0) "increase" "decrease")))
    (setq text-scale-mode-amount new-value))
339 340 341
  (text-scale-mode (if (zerop text-scale-mode-amount) -1 1)))

;;;###autoload
342
(defun text-scale-decrease (dec)
343
  "Decrease the height of the default face in the current buffer by DEC steps.
344
See `text-scale-increase' for more details."
345
  (interactive "p")
346
  (text-scale-increase (- dec)))
347

348 349 350 351
;;;###autoload (define-key ctl-x-map [(control ?+)] 'text-scale-adjust)
;;;###autoload (define-key ctl-x-map [(control ?-)] 'text-scale-adjust)
;;;###autoload (define-key ctl-x-map [(control ?=)] 'text-scale-adjust)
;;;###autoload (define-key ctl-x-map [(control ?0)] 'text-scale-adjust)
352
;;;###autoload
353
(defun text-scale-adjust (inc)
354 355 356
  "Adjust the height of the default face by INC.

INC may be passed as a numeric prefix argument.
357 358

The actual adjustment made depends on the final component of the
359
key-binding used to invoke the command, with all modifiers removed:
360 361 362 363 364

   +, =   Increase the default face height by one step
   -      Decrease the default face height by one step
   0      Reset the default face height to the global default

Glenn Morris's avatar
Glenn Morris committed
365 366 367
After adjusting, continue to read input events and further adjust
the face height as long as the input event read
\(with all modifiers removed) is one of the above characters.
368 369 370 371 372 373 374

Each step scales the height of the default face by the variable
`text-scale-mode-step' (a negative number of steps decreases the
height by the same amount).  As a special case, an argument of 0
will remove any scaling currently active.

This command is a special-purpose wrapper around the
375 376 377 378
`text-scale-increase' command which makes repetition convenient
even when it is bound in a non-top-level keymap.  For binding in
a top-level keymap, `text-scale-increase' or
`text-scale-decrease' may be more appropriate."
379
  (interactive "p")
380
  (let ((ev last-command-event)
381
	(echo-keystrokes nil))
382 383 384
    (let* ((base (event-basic-type ev))
           (step
            (pcase base
Stefan Monnier's avatar
Stefan Monnier committed
385 386 387
              ((or ?+ ?=) inc)
              (?- (- inc))
              (?0 0)
388
              (_ inc))))
389
      (text-scale-increase step)
390 391
      ;; (unless (zerop step)
      (message "Use +,-,0 for further adjustment")
392
      (set-transient-map
393 394
       (let ((map (make-sparse-keymap)))
         (dolist (mods '(() (control)))
395 396 397 398
           (dolist (key '(?- ?+ ?= ?0)) ;; = is often unshifted +.
             (define-key map (vector (append mods (list key)))
               (lambda () (interactive) (text-scale-adjust (abs inc))))))
         map))))) ;; )
399

400 401

;; ----------------------------------------------------------------
Miles Bader's avatar
Miles Bader committed
402
;; buffer-face-mode
403

Miles Bader's avatar
Miles Bader committed
404 405 406 407 408
(defcustom buffer-face-mode-face 'variable-pitch
  "The face specification used by `buffer-face-mode'.
It may contain any value suitable for a `face' text property,
including a face name, a list of face names, a face-attribute
plist, etc."
409 410 411
  :type '(choice (face)
		 (repeat :tag "List of faces" face)
		 (plist :tag "Face property list"))
412 413
  :group 'display
  :version "23.1")
414

Miles Bader's avatar
Miles Bader committed
415 416 417
;; current remapping cookie for  buffer-face-mode
(defvar buffer-face-mode-remapping nil)
(make-variable-buffer-local 'buffer-face-mode-remapping)
418

Miles Bader's avatar
Miles Bader committed
419
;;;###autoload
Miles Bader's avatar
Miles Bader committed
420 421
(define-minor-mode buffer-face-mode
  "Minor mode for a buffer-specific default face.
422 423 424

When enabled, the face specified by the variable
`buffer-face-mode-face' is used to display the buffer text."
Miles Bader's avatar
Miles Bader committed
425 426 427 428 429 430
  :lighter " BufFace"
  (when buffer-face-mode-remapping
    (face-remap-remove-relative buffer-face-mode-remapping))
  (setq buffer-face-mode-remapping
	(and buffer-face-mode
	     (face-remap-add-relative 'default buffer-face-mode-face)))
431 432
  (force-window-update (current-buffer)))

Miles Bader's avatar
Miles Bader committed
433
;;;###autoload
434 435
(defun buffer-face-set (&rest specs)
  "Enable `buffer-face-mode', using face specs SPECS.
436 437 438 439 440 441 442 443
Each argument in SPECS should be a face, i.e. either a face name
or a property list of face attributes and values.  If more than
one face is listed, that specifies an aggregate face, like in a
`face' text property.  If SPECS is nil or omitted, disable
`buffer-face-mode'.

This function makes the variable `buffer-face-mode-face' buffer
local, and sets it to FACE."
444
  (interactive (list (read-face-name "Set buffer face" (face-at-point t))))
445 446 447
  (while (and (consp specs) (null (cdr specs)))
    (setq specs (car specs)))
  (if (null specs)
Miles Bader's avatar
Miles Bader committed
448
      (buffer-face-mode 0)
449
    (set (make-local-variable 'buffer-face-mode-face) specs)
Miles Bader's avatar
Miles Bader committed
450 451 452
    (buffer-face-mode t)))

;;;###autoload
453 454
(defun buffer-face-toggle (&rest specs)
  "Toggle `buffer-face-mode', using face specs SPECS.
455 456 457 458
Each argument in SPECS should be a face, i.e. either a face name
or a property list of face attributes and values.  If more than
one face is listed, that specifies an aggregate face, like in a
`face' text property.
Miles Bader's avatar
Miles Bader committed
459 460

If `buffer-face-mode' is already enabled, and is currently using
461 462 463
the face specs SPECS, then it is disabled; if `buffer-face-mode'
is disabled, or is enabled and currently displaying some other
face, then is left enabled, but the face changed to reflect SPECS.
464 465 466

This function will make the variable `buffer-face-mode-face'
buffer local, and set it to SPECS."
Miles Bader's avatar
Miles Bader committed
467
  (interactive (list buffer-face-mode-face))
468 469 470 471
  (while (and (consp specs) (null (cdr specs)))
    (setq specs (car specs)))
  (if (or (null specs)
	  (and buffer-face-mode (equal buffer-face-mode-face specs)))
Miles Bader's avatar
Miles Bader committed
472
      (buffer-face-mode 0)
473
    (set (make-local-variable 'buffer-face-mode-face) specs)
Miles Bader's avatar
Miles Bader committed
474 475
    (buffer-face-mode t)))

476
(defun buffer-face-mode-invoke (specs arg &optional interactive)
477
  "Enable or disable `buffer-face-mode' using face specs SPECS.
478 479 480
ARG controls whether the mode is enabled or disabled, and is
interpreted in the usual manner for minor-mode commands.

481
SPECS can be any value suitable for a `face' text property,
482 483
including a face name, a plist of face attributes and values,
or a list of faces.
484

485 486
If INTERACTIVE is non-nil, display a message describing the
result.
487

488
This is a wrapper function which calls `buffer-face-set' or
489 490 491
`buffer-face-toggle' (depending on ARG), and prints a status
message in the echo area.  In many cases one of those functions
may be more appropriate."
Miles Bader's avatar
Miles Bader committed
492 493
  (let ((last-message (current-message)))
    (if (or (eq arg 'toggle) (not arg))
494 495
	(buffer-face-toggle specs)
      (buffer-face-set (and (> (prefix-numeric-value arg) 0) specs)))
Miles Bader's avatar
Miles Bader committed
496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511
    (when interactive
      (unless (and (current-message)
		   (not (equal last-message (current-message))))
	(message "Buffer-Face mode %sabled"
		 (if buffer-face-mode "en" "dis"))))))


;; ----------------------------------------------------------------
;; variable-pitch-mode

;;;###autoload
(defun variable-pitch-mode (&optional arg)
  "Variable-pitch default-face mode.
An interface to `buffer-face-mode' which uses the `variable-pitch' face.
Besides the choice of face, it is the same as `buffer-face-mode'."
  (interactive (list (or current-prefix-arg 'toggle)))
512
  (buffer-face-mode-invoke 'variable-pitch (or arg t)
513
			   (called-interactively-p 'interactive)))
Miles Bader's avatar
Miles Bader committed
514

515 516 517 518

(provide 'face-remap)

;;; face-remap.el ends here