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