code.delx.au - gnu-emacs/blob - lisp/face-remap.el

   1 ;;; face-remap.el --- Functions for managing `face-remapping-alist'
   2 ;;
   3 ;; Copyright (C) 2008-2012 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Miles Bader <miles@gnu.org>
   6 ;; Keywords: faces, face remapping, 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 `face-remap-add-relative'
  40 ;; (and removed by `face-remap-remove-relative', 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 ;; `face-remap-set-base'.  Because this _overwrites_ the default
  49 ;; value inheriting from the global face definition, it is up to the
  50 ;; caller of face-remap-set-base to add such inheritance if it is
  51 ;; desired.  A typical use of face-remap-set-base 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 ;; Names of face attributes corresponding to lisp face-vector positions.
  65 ;; This variable should probably be defined in C code where the actual
  66 ;; definitions are available.
  67 ;;
  68 (defvar internal-lisp-face-attributes
  69   [nil
  70    :family :foundry :swidth :height :weight :slant :underline :inverse
  71    :foreground :background :stipple :overline :strike :box
  72    :font :inherit :fontset :vector])
  73
  74 (defun face-attrs-more-relative-p (attrs1 attrs2)
  75 "Return true if ATTRS1 contains a greater number of relative
  76 face-attributes than ATTRS2.  A face attribute is considered
  77 relative if `face-attribute-relative-p' returns non-nil.
  78
  79 ATTRS1 and ATTRS2 may be any value suitable for a `face' text
  80 property, including face names, lists of face names,
  81 face-attribute plists, etc.
  82
  83 This function can be used as a predicate with `sort', to sort
  84 face lists so that more specific faces are located near the end."
  85   (unless (vectorp attrs1)
  86     (setq attrs1 (face-attributes-as-vector attrs1)))
  87   (unless (vectorp attrs2)
  88     (setq attrs2 (face-attributes-as-vector attrs2)))
  89   (let ((rel1-count 0) (rel2-count 0))
  90     (dotimes (i (length attrs1))
  91       (let ((attr (aref internal-lisp-face-attributes i)))
  92         (when attr
  93           (when (face-attribute-relative-p attr (aref attrs1 i))
  94             (setq rel1-count (+ rel1-count 1)))
  95           (when (face-attribute-relative-p attr (aref attrs2 i))
  96             (setq rel2-count (+ rel2-count 1))))))
  97     (< rel1-count rel2-count)))
  98
  99 (defun face-remap-order (entry)
 100   "Order ENTRY so that more relative face specs are near the beginning.
 101 The list structure of ENTRY may be destructively modified."
 102   (setq entry (nreverse entry))
 103   (setcdr entry (sort (cdr entry) 'face-attrs-more-relative-p))
 104   (nreverse entry))
 105
 106 ;;;###autoload
 107 (defun face-remap-add-relative (face &rest specs)
 108   "Add a face remapping entry of FACE to SPECS in the current buffer.
 109
 110 Return a cookie which can be used to delete the remapping with
 111 `face-remap-remove-relative'.
 112
 113 SPECS can be any value suitable for the `face' text property,
 114 including a face name, a list of face names, or a face-attribute
 115 property list.  The attributes given by SPECS will be merged with
 116 any other currently active face remappings of FACE, and with the
 117 global definition of FACE.  An attempt is made to sort multiple
 118 entries so that entries with relative face-attributes are applied
 119 after entries with absolute face-attributes.
 120
 121 The base (lowest priority) remapping may be set to a specific
 122 value, instead of the default of the global face definition,
 123 using `face-remap-set-base'."
 124   (while (and (consp specs) (null (cdr specs)))
 125     (setq specs (car specs)))
 126   (make-local-variable 'face-remapping-alist)
 127   (let ((entry (assq face face-remapping-alist)))
 128     (when (null entry)
 129       (setq entry (list face face))     ; explicitly merge with global def
 130       (push entry face-remapping-alist))
 131     (setcdr entry (face-remap-order (cons specs (cdr entry))))
 132     (cons face specs)))
 133
 134 (defun face-remap-remove-relative (cookie)
 135   "Remove a face remapping previously added by `face-remap-add-relative'.
 136 COOKIE should be the return value from that function."
 137   (let ((remapping (assq (car cookie) face-remapping-alist)))
 138     (when remapping
 139       (let ((updated-entries (remq (cdr cookie) (cdr remapping))))
 140         (unless (eq updated-entries (cdr remapping))
 141           (setcdr remapping updated-entries)
 142           (when (or (null updated-entries)
 143                     (and (eq (car-safe updated-entries) (car cookie))
 144                          (null (cdr updated-entries))))
 145             (setq face-remapping-alist
 146                   (remq remapping face-remapping-alist)))
 147           (cdr cookie))))))
 148
 149 ;;;###autoload
 150 (defun face-remap-reset-base (face)
 151   "Set the base remapping of FACE to inherit from FACE's global definition."
 152   (let ((entry (assq face face-remapping-alist)))
 153     (when entry
 154       ;; If there's nothing except a base remapping, we simply remove
 155       ;; the entire remapping entry, as setting the base to the default
 156       ;; would be the same as the global definition.  Otherwise, we
 157       ;; modify the base remapping.
 158       (if (null (cddr entry))           ; nothing except base remapping
 159           (setq face-remapping-alist    ; so remove entire entry
 160                 (remq entry face-remapping-alist))
 161         (setcar (last entry) face)))))  ; otherwise, just inherit global def
 162
 163 ;;;###autoload
 164 (defun face-remap-set-base (face &rest specs)
 165   "Set the base remapping of FACE in the current buffer to SPECS.
 166 If SPECS is empty, the default base remapping is restored, which
 167 inherits from the global definition of FACE; note that this is
 168 different from SPECS containing a single value `nil', which does
 169 not inherit from the global definition of FACE."
 170   (while (and (consp specs) (not (null (car specs))) (null (cdr specs)))
 171     (setq specs (car specs)))
 172   (if (or (null specs)
 173           (and (eq (car specs) face) (null (cdr specs)))) ; default
 174       ;; Set entry back to default
 175       (face-remap-reset-base face)
 176     ;; Set the base remapping
 177     (make-local-variable 'face-remapping-alist)
 178     (let ((entry (assq face face-remapping-alist)))
 179       (if entry
 180           (setcar (last entry) specs)   ; overwrite existing base entry
 181         (push (list face specs) face-remapping-alist)))))
 182
 183 \f
 184 ;; ----------------------------------------------------------------
 185 ;; text-scale-mode
 186
 187 (defcustom text-scale-mode-step 1.2
 188   "Scale factor used by `text-scale-mode'.
 189 Each positive or negative step scales the default face height by this amount."
 190   :group 'display
 191   :type 'number
 192   :version "23.1")
 193
 194 ;; current remapping cookie for text-scale-mode
 195 (defvar text-scale-mode-remapping nil)
 196 (make-variable-buffer-local 'text-scale-mode-remapping)
 197
 198 ;; Lighter displayed for text-scale-mode in mode-line minor-mode list
 199 (defvar text-scale-mode-lighter "+0")
 200 (make-variable-buffer-local 'text-scale-mode-lighter)
 201
 202 ;; Number of steps that text-scale-mode will increase/decrease text height
 203 (defvar text-scale-mode-amount 0)
 204 (make-variable-buffer-local 'text-scale-mode-amount)
 205
 206 (define-minor-mode text-scale-mode
 207   "Minor mode for displaying buffer text in a larger/smaller font.
 208 With a prefix argument ARG, enable the mode if ARG is positive,
 209 and disable it otherwise.  If called from Lisp, enable the mode
 210 if ARG is omitted or nil.
 211
 212 The amount of scaling is determined by the variable
 213 `text-scale-mode-amount': one step scales the global default
 214 face size by the value of the variable `text-scale-mode-step'
 215 \(a negative amount shrinks the text).
 216
 217 The `text-scale-increase', `text-scale-decrease', and
 218 `text-scale-set' functions may be used to interactively modify
 219 the variable `text-scale-mode-amount' (they also enable or
 220 disable `text-scale-mode' as necessary)."
 221   :lighter (" " text-scale-mode-lighter)
 222   (when text-scale-mode-remapping
 223     (face-remap-remove-relative text-scale-mode-remapping))
 224   (setq text-scale-mode-lighter
 225         (format (if (>= text-scale-mode-amount 0) "+%d" "%d")
 226                 text-scale-mode-amount))
 227   (setq text-scale-mode-remapping
 228         (and text-scale-mode
 229              (face-remap-add-relative 'default
 230                                           :height
 231                                           (expt text-scale-mode-step
 232                                                 text-scale-mode-amount))))
 233   (force-window-update (current-buffer)))
 234
 235 ;;;###autoload
 236 (defun text-scale-set (level)
 237   "Set the scale factor of the default face in the current buffer to LEVEL.
 238 If LEVEL is non-zero, `text-scale-mode' is enabled, otherwise it is disabled.
 239
 240 LEVEL is a number of steps, with 0 representing the default size.
 241 Each step scales the height of the default face by the variable
 242 `text-scale-mode-step' (a negative number decreases the height by
 243 the same amount)."
 244   (interactive "p")
 245   (setq text-scale-mode-amount level)
 246   (text-scale-mode (if (zerop text-scale-mode-amount) -1 1)))
 247
 248 ;;;###autoload
 249 (defun text-scale-increase (inc)
 250   "Increase the height of the default face in the current buffer by INC steps.
 251 If the new height is other than the default, `text-scale-mode' is enabled.
 252
 253 Each step scales the height of the default face by the variable
 254 `text-scale-mode-step' (a negative number of steps decreases the
 255 height by the same amount).  As a special case, an argument of 0
 256 will remove any scaling currently active."
 257   (interactive "p")
 258   (setq text-scale-mode-amount
 259         (if (= inc 0) 0 (+ (if text-scale-mode text-scale-mode-amount 0) inc)))
 260   (text-scale-mode (if (zerop text-scale-mode-amount) -1 1)))
 261
 262 ;;;###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 ;;;###autoload (define-key ctl-x-map [(control ?+)] 'text-scale-adjust)
 270 ;;;###autoload (define-key ctl-x-map [(control ?-)] 'text-scale-adjust)
 271 ;;;###autoload (define-key ctl-x-map [(control ?=)] 'text-scale-adjust)
 272 ;;;###autoload (define-key ctl-x-map [(control ?0)] 'text-scale-adjust)
 273 ;;;###autoload
 274 (defun text-scale-adjust (inc)
 275   "Increase or decrease the height of the default face in the current buffer.
 276
 277 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    +, =   Increase the default face height by one step
 281    -      Decrease the default face height by one step
 282    0      Reset the default face height to the global default
 283
 284 Then, continue to read input events and further adjust the face
 285 height as long as the input event read (with all modifiers removed)
 286 is one of the above.
 287
 288 Each step scales the height of the default face by the variable
 289 `text-scale-mode-step' (a negative number of steps decreases the
 290 height by the same amount).  As a special case, an argument of 0
 291 will remove any scaling currently active.
 292
 293 This command is a special-purpose wrapper around the
 294 `text-scale-increase' command which makes repetition convenient
 295 even when it is bound in a non-top-level keymap.  For binding in
 296 a top-level keymap, `text-scale-increase' or
 297 `text-scale-decrease' may be more appropriate."
 298   (interactive "p")
 299   (let ((first t)
 300         (step t)
 301         (ev last-command-event)
 302         (echo-keystrokes nil))
 303     (while step
 304       (let ((base (event-basic-type ev)))
 305         (cond ((or (eq base ?+) (eq base ?=))
 306                (setq step inc))
 307               ((eq base ?-)
 308                (setq step (- inc)))
 309               ((eq base ?0)
 310                (setq step 0))
 311               (first
 312                (setq step inc))
 313               (t
 314                (setq step nil))))
 315       (when step
 316         (text-scale-increase step)
 317         (setq inc 1 first nil)
 318         (setq ev (read-event "+,-,0 for further adjustment: "))))
 319     (push ev unread-command-events)))
 320
 321 \f
 322 ;; ----------------------------------------------------------------
 323 ;; buffer-face-mode
 324
 325 (defcustom buffer-face-mode-face 'variable-pitch
 326   "The face specification used by `buffer-face-mode'.
 327 It may contain any value suitable for a `face' text property,
 328 including a face name, a list of face names, a face-attribute
 329 plist, etc."
 330   :group 'display
 331   :version "23.1")
 332
 333 ;; current remapping cookie for  buffer-face-mode
 334 (defvar buffer-face-mode-remapping nil)
 335 (make-variable-buffer-local 'buffer-face-mode-remapping)
 336
 337 ;;;###autoload
 338 (define-minor-mode buffer-face-mode
 339   "Minor mode for a buffer-specific default face.
 340 With a prefix argument ARG, enable the mode if ARG is positive,
 341 and disable it otherwise.  If called from Lisp, enable the mode
 342 if ARG is omitted or nil.  When enabled, the face specified by the
 343 variable `buffer-face-mode-face' is used to display the buffer text."
 344   :lighter " BufFace"
 345   (when buffer-face-mode-remapping
 346     (face-remap-remove-relative buffer-face-mode-remapping))
 347   (setq buffer-face-mode-remapping
 348         (and buffer-face-mode
 349              (face-remap-add-relative 'default buffer-face-mode-face)))
 350   (force-window-update (current-buffer)))
 351
 352 ;;;###autoload
 353 (defun buffer-face-set (&rest specs)
 354   "Enable `buffer-face-mode', using face specs SPECS.
 355 SPECS can be any value suitable for the `face' text property,
 356 including a face name, a list of face names, or a face-attribute
 357 If SPECS is nil, then `buffer-face-mode' is disabled.
 358
 359 This function will make the variable `buffer-face-mode-face'
 360 buffer local, and set it to FACE."
 361   (interactive (list (read-face-name "Set buffer face")))
 362   (while (and (consp specs) (null (cdr specs)))
 363     (setq specs (car specs)))
 364   (if (null specs)
 365       (buffer-face-mode 0)
 366     (set (make-local-variable 'buffer-face-mode-face) specs)
 367     (buffer-face-mode t)))
 368
 369 ;;;###autoload
 370 (defun buffer-face-toggle (&rest specs)
 371   "Toggle `buffer-face-mode', using face specs SPECS.
 372 SPECS can be any value suitable for the `face' text property,
 373 including a face name, a list of face names, or a face-attribute
 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
 377 disabled, or is enabled and currently displaying some other face,
 378 then is left enabled, but the face changed to reflect SPECS.
 379
 380 This function will make the variable `buffer-face-mode-face'
 381 buffer local, and set it to SPECS."
 382   (interactive (list buffer-face-mode-face))
 383   (while (and (consp specs) (null (cdr specs)))
 384     (setq specs (car specs)))
 385   (if (or (null specs)
 386           (and buffer-face-mode (equal buffer-face-mode-face specs)))
 387       (buffer-face-mode 0)
 388     (set (make-local-variable 'buffer-face-mode-face) specs)
 389     (buffer-face-mode t)))
 390
 391 (defun buffer-face-mode-invoke (specs arg &optional interactive)
 392   "Enable or disable `buffer-face-mode' using face specs SPECS, and argument ARG.
 393 ARG controls whether the mode is enabled or disabled, and is
 394 interpreted in the usual manner for minor-mode commands.
 395
 396 SPECS can be any value suitable for the `face' text property,
 397 including a face name, a list of face names, or a face-attribute
 398
 399 If INTERACTIVE is non-nil, a message will be displayed describing the result.
 400
 401 This is a wrapper function which calls `buffer-face-set' or
 402 `buffer-face-toggle' (depending on ARG), and prints a status
 403 message in the echo area.  In many cases one of those functions
 404 may be more appropriate."
 405   (let ((last-message (current-message)))
 406     (if (or (eq arg 'toggle) (not arg))
 407         (buffer-face-toggle specs)
 408       (buffer-face-set (and (> (prefix-numeric-value arg) 0) specs)))
 409     (when interactive
 410       (unless (and (current-message)
 411                    (not (equal last-message (current-message))))
 412         (message "Buffer-Face mode %sabled"
 413                  (if buffer-face-mode "en" "dis"))))))
 414
 415 \f
 416 ;; ----------------------------------------------------------------
 417 ;; variable-pitch-mode
 418
 419 ;;;###autoload
 420 (defun variable-pitch-mode (&optional arg)
 421   "Variable-pitch default-face mode.
 422 An interface to `buffer-face-mode' which uses the `variable-pitch' face.
 423 Besides the choice of face, it is the same as `buffer-face-mode'."
 424   (interactive (list (or current-prefix-arg 'toggle)))
 425   (buffer-face-mode-invoke 'variable-pitch arg
 426                            (called-interactively-p 'interactive)))
 427
 428
 429 (provide 'face-remap)
 430
 431 ;;; face-remap.el ends here