face-remap.el 16.7 KB
Newer Older
1 2
;;; face-remap.el --- Functions for managing `face-remapping-alist'
;;
3
;; Copyright (C) 2008-2012 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 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38
;;
;; 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
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
;;

;;; 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 67 68 69 70 71 72 73 74 75 76 77 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
;; 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))

106
;;;###autoload
107
(defun face-remap-add-relative (face &rest specs)
108 109 110
  "Add a face remapping entry of FACE to SPECS in the current buffer.

Return a cookie which can be used to delete the remapping with
111
`face-remap-remove-relative'.
112 113 114 115 116

SPECS can be any value suitable for the `face' text property,
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
117 118 119
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.
120 121 122

The base (lowest priority) remapping may be set to a specific
value, instead of the default of the global face definition,
123
using `face-remap-set-base'."
124 125
  (while (and (consp specs) (null (cdr specs)))
    (setq specs (car specs)))
126 127 128 129 130
  (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))
131
    (setcdr entry (face-remap-order (cons specs (cdr entry))))
132 133
    (cons face specs)))

134 135
(defun face-remap-remove-relative (cookie)
  "Remove a face remapping previously added by `face-remap-add-relative'.
136 137 138 139 140 141 142 143 144 145 146 147 148
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
		  (remq remapping face-remapping-alist)))
	  (cdr cookie))))))

149
;;;###autoload
150
(defun face-remap-reset-base (face)
151 152 153 154 155 156 157 158 159 160 161 162
  "Set the base remapping of FACE to inherit from FACE's global definition."
  (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))
	(setcar (last entry) face)))))  ; otherwise, just inherit global def

163
;;;###autoload
164
(defun face-remap-set-base (face &rest specs)
165 166 167 168 169
  "Set the base remapping of FACE in the current buffer to SPECS.
If SPECS is empty, the default base remapping is restored, which
inherits from the global definition of FACE; note that this is
different from SPECS containing a single value `nil', which does
not inherit from the global definition of FACE."
170 171
  (while (and (consp specs) (not (null (car specs))) (null (cdr specs)))
    (setq specs (car specs)))
172 173 174
  (if (or (null specs)
	  (and (eq (car specs) face) (null (cdr specs)))) ; default
      ;; Set entry back to default
175
      (face-remap-reset-base face)
176 177 178 179 180 181
    ;; 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
	(push (list face specs) face-remapping-alist)))))
182

183 184 185 186 187 188 189 190

;; ----------------------------------------------------------------
;; 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
191 192
  :type 'number
  :version "23.1")
193 194 195 196 197 198 199 200 201 202 203 204 205 206

;; 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)

(define-minor-mode text-scale-mode
207
  "Minor mode for displaying buffer text in a larger/smaller font.
208 209 210
With a prefix argument ARG, enable the mode if ARG is positive,
and disable it otherwise.  If called from Lisp, enable the mode
if ARG is omitted or nil.
211 212

The amount of scaling is determined by the variable
213 214 215 216
`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
217 218 219 220
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
disable `text-scale-mode' as necessary)."
221 222
  :lighter (" " text-scale-mode-lighter)
  (when text-scale-mode-remapping
223
    (face-remap-remove-relative text-scale-mode-remapping))
224 225 226 227 228
  (setq text-scale-mode-lighter
	(format (if (>= text-scale-mode-amount 0) "+%d" "%d")
		text-scale-mode-amount))
  (setq text-scale-mode-remapping
	(and text-scale-mode
229
	     (face-remap-add-relative 'default
230 231 232 233 234
					  :height
					  (expt text-scale-mode-step
						text-scale-mode-amount))))
  (force-window-update (current-buffer)))

Miles Bader's avatar
Miles Bader committed
235 236 237 238 239 240 241 242 243 244 245 246 247
;;;###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")
  (setq text-scale-mode-amount level)
  (text-scale-mode (if (zerop text-scale-mode-amount) -1 1)))

248
;;;###autoload
249
(defun text-scale-increase (inc)
250 251 252 253 254 255 256
  "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."
257
  (interactive "p")
258 259
  (setq text-scale-mode-amount
	(if (= inc 0) 0 (+ (if text-scale-mode text-scale-mode-amount 0) inc)))
260 261 262
  (text-scale-mode (if (zerop text-scale-mode-amount) -1 1)))

;;;###autoload
263
(defun text-scale-decrease (dec)
264
  "Decrease the height of the default face in the current buffer by DEC steps.
265
See `text-scale-increase' for more details."
266
  (interactive "p")
267
  (text-scale-increase (- dec)))
268

