lisp/face-remap.el

   1 ;;; face-remap.el --- Functions for managing `face-remapping-alist'
   2 ;;
   3 ;; Copyright (C) 2008 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Miles Bader <miles@gnu.org>
   6 ;; Keywords: faces face 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 ;;;### autoload
  65 (defun face-remap-add-relative (face &rest specs)
  66   "Add a face remapping entry of FACE to SPECS in the current buffer.
  67
  68 Return a cookie which can be used to delete the remapping with
  69 `face-remap-remove-relative'.
  70
  71 SPECS can be any value suitable for the `face' text property,
  72 including a face name, a list of face names, or a face-attribute
  73 property list.  The attributes given by SPECS will be merged with
  74 any other currently active face remappings of FACE, and with the
  75 global definition of FACE, with the most recently added relative
  76 remapping taking precedence.
  77
  78 The base (lowest priority) remapping may be set to a specific
  79 value, instead of the default of the global face definition,
  80 using `face-remap-set-base'."
  81   (make-local-variable 'face-remapping-alist)
  82   (let ((entry (assq face face-remapping-alist)))
  83     (when (null entry)
  84       (setq entry (list face face))     ; explicitly merge with global def
  85       (push entry face-remapping-alist))
  86     (setcdr entry (cons specs (cdr entry)))
  87     (cons face specs)))
  88
  89 (defun face-remap-remove-relative (cookie)
  90   "Remove a face remapping previously added by `face-remap-add-relative'.
  91 COOKIE should be the return value from that function."
  92   (let ((remapping (assq (car cookie) face-remapping-alist)))
  93     (when remapping
  94       (let ((updated-entries (remq (cdr cookie) (cdr remapping))))
  95         (unless (eq updated-entries (cdr remapping))
  96           (setcdr remapping updated-entries)
  97           (when (or (null updated-entries)
  98                     (and (eq (car-safe updated-entries) (car cookie))
  99                          (null (cdr updated-entries))))
 100             (setq face-remapping-alist
 101                   (remq remapping face-remapping-alist)))
 102           (cdr cookie))))))
 103
 104 ;;;### autoload
 105 (defun face-remap-reset-base (face)
 106   "Set the base remapping of FACE to inherit from FACE's global definition."
 107   (let ((entry (assq face face-remapping-alist)))
 108     (when entry
 109       ;; If there's nothing except a base remapping, we simply remove
 110       ;; the entire remapping entry, as setting the base to the default
 111       ;; would be the same as the global definition.  Otherwise, we
 112       ;; modify the base remapping.
 113       (if (null (cddr entry))           ; nothing except base remapping
 114           (setq face-remapping-alist    ; so remove entire entry
 115                 (remq entry face-remapping-alist))
 116         (setcar (last entry) face)))))  ; otherwise, just inherit global def
 117
 118 ;;;### autoload
 119 (defun face-remap-set-base (face &rest specs)
 120   "Set the base remapping of FACE in the current buffer to SPECS.
 121 If SPECS is empty, the default base remapping is restored, which
 122 inherits from the global definition of FACE; note that this is
 123 different from SPECS containing a single value `nil', which does
 124 not inherit from the global definition of FACE."
 125   (if (or (null specs)
 126           (and (eq (car specs) face) (null (cdr specs)))) ; default
 127       ;; Set entry back to default
 128       (face-remap-reset-base face)
 129     ;; Set the base remapping
 130     (make-local-variable 'face-remapping-alist)
 131     (let ((entry (assq face face-remapping-alist)))
 132       (if entry
 133           (setcar (last entry) specs)   ; overwrite existing base entry
 134         (push (list face specs) face-remapping-alist)))))
 135
 136 \f
 137 ;; ----------------------------------------------------------------
 138 ;; text-scale-mode
 139
 140 (defcustom text-scale-mode-step 1.2
 141   "Scale factor used by `text-scale-mode'.
 142 Each positive or negative step scales the default face height by this amount."
 143   :group 'display
 144   :type 'number)
 145
 146 ;; current remapping cookie for text-scale-mode
 147 (defvar text-scale-mode-remapping nil)
 148 (make-variable-buffer-local 'text-scale-mode-remapping)
 149
 150 ;; Lighter displayed for text-scale-mode in mode-line minor-mode list
 151 (defvar text-scale-mode-lighter "+0")
 152 (make-variable-buffer-local 'text-scale-mode-lighter)
 153
 154 ;; Number of steps that text-scale-mode will increase/decrease text height
 155 (defvar text-scale-mode-amount 0)
 156 (make-variable-buffer-local 'text-scale-mode-amount)
 157
 158 (define-minor-mode text-scale-mode
 159   "Minor mode for displaying buffer text in a larger/smaller font than usual.
 160
 161 The amount of scaling is determined by the variable
 162 `text-scale-mode-amount': one step scales the global default
 163 face size by the value of the variable `text-scale-mode-step'
 164 \(a negative amount shrinks the text).
 165
 166 The `text-scale-increase' and `text-scale-decrease' functions may
 167 be used to interactively modify the variable
 168 `text-scale-mode-amount' (they also enable or disable
 169 `text-scale-mode' as necessary)."
 170   :lighter (" " text-scale-mode-lighter)
 171   (when text-scale-mode-remapping
 172     (face-remap-remove-relative text-scale-mode-remapping))
 173   (setq text-scale-mode-lighter
 174         (format (if (>= text-scale-mode-amount 0) "+%d" "%d")
 175                 text-scale-mode-amount))
 176   (setq text-scale-mode-remapping
 177         (and text-scale-mode
 178              (face-remap-add-relative 'default
 179                                           :height
 180                                           (expt text-scale-mode-step
 181                                                 text-scale-mode-amount))))
 182   (force-window-update (current-buffer)))
 183
 184 ;;;###autoload
 185 (defun text-scale-increase (&optional inc)
 186   "Increase the height of the default face in the current buffer by INC steps.
 187 If the new height is other than the default, `text-scale-mode' is enabled.
 188
 189 Each step scales the height of the default face by the variable
 190 `text-scale-mode-step' (a negative number of steps decreases the
 191 height by the same amount).  As a special case, an argument of 0
 192 will remove any scaling currently active."
 193   (interactive "p")
 194   (setq text-scale-mode-amount (if (= inc 0) 0 (+ text-scale-mode-amount inc)))
 195   (text-scale-mode (if (zerop text-scale-mode-amount) -1 1)))
 196
 197 ;;;###autoload
 198 (defun text-scale-decrease (&optional dec)
 199   "Decrease the height of the default face in the current buffer by DEC steps.
 200 See `text-scale-increase' for more details."
 201   (interactive "p")
 202   (text-scale-increase (- dec)))
 203
 204 ;;;###autoload (define-key ctl-x-map [(control ?+)] 'text-scale-adjust)
 205 ;;;###autoload (define-key ctl-x-map [(control ?-)] 'text-scale-adjust)
 206 ;;;###autoload (define-key ctl-x-map [(control ?=)] 'text-scale-adjust)
 207 ;;;###autoload (define-key ctl-x-map [(control ?0)] 'text-scale-adjust)
 208 ;;;###autoload
 209 (defun text-scale-adjust (&optional inc)
 210   "Increase or decrease the height of the default face in the current buffer.
 211
 212 The actual adjustment made depends on the final component of the
 213 key-binding used to invoke the command, with all modifiers removed:
 214
 215    +, =   Increase the default face height by one step
 216    -      Decrease the default face height by one step
 217    0      Reset the default face height to the global default
 218
 219 Then, continue to read input events and further adjust the face
 220 height as long as the input event read (with all modifiers removed)
 221 is one of the above.
 222
 223 Each step scales the height of the default face by the variable
 224 `text-scale-mode-step' (a negative number of steps decreases the
 225 height by the same amount).  As a special case, an argument of 0
 226 will remove any scaling currently active.
 227
 228 This command is a special-purpose wrapper around the
 229 `text-scale-increase' command which makes repetition convenient
 230 even when it is bound in a non-top-level keymap.  For binding in
 231 a top-level keymap, `text-scale-increase' or
 232 `text-scale-decrease' may be more appropriate."
 233   (interactive "p")
 234   (let ((first t)
 235         (step t)
 236         (ev last-command-event))
 237     (while step
 238       (let ((base (event-basic-type ev)))
 239         (cond ((or (eq base ?+) (eq base ?=))
 240                (setq step inc))
 241               ((eq base ?-)
 242                (setq step (- inc)))
 243               ((eq base ?0)
 244                (setq step 0))
 245               (first
 246                (setq step inc))
 247               (t
 248                (setq step nil))))
 249       (when step
 250         (text-scale-increase step)
 251         (setq inc 1 first nil)
 252         (setq ev (read-event))))
 253     (push ev unread-command-events)))
 254
 255 \f
 256 ;; ----------------------------------------------------------------
 257 ;; variable-pitch-mode
 258
 259 ;; suggested key binding: (global-set-key "\C-cv" 'variable-pitch-mode)
 260
 261 ;; current remapping cookie for  variable-pitch-mode
 262 (defvar variable-pitch-mode-remapping nil)
 263 (make-variable-buffer-local 'variable-pitch-mode-remapping)
 264
 265 ;;;###autoload
 266 (define-minor-mode variable-pitch-mode
 267   "Variable-pitch default-face mode.
 268 When active, causes the buffer text to be displayed using
 269 the `variable-pitch' face."
 270   :lighter " VarPitch"
 271   (when variable-pitch-mode-remapping
 272     (face-remap-remove-relative variable-pitch-mode-remapping))
 273   (setq variable-pitch-mode-remapping
 274         (and variable-pitch-mode
 275              (face-remap-add-relative 'default 'variable-pitch)))
 276   (force-window-update (current-buffer)))
 277
 278
 279 (provide 'face-remap)
 280
 281 ;; arch-tag: 5c5f034b-8d58-4967-82bd-d61fd364e686
 282 ;;; face-remap.el ends here