| 1 | ;;; cus-face.el --- customization support for faces |
| 2 | ;; |
| 3 | ;; Copyright (C) 1996-1997, 1999-2014 Free Software Foundation, Inc. |
| 4 | ;; |
| 5 | ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> |
| 6 | ;; Keywords: help, faces |
| 7 | ;; Package: emacs |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 12 | ;; it under the terms of the GNU General Public License as published by |
| 13 | ;; the Free Software Foundation, either version 3 of the License, or |
| 14 | ;; (at your option) any later version. |
| 15 | |
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 19 | ;; GNU General Public License for more details. |
| 20 | |
| 21 | ;; You should have received a copy of the GNU General Public License |
| 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 23 | |
| 24 | ;;; Commentary: |
| 25 | ;; |
| 26 | ;; See `custom.el'. |
| 27 | |
| 28 | ;;; Code: |
| 29 | |
| 30 | (defalias 'custom-facep 'facep) |
| 31 | |
| 32 | ;;; Declaring a face. |
| 33 | |
| 34 | (defun custom-declare-face (face spec doc &rest args) |
| 35 | "Like `defface', but with FACE evaluated as a normal argument." |
| 36 | (unless (get face 'face-defface-spec) |
| 37 | (face-spec-set face (purecopy spec) 'face-defface-spec) |
| 38 | (push (cons 'defface face) current-load-list) |
| 39 | (when doc |
| 40 | (set-face-documentation face (purecopy doc))) |
| 41 | (custom-handle-all-keywords face args 'custom-face) |
| 42 | (run-hooks 'custom-define-hook)) |
| 43 | face) |
| 44 | |
| 45 | ;;; Face attributes. |
| 46 | |
| 47 | (defconst custom-face-attributes |
| 48 | '((:family |
| 49 | (string :tag "Font Family" |
| 50 | :help-echo "Font family or fontset alias name.")) |
| 51 | |
| 52 | (:foundry |
| 53 | (string :tag "Font Foundry" |
| 54 | :help-echo "Font foundry name.")) |
| 55 | |
| 56 | (:width |
| 57 | (choice :tag "Width" |
| 58 | :help-echo "Font width." |
| 59 | :value normal ; default |
| 60 | (const :tag "compressed" condensed) |
| 61 | (const :tag "condensed" condensed) |
| 62 | (const :tag "demiexpanded" semi-expanded) |
| 63 | (const :tag "expanded" expanded) |
| 64 | (const :tag "extracondensed" extra-condensed) |
| 65 | (const :tag "extraexpanded" extra-expanded) |
| 66 | (const :tag "medium" normal) |
| 67 | (const :tag "narrow" condensed) |
| 68 | (const :tag "normal" normal) |
| 69 | (const :tag "regular" normal) |
| 70 | (const :tag "semicondensed" semi-condensed) |
| 71 | (const :tag "semiexpanded" semi-expanded) |
| 72 | (const :tag "ultracondensed" ultra-condensed) |
| 73 | (const :tag "ultraexpanded" ultra-expanded) |
| 74 | (const :tag "wide" extra-expanded))) |
| 75 | |
| 76 | (:height |
| 77 | (choice :tag "Height" |
| 78 | :help-echo "Face's font height." |
| 79 | :value 1.0 ; default |
| 80 | (integer :tag "Height in 1/10 pt") |
| 81 | (number :tag "Scale" 1.0))) |
| 82 | |
| 83 | (:weight |
| 84 | (choice :tag "Weight" |
| 85 | :help-echo "Font weight." |
| 86 | :value normal ; default |
| 87 | (const :tag "black" ultra-bold) |
| 88 | (const :tag "bold" bold) |
| 89 | (const :tag "book" semi-light) |
| 90 | (const :tag "demibold" semi-bold) |
| 91 | (const :tag "extralight" extra-light) |
| 92 | (const :tag "extrabold" extra-bold) |
| 93 | (const :tag "heavy" extra-bold) |
| 94 | (const :tag "light" light) |
| 95 | (const :tag "medium" normal) |
| 96 | (const :tag "normal" normal) |
| 97 | (const :tag "regular" normal) |
| 98 | (const :tag "semibold" semi-bold) |
| 99 | (const :tag "semilight" semi-light) |
| 100 | (const :tag "ultralight" ultra-light) |
| 101 | (const :tag "ultrabold" ultra-bold) |
| 102 | (const :tag "thin" thin))) |
| 103 | |
| 104 | (:slant |
| 105 | (choice :tag "Slant" |
| 106 | :help-echo "Font slant." |
| 107 | :value normal ; default |
| 108 | (const :tag "italic" italic) |
| 109 | (const :tag "oblique" oblique) |
| 110 | (const :tag "normal" normal) |
| 111 | (const :tag "roman" roman))) |
| 112 | |
| 113 | (:underline |
| 114 | (choice :tag "Underline" |
| 115 | :help-echo "Control text underlining." |
| 116 | (const :tag "Off" nil) |
| 117 | (list :tag "On" |
| 118 | :value (:color foreground-color :style line) |
| 119 | (const :format "" :value :color) |
| 120 | (choice :tag "Color" |
| 121 | (const :tag "Foreground Color" foreground-color) |
| 122 | color) |
| 123 | (const :format "" :value :style) |
| 124 | (choice :tag "Style" |
| 125 | (const :tag "Line" line) |
| 126 | (const :tag "Wave" wave)))) |
| 127 | ;; filter to make value suitable for customize |
| 128 | (lambda (real-value) |
| 129 | (and real-value |
| 130 | (let ((color |
| 131 | (or (and (consp real-value) (plist-get real-value :color)) |
| 132 | (and (stringp real-value) real-value) |
| 133 | 'foreground-color)) |
| 134 | (style |
| 135 | (or (and (consp real-value) (plist-get real-value :style)) |
| 136 | 'line))) |
| 137 | (list :color color :style style)))) |
| 138 | ;; filter to make customized-value suitable for storing |
| 139 | (lambda (cus-value) |
| 140 | (and cus-value |
| 141 | (let ((color (plist-get cus-value :color)) |
| 142 | (style (plist-get cus-value :style))) |
| 143 | (cond ((eq style 'line) |
| 144 | ;; Use simple value for default style |
| 145 | (if (eq color 'foreground-color) t color)) |
| 146 | (t |
| 147 | `(:color ,color :style ,style))))))) |
| 148 | |
| 149 | (:overline |
| 150 | (choice :tag "Overline" |
| 151 | :help-echo "Control text overlining." |
| 152 | (const :tag "Off" nil) |
| 153 | (const :tag "On" t) |
| 154 | (color :tag "Colored"))) |
| 155 | |
| 156 | (:strike-through |
| 157 | (choice :tag "Strike-through" |
| 158 | :help-echo "Control text strike-through." |
| 159 | (const :tag "Off" nil) |
| 160 | (const :tag "On" t) |
| 161 | (color :tag "Colored"))) |
| 162 | |
| 163 | (:box |
| 164 | ;; Fixme: this can probably be done better. |
| 165 | (choice :tag "Box around text" |
| 166 | :help-echo "Control box around text." |
| 167 | (const :tag "Off" nil) |
| 168 | (list :tag "Box" |
| 169 | :value (:line-width 2 :color "grey75" :style released-button) |
| 170 | (const :format "" :value :line-width) |
| 171 | (integer :tag "Width") |
| 172 | (const :format "" :value :color) |
| 173 | (choice :tag "Color" (const :tag "*" nil) color) |
| 174 | (const :format "" :value :style) |
| 175 | (choice :tag "Style" |
| 176 | (const :tag "Raised" released-button) |
| 177 | (const :tag "Sunken" pressed-button) |
| 178 | (const :tag "None" nil)))) |
| 179 | ;; filter to make value suitable for customize |
| 180 | (lambda (real-value) |
| 181 | (and real-value |
| 182 | (let ((lwidth |
| 183 | (or (and (consp real-value) |
| 184 | (plist-get real-value :line-width)) |
| 185 | (and (integerp real-value) real-value) |
| 186 | 1)) |
| 187 | (color |
| 188 | (or (and (consp real-value) (plist-get real-value :color)) |
| 189 | (and (stringp real-value) real-value) |
| 190 | nil)) |
| 191 | (style |
| 192 | (and (consp real-value) (plist-get real-value :style)))) |
| 193 | (list :line-width lwidth :color color :style style)))) |
| 194 | ;; filter to make customized-value suitable for storing |
| 195 | (lambda (cus-value) |
| 196 | (and cus-value |
| 197 | (let ((lwidth (plist-get cus-value :line-width)) |
| 198 | (color (plist-get cus-value :color)) |
| 199 | (style (plist-get cus-value :style))) |
| 200 | (cond ((and (null color) (null style)) |
| 201 | lwidth) |
| 202 | ((and (null lwidth) (null style)) |
| 203 | ;; actually can't happen, because LWIDTH is always an int |
| 204 | color) |
| 205 | (t |
| 206 | ;; Keep as a plist, but remove null entries |
| 207 | (nconc (and lwidth `(:line-width ,lwidth)) |
| 208 | (and color `(:color ,color)) |
| 209 | (and style `(:style ,style))))))))) |
| 210 | |
| 211 | (:inverse-video |
| 212 | (choice :tag "Inverse-video" |
| 213 | :help-echo "Control whether text should be in inverse-video." |
| 214 | (const :tag "Off" nil) |
| 215 | (const :tag "On" t))) |
| 216 | |
| 217 | (:foreground |
| 218 | (color :tag "Foreground" |
| 219 | :help-echo "Set foreground color (name or #RRGGBB hex spec).")) |
| 220 | |
| 221 | (:distant-foreground |
| 222 | (color :tag "Distant Foreground" |
| 223 | :help-echo "Set distant foreground color (name or #RRGGBB hex spec).")) |
| 224 | |
| 225 | (:background |
| 226 | (color :tag "Background" |
| 227 | :help-echo "Set background color (name or #RRGGBB hex spec).")) |
| 228 | |
| 229 | (:stipple |
| 230 | (choice :tag "Stipple" |
| 231 | :help-echo "Background bit-mask" |
| 232 | (const :tag "None" nil) |
| 233 | (file :tag "File" |
| 234 | :help-echo "Name of bitmap file." |
| 235 | :must-match t))) |
| 236 | |
| 237 | (:inherit |
| 238 | (repeat :tag "Inherit" |
| 239 | :help-echo "List of faces to inherit attributes from." |
| 240 | (face :Tag "Face" default)) |
| 241 | ;; filter to make value suitable for customize |
| 242 | (lambda (real-value) |
| 243 | (cond ((or (null real-value) (eq real-value 'unspecified)) |
| 244 | nil) |
| 245 | ((symbolp real-value) |
| 246 | (list real-value)) |
| 247 | (t |
| 248 | real-value))) |
| 249 | ;; filter to make customized-value suitable for storing |
| 250 | (lambda (cus-value) |
| 251 | (if (and (consp cus-value) (null (cdr cus-value))) |
| 252 | (car cus-value) |
| 253 | cus-value)))) |
| 254 | |
| 255 | "Alist of face attributes. |
| 256 | |
| 257 | The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER), |
| 258 | where KEY is the name of the attribute, TYPE is a widget type for |
| 259 | editing the attribute, PRE-FILTER is a function to make the attribute's |
| 260 | value suitable for the customization widget, and POST-FILTER is a |
| 261 | function to make the customized value suitable for storing. PRE-FILTER |
| 262 | and POST-FILTER are optional. |
| 263 | |
| 264 | The PRE-FILTER should take a single argument, the attribute value as |
| 265 | stored, and should return a value for customization (using the |
| 266 | customization type TYPE). |
| 267 | |
| 268 | The POST-FILTER should also take a single argument, the value after |
| 269 | being customized, and should return a value suitable for setting the |
| 270 | given face attribute.") |
| 271 | |
| 272 | (defun custom-face-attributes-get (face frame) |
| 273 | "For FACE on FRAME, return an alternating list describing its attributes. |
| 274 | The list has the form (KEYWORD VALUE KEYWORD VALUE...). |
| 275 | Each keyword should be listed in `custom-face-attributes'. |
| 276 | |
| 277 | If FRAME is nil, use the global defaults for FACE." |
| 278 | (let ((attrs custom-face-attributes) |
| 279 | plist) |
| 280 | (while attrs |
| 281 | (let* ((attribute (car (car attrs))) |
| 282 | (value (face-attribute face attribute frame))) |
| 283 | (setq attrs (cdr attrs)) |
| 284 | (unless (or (eq value 'unspecified) |
| 285 | (and (null value) (memq attribute '(:inherit)))) |
| 286 | (setq plist (cons attribute (cons value plist)))))) |
| 287 | plist)) |
| 288 | |
| 289 | ;;; Initializing. |
| 290 | |
| 291 | (defun custom-set-faces (&rest args) |
| 292 | "Apply a list of face specs for user customizations. |
| 293 | This works by calling `custom-theme-set-faces' for the `user' |
| 294 | theme, a special theme referring to settings made via Customize. |
| 295 | The arguments should be a list where each entry has the form: |
| 296 | |
| 297 | (FACE SPEC [NOW [COMMENT]]) |
| 298 | |
| 299 | See the documentation of `custom-theme-set-faces' for details." |
| 300 | (apply 'custom-theme-set-faces 'user args)) |
| 301 | |
| 302 | (defun custom-theme-set-faces (theme &rest args) |
| 303 | "Apply a list of face specs associated with theme THEME. |
| 304 | THEME should be a theme name (a symbol). The special theme named |
| 305 | `user' refers to user settings applied via Customize. |
| 306 | |
| 307 | The remaining ARGS should be a list where each entry is a list of |
| 308 | the form: |
| 309 | |
| 310 | (FACE SPEC [NOW [COMMENT]]) |
| 311 | |
| 312 | FACE should be a face name (a symbol). If FACE is a face alias, |
| 313 | the setting refers to the parent face. |
| 314 | |
| 315 | SPEC should be a face spec. For details, see `defface'. |
| 316 | |
| 317 | NOW, if present and non-nil, forces the face settings to take |
| 318 | immediate effect in the Emacs display; in particular, FACE is |
| 319 | initialized as a face if it is not yet one. If NOW is omitted or |
| 320 | nil, the caller is responsible for making the settings take |
| 321 | effect later, by calling `custom-theme-recalc-face' or |
| 322 | `face-spec-recalc'. |
| 323 | |
| 324 | COMMENT is a string comment about FACE. |
| 325 | |
| 326 | This function works by calling `custom-push-theme' to record each |
| 327 | SPEC in each FACE's `theme-face' property, and in THEME's |
| 328 | `theme-settings' property. If FACE has not already been |
| 329 | customized, it also stores SPEC in the `saved-face' property. |
| 330 | |
| 331 | If THEME has a non-nil `theme-immediate' property, this is |
| 332 | equivalent to providing the NOW argument to all faces in the |
| 333 | argument list." |
| 334 | (custom-check-theme theme) |
| 335 | (let ((immediate (get theme 'theme-immediate))) |
| 336 | (dolist (entry args) |
| 337 | (unless (listp entry) |
| 338 | (error "Incompatible Custom theme spec")) |
| 339 | (let ((face (car entry)) |
| 340 | (spec (nth 1 entry))) |
| 341 | ;; If FACE is actually an alias, customize the face it |
| 342 | ;; is aliased to. |
| 343 | (if (get face 'face-alias) |
| 344 | (setq face (get face 'face-alias))) |
| 345 | (if custom--inhibit-theme-enable |
| 346 | ;; Just update theme settings. |
| 347 | (custom-push-theme 'theme-face face theme 'set spec) |
| 348 | ;; Update theme settings and set the face spec. |
| 349 | (let ((now (nth 2 entry)) |
| 350 | (comment (nth 3 entry)) |
| 351 | (oldspec (get face 'theme-face))) |
| 352 | (when (not (and oldspec (eq 'user (caar oldspec)))) |
| 353 | (put face 'saved-face spec) |
| 354 | (put face 'saved-face-comment comment)) |
| 355 | (custom-push-theme 'theme-face face theme 'set spec) |
| 356 | (when (or now immediate) |
| 357 | (put face 'force-face (if now 'rogue 'immediate))) |
| 358 | (when (or now immediate (facep face)) |
| 359 | (put face 'face-comment comment) |
| 360 | (face-spec-set face spec t)))))))) |
| 361 | |
| 362 | ;; XEmacs compatibility function. In XEmacs, when you reset a Custom |
| 363 | ;; Theme, you have to specify the theme to reset it to. We just apply |
| 364 | ;; the next theme. |
| 365 | (defun custom-theme-reset-faces (theme &rest args) |
| 366 | "Reset the specs in THEME of some faces to their specs in other themes. |
| 367 | Each of the arguments ARGS has this form: |
| 368 | |
| 369 | (FACE IGNORED) |
| 370 | |
| 371 | This means reset FACE. The argument IGNORED is ignored." |
| 372 | (custom-check-theme theme) |
| 373 | (dolist (arg args) |
| 374 | (custom-push-theme 'theme-face (car arg) theme 'reset))) |
| 375 | |
| 376 | (defun custom-reset-faces (&rest args) |
| 377 | "Reset the specs of some faces to their specs in specified themes. |
| 378 | This creates settings in the `user' theme. |
| 379 | |
| 380 | Each of the arguments ARGS has this form: |
| 381 | |
| 382 | (FACE FROM-THEME) |
| 383 | |
| 384 | This means reset FACE to its value in FROM-THEME." |
| 385 | (apply 'custom-theme-reset-faces 'user args)) |
| 386 | |
| 387 | ;;; The End. |
| 388 | |
| 389 | (provide 'cus-face) |
| 390 | |
| 391 | ;;; cus-face.el ends here |