269 270 271 272
;;;###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)
273
;;;###autoload
274
(defun text-scale-adjust (inc)
275 276 277
  "Increase or decrease the height of the default face in the current buffer.

The actual adjustment made depends on the final component of the
278
key-binding used to invoke the command, with all modifiers removed:
279 280 281 282 283 284

   +, =   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

Then, continue to read input events and further adjust the face
285 286
height as long as the input event read (with all modifiers removed)
is one of the above.
287 288 289 290 291 292 293

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
294 295 296 297
`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."
298
  (interactive "p")
299
  (let ((first t)
300
	(step t)
301 302
	(ev last-command-event)
	(echo-keystrokes nil))
303 304 305 306 307 308 309 310
    (while step
      (let ((base (event-basic-type ev)))
	(cond ((or (eq base ?+) (eq base ?=))
	       (setq step inc))
	      ((eq base ?-)
	       (setq step (- inc)))
	      ((eq base ?0)
	       (setq step 0))
311
	      (first
312 313 314 315
	       (setq step inc))
	      (t
	       (setq step nil))))
      (when step
316
	(text-scale-increase step)
317
	(setq inc 1 first nil)
318
	(setq ev (read-event "+,-,0 for further adjustment: "))))
319 320
    (push ev unread-command-events)))

321 322

;; ----------------------------------------------------------------
Miles Bader's avatar
Miles Bader committed
323
;; buffer-face-mode
324

Miles Bader's avatar
Miles Bader committed
325 326 327 328 329
(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."
330 331
  :group 'display
  :version "23.1")
332

Miles Bader's avatar
Miles Bader committed
333 334 335
;; current remapping cookie for  buffer-face-mode
(defvar buffer-face-mode-remapping nil)
(make-variable-buffer-local 'buffer-face-mode-remapping)
336

Miles Bader's avatar
Miles Bader committed
337
;;;###autoload
Miles Bader's avatar
Miles Bader committed
338 339
(define-minor-mode buffer-face-mode
  "Minor mode for a buffer-specific default face.
340 341 342 343
With a prefix argument ARG, enable the mode if ARG is positive,
and disable it otherwise.  If called from Lisp, enable the mode
if ARG is omitted or nil.  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
344 345 346 347 348 349
  :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)))
350 351
  (force-window-update (current-buffer)))

Miles Bader's avatar
Miles Bader committed
352
;;;###autoload
353 354 355 356 357 358 359 360
(defun buffer-face-set (&rest specs)
  "Enable `buffer-face-mode', using face specs SPECS.
SPECS can be any value suitable for the `face' text property,
including a face name, a list of face names, or a face-attribute
If SPECS is nil, then `buffer-face-mode' is disabled.

This function will make the variable `buffer-face-mode-face'
buffer local, and set it to FACE."
Miles Bader's avatar
Miles Bader committed
361
  (interactive (list (read-face-name "Set buffer face")))
362 363 364
  (while (and (consp specs) (null (cdr specs)))
    (setq specs (car specs)))
  (if (null specs)
Miles Bader's avatar
Miles Bader committed
365
      (buffer-face-mode 0)
366
    (set (make-local-variable 'buffer-face-mode-face) specs)
Miles Bader's avatar
Miles Bader committed
367 368 369
    (buffer-face-mode t)))

;;;###autoload
370 371 372 373
(defun buffer-face-toggle (&rest specs)
  "Toggle `buffer-face-mode', using face specs SPECS.
SPECS can be any value suitable for the `face' text property,
including a face name, a list of face names, or a face-attribute
Miles Bader's avatar
Miles Bader committed
374 375

If `buffer-face-mode' is already enabled, and is currently using
376
the face specs SPECS, then it is disabled; if buffer-face-mode is
Miles Bader's avatar
Miles Bader committed
377
disabled, or is enabled and currently displaying some other face,
378 379 380 381
then is left enabled, but the face changed to reflect SPECS.

This function will make the variable `buffer-face-mode-face'
buffer local, and set it to SPECS."
Miles Bader's avatar
Miles Bader committed
382
  (interactive (list buffer-face-mode-face))
383 384 385 386
  (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
387
      (buffer-face-mode 0)
388
    (set (make-local-variable 'buffer-face-mode-face) specs)
Miles Bader's avatar
Miles Bader committed
389 390
    (buffer-face-mode t)))

391 392 393 394 395 396 397 398 399 400
(defun buffer-face-mode-invoke (specs arg &optional interactive)
  "Enable or disable `buffer-face-mode' using face specs SPECS, and argument ARG.
ARG controls whether the mode is enabled or disabled, and is
interpreted in the usual manner for minor-mode commands.

SPECS can be any value suitable for the `face' text property,
including a face name, a list of face names, or a face-attribute

If INTERACTIVE is non-nil, a message will be displayed describing the result.

401
This is a wrapper function which calls `buffer-face-set' or
402 403 404
`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
405 406
  (let ((last-message (current-message)))
    (if (or (eq arg 'toggle) (not arg))
407 408
	(buffer-face-toggle specs)
      (buffer-face-set (and (> (prefix-numeric-value arg) 0) specs)))
Miles Bader's avatar
Miles Bader committed
409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424
    (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)))
425 426
  (buffer-face-mode-invoke 'variable-pitch arg
			   (called-interactively-p 'interactive)))
Miles Bader's avatar
Miles Bader committed
427

428 429 430 431

(provide 'face-remap)

;;; face-remap.el ends here