lisp/cus-face.el

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