lisp/cus-face.el

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