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 Return a cookie which can be used to delete this remapping with
 110 `face-remap-remove-relative'.
 111
 112 The remaining arguments, SPECS, should form a list of faces.
 113 Each list element should be either a face name or a property list
 114 of face attribute/value pairs.  If more than one face is listed,
 115 that specifies an aggregate face, in the same way as in a `face'
 116 text property, except for possible priority changes noted below.
 117
 118 The face remapping specified by SPECS takes effect alongside the
 119 remappings from other calls to `face-remap-add-relative' for the
 120 same FACE, as well as the normal definition of FACE (at lowest
 121 priority).  This function tries to sort multiple remappings for
 122 the same face, so that remappings specifying relative face
 123 attributes are applied after remappings specifying absolute face
 124 attributes.
 125
 126 The base (lowest priority) remapping may be set to something
 127 other than the normal definition of FACE via `face-remap-set-base'."
 128   (while (and (consp specs) (null (cdr specs)))
 129     (setq specs (car specs)))
 130   (make-local-variable 'face-remapping-alist)
 131   (let ((entry (assq face face-remapping-alist)))
 132     (when (null entry)
 133       (setq entry (list face face))     ; explicitly merge with global def
 134       (push entry face-remapping-alist))
 135     (setcdr entry (face-remap-order (cons specs (cdr entry))))
 136     (cons face specs)))
 137
 138 (defun face-remap-remove-relative (cookie)
 139   "Remove a face remapping previously added by `face-remap-add-relative'.
 140 COOKIE should be the return value from that function."
 141   (let ((remapping (assq (car cookie) face-remapping-alist)))
 142     (when remapping
 143       (let ((updated-entries (remq (cdr cookie) (cdr remapping))))
 144         (unless (eq updated-entries (cdr remapping))
 145           (setcdr remapping updated-entries)
 146           (when (or (null updated-entries)
 147                     (and (eq (car-safe updated-entries) (car cookie))
 148                          (null (cdr updated-entries))))
 149             (setq face-remapping-alist
 150                   (remq remapping face-remapping-alist)))
 151           (cdr cookie))))))
 152
 153 ;;;###autoload
 154 (defun face-remap-reset-base (face)
 155   "Set the base remapping of FACE to the normal definition of FACE.
 156 This causes the remappings specified by `face-remap-add-relative'
 157 to apply on top of the normal definition of FACE."
 158   (let ((entry (assq face face-remapping-alist)))
 159     (when entry
 160       ;; If there's nothing except a base remapping, we simply remove
 161       ;; the entire remapping entry, as setting the base to the default
 162       ;; would be the same as the global definition.  Otherwise, we
 163       ;; modify the base remapping.
 164       (if (null (cddr entry))           ; nothing except base remapping
 165           (setq face-remapping-alist    ; so remove entire entry
 166                 (remq entry face-remapping-alist))
 167         (setcar (last entry) face)))))  ; otherwise, just inherit global def
 168
 169 ;;;###autoload
 170 (defun face-remap-set-base (face &rest specs)
 171   "Set the base remapping of FACE in the current buffer to SPECS.
 172 This causes the remappings specified by `face-remap-add-relative'
 173 to apply on top of the face specification given by SPECS.
 174
 175 The remaining arguments, SPECS, should form a list of faces.
 176 Each list element should be either a face name or a property list
 177 of face attribute/value pairs, like in a `face' text property.
 178
 179 If SPECS is empty, call `face-remap-reset-base' to use the normal
 180 definition of FACE as the base remapping; note that this is
 181 different from SPECS containing a single value `nil', which means
 182 not to inherit from the global definition of FACE at all."
 183   (while (and (consp specs) (not (null (car specs))) (null (cdr specs)))
 184     (setq specs (car specs)))
 185   (if (or (null specs)
 186           (and (eq (car specs) face) (null (cdr specs)))) ; default
 187       ;; Set entry back to default
 188       (face-remap-reset-base face)
 189     ;; Set the base remapping
 190     (make-local-variable 'face-remapping-alist)
 191     (let ((entry (assq face face-remapping-alist)))
 192       (if entry
 193           (setcar (last entry) specs)   ; overwrite existing base entry
 194         (push (list face specs) face-remapping-alist)))))
 195
 196 \f
 197 ;; ----------------------------------------------------------------
 198 ;; text-scale-mode
 199
 200 (defcustom text-scale-mode-step 1.2
 201   "Scale factor used by `text-scale-mode'.
 202 Each positive or negative step scales the default face height by this amount."
 203   :group 'display
 204   :type 'number
 205   :version "23.1")
 206
 207 ;; current remapping cookie for text-scale-mode
 208 (defvar text-scale-mode-remapping nil)
 209 (make-variable-buffer-local 'text-scale-mode-remapping)
 210
 211 ;; Lighter displayed for text-scale-mode in mode-line minor-mode list
 212 (defvar text-scale-mode-lighter "+0")
 213 (make-variable-buffer-local 'text-scale-mode-lighter)
 214
 215 ;; Number of steps that text-scale-mode will increase/decrease text height
 216 (defvar text-scale-mode-amount 0)
 217 (make-variable-buffer-local 'text-scale-mode-amount)
 218
 219 (define-minor-mode text-scale-mode
 220   "Minor mode for displaying buffer text in a larger/smaller font.
 221 With a prefix argument ARG, enable the mode if ARG is positive,
 222 and disable it otherwise.  If called from Lisp, enable the mode
 223 if ARG is omitted or nil.
 224
 225 The amount of scaling is determined by the variable
 226 `text-scale-mode-amount': one step scales the global default
 227 face size by the value of the variable `text-scale-mode-step'
 228 \(a negative amount shrinks the text).
 229
 230 The `text-scale-increase', `text-scale-decrease', and
 231 `text-scale-set' functions may be used to interactively modify
 232 the variable `text-scale-mode-amount' (they also enable or
 233 disable `text-scale-mode' as necessary)."
 234   :lighter (" " text-scale-mode-lighter)
 235   (when text-scale-mode-remapping
 236     (face-remap-remove-relative text-scale-mode-remapping))
 237   (setq text-scale-mode-lighter
 238         (format (if (>= text-scale-mode-amount 0) "+%d" "%d")
 239                 text-scale-mode-amount))
 240   (setq text-scale-mode-remapping
 241         (and text-scale-mode
 242              (face-remap-add-relative 'default
 243                                           :height
 244                                           (expt text-scale-mode-step
 245                                                 text-scale-mode-amount))))
 246   (force-window-update (current-buffer)))
 247
 248 ;;;###autoload
 249 (defun text-scale-set (level)
 250   "Set the scale factor of the default face in the current buffer to LEVEL.
 251 If LEVEL is non-zero, `text-scale-mode' is enabled, otherwise it is disabled.
 252
 253 LEVEL is a number of steps, with 0 representing the default size.
 254 Each step scales the height of the default face by the variable
 255 `text-scale-mode-step' (a negative number decreases the height by
 256 the same amount)."
 257   (interactive "p")
 258   (setq text-scale-mode-amount level)
 259   (text-scale-mode (if (zerop text-scale-mode-amount) -1 1)))
 260
 261 ;;;###autoload
 262 (defun text-scale-increase (inc)
 263   "Increase the height of the default face in the current buffer by INC steps.
 264 If the new height is other than the default, `text-scale-mode' is enabled.
 265
 266 Each step scales the height of the default face by the variable
 267 `text-scale-mode-step' (a negative number of steps decreases the
 268 height by the same amount).  As a special case, an argument of 0
 269 will remove any scaling currently active."
 270   (interactive "p")
 271   (setq text-scale-mode-amount
 272         (if (= inc 0) 0 (+ (if text-scale-mode text-scale-mode-amount 0) inc)))
 273   (text-scale-mode (if (zerop text-scale-mode-amount) -1 1)))
 274
 275 ;;;###autoload
 276 (defun text-scale-decrease (dec)
 277   "Decrease the height of the default face in the current buffer by DEC steps.
 278 See `text-scale-increase' for more details."
 279   (interactive "p")
 280   (text-scale-increase (- dec)))
 281
 282 ;;;###autoload (define-key ctl-x-map [(control ?+)] 'text-scale-adjust)
 283 ;;;###autoload (define-key ctl-x-map [(control ?-)] 'text-scale-adjust)
 284 ;;;###autoload (define-key ctl-x-map [(control ?=)] 'text-scale-adjust)
 285 ;;;###autoload (define-key ctl-x-map [(control ?0)] 'text-scale-adjust)
 286 ;;;###autoload
 287 (defun text-scale-adjust (inc)
 288   "Increase or decrease the height of the default face in the current buffer.
 289
 290 The actual adjustment made depends on the final component of the
 291 key-binding used to invoke the command, with all modifiers removed:
 292
 293    +, =   Increase the default face height by one step
 294    -      Decrease the default face height by one step
 295    0      Reset the default face height to the global default
 296
 297 Then, continue to read input events and further adjust the face
 298 height as long as the input event read (with all modifiers removed)
 299 is one of the above.
 300
 301 Each step scales the height of the default face by the variable
 302 `text-scale-mode-step' (a negative number of steps decreases the
 303 height by the same amount).  As a special case, an argument of 0
 304 will remove any scaling currently active.
 305
 306 This command is a special-purpose wrapper around the
 307 `text-scale-increase' command which makes repetition convenient
 308 even when it is bound in a non-top-level keymap.  For binding in
 309 a top-level keymap, `text-scale-increase' or
 310 `text-scale-decrease' may be more appropriate."
 311   (interactive "p")
 312   (let ((first t)
 313         (ev last-command-event)
 314         (echo-keystrokes nil))
 315     (let* ((base (event-basic-type ev))
 316            (step
 317             (pcase base
 318               ((or ?+ ?=) inc)
 319               (?- (- inc))
 320               (?0 0)
 321               (t inc))))
 322       (text-scale-increase step)
 323       ;; FIXME: do it after every "iteration of the loop".
 324       (message "+,-,0 for further adjustment: ")
 325       (set-temporary-overlay-map
 326        (let ((map (make-sparse-keymap)))
 327          (dolist (mods '(() (control)))
 328            (define-key map (vector (append mods '(?-))) 'text-scale-decrease)
 329            (define-key map (vector (append mods '(?+))) 'text-scale-increase)
 330            ;; = is unshifted + on most keyboards.
 331            (define-key map (vector (append mods '(?=))) 'text-scale-increase)
 332            (define-key map (vector (append mods '(?0)))
 333              (lambda () (interactive) (text-scale-increase 0))))
 334          map)
 335        t))))
 336
 337 \f
 338 ;; ----------------------------------------------------------------
 339 ;; buffer-face-mode
 340
 341 (defcustom buffer-face-mode-face 'variable-pitch
 342   "The face specification used by `buffer-face-mode'.
 343 It may contain any value suitable for a `face' text property,
 344 including a face name, a list of face names, a face-attribute
 345 plist, etc."
 346   :group 'display
 347   :version "23.1")
 348
 349 ;; current remapping cookie for  buffer-face-mode
 350 (defvar buffer-face-mode-remapping nil)
 351 (make-variable-buffer-local 'buffer-face-mode-remapping)
 352
 353 ;;;###autoload
 354 (define-minor-mode buffer-face-mode
 355   "Minor mode for a buffer-specific default face.
 356 With a prefix argument ARG, enable the mode if ARG is positive,
 357 and disable it otherwise.  If called from Lisp, enable the mode
 358 if ARG is omitted or nil.  When enabled, the face specified by the
 359 variable `buffer-face-mode-face' is used to display the buffer text."
 360   :lighter " BufFace"
 361   (when buffer-face-mode-remapping
 362     (face-remap-remove-relative buffer-face-mode-remapping))
 363   (setq buffer-face-mode-remapping
 364         (and buffer-face-mode
 365              (face-remap-add-relative 'default buffer-face-mode-face)))
 366   (force-window-update (current-buffer)))
 367
 368 ;;;###autoload
 369 (defun buffer-face-set (&rest specs)
 370   "Enable `buffer-face-mode', using face specs SPECS.
 371 Each argument in SPECS should be a face, i.e. either a face name
 372 or a property list of face attributes and values.  If more than
 373 one face is listed, that specifies an aggregate face, like in a
 374 `face' text property.  If SPECS is nil or omitted, disable
 375 `buffer-face-mode'.
 376
 377 This function makes the variable `buffer-face-mode-face' buffer
 378 local, and sets it to FACE."
 379   (interactive (list (read-face-name "Set buffer face")))
 380   (while (and (consp specs) (null (cdr specs)))
 381     (setq specs (car specs)))
 382   (if (null specs)
 383       (buffer-face-mode 0)
 384     (set (make-local-variable 'buffer-face-mode-face) specs)
 385     (buffer-face-mode t)))
 386
 387 ;;;###autoload
 388 (defun buffer-face-toggle (&rest specs)
 389   "Toggle `buffer-face-mode', using face specs SPECS.
 390 Each argument in SPECS should be a face, i.e. either a face name
 391 or a property list of face attributes and values.  If more than
 392 one face is listed, that specifies an aggregate face, like in a
 393 `face' text property.
 394
 395 If `buffer-face-mode' is already enabled, and is currently using
 396 the face specs SPECS, then it is disabled; if buffer-face-mode is
 397 disabled, or is enabled and currently displaying some other face,
 398 then is left enabled, but the face changed to reflect SPECS.
 399
 400 This function will make the variable `buffer-face-mode-face'
 401 buffer local, and set it to SPECS."
 402   (interactive (list buffer-face-mode-face))
 403   (while (and (consp specs) (null (cdr specs)))
 404     (setq specs (car specs)))
 405   (if (or (null specs)
 406           (and buffer-face-mode (equal buffer-face-mode-face specs)))
 407       (buffer-face-mode 0)
 408     (set (make-local-variable 'buffer-face-mode-face) specs)
 409     (buffer-face-mode t)))
 410
 411 (defun buffer-face-mode-invoke (specs arg &optional interactive)
 412   "Enable or disable `buffer-face-mode' using face specs SPECS, and argument ARG.
 413 ARG controls whether the mode is enabled or disabled, and is
 414 interpreted in the usual manner for minor-mode commands.
 415
 416 SPECS can be any value suitable for a `face' text property,
 417 including a face name, a plist of face attributes and values, or
 418 a list of faces.
 419
 420 If INTERACTIVE is non-nil, display a message describing the
 421 result.
 422
 423 This is a wrapper function which calls `buffer-face-set' or
 424 `buffer-face-toggle' (depending on ARG), and prints a status
 425 message in the echo area.  In many cases one of those functions
 426 may be more appropriate."
 427   (let ((last-message (current-message)))
 428     (if (or (eq arg 'toggle) (not arg))
 429         (buffer-face-toggle specs)
 430       (buffer-face-set (and (> (prefix-numeric-value arg) 0) specs)))
 431     (when interactive
 432       (unless (and (current-message)
 433                    (not (equal last-message (current-message))))
 434         (message "Buffer-Face mode %sabled"
 435                  (if buffer-face-mode "en" "dis"))))))
 436
 437 \f
 438 ;; ----------------------------------------------------------------
 439 ;; variable-pitch-mode
 440
 441 ;;;###autoload
 442 (defun variable-pitch-mode (&optional arg)
 443   "Variable-pitch default-face mode.
 444 An interface to `buffer-face-mode' which uses the `variable-pitch' face.
 445 Besides the choice of face, it is the same as `buffer-face-mode'."
 446   (interactive (list (or current-prefix-arg 'toggle)))
 447   (buffer-face-mode-invoke 'variable-pitch arg
 448                            (called-interactively-p 'interactive)))
 449
 450
 451 (provide 'face-remap)
 452
 453 ;;; face-remap.el ends here