Commit | Line | Data |
---|---|---|
4e8aa578 RS |
1 | ;;; facemenu.el -- Create a face menu for interactively adding fonts to text |
2 | ;; Copyright (c) 1994 Free Software Foundation, Inc. | |
3 | ||
4 | ;; Author: Boris Goldowsky <boris@cs.rochester.edu> | |
5 | ;; Keywords: faces | |
6 | ||
7 | ;; This file is part of GNU Emacs. | |
8 | ||
9 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
10 | ;; it under the terms of the GNU General Public License as published by | |
11 | ;; the Free Software Foundation; either version 2, or (at your option) | |
12 | ;; any later version. | |
13 | ||
14 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;; GNU General Public License for more details. | |
18 | ||
19 | ;; You should have received a copy of the GNU General Public License | |
20 | ;; along with GNU Emacs; see the file COPYING. If not, write to | |
21 | ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
22 | ||
23 | ;;; Commentary: | |
bf7d4561 BG |
24 | ;; This file defines a menu of faces (bold, italic, etc) which allows you to |
25 | ;; set the face used for a region of the buffer. Some faces also have | |
26 | ;; keybindings, which are shown in the menu. Faces with names beginning with | |
27 | ;; "fg:" or "bg:", as in "fg:red", are treated specially. It is assumed that | |
28 | ;; Such faces are assumed to consist only of a foreground (if "fg:") or | |
29 | ;; background (if "bg:") color. They are thus put into the color submenus | |
30 | ;; rather than the general Face submenu. Such faces can also be created on | |
31 | ;; demand from the "Other..." menu items. | |
4e8aa578 | 32 | |
4e8aa578 | 33 | ;;; Usage: |
bf7d4561 BG |
34 | ;; Selecting a face from the menu or typing the keyboard equivalent will |
35 | ;; change the region to use that face. If you use transient-mark-mode and the | |
36 | ;; region is not active, the face will be remembered and used for the next | |
37 | ;; insertion. It will be forgotten if you move point or make other | |
38 | ;; modifications before inserting or typing anything. | |
4e8aa578 RS |
39 | ;; |
40 | ;; Faces can be selected from the keyboard as well. | |
41 | ;; The standard keybindings are M-s (or ESC s) + letter: | |
42 | ;; M-s i = "set italic", M-s b = "set bold", etc. | |
43 | ||
44 | ;;; Customization: | |
45 | ;; An alternative set of keybindings that may be easier to type can be set up | |
46 | ;; using "Hyper" keys. This requires that you set up a hyper-key on your | |
47 | ;; keyboard. On my system, putting the following command in my .xinitrc: | |
48 | ;; xmodmap -e "keysym Alt_L = Hyper_L" -e "add Mod2 = Hyper_L" | |
49 | ;; makes the key labelled "Alt" act as a hyper key, but check with local | |
50 | ;; X-perts for how to do it on your system. If you do this, then put the | |
51 | ;; following in your .emacs before the (require 'facemenu): | |
52 | ;; (setq facemenu-keybindings | |
53 | ;; '((default . [?\H-d]) | |
54 | ;; (bold . [?\H-b]) | |
55 | ;; (italic . [?\H-i]) | |
56 | ;; (bold-italic . [?\H-o]) | |
57 | ;; (underline . [?\H-u]))) | |
58 | ;; (setq facemenu-keymap global-map) | |
59 | ;; (setq facemenu-key nil) | |
60 | ;; | |
61 | ;; In general, the order of the faces that appear in the menu and their | |
62 | ;; keybindings can be controlled by setting the variable | |
63 | ;; `facemenu-keybindings'. Faces that you never want to add to your | |
64 | ;; document (e.g., `region') are listed in `facemenu-unlisted-faces'. | |
65 | ||
66 | ;;; Known Problems: | |
4e8aa578 RS |
67 | ;; There is at present no way to display what the faces look like in |
68 | ;; the menu itself. | |
69 | ;; | |
70 | ;; `list-faces-display' shows the faces in a different order than | |
71 | ;; this menu, which could be confusing. I do /not/ sort the list | |
72 | ;; alphabetically, because I like the default order: it puts the most | |
73 | ;; basic, common fonts first. | |
74 | ;; | |
75 | ;; Please send me any other problems, comments or ideas. | |
76 | ||
77 | ;;; Code: | |
78 | ||
79 | (provide 'facemenu) | |
80 | ||
81 | (defvar facemenu-key "\M-s" | |
82 | "Prefix to use for facemenu commands.") | |
83 | ||
4e8aa578 RS |
84 | (defvar facemenu-keybindings |
85 | '((default . "d") | |
86 | (bold . "b") | |
87 | (italic . "i") | |
88 | (bold-italic . "o") ; O for "Oblique" or "bOld"... | |
89 | (underline . "u")) | |
90 | "Alist of interesting faces and keybindings. | |
91 | Each element is itself a list: the car is the name of the face, | |
92 | the next element is the key to use as a keyboard equivalent of the menu item; | |
93 | the binding is made in facemenu-keymap. | |
94 | ||
95 | The faces specifically mentioned in this list are put at the top of | |
96 | the menu, in the order specified. All other faces which are defined, | |
97 | except for those in `facemenu-unlisted-faces', are listed after them, | |
98 | but get no keyboard equivalents. | |
99 | ||
100 | If you change this variable after loading facemenu.el, you will need to call | |
101 | `facemenu-update' to make it take effect.") | |
102 | ||
103 | (defvar facemenu-unlisted-faces | |
104 | '(modeline region secondary-selection highlight scratch-face) | |
105 | "Faces that are not included in the Face menu. | |
106 | Set this before loading facemenu.el, or call `facemenu-update' after | |
107 | changing it.") | |
108 | ||
bf7d4561 BG |
109 | (defvar facemenu-face-menu |
110 | (let ((map (make-sparse-keymap "Face"))) | |
111 | (define-key map [other] (cons "Other..." 'facemenu-set-face)) | |
112 | map) | |
113 | "Menu keymap for faces.") | |
114 | ||
115 | (defvar facemenu-foreground-menu | |
116 | (let ((map (make-sparse-keymap "Foreground Color"))) | |
117 | (define-key map "o" (cons "Other" 'facemenu-set-foreground)) | |
118 | map) | |
119 | "Menu keymap for foreground colors.") | |
120 | ||
121 | (defvar facemenu-background-menu | |
122 | (let ((map (make-sparse-keymap "Background Color"))) | |
123 | (define-key map "o" (cons "Other" 'facemenu-set-background)) | |
124 | map) | |
125 | "Menu keymap for background colors") | |
126 | ||
127 | (defvar facemenu-special-menu | |
128 | (let ((map (make-sparse-keymap "Special"))) | |
129 | (define-key map [read-only] (cons "Read-Only" 'facemenu-set-read-only)) | |
130 | (define-key map [invisible] (cons "Invisible" 'facemenu-set-invisible)) | |
131 | map) | |
132 | "Menu keymap for non-face text-properties.") | |
133 | ||
134 | (defvar facemenu-menu | |
135 | (let ((map (make-sparse-keymap "Face"))) | |
136 | (define-key map [display] (cons "Display Faces" 'list-faces-display)) | |
137 | (define-key map [remove] (cons "Remove Props" 'facemenu-remove-all)) | |
138 | (define-key map [sep1] (list "-----------------")) | |
139 | (define-key map [special] (cons "Special Props" facemenu-special-menu)) | |
140 | (define-key map [bg] (cons "Background Color" facemenu-background-menu)) | |
141 | (define-key map [fg] (cons "Foreground Color" facemenu-foreground-menu)) | |
142 | (define-key map [face] (cons "Face" facemenu-face-menu)) | |
143 | map) | |
535d2617 | 144 | "Facemenu top-level menu keymap.") |
bf7d4561 BG |
145 | |
146 | (defvar facemenu-keymap (make-sparse-keymap "Set face") | |
147 | "Map for keyboard face-changing commands. | |
148 | `Facemenu-update' fills in the keymap according to the bindings | |
535d2617 | 149 | requested in `facemenu-keybindings'.") |
bf7d4561 BG |
150 | |
151 | ;;; Internal Variables | |
152 | ||
153 | (defvar facemenu-color-alist nil | |
154 | ;; Don't initialize here; that doesn't work if preloaded. | |
155 | "Alist of colors, used for completion. | |
156 | If null, `facemenu-read-color' will set it.") | |
4a24b314 | 157 | |
4e8aa578 RS |
158 | (defvar facemenu-next nil) ; set when we are going to set a face on next char. |
159 | (defvar facemenu-loc nil) | |
160 | ||
161 | (defun facemenu-update () | |
bf7d4561 BG |
162 | "Add or update the \"Face\" menu in the menu bar. |
163 | You can call this to update things if you change any of the menu configuration | |
164 | variables." | |
4e8aa578 RS |
165 | (interactive) |
166 | ||
bf7d4561 | 167 | ;; Global bindings: |
535d2617 | 168 | (define-key global-map [C-down-mouse-2] facemenu-menu) |
bf7d4561 | 169 | (if facemenu-key (define-key global-map facemenu-key facemenu-keymap)) |
4e8aa578 | 170 | |
bf7d4561 BG |
171 | ;; Add each defined face to the menu. |
172 | (facemenu-iterate 'facemenu-add-new-face | |
173 | (facemenu-complete-face-list facemenu-keybindings))) | |
4a24b314 | 174 | |
4e8aa578 RS |
175 | ;;;###autoload |
176 | (defun facemenu-set-face (face &optional start end) | |
4a24b314 RS |
177 | "Add FACE to the region or next character typed. |
178 | It will be added to the top of the face list; any faces lower on the list that | |
179 | will not show through at all will be removed. | |
180 | ||
181 | Interactively, the face to be used is prompted for. | |
182 | If the region is active, it will be set to the requested face. If | |
4e8aa578 RS |
183 | it is inactive \(even if mark-even-if-inactive is set) the next |
184 | character that is typed \(via `self-insert-command') will be set to | |
185 | the the selected face. Moving point or switching buffers before | |
186 | typing a character cancels the request." | |
187 | (interactive (list (read-face-name "Use face: "))) | |
188 | (if mark-active | |
4a24b314 RS |
189 | (let ((start (or start (region-beginning))) |
190 | (end (or end (region-end)))) | |
191 | (facemenu-add-face face start end)) | |
192 | (setq facemenu-next face | |
193 | facemenu-loc (point)))) | |
194 | ||
bf7d4561 | 195 | ;;;###autoload |
4a24b314 RS |
196 | (defun facemenu-set-foreground (color &optional start end) |
197 | "Set the foreground color of the region or next character typed. | |
198 | The color is prompted for. A face named `fg:color' is used \(or created). | |
199 | If the region is active, it will be set to the requested face. If | |
200 | it is inactive \(even if mark-even-if-inactive is set) the next | |
201 | character that is typed \(via `self-insert-command') will be set to | |
202 | the the selected face. Moving point or switching buffers before | |
203 | typing a character cancels the request." | |
204 | (interactive (list (facemenu-read-color "Foreground color: "))) | |
205 | (let ((face (intern (concat "fg:" color)))) | |
206 | (or (facemenu-get-face face) | |
207 | (error "Unknown color: %s" color)) | |
208 | (facemenu-set-face face start end))) | |
209 | ||
bf7d4561 | 210 | ;;;###autoload |
4a24b314 RS |
211 | (defun facemenu-set-background (color &optional start end) |
212 | "Set the background color of the region or next character typed. | |
213 | The color is prompted for. A face named `bg:color' is used \(or created). | |
214 | If the region is active, it will be set to the requested face. If | |
215 | it is inactive \(even if mark-even-if-inactive is set) the next | |
216 | character that is typed \(via `self-insert-command') will be set to | |
217 | the the selected face. Moving point or switching buffers before | |
218 | typing a character cancels the request." | |
219 | (interactive (list (facemenu-read-color "Background color: "))) | |
220 | (let ((face (intern (concat "bg:" color)))) | |
221 | (or (facemenu-get-face face) | |
222 | (error "Unknown color: %s" color)) | |
223 | (facemenu-set-face face start end))) | |
4e8aa578 RS |
224 | |
225 | (defun facemenu-set-face-from-menu (face start end) | |
226 | "Set the face of the region or next character typed. | |
227 | This function is designed to be called from a menu; the face to use | |
228 | is the menu item's name. | |
229 | If the region is active, it will be set to the requested face. If | |
230 | it is inactive \(even if mark-even-if-inactive is set) the next | |
231 | character that is typed \(via `self-insert-command') will be set to | |
232 | the the selected face. Moving point or switching buffers before | |
233 | typing a character cancels the request." | |
4a24b314 RS |
234 | (interactive (list last-command-event |
235 | (if mark-active (region-beginning)) | |
236 | (if mark-active (region-end)))) | |
237 | (facemenu-get-face face) | |
4e8aa578 | 238 | (if start |
4a24b314 | 239 | (facemenu-add-face face start end) |
4e8aa578 RS |
240 | (setq facemenu-next face facemenu-loc (point)))) |
241 | ||
242 | (defun facemenu-set-invisible (start end) | |
243 | "Make the region invisible. | |
244 | This sets the `invisible' text property; it can be undone with | |
245 | `facemenu-remove-all'." | |
246 | (interactive "r") | |
247 | (put-text-property start end 'invisible t)) | |
248 | ||
249 | (defun facemenu-set-intangible (start end) | |
250 | "Make the region intangible: disallow moving into it. | |
251 | This sets the `intangible' text property; it can be undone with | |
252 | `facemenu-remove-all'." | |
253 | (interactive "r") | |
254 | (put-text-property start end 'intangible t)) | |
255 | ||
256 | (defun facemenu-set-read-only (start end) | |
257 | "Make the region unmodifiable. | |
258 | This sets the `read-only' text property; it can be undone with | |
259 | `facemenu-remove-all'." | |
260 | (interactive "r") | |
261 | (put-text-property start end 'read-only t)) | |
262 | ||
263 | (defun facemenu-remove-all (start end) | |
264 | "Remove all text properties that facemenu added to region." | |
265 | (interactive "*r") ; error if buffer is read-only despite the next line. | |
266 | (let ((inhibit-read-only t)) | |
267 | (remove-text-properties | |
268 | start end '(face nil invisible nil intangible nil | |
269 | read-only nil category nil)))) | |
270 | ||
bf7d4561 BG |
271 | ;;;###autoload |
272 | (defun facemenu-read-color (prompt) | |
273 | "Read a color using the minibuffer." | |
274 | (let ((col (completing-read (or "Color: ") | |
275 | (or facemenu-color-alist | |
276 | (if (eq 'x window-system) | |
277 | (mapcar 'list (x-defined-colors)))) | |
278 | nil t))) | |
279 | (if (equal "" col) | |
280 | nil | |
281 | col))) | |
4e8aa578 | 282 | |
4a24b314 RS |
283 | (defun facemenu-add-face (face start end) |
284 | "Add FACE to text between START and END. | |
285 | For each section of that region that has a different face property, FACE will | |
286 | be consed onto it, and other faces that are completely hidden by that will be | |
bf7d4561 BG |
287 | removed from the list. |
288 | ||
289 | As a special case, if FACE is `default', then the region is left with NO face | |
290 | text property. Otherwise, selecting the default face would not have any | |
291 | effect." | |
4a24b314 | 292 | (interactive "*xFace:\nr") |
bf7d4561 BG |
293 | (if (eq face 'default) |
294 | (remove-text-properties start end '(face default)) | |
295 | (let ((part-start start) part-end) | |
296 | (while (not (= part-start end)) | |
297 | (setq part-end (next-single-property-change part-start 'face nil end)) | |
298 | (let ((prev (get-text-property part-start 'face))) | |
299 | (put-text-property part-start part-end 'face | |
300 | (if (null prev) | |
301 | face | |
302 | (facemenu-discard-redundant-faces | |
303 | (cons face | |
304 | (if (listp prev) prev (list prev))))))) | |
305 | (setq part-start part-end))))) | |
4a24b314 RS |
306 | |
307 | (defun facemenu-discard-redundant-faces (face-list &optional mask) | |
308 | "Remove from FACE-LIST any faces that won't show at all. | |
309 | This means they have no non-nil elements that aren't also non-nil in an | |
310 | earlier face." | |
311 | (let ((useful nil)) | |
312 | (cond ((null face-list) nil) | |
313 | ((null mask) | |
314 | (cons (car face-list) | |
315 | (facemenu-discard-redundant-faces | |
316 | (cdr face-list) | |
317 | (copy-sequence (internal-get-face (car face-list)))))) | |
318 | ((let ((i (length mask)) | |
319 | (face (internal-get-face (car face-list)))) | |
320 | (while (>= (setq i (1- i)) 0) | |
321 | (if (and (aref face i) | |
322 | (not (aref mask i))) | |
323 | (progn (setq useful t) | |
324 | (aset mask i t)))) | |
325 | useful) | |
326 | (cons (car face-list) | |
327 | (facemenu-discard-redundant-faces (cdr face-list) mask))) | |
328 | (t (facemenu-discard-redundant-faces (cdr face-list) mask))))) | |
329 | ||
bf7d4561 BG |
330 | (defun facemenu-get-face (symbol) |
331 | "Make sure FACE exists. | |
332 | If not, it is created. If it is created and is of the form `fg:color', then | |
333 | set the foreground to that color. If of the form `bg:color', set the | |
334 | background. In any case, add it to the appropriate menu. Returns nil if | |
335 | given a bad color." | |
336 | (or (internal-find-face symbol) | |
337 | (let* ((face (make-face symbol)) | |
338 | (name (symbol-name symbol)) | |
339 | (color (substring name 3))) | |
340 | (cond ((string-match "^fg:" name) | |
341 | (set-face-foreground face color) | |
342 | (and (eq 'x window-system) (x-color-defined-p color))) | |
343 | ((string-match "^bg:" name) | |
344 | (set-face-background face color) | |
345 | (and (eq 'x window-system) (x-color-defined-p color))) | |
346 | (t))))) | |
347 | ||
348 | (defun facemenu-add-new-face (face) | |
349 | "Add a FACE to the appropriate Face menu. | |
350 | Automatically called when a new face is created." | |
351 | (let* ((name (symbol-name face)) | |
352 | (menu (cond ((string-match "^fg:" name) | |
353 | (setq name (substring name 3)) | |
354 | facemenu-foreground-menu) | |
355 | ((string-match "^bg:" name) | |
356 | (setq name (substring name 3)) | |
357 | facemenu-background-menu) | |
358 | (t facemenu-face-menu))) | |
359 | key) | |
360 | (cond ((memq face facemenu-unlisted-faces) | |
361 | nil) | |
362 | ((setq key (cdr (assoc face facemenu-keybindings))) | |
363 | (let ((function (intern (concat "facemenu-set-" name)))) | |
364 | (fset function | |
365 | (` (lambda () (interactive) | |
366 | (facemenu-set-face (quote (, face)))))) | |
367 | (define-key facemenu-keymap key (cons name function)) | |
368 | (define-key menu key (cons name function)))) | |
369 | (t (define-key menu (vector face) | |
370 | (cons name 'facemenu-set-face-from-menu))))) | |
371 | ;; Return nil for facemenu-iterate's benefit: | |
372 | nil) | |
373 | ||
374 | (defun facemenu-after-change (begin end old-length) | |
375 | "May set the face of just-inserted text to user's request. | |
376 | This only happens if the change is an insertion, and | |
377 | `facemenu-set-face[-from-menu]' was called with point at the | |
378 | beginning of the insertion." | |
379 | (if (null facemenu-next) ; exit immediately if no work | |
380 | nil | |
381 | (if (and (= 0 old-length) ; insertion | |
382 | (= facemenu-loc begin)) ; point wasn't moved in between | |
383 | (facemenu-add-face facemenu-next begin end)) | |
384 | (setq facemenu-next nil))) | |
385 | ||
386 | (defun facemenu-complete-face-list (&optional oldlist) | |
387 | "Return list of all faces that are look different. | |
388 | Starts with given ALIST of faces, and adds elements only if they display | |
389 | differently from any face already on the list. | |
390 | The faces on ALIST will end up at the end of the returned list, in reverse | |
391 | order." | |
392 | (let ((list (nreverse (mapcar 'car oldlist)))) | |
393 | (facemenu-iterate | |
394 | (lambda (new-face) | |
395 | (if (not (memq new-face list)) | |
396 | (setq list (cons new-face list))) | |
397 | nil) | |
398 | (nreverse (face-list))) | |
399 | list)) | |
400 | ||
4e8aa578 RS |
401 | (defun facemenu-iterate (func iterate-list) |
402 | "Apply FUNC to each element of LIST until one returns non-nil. | |
403 | Returns the non-nil value it found, or nil if all were nil." | |
404 | (while (and iterate-list (not (funcall func (car iterate-list)))) | |
405 | (setq iterate-list (cdr iterate-list))) | |
406 | (car iterate-list)) | |
407 | ||
408 | (facemenu-update) | |
4e8aa578 RS |
409 | (add-hook 'after-change-functions 'facemenu-after-change) |
410 | ||
411 | ;;; facemenu.el ends here |