Standardize case of "GTK+" in a few manuals
[emacs.git] / lisp / face-remap.el
blobca7a28328f9784caf8a2bb7e1fa5768195cd7e76
1 ;;; face-remap.el --- Functions for managing `face-remapping-alist'
2 ;;
3 ;; Copyright (C) 2008-2012 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 be either a list of face
113 names, or a property list of face attribute/value pairs. The
114 remapping specified by SPECS takes effect alongside the
115 remappings from other calls to `face-remap-add-relative', as well
116 as the normal definition of FACE (at lowest priority). This
117 function tries to sort multiple remappings for the same face, so
118 that remappings specifying relative face attributes are applied
119 after remappings specifying absolute face attributes.
121 The base (lowest priority) remapping may be set to something
122 other than the normal definition of FACE via `face-remap-set-base'."
123 (while (and (consp specs) (null (cdr specs)))
124 (setq specs (car specs)))
125 (make-local-variable 'face-remapping-alist)
126 (let ((entry (assq face face-remapping-alist)))
127 (when (null entry)
128 (setq entry (list face face)) ; explicitly merge with global def
129 (push entry face-remapping-alist))
130 (setcdr entry (face-remap-order (cons specs (cdr entry))))
131 (cons face specs)))
133 (defun face-remap-remove-relative (cookie)
134 "Remove a face remapping previously added by `face-remap-add-relative'.
135 COOKIE should be the return value from that function."
136 (let ((remapping (assq (car cookie) face-remapping-alist)))
137 (when remapping
138 (let ((updated-entries (remq (cdr cookie) (cdr remapping))))
139 (unless (eq updated-entries (cdr remapping))
140 (setcdr remapping updated-entries)
141 (when (or (null updated-entries)
142 (and (eq (car-safe updated-entries) (car cookie))
143 (null (cdr updated-entries))))
144 (setq face-remapping-alist
145 (remq remapping face-remapping-alist)))
146 (cdr cookie))))))
148 ;;;###autoload
149 (defun face-remap-reset-base (face)
150 "Set the base remapping of FACE to the normal definition of FACE.
151 This causes the remappings specified by `face-remap-add-relative'
152 to apply on top of the normal definition of FACE."
153 (let ((entry (assq face face-remapping-alist)))
154 (when entry
155 ;; If there's nothing except a base remapping, we simply remove
156 ;; the entire remapping entry, as setting the base to the default
157 ;; would be the same as the global definition. Otherwise, we
158 ;; modify the base remapping.
159 (if (null (cddr entry)) ; nothing except base remapping
160 (setq face-remapping-alist ; so remove entire entry
161 (remq entry face-remapping-alist))
162 (setcar (last entry) face))))) ; otherwise, just inherit global def
164 ;;;###autoload
165 (defun face-remap-set-base (face &rest specs)
166 "Set the base remapping of FACE in the current buffer to SPECS.
167 This causes the remappings specified by `face-remap-add-relative'
168 to apply on top of the face specification given by SPECS. SPECS
169 should be either a list of face names, or a property list of face
170 attribute/value pairs.
172 If SPECS is empty, call `face-remap-reset-base' to use the normal
173 definition of FACE as the base remapping; note that this is
174 different from SPECS containing a single value `nil', which means
175 not to inherit from the global definition of FACE at all."
176 (while (and (consp specs) (not (null (car specs))) (null (cdr specs)))
177 (setq specs (car specs)))
178 (if (or (null specs)
179 (and (eq (car specs) face) (null (cdr specs)))) ; default
180 ;; Set entry back to default
181 (face-remap-reset-base face)
182 ;; Set the base remapping
183 (make-local-variable 'face-remapping-alist)
184 (let ((entry (assq face face-remapping-alist)))
185 (if entry
186 (setcar (last entry) specs) ; overwrite existing base entry
187 (push (list face specs) face-remapping-alist)))))
190 ;; ----------------------------------------------------------------
191 ;; text-scale-mode
193 (defcustom text-scale-mode-step 1.2
194 "Scale factor used by `text-scale-mode'.
195 Each positive or negative step scales the default face height by this amount."
196 :group 'display
197 :type 'number
198 :version "23.1")
200 ;; current remapping cookie for text-scale-mode
201 (defvar text-scale-mode-remapping nil)
202 (make-variable-buffer-local 'text-scale-mode-remapping)
204 ;; Lighter displayed for text-scale-mode in mode-line minor-mode list
205 (defvar text-scale-mode-lighter "+0")
206 (make-variable-buffer-local 'text-scale-mode-lighter)
208 ;; Number of steps that text-scale-mode will increase/decrease text height
209 (defvar text-scale-mode-amount 0)
210 (make-variable-buffer-local 'text-scale-mode-amount)
212 (define-minor-mode text-scale-mode
213 "Minor mode for displaying buffer text in a larger/smaller font.
214 With a prefix argument ARG, enable the mode if ARG is positive,
215 and disable it otherwise. If called from Lisp, enable the mode
216 if ARG is omitted or nil.
218 The amount of scaling is determined by the variable
219 `text-scale-mode-amount': one step scales the global default
220 face size by the value of the variable `text-scale-mode-step'
221 \(a negative amount shrinks the text).
223 The `text-scale-increase', `text-scale-decrease', and
224 `text-scale-set' functions may be used to interactively modify
225 the variable `text-scale-mode-amount' (they also enable or
226 disable `text-scale-mode' as necessary)."
227 :lighter (" " text-scale-mode-lighter)
228 (when text-scale-mode-remapping
229 (face-remap-remove-relative text-scale-mode-remapping))
230 (setq text-scale-mode-lighter
231 (format (if (>= text-scale-mode-amount 0) "+%d" "%d")
232 text-scale-mode-amount))
233 (setq text-scale-mode-remapping
234 (and text-scale-mode
235 (face-remap-add-relative 'default
236 :height
237 (expt text-scale-mode-step
238 text-scale-mode-amount))))
239 (force-window-update (current-buffer)))
241 ;;;###autoload
242 (defun text-scale-set (level)
243 "Set the scale factor of the default face in the current buffer to LEVEL.
244 If LEVEL is non-zero, `text-scale-mode' is enabled, otherwise it is disabled.
246 LEVEL is a number of steps, with 0 representing the default size.
247 Each step scales the height of the default face by the variable
248 `text-scale-mode-step' (a negative number decreases the height by
249 the same amount)."
250 (interactive "p")
251 (setq text-scale-mode-amount level)
252 (text-scale-mode (if (zerop text-scale-mode-amount) -1 1)))
254 ;;;###autoload
255 (defun text-scale-increase (inc)
256 "Increase the height of the default face in the current buffer by INC steps.
257 If the new height is other than the default, `text-scale-mode' is enabled.
259 Each step scales the height of the default face by the variable
260 `text-scale-mode-step' (a negative number of steps decreases the
261 height by the same amount). As a special case, an argument of 0
262 will remove any scaling currently active."
263 (interactive "p")
264 (setq text-scale-mode-amount
265 (if (= inc 0) 0 (+ (if text-scale-mode text-scale-mode-amount 0) inc)))
266 (text-scale-mode (if (zerop text-scale-mode-amount) -1 1)))
268 ;;;###autoload
269 (defun text-scale-decrease (dec)
270 "Decrease the height of the default face in the current buffer by DEC steps.
271 See `text-scale-increase' for more details."
272 (interactive "p")
273 (text-scale-increase (- dec)))
275 ;;;###autoload (define-key ctl-x-map [(control ?+)] 'text-scale-adjust)
276 ;;;###autoload (define-key ctl-x-map [(control ?-)] 'text-scale-adjust)
277 ;;;###autoload (define-key ctl-x-map [(control ?=)] 'text-scale-adjust)
278 ;;;###autoload (define-key ctl-x-map [(control ?0)] 'text-scale-adjust)
279 ;;;###autoload
280 (defun text-scale-adjust (inc)
281 "Increase or decrease the height of the default face in the current buffer.
283 The actual adjustment made depends on the final component of the
284 key-binding used to invoke the command, with all modifiers removed:
286 +, = Increase the default face height by one step
287 - Decrease the default face height by one step
288 0 Reset the default face height to the global default
290 Then, continue to read input events and further adjust the face
291 height as long as the input event read (with all modifiers removed)
292 is one of the above.
294 Each step scales the height of the default face by the variable
295 `text-scale-mode-step' (a negative number of steps decreases the
296 height by the same amount). As a special case, an argument of 0
297 will remove any scaling currently active.
299 This command is a special-purpose wrapper around the
300 `text-scale-increase' command which makes repetition convenient
301 even when it is bound in a non-top-level keymap. For binding in
302 a top-level keymap, `text-scale-increase' or
303 `text-scale-decrease' may be more appropriate."
304 (interactive "p")
305 (let ((first t)
306 (step t)
307 (ev last-command-event)
308 (echo-keystrokes nil))
309 (while step
310 (let ((base (event-basic-type ev)))
311 (cond ((or (eq base ?+) (eq base ?=))
312 (setq step inc))
313 ((eq base ?-)
314 (setq step (- inc)))
315 ((eq base ?0)
316 (setq step 0))
317 (first
318 (setq step inc))
320 (setq step nil))))
321 (when step
322 (text-scale-increase step)
323 (setq inc 1 first nil)
324 (setq ev (read-event "+,-,0 for further adjustment: "))))
325 (push ev unread-command-events)))
328 ;; ----------------------------------------------------------------
329 ;; buffer-face-mode
331 (defcustom buffer-face-mode-face 'variable-pitch
332 "The face specification used by `buffer-face-mode'.
333 It may contain any value suitable for a `face' text property,
334 including a face name, a list of face names, a face-attribute
335 plist, etc."
336 :group 'display
337 :version "23.1")
339 ;; current remapping cookie for buffer-face-mode
340 (defvar buffer-face-mode-remapping nil)
341 (make-variable-buffer-local 'buffer-face-mode-remapping)
343 ;;;###autoload
344 (define-minor-mode buffer-face-mode
345 "Minor mode for a buffer-specific default face.
346 With a prefix argument ARG, enable the mode if ARG is positive,
347 and disable it otherwise. If called from Lisp, enable the mode
348 if ARG is omitted or nil. When enabled, the face specified by the
349 variable `buffer-face-mode-face' is used to display the buffer text."
350 :lighter " BufFace"
351 (when buffer-face-mode-remapping
352 (face-remap-remove-relative buffer-face-mode-remapping))
353 (setq buffer-face-mode-remapping
354 (and buffer-face-mode
355 (face-remap-add-relative 'default buffer-face-mode-face)))
356 (force-window-update (current-buffer)))
358 ;;;###autoload
359 (defun buffer-face-set (&rest specs)
360 "Enable `buffer-face-mode', using face specs SPECS.
361 SPECS can be any value suitable for the `face' text property,
362 including a face name, a list of face names, or a face-attribute
363 If SPECS is nil, then `buffer-face-mode' is disabled.
365 This function will make the variable `buffer-face-mode-face'
366 buffer local, and set it to FACE."
367 (interactive (list (read-face-name "Set buffer face")))
368 (while (and (consp specs) (null (cdr specs)))
369 (setq specs (car specs)))
370 (if (null specs)
371 (buffer-face-mode 0)
372 (set (make-local-variable 'buffer-face-mode-face) specs)
373 (buffer-face-mode t)))
375 ;;;###autoload
376 (defun buffer-face-toggle (&rest specs)
377 "Toggle `buffer-face-mode', using face specs SPECS.
378 SPECS can be any value suitable for the `face' text property,
379 including a face name, a list of face names, or a face-attribute
381 If `buffer-face-mode' is already enabled, and is currently using
382 the face specs SPECS, then it is disabled; if buffer-face-mode is
383 disabled, or is enabled and currently displaying some other face,
384 then is left enabled, but the face changed to reflect SPECS.
386 This function will make the variable `buffer-face-mode-face'
387 buffer local, and set it to SPECS."
388 (interactive (list buffer-face-mode-face))
389 (while (and (consp specs) (null (cdr specs)))
390 (setq specs (car specs)))
391 (if (or (null specs)
392 (and buffer-face-mode (equal buffer-face-mode-face specs)))
393 (buffer-face-mode 0)
394 (set (make-local-variable 'buffer-face-mode-face) specs)
395 (buffer-face-mode t)))
397 (defun buffer-face-mode-invoke (specs arg &optional interactive)
398 "Enable or disable `buffer-face-mode' using face specs SPECS, and argument ARG.
399 ARG controls whether the mode is enabled or disabled, and is
400 interpreted in the usual manner for minor-mode commands.
402 SPECS can be any value suitable for the `face' text property,
403 including a face name, a list of face names, or a face-attribute
405 If INTERACTIVE is non-nil, a message will be displayed describing the result.
407 This is a wrapper function which calls `buffer-face-set' or
408 `buffer-face-toggle' (depending on ARG), and prints a status
409 message in the echo area. In many cases one of those functions
410 may be more appropriate."
411 (let ((last-message (current-message)))
412 (if (or (eq arg 'toggle) (not arg))
413 (buffer-face-toggle specs)
414 (buffer-face-set (and (> (prefix-numeric-value arg) 0) specs)))
415 (when interactive
416 (unless (and (current-message)
417 (not (equal last-message (current-message))))
418 (message "Buffer-Face mode %sabled"
419 (if buffer-face-mode "en" "dis"))))))
422 ;; ----------------------------------------------------------------
423 ;; variable-pitch-mode
425 ;;;###autoload
426 (defun variable-pitch-mode (&optional arg)
427 "Variable-pitch default-face mode.
428 An interface to `buffer-face-mode' which uses the `variable-pitch' face.
429 Besides the choice of face, it is the same as `buffer-face-mode'."
430 (interactive (list (or current-prefix-arg 'toggle)))
431 (buffer-face-mode-invoke 'variable-pitch arg
432 (called-interactively-p 'interactive)))
435 (provide 'face-remap)
437 ;;; face-remap.el ends here