| 1 | ;;; cus-face.el --- customization support for faces |
| 2 | ;; |
| 3 | ;; Copyright (C) 1996-1997, 1999-2011 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 FACE is evaluated as a normal argument." |
| 36 | (unless (get face 'face-defface-spec) |
| 37 | (let ((facep (facep face))) |
| 38 | (unless facep |
| 39 | ;; If the user has already created the face, respect that. |
| 40 | (let ((value (or (get face 'saved-face) spec)) |
| 41 | (have-window-system (memq initial-window-system '(x w32)))) |
| 42 | ;; Create global face. |
| 43 | (make-empty-face face) |
| 44 | ;; Create frame-local faces |
| 45 | (dolist (frame (frame-list)) |
| 46 | (face-spec-set-2 face frame value) |
| 47 | (when (memq (window-system frame) '(x w32 ns)) |
| 48 | (setq have-window-system t))) |
| 49 | ;; When making a face after frames already exist |
| 50 | (if have-window-system |
| 51 | (make-face-x-resource-internal face)))) |
| 52 | ;; Don't record SPEC until we see it causes no errors. |
| 53 | (put face 'face-defface-spec (purecopy spec)) |
| 54 | (push (cons 'defface face) current-load-list) |
| 55 | (when (and doc (null (face-documentation face))) |
| 56 | (set-face-documentation face (purecopy doc))) |
| 57 | (custom-handle-all-keywords face args 'custom-face) |
| 58 | (run-hooks 'custom-define-hook) |
| 59 | ;; If the face had existing settings, recalculate it. For |
| 60 | ;; example, the user might load a theme with a face setting, and |
| 61 | ;; later load a library defining that face. |
| 62 | (if facep |
| 63 | (custom-theme-recalc-face face)))) |
| 64 | face) |
| 65 | |
| 66 | ;;; Face attributes. |
| 67 | |
| 68 | (defconst custom-face-attributes |
| 69 | '((:family |
| 70 | (string :tag "Font Family" |
| 71 | :help-echo "Font family or fontset alias name.")) |
| 72 | |
| 73 | (:foundry |
| 74 | (string :tag "Font Foundry" |
| 75 | :help-echo "Font foundry name.")) |
| 76 | |
| 77 | (:width |
| 78 | (choice :tag "Width" |
| 79 | :help-echo "Font width." |
| 80 | :value normal ; default |
| 81 | (const :tag "compressed" condensed) |
| 82 | (const :tag "condensed" condensed) |
| 83 | (const :tag "demiexpanded" semi-expanded) |
| 84 | (const :tag "expanded" expanded) |
| 85 | (const :tag "extracondensed" extra-condensed) |
| 86 | (const :tag "extraexpanded" extra-expanded) |
| 87 | (const :tag "medium" normal) |
| 88 | (const :tag "narrow" condensed) |
| 89 | (const :tag "normal" normal) |
| 90 | (const :tag "regular" normal) |
| 91 | (const :tag "semicondensed" semi-condensed) |
| 92 | (const :tag "semiexpanded" semi-expanded) |
| 93 | (const :tag "ultracondensed" ultra-condensed) |
| 94 | (const :tag "ultraexpanded" ultra-expanded) |
| 95 | (const :tag "wide" extra-expanded))) |
| 96 | |
| 97 | (:height |
| 98 | (choice :tag "Height" |
| 99 | :help-echo "Face's font height." |
| 100 | :value 1.0 ; default |
| 101 | (integer :tag "Height in 1/10 pt") |
| 102 | (number :tag "Scale" 1.0))) |
| 103 | |
| 104 | (:weight |
| 105 | (choice :tag "Weight" |
| 106 | :help-echo "Font weight." |
| 107 | :value normal ; default |
| 108 | (const :tag "black" ultra-bold) |
| 109 | (const :tag "bold" bold) |
| 110 | (const :tag "book" semi-light) |
| 111 | (const :tag "demibold" semi-bold) |
| 112 | (const :tag "extralight" extra-light) |
| 113 | (const :tag "extrabold" extra-bold) |
| 114 | (const :tag "heavy" extra-bold) |
| 115 | (const :tag "light" light) |
| 116 | (const :tag "medium" normal) |
| 117 | (const :tag "normal" normal) |
| 118 | (const :tag "regular" normal) |
| 119 | (const :tag "semibold" semi-bold) |
| 120 | (const :tag "semilight" semi-light) |
| 121 | (const :tag "ultralight" ultra-light) |
| 122 | (const :tag "ultrabold" ultra-bold) |
| 123 | (const :tag "thin" thin))) |
| 124 | |
| 125 | (:slant |
| 126 | (choice :tag "Slant" |
| 127 | :help-echo "Font slant." |
| 128 | :value normal ; default |
| 129 | (const :tag "italic" italic) |
| 130 | (const :tag "oblique" oblique) |
| 131 | (const :tag "normal" normal) |
| 132 | (const :tag "roman" roman))) |
| 133 | |
| 134 | (:underline |
| 135 | (choice :tag "Underline" |
| 136 | :help-echo "Control text underlining." |
| 137 | (const :tag "Off" nil) |
| 138 | (const :tag "On" t) |
| 139 | (color :tag "Colored"))) |
| 140 | |
| 141 | (:overline |
| 142 | (choice :tag "Overline" |
| 143 | :help-echo "Control text overlining." |
| 144 | (const :tag "Off" nil) |
| 145 | (const :tag "On" t) |
| 146 | (color :tag "Colored"))) |
| 147 | |
| 148 | (:strike-through |
| 149 | (choice :tag "Strike-through" |
| 150 | :help-echo "Control text strike-through." |
| 151 | (const :tag "Off" nil) |
| 152 | (const :tag "On" t) |
| 153 | (color :tag "Colored"))) |
| 154 | |
| 155 | (:box |
| 156 | ;; Fixme: this can probably be done better. |
| 157 | (choice :tag "Box around text" |
| 158 | :help-echo "Control box around text." |
| 159 | (const :tag "Off" nil) |
| 160 | (list :tag "Box" |
| 161 | :value (:line-width 2 :color "grey75" :style released-button) |
| 162 | (const :format "" :value :line-width) |
| 163 | (integer :tag "Width") |
| 164 | (const :format "" :value :color) |
| 165 | (choice :tag "Color" (const :tag "*" nil) color) |
| 166 | (const :format "" :value :style) |
| 167 | (choice :tag "Style" |
| 168 | (const :tag "Raised" released-button) |
| 169 | (const :tag "Sunken" pressed-button) |
| 170 | (const :tag "None" nil)))) |
| 171 | ;; filter to make value suitable for customize |
| 172 | (lambda (real-value) |
| 173 | (and real-value |
| 174 | (let ((lwidth |
| 175 | (or (and (consp real-value) |
| 176 | (plist-get real-value :line-width)) |
| 177 | (and (integerp real-value) real-value) |
| 178 | 1)) |
| 179 | (color |
| 180 | (or (and (consp real-value) (plist-get real-value :color)) |
| 181 | (and (stringp real-value) real-value) |
| 182 | nil)) |
| 183 | (style |
| 184 | (and (consp real-value) (plist-get real-value :style)))) |
| 185 | (list :line-width lwidth :color color :style style)))) |
| 186 | ;; filter to make customized-value suitable for storing |
| 187 | (lambda (cus-value) |
| 188 | (and cus-value |
| 189 | (let ((lwidth (plist-get cus-value :line-width)) |
| 190 | (color (plist-get cus-value :color)) |
| 191 | (style (plist-get cus-value :style))) |
| 192 | (cond ((and (null color) (null style)) |
| 193 | lwidth) |
| 194 | ((and (null lwidth) (null style)) |
| 195 | ;; actually can't happen, because LWIDTH is always an int |
| 196 | color) |
| 197 | (t |
| 198 | ;; Keep as a plist, but remove null entries |
| 199 | (nconc (and lwidth `(:line-width ,lwidth)) |
| 200 | (and color `(:color ,color)) |
| 201 | (and style `(:style ,style))))))))) |
| 202 | |
| 203 | (:inverse-video |
| 204 | (choice :tag "Inverse-video" |
| 205 | :help-echo "Control whether text should be in inverse-video." |
| 206 | (const :tag "Off" nil) |
| 207 | (const :tag "On" t))) |
| 208 | |
| 209 | (:foreground |
| 210 | (color :tag "Foreground" |
| 211 | :help-echo "Set foreground color (name or #RRGGBB hex spec).")) |
| 212 | |
| 213 | (:background |
| 214 | (color :tag "Background" |
| 215 | :help-echo "Set background color (name or #RRGGBB hex spec).")) |
| 216 | |
| 217 | (:stipple |
| 218 | (choice :tag "Stipple" |
| 219 | :help-echo "Background bit-mask" |
| 220 | (const :tag "None" nil) |
| 221 | (file :tag "File" |
| 222 | :help-echo "Name of bitmap file." |
| 223 | :must-match t))) |
| 224 | |
| 225 | (:inherit |
| 226 | (repeat :tag "Inherit" |
| 227 | :help-echo "List of faces to inherit attributes from." |
| 228 | (face :Tag "Face" default)) |
| 229 | ;; filter to make value suitable for customize |
| 230 | (lambda (real-value) |
| 231 | (cond ((or (null real-value) (eq real-value 'unspecified)) |
| 232 | nil) |
| 233 | ((symbolp real-value) |
| 234 | (list real-value)) |
| 235 | (t |
| 236 | real-value))) |
| 237 | ;; filter to make customized-value suitable for storing |
| 238 | (lambda (cus-value) |
| 239 | (if (and (consp cus-value) (null (cdr cus-value))) |
| 240 | (car cus-value) |
| 241 | cus-value)))) |
| 242 | |
| 243 | "Alist of face attributes. |
| 244 | |
| 245 | The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER), |
| 246 | where KEY is the name of the attribute, TYPE is a widget type for |
| 247 | editing the attribute, PRE-FILTER is a function to make the attribute's |
| 248 | value suitable for the customization widget, and POST-FILTER is a |
| 249 | function to make the customized value suitable for storing. PRE-FILTER |
| 250 | and POST-FILTER are optional. |
| 251 | |
| 252 | The PRE-FILTER should take a single argument, the attribute value as |
| 253 | stored, and should return a value for customization (using the |
| 254 | customization type TYPE). |
| 255 | |
| 256 | The POST-FILTER should also take a single argument, the value after |
| 257 | being customized, and should return a value suitable for setting the |
| 258 | given face attribute.") |
| 259 | |
| 260 | (defun custom-face-attributes-get (face frame) |
| 261 | "For FACE on FRAME, return an alternating list describing its attributes. |
| 262 | The list has the form (KEYWORD VALUE KEYWORD VALUE...). |
| 263 | Each keyword should be listed in `custom-face-attributes'. |
| 264 | |
| 265 | If FRAME is nil, use the global defaults for FACE." |
| 266 | (let ((attrs custom-face-attributes) |
| 267 | plist) |
| 268 | (while attrs |
| 269 | (let* ((attribute (car (car attrs))) |
| 270 | (value (face-attribute face attribute frame))) |
| 271 | (setq attrs (cdr attrs)) |
| 272 | (unless (or (eq value 'unspecified) |
| 273 | (and (null value) (memq attribute '(:inherit)))) |
| 274 | (setq plist (cons attribute (cons value plist)))))) |
| 275 | plist)) |
| 276 | |
| 277 | ;;; Initializing. |
| 278 | |
| 279 | (defun custom-set-faces (&rest args) |
| 280 | "Initialize faces according to user preferences. |
| 281 | This associates the settings with the `user' theme. |
| 282 | The arguments should be a list where each entry has the form: |
| 283 | |
| 284 | (FACE SPEC [NOW [COMMENT]]) |
| 285 | |
| 286 | SPEC is stored as the saved value for FACE, as well as the value for the |
| 287 | `user' theme. The `user' theme is one of the default themes known to Emacs. |
| 288 | See `custom-known-themes' for more information on the known themes. |
| 289 | See `custom-theme-set-faces' for more information on the interplay |
| 290 | between themes and faces. |
| 291 | See `defface' for the format of SPEC. |
| 292 | |
| 293 | If NOW is present and non-nil, FACE is created now, according to SPEC. |
| 294 | COMMENT is a string comment about FACE." |
| 295 | (apply 'custom-theme-set-faces 'user args)) |
| 296 | |
| 297 | (defun custom-theme-set-faces (theme &rest args) |
| 298 | "Initialize faces for theme THEME. |
| 299 | The arguments should be a list where each entry has the form: |
| 300 | |
| 301 | (FACE SPEC [NOW [COMMENT]]) |
| 302 | |
| 303 | SPEC is stored as the saved value for FACE, as well as the value for the |
| 304 | `user' theme. The `user' theme is one of the default themes known to Emacs. |
| 305 | See `custom-known-themes' for more information on the known themes. |
| 306 | See `custom-theme-set-faces' for more information on the interplay |
| 307 | between themes and faces. |
| 308 | See `defface' for the format of SPEC. |
| 309 | |
| 310 | If NOW is present and non-nil, FACE is created now, according to SPEC. |
| 311 | COMMENT is a string comment about FACE. |
| 312 | |
| 313 | Several properties of THEME and FACE are used in the process: |
| 314 | |
| 315 | If THEME property `theme-immediate' is non-nil, this is equivalent of |
| 316 | providing the NOW argument to all faces in the argument list: FACE is |
| 317 | created now. The only difference is FACE property `force-face': if NOW |
| 318 | is non-nil, FACE property `force-face' is set to the symbol `rogue', else |
| 319 | if THEME property `theme-immediate' is non-nil, FACE property `force-face' |
| 320 | is set to the symbol `immediate'. |
| 321 | |
| 322 | SPEC itself is saved in FACE property `saved-face' and it is stored in |
| 323 | FACE's list property `theme-face' \(using `custom-push-theme')." |
| 324 | (custom-check-theme theme) |
| 325 | (let ((immediate (get theme 'theme-immediate))) |
| 326 | (dolist (entry args) |
| 327 | (unless (listp entry) |
| 328 | (error "Incompatible Custom theme spec")) |
| 329 | (let ((face (car entry)) |
| 330 | (spec (nth 1 entry))) |
| 331 | ;; If FACE is actually an alias, customize the face it |
| 332 | ;; is aliased to. |
| 333 | (if (get face 'face-alias) |
| 334 | (setq face (get face 'face-alias))) |
| 335 | (if custom--inhibit-theme-enable |
| 336 | ;; Just update theme settings. |
| 337 | (custom-push-theme 'theme-face face theme 'set spec) |
| 338 | ;; Update theme settings and set the face spec. |
| 339 | (let ((now (nth 2 entry)) |
| 340 | (comment (nth 3 entry)) |
| 341 | (oldspec (get face 'theme-face))) |
| 342 | (when (not (and oldspec (eq 'user (caar oldspec)))) |
| 343 | (put face 'saved-face spec) |
| 344 | (put face 'saved-face-comment comment)) |
| 345 | ;; Do this AFTER checking the `theme-face' property. |
| 346 | (custom-push-theme 'theme-face face theme 'set spec) |
| 347 | (when (or now immediate) |
| 348 | (put face 'force-face (if now 'rogue 'immediate))) |
| 349 | (when (or now immediate (facep face)) |
| 350 | (unless (facep face) |
| 351 | (make-empty-face face)) |
| 352 | (put face 'face-comment comment) |
| 353 | (put face 'face-override-spec nil) |
| 354 | (face-spec-set face spec t)))))))) |
| 355 | |
| 356 | ;; XEmacs compatibility function. In XEmacs, when you reset a Custom |
| 357 | ;; Theme, you have to specify the theme to reset it to. We just apply |
| 358 | ;; the next theme. |
| 359 | (defun custom-theme-reset-faces (theme &rest args) |
| 360 | "Reset the specs in THEME of some faces to their specs in other themes. |
| 361 | Each of the arguments ARGS has this form: |
| 362 | |
| 363 | (FACE IGNORED) |
| 364 | |
| 365 | This means reset FACE. The argument IGNORED is ignored." |
| 366 | (custom-check-theme theme) |
| 367 | (dolist (arg args) |
| 368 | (custom-push-theme 'theme-face (car arg) theme 'reset))) |
| 369 | |
| 370 | (defun custom-reset-faces (&rest args) |
| 371 | "Reset the specs of some faces to their specs in specified themes. |
| 372 | This creates settings in the `user' theme. |
| 373 | |
| 374 | Each of the arguments ARGS has this form: |
| 375 | |
| 376 | (FACE FROM-THEME) |
| 377 | |
| 378 | This means reset FACE to its value in FROM-THEME." |
| 379 | (apply 'custom-theme-reset-faces 'user args)) |
| 380 | |
| 381 | ;;; The End. |
| 382 | |
| 383 | (provide 'cus-face) |
| 384 | |
| 385 | ;;; cus-face.el ends here |