merge from trunk
[emacs.git] / lisp / face-remap.el
blobe4ec602efe74c6fae991d4b70a2c2ca23dde6357
1 ;;; face-remap.el --- Functions for managing `face-remapping-alist' -*- lexical-binding: t -*-
2 ;;
3 ;; Copyright (C) 2008-2013 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.
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.
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/>.
24 ;;; Commentary:
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.
31 ;; Each face-remapping definition in `face-remapping-alist' added by
32 ;; this code uses the form:
34 ;; (face RELATIVE_SPECS_1 RELATIVE_SPECS_2 ... BASE_SPECS)
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.
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.
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.
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.
54 ;; All modifications cause face-remapping-alist to be made buffer-local.
58 ;;; Code:
61 ;; ----------------------------------------------------------------
62 ;; Utility functions
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.
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])
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.
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.
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)))
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))
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'.
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.
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.
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 (cons face specs)))
141 (defun face-remap-remove-relative (cookie)
142 "Remove a face remapping previously added by `face-remap-add-relative'.
143 COOKIE should be the return value from that function."
144 (let ((remapping (assq (car cookie) face-remapping-alist)))
145 (when remapping
146 (let ((updated-entries (remq (cdr cookie) (cdr remapping))))
147 (unless (eq updated-entries (cdr remapping))
148 (setcdr remapping updated-entries)
149 (when (or (null updated-entries)
150 (and (eq (car-safe updated-entries) (car cookie))
151 (null (cdr updated-entries))))
152 (setq face-remapping-alist
153 (remq remapping face-remapping-alist)))
154 (cdr cookie))))))
156 ;;;###autoload
157 (defun face-remap-reset-base (face)
158 "Set the base remapping of FACE to the normal definition of FACE.
159 This causes the remappings specified by `face-remap-add-relative'
160 to apply on top of the normal definition of FACE."
161 (let ((entry (assq face face-remapping-alist)))
162 (when entry
163 ;; If there's nothing except a base remapping, we simply remove
164 ;; the entire remapping entry, as setting the base to the default
165 ;; would be the same as the global definition. Otherwise, we
166 ;; modify the base remapping.
167 (if (null (cddr entry)) ; nothing except base remapping
168 (setq face-remapping-alist ; so remove entire entry
169 (remq entry face-remapping-alist))
170 (setcar (last entry) face))))) ; otherwise, just inherit global def
172 ;;;###autoload
173 (defun face-remap-set-base (face &rest specs)
174 "Set the base remapping of FACE in the current buffer to SPECS.
175 This causes the remappings specified by `face-remap-add-relative'
176 to apply on top of the face specification given by SPECS.
178 The remaining arguments, SPECS, should form a list of faces.
179 Each list element should be either a face name or a property list
180 of face attribute/value pairs, like in a `face' text property.
182 If SPECS is empty, call `face-remap-reset-base' to use the normal
183 definition of FACE as the base remapping; note that this is
184 different from SPECS containing a single value `nil', which means
185 not to inherit from the global definition of FACE at all."
186 (while (and (consp specs) (not (null (car specs))) (null (cdr specs)))
187 (setq specs (car specs)))
188 (if (or (null specs)
189 (and (eq (car specs) face) (null (cdr specs)))) ; default
190 ;; Set entry back to default
191 (face-remap-reset-base face)
192 ;; Set the base remapping
193 (make-local-variable 'face-remapping-alist)
194 (let ((entry (assq face face-remapping-alist)))
195 (if entry
196 (setcar (last entry) specs) ; overwrite existing base entry
197 (push (list face specs) face-remapping-alist)))))
200 ;; ----------------------------------------------------------------
201 ;; text-scale-mode
203 (defcustom text-scale-mode-step 1.2
204 "Scale factor used by `text-scale-mode'.
205 Each positive or negative step scales the default face height by this amount."
206 :group 'display
207 :type 'number
208 :version "23.1")
210 ;; current remapping cookie for text-scale-mode
211 (defvar text-scale-mode-remapping nil)
212 (make-variable-buffer-local 'text-scale-mode-remapping)
214 ;; Lighter displayed for text-scale-mode in mode-line minor-mode list
215 (defvar text-scale-mode-lighter "+0")
216 (make-variable-buffer-local 'text-scale-mode-lighter)
218 ;; Number of steps that text-scale-mode will increase/decrease text height
219 (defvar text-scale-mode-amount 0)
220 (make-variable-buffer-local 'text-scale-mode-amount)
222 (define-minor-mode text-scale-mode
223 "Minor mode for displaying buffer text in a larger/smaller font.
224 With a prefix argument ARG, enable the mode if ARG is positive,
225 and disable it otherwise. If called from Lisp, enable the mode
226 if ARG is omitted or nil.
228 The amount of scaling is determined by the variable
229 `text-scale-mode-amount': one step scales the global default
230 face size by the value of the variable `text-scale-mode-step'
231 \(a negative amount shrinks the text).
233 The `text-scale-increase', `text-scale-decrease', and
234 `text-scale-set' functions may be used to interactively modify
235 the variable `text-scale-mode-amount' (they also enable or
236 disable `text-scale-mode' as necessary)."
237 :lighter (" " text-scale-mode-lighter)
238 (when text-scale-mode-remapping
239 (face-remap-remove-relative text-scale-mode-remapping))
240 (setq text-scale-mode-lighter
241 (format (if (>= text-scale-mode-amount 0) "+%d" "%d")
242 text-scale-mode-amount))
243 (setq text-scale-mode-remapping
244 (and text-scale-mode
245 (face-remap-add-relative 'default
246 :height
247 (expt text-scale-mode-step
248 text-scale-mode-amount))))
249 (force-window-update (current-buffer)))
251 ;;;###autoload
252 (defun text-scale-set (level)
253 "Set the scale factor of the default face in the current buffer to LEVEL.
254 If LEVEL is non-zero, `text-scale-mode' is enabled, otherwise it is disabled.
256 LEVEL is a number of steps, with 0 representing the default size.
257 Each step scales the height of the default face by the variable
258 `text-scale-mode-step' (a negative number decreases the height by
259 the same amount)."
260 (interactive "p")
261 (setq text-scale-mode-amount level)
262 (text-scale-mode (if (zerop text-scale-mode-amount) -1 1)))
264 ;;;###autoload
265 (defun text-scale-increase (inc)
266 "Increase the height of the default face in the current buffer by INC steps.
267 If the new height is other than the default, `text-scale-mode' is enabled.
269 Each step scales the height of the default face by the variable
270 `text-scale-mode-step' (a negative number of steps decreases the
271 height by the same amount). As a special case, an argument of 0
272 will remove any scaling currently active."
273 (interactive "p")
274 (setq text-scale-mode-amount
275 (if (= inc 0) 0 (+ (if text-scale-mode text-scale-mode-amount 0) inc)))
276 (text-scale-mode (if (zerop text-scale-mode-amount) -1 1)))
278 ;;;###autoload
279 (defun text-scale-decrease (dec)
280 "Decrease the height of the default face in the current buffer by DEC steps.
281 See `text-scale-increase' for more details."
282 (interactive "p")
283 (text-scale-increase (- dec)))
285 ;;;###autoload (define-key ctl-x-map [(control ?+)] 'text-scale-adjust)
286 ;;;###autoload (define-key ctl-x-map [(control ?-)] 'text-scale-adjust)
287 ;;;###autoload (define-key ctl-x-map [(control ?=)] 'text-scale-adjust)
288 ;;;###autoload (define-key ctl-x-map [(control ?0)] 'text-scale-adjust)
289 ;;;###autoload
290 (defun text-scale-adjust (inc)
291 "Adjust the height of the default face by INC.
293 INC may be passed as a numeric prefix argument.
295 The actual adjustment made depends on the final component of the
296 key-binding used to invoke the command, with all modifiers removed:
298 +, = Increase the default face height by one step
299 - Decrease the default face height by one step
300 0 Reset the default face height to the global default
302 When adjusting with `+' or `-', continue to read input events and
303 further adjust the face height as long as the input event read
304 \(with all modifiers removed) is `+' or `-'.
306 When adjusting with `0', immediately finish.
308 Each step scales the height of the default face by the variable
309 `text-scale-mode-step' (a negative number of steps decreases the
310 height by the same amount). As a special case, an argument of 0
311 will remove any scaling currently active.
313 This command is a special-purpose wrapper around the
314 `text-scale-increase' command which makes repetition convenient
315 even when it is bound in a non-top-level keymap. For binding in
316 a top-level keymap, `text-scale-increase' or
317 `text-scale-decrease' may be more appropriate."
318 (interactive "p")
319 (let ((ev last-command-event)
320 (echo-keystrokes nil))
321 (let* ((base (event-basic-type ev))
322 (step
323 (pcase base
324 ((or ?+ ?=) inc)
325 (?- (- inc))
326 (?0 0)
327 (t inc))))
328 (text-scale-increase step)
329 ;; (unless (zerop step)
330 (message "Use +,-,0 for further adjustment")
331 (set-temporary-overlay-map
332 (let ((map (make-sparse-keymap)))
333 (dolist (mods '(() (control)))
334 (dolist (key '(?- ?+ ?= ?0)) ;; = is often unshifted +.
335 (define-key map (vector (append mods (list key)))
336 (lambda () (interactive) (text-scale-adjust (abs inc))))))
337 map))))) ;; )
340 ;; ----------------------------------------------------------------
341 ;; buffer-face-mode
343 (defcustom buffer-face-mode-face 'variable-pitch
344 "The face specification used by `buffer-face-mode'.
345 It may contain any value suitable for a `face' text property,
346 including a face name, a list of face names, a face-attribute
347 plist, etc."
348 :group 'display
349 :version "23.1")
351 ;; current remapping cookie for buffer-face-mode
352 (defvar buffer-face-mode-remapping nil)
353 (make-variable-buffer-local 'buffer-face-mode-remapping)
355 ;;;###autoload
356 (define-minor-mode buffer-face-mode
357 "Minor mode for a buffer-specific default face.
358 With a prefix argument ARG, enable the mode if ARG is positive,
359 and disable it otherwise. If called from Lisp, enable the mode
360 if ARG is omitted or nil. When enabled, the face specified by the
361 variable `buffer-face-mode-face' is used to display the buffer text."
362 :lighter " BufFace"
363 (when buffer-face-mode-remapping
364 (face-remap-remove-relative buffer-face-mode-remapping))
365 (setq buffer-face-mode-remapping
366 (and buffer-face-mode
367 (face-remap-add-relative 'default buffer-face-mode-face)))
368 (force-window-update (current-buffer)))
370 ;;;###autoload
371 (defun buffer-face-set (&rest specs)
372 "Enable `buffer-face-mode', using face specs SPECS.
373 Each argument in SPECS should be a face, i.e. either a face name
374 or a property list of face attributes and values. If more than
375 one face is listed, that specifies an aggregate face, like in a
376 `face' text property. If SPECS is nil or omitted, disable
377 `buffer-face-mode'.
379 This function makes the variable `buffer-face-mode-face' buffer
380 local, and sets it to FACE."
381 (interactive (list (read-face-name "Set buffer face" (face-at-point t))))
382 (while (and (consp specs) (null (cdr specs)))
383 (setq specs (car specs)))
384 (if (null specs)
385 (buffer-face-mode 0)
386 (set (make-local-variable 'buffer-face-mode-face) specs)
387 (buffer-face-mode t)))
389 ;;;###autoload
390 (defun buffer-face-toggle (&rest specs)
391 "Toggle `buffer-face-mode', using face specs SPECS.
392 Each argument in SPECS should be a face, i.e. either a face name
393 or a property list of face attributes and values. If more than
394 one face is listed, that specifies an aggregate face, like in a
395 `face' text property.
397 If `buffer-face-mode' is already enabled, and is currently using
398 the face specs SPECS, then it is disabled; if `buffer-face-mode'
399 is disabled, or is enabled and currently displaying some other
400 face, then is left enabled, but the face changed to reflect SPECS.
402 This function will make the variable `buffer-face-mode-face'
403 buffer local, and set it to SPECS."
404 (interactive (list buffer-face-mode-face))
405 (while (and (consp specs) (null (cdr specs)))
406 (setq specs (car specs)))
407 (if (or (null specs)
408 (and buffer-face-mode (equal buffer-face-mode-face specs)))
409 (buffer-face-mode 0)
410 (set (make-local-variable 'buffer-face-mode-face) specs)
411 (buffer-face-mode t)))
413 (defun buffer-face-mode-invoke (specs arg &optional interactive)
414 "Enable or disable `buffer-face-mode' using face specs SPECS.
415 ARG controls whether the mode is enabled or disabled, and is
416 interpreted in the usual manner for minor-mode commands.
418 SPECS can be any value suitable for a `face' text property,
419 including a face name, a plist of face attributes and values,
420 or a list of faces.
422 If INTERACTIVE is non-nil, display a message describing the
423 result.
425 This is a wrapper function which calls `buffer-face-set' or
426 `buffer-face-toggle' (depending on ARG), and prints a status
427 message in the echo area. In many cases one of those functions
428 may be more appropriate."
429 (let ((last-message (current-message)))
430 (if (or (eq arg 'toggle) (not arg))
431 (buffer-face-toggle specs)
432 (buffer-face-set (and (> (prefix-numeric-value arg) 0) specs)))
433 (when interactive
434 (unless (and (current-message)
435 (not (equal last-message (current-message))))
436 (message "Buffer-Face mode %sabled"
437 (if buffer-face-mode "en" "dis"))))))
440 ;; ----------------------------------------------------------------
441 ;; variable-pitch-mode
443 ;;;###autoload
444 (defun variable-pitch-mode (&optional arg)
445 "Variable-pitch default-face mode.
446 An interface to `buffer-face-mode' which uses the `variable-pitch' face.
447 Besides the choice of face, it is the same as `buffer-face-mode'."
448 (interactive (list (or current-prefix-arg 'toggle)))
449 (buffer-face-mode-invoke 'variable-pitch arg
450 (called-interactively-p 'interactive)))
453 (provide 'face-remap)
455 ;;; face-remap.el ends here