face-remap.el 10.6 KB
Newer Older
1 2 3 4 5 6 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
;;; face-remap.el --- Functions for managing `face-remapping-alist'
;;
;; Copyright (C) 2008 Free Software Foundation, Inc.
;;
;; Author: Miles Bader <miles@gnu.org>
;; Keywords: faces face display user commands
;;
;; 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 64
;; mode setting face remappings, e.g., of the default face.
;;
;; All modifications cause face-remapping-alist to be made buffer-local.
;;


;;; Code:

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

;;;### autoload
65
(defun face-remap-add-relative (face &rest specs)
66 67 68
  "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
69
`face-remap-remove-relative'.
70 71 72 73 74 75 76 77 78 79

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
global definition of FACE, with the most recently added relative
remapping taking precedence.

The base (lowest priority) remapping may be set to a specific
value, instead of the default of the global face definition,
80
using `face-remap-set-base'."
81 82 83 84 85 86 87 88
  (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))
    (setcdr entry (cons specs (cdr entry)))
    (cons face specs)))

89 90
(defun face-remap-remove-relative (cookie)
  "Remove a face remapping previously added by `face-remap-add-relative'.
91 92 93 94 95 96 97 98 99 100 101 102 103 104
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))))))

;;;### autoload
105
(defun face-remap-reset-base (face)
106 107 108 109 110 111 112 113 114 115 116 117 118
  "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

;;;### autoload
119
(defun face-remap-set-base (face &rest specs)
120 121 122 123 124 125 126 127
  "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."
  (if (or (null specs)
	  (and (eq (car specs) face) (null (cdr specs)))) ; default
      ;; Set entry back to default
128
      (face-remap-reset-base face)
129 130 131 132 133 134
    ;; 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)))))
135

136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161

;; ----------------------------------------------------------------
;; 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
  :type 'number)

;; 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
  "Minor mode for displaying buffer text in a larger/smaller font than usual.

The amount of scaling is determined by the variable
162 163 164 165
`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).

166 167 168 169
The `text-scale-increase' and `text-scale-decrease' functions may
be used to interactively modify the variable
`text-scale-mode-amount' (they also enable or disable
`text-scale-mode' as necessary)."
170 171
  :lighter (" " text-scale-mode-lighter)
  (when text-scale-mode-remapping
172
    (face-remap-remove-relative text-scale-mode-remapping))
173 174 175 176 177
  (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
178
	     (face-remap-add-relative 'default
179 180 181 182 183 184
					  :height
					  (expt text-scale-mode-step
						text-scale-mode-amount))))
  (force-window-update (current-buffer)))

;;;###autoload
185
(defun text-scale-increase (&optional inc)
186 187 188 189 190 191 192
  "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."
193
  (interactive "p")
194 195 196 197
  (setq text-scale-mode-amount (if (= inc 0) 0 (+ text-scale-mode-amount inc)))
  (text-scale-mode (if (zerop text-scale-mode-amount) -1 1)))

;;;###autoload
198
(defun text-scale-decrease (&optional dec)
199
  "Decrease the height of the default face in the current buffer by DEC steps.
200
See `text-scale-increase' for more details."
201
  (interactive "p")
202
  (text-scale-increase (- dec)))
203

204 205 206 207
;;;###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)
208
;;;###autoload
209
(defun text-scale-adjust (&optional inc)
210 211 212
  "Increase or decrease the height of the default face in the current buffer.

The actual adjustment made depends on the final component of the
213
key-binding used to invoke the command, with all modifiers removed:
214 215 216 217 218 219

   +, =   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
220 221
height as long as the input event read (with all modifiers removed)
is one of the above.
222 223 224 225 226 227 228

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
229 230 231 232
`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."
233
  (interactive "p")
234
  (let ((first t)
235 236 237 238 239 240 241 242 243 244
	(step t)
	(ev last-command-event))
    (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))
245
	      (first
246 247 248 249
	       (setq step inc))
	      (t
	       (setq step nil))))
      (when step
250
	(text-scale-increase step)
251 252 253 254
	(setq inc 1 first nil)
	(setq ev (read-event))))
    (push ev unread-command-events)))

255 256 257 258 259 260 261 262 263 264

;; ----------------------------------------------------------------
;; variable-pitch-mode

;; suggested key binding: (global-set-key "\C-cv" 'variable-pitch-mode)

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

Miles Bader's avatar
Miles Bader committed
265
;;;###autoload
266
(define-minor-mode variable-pitch-mode
267 268 269
  "Variable-pitch default-face mode.
When active, causes the buffer text to be displayed using
the `variable-pitch' face."
270 271
  :lighter " VarPitch"
  (when variable-pitch-mode-remapping
272
    (face-remap-remove-relative variable-pitch-mode-remapping))
273 274
  (setq variable-pitch-mode-remapping
	(and variable-pitch-mode
275
	     (face-remap-add-relative 'default 'variable-pitch)))
276 277 278 279 280 281 282
  (force-window-update (current-buffer)))


(provide 'face-remap)

;; arch-tag: 5c5f034b-8d58-4967-82bd-d61fd364e686
;;; face-remap.el ends here