lisp/cus-face.el

   1 ;;; cus-face.el --- customization support for faces
   2 ;;
   3 ;; Copyright (C) 1996-1997, 1999-2012 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              (list :tag "On"
 139                    :value (:color foreground-color :style line)
 140                    (const :format "" :value :color)
 141                    (choice :tag "Color"
 142                            (const :tag "Foreground Color" foreground-color)
 143                            color)
 144                    (const :format "" :value :style)
 145                    (choice :tag "Style"
 146                            (const :tag "Line" line)
 147                            (const :tag "Wave" wave))))
 148      ;; filter to make value suitable for customize
 149      (lambda (real-value)
 150        (and real-value
 151             (let ((color
 152                    (or (and (consp real-value) (plist-get real-value :color))
 153                        (and (stringp real-value) real-value)
 154                        'foreground-color))
 155                   (style
 156                    (or (and (consp real-value) (plist-get real-value :style))
 157                        'line)))
 158               (list :color color :style style))))
 159      ;; filter to make customized-value suitable for storing
 160      (lambda (cus-value)
 161        (and cus-value
 162             (let ((color (plist-get cus-value :color))
 163                   (style (plist-get cus-value :style)))
 164               (cond ((eq style 'line)
 165                      ;; Use simple value for default style
 166                      (if (eq color 'foreground-color) t color))
 167                     (t
 168                      `(:color ,color :style ,style)))))))
 169
 170     (:overline
 171      (choice :tag "Overline"
 172              :help-echo "Control text overlining."
 173              (const :tag "Off" nil)
 174              (const :tag "On" t)
 175              (color :tag "Colored")))
 176
 177     (:strike-through
 178      (choice :tag "Strike-through"
 179              :help-echo "Control text strike-through."
 180              (const :tag "Off" nil)
 181              (const :tag "On" t)
 182              (color :tag "Colored")))
 183
 184     (:box
 185      ;; Fixme: this can probably be done better.
 186      (choice :tag "Box around text"
 187              :help-echo "Control box around text."
 188              (const :tag "Off" nil)
 189              (list :tag "Box"
 190                    :value (:line-width 2 :color "grey75" :style released-button)
 191                    (const :format "" :value :line-width)
 192                    (integer :tag "Width")
 193                    (const :format "" :value :color)
 194                    (choice :tag "Color" (const :tag "*" nil) color)
 195                    (const :format "" :value :style)
 196                    (choice :tag "Style"
 197                            (const :tag "Raised" released-button)
 198                            (const :tag "Sunken" pressed-button)
 199                            (const :tag "None" nil))))
 200      ;; filter to make value suitable for customize
 201      (lambda (real-value)
 202        (and real-value
 203             (let ((lwidth
 204                    (or (and (consp real-value)
 205                             (plist-get real-value :line-width))
 206                        (and (integerp real-value) real-value)
 207                        1))
 208                   (color
 209                    (or (and (consp real-value) (plist-get real-value :color))
 210                        (and (stringp real-value) real-value)
 211                        nil))
 212                   (style
 213                    (and (consp real-value) (plist-get real-value :style))))
 214               (list :line-width lwidth :color color :style style))))
 215      ;; filter to make customized-value suitable for storing
 216      (lambda (cus-value)
 217        (and cus-value
 218             (let ((lwidth (plist-get cus-value :line-width))
 219                   (color (plist-get cus-value :color))
 220                   (style (plist-get cus-value :style)))
 221               (cond ((and (null color) (null style))
 222                      lwidth)
 223                     ((and (null lwidth) (null style))
 224                      ;; actually can't happen, because LWIDTH is always an int
 225                      color)
 226                     (t
 227                      ;; Keep as a plist, but remove null entries
 228                      (nconc (and lwidth `(:line-width ,lwidth))
 229                             (and color  `(:color ,color))
 230                             (and style  `(:style ,style)))))))))
 231
 232     (:inverse-video
 233      (choice :tag "Inverse-video"
 234              :help-echo "Control whether text should be in inverse-video."
 235              (const :tag "Off" nil)
 236              (const :tag "On" t)))
 237
 238     (:foreground
 239      (color :tag "Foreground"
 240             :help-echo "Set foreground color (name or #RRGGBB hex spec)."))
 241
 242     (:background
 243      (color :tag "Background"
 244             :help-echo "Set background color (name or #RRGGBB hex spec)."))
 245
 246     (:stipple
 247      (choice :tag "Stipple"
 248              :help-echo "Background bit-mask"
 249              (const :tag "None" nil)
 250              (file :tag "File"
 251                    :help-echo "Name of bitmap file."
 252                    :must-match t)))
 253
 254     (:inherit
 255      (repeat :tag "Inherit"
 256              :help-echo "List of faces to inherit attributes from."
 257              (face :Tag "Face" default))
 258      ;; filter to make value suitable for customize
 259      (lambda (real-value)
 260        (cond ((or (null real-value) (eq real-value 'unspecified))
 261               nil)
 262              ((symbolp real-value)
 263               (list real-value))
 264              (t
 265               real-value)))
 266      ;; filter to make customized-value suitable for storing
 267      (lambda (cus-value)
 268        (if (and (consp cus-value) (null (cdr cus-value)))
 269            (car cus-value)
 270          cus-value))))
 271
 272   "Alist of face attributes.
 273
 274 The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER),
 275 where KEY is the name of the attribute, TYPE is a widget type for
 276 editing the attribute, PRE-FILTER is a function to make the attribute's
 277 value suitable for the customization widget, and POST-FILTER is a
 278 function to make the customized value suitable for storing.  PRE-FILTER
 279 and POST-FILTER are optional.
 280
 281 The PRE-FILTER should take a single argument, the attribute value as
 282 stored, and should return a value for customization (using the
 283 customization type TYPE).
 284
 285 The POST-FILTER should also take a single argument, the value after
 286 being customized, and should return a value suitable for setting the
 287 given face attribute.")
 288
 289 (defun custom-face-attributes-get (face frame)
 290   "For FACE on FRAME, return an alternating list describing its attributes.
 291 The list has the form (KEYWORD VALUE KEYWORD VALUE...).
 292 Each keyword should be listed in `custom-face-attributes'.
 293
 294 If FRAME is nil, use the global defaults for FACE."
 295   (let ((attrs custom-face-attributes)
 296         plist)
 297     (while attrs
 298       (let* ((attribute (car (car attrs)))
 299              (value (face-attribute face attribute frame)))
 300         (setq attrs (cdr attrs))
 301         (unless (or (eq value 'unspecified)
 302                     (and (null value) (memq attribute '(:inherit))))
 303           (setq plist (cons attribute (cons value plist))))))
 304     plist))
 305
 306 ;;; Initializing.
 307
 308 (defun custom-set-faces (&rest args)
 309   "Initialize faces according to user preferences.
 310 This associates the settings with the `user' theme.
 311 The arguments should be a list where each entry has the form:
 312
 313   (FACE SPEC [NOW [COMMENT]])
 314
 315 SPEC is stored as the saved value for FACE, as well as the value for the
 316 `user' theme.  The `user' theme is one of the default themes known to Emacs.
 317 See `custom-known-themes' for more information on the known themes.
 318 See `custom-theme-set-faces' for more information on the interplay
 319 between themes and faces.
 320 See `defface' for the format of SPEC.
 321
 322 If NOW is present and non-nil, FACE is created now, according to SPEC.
 323 COMMENT is a string comment about FACE."
 324   (apply 'custom-theme-set-faces 'user args))
 325
 326 (defun custom-theme-set-faces (theme &rest args)
 327   "Initialize faces for theme THEME.
 328 The arguments should be a list where each entry has the form:
 329
 330   (FACE SPEC [NOW [COMMENT]])
 331
 332 SPEC is stored as the saved value for FACE, as well as the value for the
 333 `user' theme.  The `user' theme is one of the default themes known to Emacs.
 334 See `custom-known-themes' for more information on the known themes.
 335 See `custom-theme-set-faces' for more information on the interplay
 336 between themes and faces.
 337 See `defface' for the format of SPEC.
 338
 339 If NOW is present and non-nil, FACE is created now, according to SPEC.
 340 COMMENT is a string comment about FACE.
 341
 342 Several properties of THEME and FACE are used in the process:
 343
 344 If THEME property `theme-immediate' is non-nil, this is equivalent of
 345 providing the NOW argument to all faces in the argument list: FACE is
 346 created now.  The only difference is FACE property `force-face': if NOW
 347 is non-nil, FACE property `force-face' is set to the symbol `rogue', else
 348 if THEME property `theme-immediate' is non-nil, FACE property `force-face'
 349 is set to the symbol `immediate'.
 350
 351 SPEC itself is saved in FACE property `saved-face' and it is stored in
 352 FACE's list property `theme-face' \(using `custom-push-theme')."
 353   (custom-check-theme theme)
 354   (let ((immediate (get theme 'theme-immediate)))
 355     (dolist (entry args)
 356       (unless (listp entry)
 357         (error "Incompatible Custom theme spec"))
 358       (let ((face (car entry))
 359             (spec (nth 1 entry)))
 360         ;; If FACE is actually an alias, customize the face it
 361         ;; is aliased to.
 362         (if (get face 'face-alias)
 363             (setq face (get face 'face-alias)))
 364         (if custom--inhibit-theme-enable
 365             ;; Just update theme settings.
 366             (custom-push-theme 'theme-face face theme 'set spec)
 367           ;; Update theme settings and set the face spec.
 368           (let ((now (nth 2 entry))
 369                 (comment (nth 3 entry))
 370                 (oldspec (get face 'theme-face)))
 371             (when (not (and oldspec (eq 'user (caar oldspec))))
 372               (put face 'saved-face spec)
 373               (put face 'saved-face-comment comment))
 374             ;; Do this AFTER checking the `theme-face' property.
 375             (custom-push-theme 'theme-face face theme 'set spec)
 376             (when (or now immediate)
 377               (put face 'force-face (if now 'rogue 'immediate)))
 378             (when (or now immediate (facep face))
 379               (unless (facep face)
 380                 (make-empty-face face))
 381               (put face 'face-comment comment)
 382               (put face 'face-override-spec nil)
 383               (face-spec-set face spec t))))))))
 384
 385 ;; XEmacs compatibility function.  In XEmacs, when you reset a Custom
 386 ;; Theme, you have to specify the theme to reset it to.  We just apply
 387 ;; the next theme.
 388 (defun custom-theme-reset-faces (theme &rest args)
 389   "Reset the specs in THEME of some faces to their specs in other themes.
 390 Each of the arguments ARGS has this form:
 391
 392     (FACE IGNORED)
 393
 394 This means reset FACE.  The argument IGNORED is ignored."
 395   (custom-check-theme theme)
 396   (dolist (arg args)
 397     (custom-push-theme 'theme-face (car arg) theme 'reset)))
 398
 399 (defun custom-reset-faces (&rest args)
 400   "Reset the specs of some faces to their specs in specified themes.
 401 This creates settings in the `user' theme.
 402
 403 Each of the arguments ARGS has this form:
 404
 405     (FACE FROM-THEME)
 406
 407 This means reset FACE to its value in FROM-THEME."
 408   (apply 'custom-theme-reset-faces 'user args))
 409
 410 ;;; The End.
 411
 412 (provide 'cus-face)
 413
 414 ;;; cus-face.el ends here