lisp/facemenu.el

   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:
  24 ;; This file defines a menu of faces (bold, italic, etc) which
  25 ;; allows you to set the face used for a region of the buffer.
  26 ;; Some faces also have keybindings, which are shown in the menu.
  27
  28 ;;; Installation:
  29 ;; Put this file somewhere on emacs's load-path, and put
  30 ;;   (require 'facemenu)
  31 ;; in your .emacs file.
  32
  33 ;;; Usage:
  34 ;; Selecting a face from the menu or typing the keyboard equivalent
  35 ;; will change the region to use that face.
  36 ;; If you use transient-mark-mode and the region is not active, the
  37 ;; face will be remembered and used for the next insertion.  It will
  38 ;; be forgotten if you move point or make other modifications before
  39 ;; inserting or typing anything.
  40 ;;
  41 ;; Faces can be selected from the keyboard as well.
  42 ;; The standard keybindings are M-s (or ESC s) + letter:
  43 ;; M-s i = "set italic",  M-s b = "set bold", etc.
  44
  45 ;;; Customization:
  46 ;; An alternative set of keybindings that may be easier to type can be set up
  47 ;; using "Hyper" keys.  This requires that you set up a hyper-key on your
  48 ;; keyboard.  On my system, putting the following command in my .xinitrc:
  49 ;;    xmodmap -e "keysym Alt_L = Hyper_L" -e "add Mod2 = Hyper_L"
  50 ;; makes the key labelled "Alt" act as a hyper key, but check with local
  51 ;; X-perts for how to do it on your system. If you do this, then put the
  52 ;; following in your .emacs before the (require 'facemenu):
  53 ;;   (setq facemenu-keybindings
  54 ;;    '((default     . [?\H-d])
  55 ;;      (bold        . [?\H-b])
  56 ;;      (italic      . [?\H-i])
  57 ;;      (bold-italic . [?\H-o])
  58 ;;      (underline   . [?\H-u])))
  59 ;;   (setq facemenu-keymap global-map)
  60 ;;   (setq facemenu-key nil)
  61 ;;
  62 ;; In general, the order of the faces that appear in the menu and their
  63 ;; keybindings can be controlled by setting the variable
  64 ;; `facemenu-keybindings'.  Faces that you never want to add to your
  65 ;; document (e.g., `region') are listed in `facemenu-unlisted-faces'.
  66
  67 ;;; Known Problems:
  68 ;; Only works with Emacs 19.23 and later.
  69 ;;
  70 ;; There is at present no way to display what the faces look like in
  71 ;; the menu itself.
  72 ;;
  73 ;; `list-faces-display' shows the faces in a different order than
  74 ;; this menu, which could be confusing.  I do /not/ sort the list
  75 ;; alphabetically, because I like the default order: it puts the most
  76 ;; basic, common fonts first.
  77 ;;
  78 ;; Please send me any other problems, comments or ideas.
  79
  80 ;;; Code:
  81
  82 (provide 'facemenu)
  83
  84 (defvar facemenu-key "\M-s"
  85   "Prefix to use for facemenu commands.")
  86
  87 (defvar facemenu-keymap nil
  88   "Map for keybindings of face commands.
  89 If nil, `facemenu-update' will create one.
  90 `Facemenu-update' also fills in the keymap according to the bindings
  91 requested in facemenu-keybindings.")
  92
  93 (defvar facemenu-keybindings
  94   '((default     . "d")
  95     (bold        . "b")
  96     (italic      . "i")
  97     (bold-italic . "o")  ; O for "Oblique" or "bOld"...
  98     (underline   . "u"))
  99   "Alist of interesting faces and keybindings.
 100 Each element is itself a list: the car is the name of the face,
 101 the next element is the key to use as a keyboard equivalent of the menu item;
 102 the binding is made in facemenu-keymap.
 103
 104 The faces specifically mentioned in this list are put at the top of
 105 the menu, in the order specified.  All other faces which are defined,
 106 except for those in `facemenu-unlisted-faces', are listed after them,
 107 but get no keyboard equivalents.
 108
 109 If you change this variable after loading facemenu.el, you will need to call
 110 `facemenu-update' to make it take effect.")
 111
 112 (defvar facemenu-unlisted-faces
 113   '(modeline region secondary-selection highlight scratch-face)
 114   "Faces that are not included in the Face menu.
 115 Set this before loading facemenu.el, or call `facemenu-update' after
 116 changing it.")
 117
 118 (defvar facemenu-next nil) ; set when we are going to set a face on next char.
 119 (defvar facemenu-loc nil)
 120
 121 (defun facemenu-update ()
 122   "Add or update the \"Face\" menu in the menu bar."
 123   (interactive)
 124
 125   ;; Set up keymaps
 126   (fset 'facemenu-menu (setq facemenu-menu (make-sparse-keymap "Face")))
 127   (if (null facemenu-keymap)
 128       (fset 'facemenu-keymap
 129             (setq facemenu-keymap (make-sparse-keymap "Set face"))))
 130   (if facemenu-key
 131       (define-key global-map facemenu-key facemenu-keymap))
 132
 133   ;; Define basic keys
 134   ;; We construct this list structure explicitly because a quoted constant
 135   ;; would be pure.
 136   (define-key facemenu-menu [other]     (cons "Other..." 'facemenu-set-face))
 137   (define-key facemenu-menu [sep2]      (list "---Special---"))
 138   (define-key facemenu-menu [invisible] (cons "Invisible"
 139                                           'facemenu-set-invisible))
 140   (define-key facemenu-menu [read-only] (cons "Read-Only"
 141                                               'facemenu-set-read-only))
 142   (define-key facemenu-menu [remove]    (cons "Remove Properties"
 143                                               'facemenu-remove-all))
 144   (define-key facemenu-menu [sep1]      (list "-------------"))
 145   (define-key facemenu-menu [display]   (cons "Display" 'list-faces-display))
 146   (define-key facemenu-menu [update]    (cons "Update Menu" 'facemenu-update))
 147
 148   ;; Define commands for face-changing
 149   (facemenu-iterate
 150    (function
 151     (lambda (f)
 152       (let ((face (car f))
 153             (name (symbol-name (car f)))
 154             (key  (cdr f)))
 155         (cond ((memq face facemenu-unlisted-faces)
 156                nil)
 157               ((null key) (define-key facemenu-menu (vector face)
 158                              (cons name 'facemenu-set-face-from-menu)))
 159               (t (let ((function (intern (concat "facemenu-set-" name))))
 160                    (fset function
 161                          (` (lambda () (interactive)
 162                               (facemenu-set-face (quote (, face))))))
 163                    (define-key facemenu-keymap key (cons name function))
 164                    (define-key facemenu-menu key (cons name function))))))
 165       nil))
 166    (facemenu-complete-face-list facemenu-keybindings))
 167
 168   (define-key global-map (vector 'menu-bar 'Face)
 169     (cons "Face" facemenu-menu)))
 170
 171 ; We'd really like to name the menu items as follows,
 172 ; but we can't since menu entries don't display text properties (yet?)
 173 ; (let ((s (copy-sequence (symbol-name face))))
 174 ;    (put-text-property 0 (1- (length s))
 175 ;                       'face face s)
 176 ;   s)
 177
 178 ;;;###autoload
 179 (defun facemenu-set-face (face &optional start end)
 180   "Set the face of the region or next character typed.
 181 The face to be used is prompted for.
 182 If the region is active, it will be set to the requested face.  If
 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
 189       (put-text-property (or start (region-beginning))
 190                          (or end (region-end))
 191                          'face face)
 192     (setq facemenu-next face facemenu-loc (point))))
 193
 194 (defun facemenu-set-face-from-menu (face start end)
 195   "Set the face of the region or next character typed.
 196 This function is designed to be called from a menu; the face to use
 197 is the menu item's name.
 198 If the region is active, it will be set to the requested face.  If
 199 it is inactive \(even if mark-even-if-inactive is set) the next
 200 character that is typed \(via `self-insert-command') will be set to
 201 the the selected face.  Moving point or switching buffers before
 202 typing a character cancels the request."
 203   (interactive (let ((keys (this-command-keys)))
 204                  (list (elt keys (1- (length keys)))
 205                        (if mark-active (region-beginning))
 206                        (if mark-active (region-end)))))
 207   (if start
 208       (put-text-property start end 'face face)
 209     (setq facemenu-next face facemenu-loc (point))))
 210
 211 (defun facemenu-set-invisible (start end)
 212   "Make the region invisible.
 213 This sets the `invisible' text property; it can be undone with
 214 `facemenu-remove-all'."
 215   (interactive "r")
 216   (put-text-property start end 'invisible t))
 217
 218 (defun facemenu-set-intangible (start end)
 219   "Make the region intangible: disallow moving into it.
 220 This sets the `intangible' text property; it can be undone with
 221 `facemenu-remove-all'."
 222   (interactive "r")
 223   (put-text-property start end 'intangible t))
 224
 225 (defun facemenu-set-read-only (start end)
 226   "Make the region unmodifiable.
 227 This sets the `read-only' text property; it can be undone with
 228 `facemenu-remove-all'."
 229   (interactive "r")
 230   (put-text-property start end 'read-only t))
 231
 232 (defun facemenu-remove-all (start end)
 233   "Remove all text properties that facemenu added to region."
 234   (interactive "*r") ; error if buffer is read-only despite the next line.
 235   (let ((inhibit-read-only t))
 236     (remove-text-properties
 237      start end '(face nil invisible nil intangible nil
 238                       read-only nil category nil))))
 239
 240 (defun facemenu-after-change (begin end old-length)
 241   "May set the face of just-inserted text to user's request.
 242 This only happens if the change is an insertion, and
 243 `facemenu-set-face[-from-menu]' was called with point at the
 244 beginning of the insertion."
 245   (if (null facemenu-next)              ; exit immediately if no work
 246       nil
 247     (if (and (= 0 old-length)           ; insertion
 248              (= facemenu-loc begin))    ; point wasn't moved in between
 249         (put-text-property begin end 'face facemenu-next))
 250     (setq facemenu-next nil)))
 251
 252
 253 (defun facemenu-complete-face-list (&optional oldlist)
 254   "Return alist of all faces that are look different.
 255 Starts with given LIST of faces, and adds elements only if they display
 256 differently from any face already on the list.
 257 The original LIST will end up at the end of the returned list, in reverse
 258 order.  The elements added will have null cdrs."
 259   (let ((list nil))
 260     (facemenu-iterate
 261      (function
 262       (lambda (item)
 263         (if (internal-find-face (car item))
 264             (setq list (cons item list)))
 265         nil))
 266      oldlist)
 267     (facemenu-iterate
 268      (function
 269       (lambda (new-face)
 270         (if (not (facemenu-iterate
 271                   (function
 272                    (lambda (item) (face-equal (car item) new-face t)))
 273                   list))
 274             (setq list (cons (cons new-face nil) list)))
 275         nil))
 276      (nreverse (face-list)))
 277     list))
 278
 279 (defun facemenu-iterate (func iterate-list)
 280   "Apply FUNC to each element of LIST until one returns non-nil.
 281 Returns the non-nil value it found, or nil if all were nil."
 282   (while (and iterate-list (not (funcall func (car iterate-list))))
 283     (setq iterate-list (cdr iterate-list)))
 284   (car iterate-list))
 285
 286 (facemenu-update)
 287 (add-hook 'menu-bar-final-items 'Face)
 288 (add-hook 'after-change-functions 'facemenu-after-change)
 289
 290 ;;; facemenu.el ends here
 291