Commit | Line | Data |
---|---|---|
9d3d42fb MB |
1 | ;;; face-remap.el --- Functions for managing `face-remapping-alist' |
2 | ;; | |
3 | ;; Copyright (C) 2008 Free Software Foundation, Inc. | |
4 | ;; | |
5 | ;; Author: Miles Bader <miles@gnu.org> | |
6 | ;; Keywords: faces face 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. | |
14 | ;; | |
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. | |
19 | ;; | |
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/>. | |
22 | ;; | |
23 | ||
24 | ;;; Commentary: | |
25 | ||
26 | ;; | |
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. | |
30 | ;; | |
31 | ;; Each face-remapping definition in `face-remapping-alist' added by | |
32 | ;; this code uses the form: | |
33 | ;; | |
34 | ;; (face RELATIVE_SPECS_1 RELATIVE_SPECS_2 ... BASE_SPECS) | |
35 | ;; | |
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. | |
38 | ;; | |
39 | ;; The RELATIVE_SPECS_* values are added by `add-relative-face-remapping' | |
40 | ;; (and removed by `remove-relative-face-remapping', and are intended for | |
41 | ;; face "modifications" (such as increasing the size). Typical users of | |
42 | ;; relative specs would be minor modes. | |
43 | ;; | |
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. | |
46 | ;; | |
47 | ;; A non-default value of BASE_SPECS may also be set using | |
48 | ;; `set-base-face-remapping'. Because this _overwrites_ the default | |
49 | ;; value inheriting from the global face definition, it is up to the | |
50 | ;; caller of set-base-face-remapping to add such inheritance if it is | |
51 | ;; desired. A typical use of set-base-face-remapping would be a major | |
52 | ;; mode setting face remappings, e.g., of the default face. | |
53 | ;; | |
54 | ;; All modifications cause face-remapping-alist to be made buffer-local. | |
55 | ;; | |
56 | ||
57 | ||
58 | ;;; Code: | |
59 | ||
60 | \f | |
61 | ;; ---------------------------------------------------------------- | |
62 | ;; Utility functions | |
63 | ||
64 | ;;;### autoload | |
65 | (defun add-relative-face-remapping (face &rest specs) | |
66 | "Add a face remapping entry of FACE to SPECS in the current buffer. | |
67 | ||
68 | Return a cookie which can be used to delete the remapping with | |
69 | `remove-relative-face-remapping'. | |
70 | ||
71 | SPECS can be any value suitable for the `face' text property, | |
72 | including a face name, a list of face names, or a face-attribute | |
73 | property list. The attributes given by SPECS will be merged with | |
74 | any other currently active face remappings of FACE, and with the | |
75 | global definition of FACE, with the most recently added relative | |
76 | remapping taking precedence. | |
77 | ||
78 | The base (lowest priority) remapping may be set to a specific | |
79 | value, instead of the default of the global face definition, | |
80 | using `set-base-face-remapping'." | |
81 | (make-local-variable 'face-remapping-alist) | |
82 | (let ((entry (assq face face-remapping-alist))) | |
83 | (when (null entry) | |
84 | (setq entry (list face face)) ; explicitly merge with global def | |
85 | (push entry face-remapping-alist)) | |
86 | (setcdr entry (cons specs (cdr entry))) | |
87 | (cons face specs))) | |
88 | ||
89 | (defun remove-relative-face-remapping (cookie) | |
90 | "Remove a face remapping previously added by `add-relative-face-remapping'. | |
91 | COOKIE should be the return value from that function." | |
92 | (let ((remapping (assq (car cookie) face-remapping-alist))) | |
93 | (when remapping | |
94 | (let ((updated-entries (remq (cdr cookie) (cdr remapping)))) | |
95 | (unless (eq updated-entries (cdr remapping)) | |
96 | (setcdr remapping updated-entries) | |
97 | (when (or (null updated-entries) | |
98 | (and (eq (car-safe updated-entries) (car cookie)) | |
99 | (null (cdr updated-entries)))) | |
100 | (setq face-remapping-alist | |
101 | (remq remapping face-remapping-alist))) | |
102 | (cdr cookie)))))) | |
103 | ||
104 | ;;;### autoload | |
105 | (defun set-default-base-face-remapping (face) | |
106 | "Set the base remapping of FACE to inherit from FACE's global definition." | |
107 | (let ((entry (assq face face-remapping-alist))) | |
108 | (when entry | |
109 | ;; If there's nothing except a base remapping, we simply remove | |
110 | ;; the entire remapping entry, as setting the base to the default | |
111 | ;; would be the same as the global definition. Otherwise, we | |
112 | ;; modify the base remapping. | |
113 | (if (null (cddr entry)) ; nothing except base remapping | |
114 | (setq face-remapping-alist ; so remove entire entry | |
115 | (remq entry face-remapping-alist)) | |
116 | (setcar (last entry) face))))) ; otherwise, just inherit global def | |
117 | ||
118 | ;;;### autoload | |
119 | (defun set-base-face-remapping (face &rest specs) | |
120 | "Set the base remapping of FACE in the current buffer to SPECS. | |
121 | If SPECS is empty, the default base remapping is restored, which | |
122 | inherits from the global definition of FACE; note that this is | |
123 | different from SPECS containing a single value `nil', which does | |
124 | not inherit from the global definition of FACE." | |
125 | (if (or (null specs) | |
126 | (and (eq (car specs) face) (null (cdr specs)))) ; default | |
127 | ;; Set entry back to default | |
128 | (set-default-base-face-remapping face) | |
129 | ;; Set the base remapping | |
130 | (make-local-variable 'face-remapping-alist) | |
131 | (let ((entry (assq face face-remapping-alist))) | |
132 | (if entry | |
133 | (setcar (last entry) specs) ; overwrite existing base entry | |
134 | (push (list face specs) face-remapping-alist))))) | |
12de5099 | 135 | |
9d3d42fb MB |
136 | \f |
137 | ;; ---------------------------------------------------------------- | |
138 | ;; text-scale-mode | |
139 | ||
140 | (defcustom text-scale-mode-step 1.2 | |
141 | "Scale factor used by `text-scale-mode'. | |
142 | Each positive or negative step scales the default face height by this amount." | |
143 | :group 'display | |
144 | :type 'number) | |
145 | ||
146 | ;; current remapping cookie for text-scale-mode | |
147 | (defvar text-scale-mode-remapping nil) | |
148 | (make-variable-buffer-local 'text-scale-mode-remapping) | |
149 | ||
150 | ;; Lighter displayed for text-scale-mode in mode-line minor-mode list | |
151 | (defvar text-scale-mode-lighter "+0") | |
152 | (make-variable-buffer-local 'text-scale-mode-lighter) | |
153 | ||
154 | ;; Number of steps that text-scale-mode will increase/decrease text height | |
155 | (defvar text-scale-mode-amount 0) | |
156 | (make-variable-buffer-local 'text-scale-mode-amount) | |
157 | ||
158 | (define-minor-mode text-scale-mode | |
159 | "Minor mode for displaying buffer text in a larger/smaller font than usual. | |
160 | ||
161 | The amount of scaling is determined by the variable | |
12de5099 JB |
162 | `text-scale-mode-amount': one step scales the global default |
163 | face size by the value of the variable `text-scale-mode-step' | |
164 | \(a negative amount shrinks the text). | |
165 | ||
166 | The `increase-buffer-face-height' and `decrease-buffer-face-height' | |
167 | functions may be used to interactively modify the variable | |
168 | `text-scale-mode-amount' (they also enable or disable `text-scale-mode' | |
169 | as necessary)." | |
9d3d42fb MB |
170 | :lighter (" " text-scale-mode-lighter) |
171 | (when text-scale-mode-remapping | |
172 | (remove-relative-face-remapping text-scale-mode-remapping)) | |
173 | (setq text-scale-mode-lighter | |
174 | (format (if (>= text-scale-mode-amount 0) "+%d" "%d") | |
175 | text-scale-mode-amount)) | |
176 | (setq text-scale-mode-remapping | |
177 | (and text-scale-mode | |
178 | (add-relative-face-remapping 'default | |
179 | :height | |
180 | (expt text-scale-mode-step | |
181 | text-scale-mode-amount)))) | |
182 | (force-window-update (current-buffer))) | |
183 | ||
9d3d42fb MB |
184 | ;;;###autoload |
185 | (defun increase-buffer-face-height (&optional inc) | |
186 | "Increase the height of the default face in the current buffer by INC steps. | |
187 | If the new height is other than the default, `text-scale-mode' is enabled. | |
188 | ||
189 | Each step scales the height of the default face by the variable | |
190 | `text-scale-mode-step' (a negative number of steps decreases the | |
191 | height by the same amount). As a special case, an argument of 0 | |
192 | will remove any scaling currently active." | |
56c73dec | 193 | (interactive "p") |
9d3d42fb MB |
194 | (setq text-scale-mode-amount (if (= inc 0) 0 (+ text-scale-mode-amount inc))) |
195 | (text-scale-mode (if (zerop text-scale-mode-amount) -1 1))) | |
196 | ||
9d3d42fb MB |
197 | ;;;###autoload |
198 | (defun decrease-buffer-face-height (&optional dec) | |
199 | "Decrease the height of the default face in the current buffer by DEC steps. | |
200 | See `increase-buffer-face-height' for more details." | |
56c73dec | 201 | (interactive "p") |
9d3d42fb MB |
202 | (increase-buffer-face-height (- dec))) |
203 | ||
56c73dec MB |
204 | ;;;###autoload (define-key ctl-x-map [(control ?+)] 'adjust-buffer-face-height) |
205 | ;;;###autoload (define-key ctl-x-map [(control ?-)] 'adjust-buffer-face-height) | |
206 | ;;;###autoload (define-key ctl-x-map [(control ?=)] 'adjust-buffer-face-height) | |
207 | ;;;###autoload (define-key ctl-x-map [(control ?0)] 'adjust-buffer-face-height) | |
208 | ;;;###autoload | |
209 | (defun adjust-buffer-face-height (&optional inc) | |
210 | "Increase or decrease the height of the default face in the current buffer. | |
211 | ||
212 | The actual adjustment made depends on the final component of the | |
12de5099 | 213 | key-binding used to invoke the command, with all modifiers removed: |
56c73dec MB |
214 | |
215 | +, = Increase the default face height by one step | |
216 | - Decrease the default face height by one step | |
217 | 0 Reset the default face height to the global default | |
218 | ||
219 | Then, continue to read input events and further adjust the face | |
12de5099 JB |
220 | height as long as the input event read (with all modifiers removed) |
221 | is one of the above. | |
56c73dec MB |
222 | |
223 | Each step scales the height of the default face by the variable | |
224 | `text-scale-mode-step' (a negative number of steps decreases the | |
225 | height by the same amount). As a special case, an argument of 0 | |
226 | will remove any scaling currently active. | |
227 | ||
228 | This command is a special-purpose wrapper around the | |
229 | `increase-buffer-face-height' command which makes repetition | |
12de5099 JB |
230 | convenient even when it is bound in a non-top-level keymap. |
231 | For binding in a top-level keymap, `increase-buffer-face-height' | |
232 | or `decrease-default-face-height' may be more appropriate." | |
56c73dec | 233 | (interactive "p") |
12de5099 | 234 | (let ((first t) |
56c73dec MB |
235 | (step t) |
236 | (ev last-command-event)) | |
237 | (while step | |
238 | (let ((base (event-basic-type ev))) | |
239 | (cond ((or (eq base ?+) (eq base ?=)) | |
240 | (setq step inc)) | |
241 | ((eq base ?-) | |
242 | (setq step (- inc))) | |
243 | ((eq base ?0) | |
244 | (setq step 0)) | |
12de5099 | 245 | (first |
56c73dec MB |
246 | (setq step inc)) |
247 | (t | |
248 | (setq step nil)))) | |
249 | (when step | |
250 | (increase-buffer-face-height step) | |
251 | (setq inc 1 first nil) | |
252 | (setq ev (read-event)))) | |
253 | (push ev unread-command-events))) | |
254 | ||
9d3d42fb MB |
255 | \f |
256 | ;; ---------------------------------------------------------------- | |
257 | ;; variable-pitch-mode | |
258 | ||
259 | ;; suggested key binding: (global-set-key "\C-cv" 'variable-pitch-mode) | |
260 | ||
261 | ;; current remapping cookie for variable-pitch-mode | |
262 | (defvar variable-pitch-mode-remapping nil) | |
263 | (make-variable-buffer-local 'variable-pitch-mode-remapping) | |
264 | ||
265 | (define-minor-mode variable-pitch-mode | |
12de5099 JB |
266 | "Variable-pitch default-face mode. |
267 | When active, causes the buffer text to be displayed using | |
268 | the `variable-pitch' face." | |
9d3d42fb MB |
269 | :lighter " VarPitch" |
270 | (when variable-pitch-mode-remapping | |
271 | (remove-relative-face-remapping variable-pitch-mode-remapping)) | |
272 | (setq variable-pitch-mode-remapping | |
273 | (and variable-pitch-mode | |
274 | (add-relative-face-remapping 'default 'variable-pitch))) | |
275 | (force-window-update (current-buffer))) | |
276 | ||
277 | ||
278 | (provide 'face-remap) | |
279 | ||
280 | ;; arch-tag: 5c5f034b-8d58-4967-82bd-d61fd364e686 | |
281 | ;;; face-remap.el ends here |