cus-face.el 12.9 KB
Newer Older
1
;;; cus-face.el --- customization support for faces
Per Abrahamsen's avatar
Per Abrahamsen committed
2
;;
3
;; Copyright (C) 1996-1997, 1999-2014 Free Software Foundation, Inc.
Per Abrahamsen's avatar
Per Abrahamsen committed
4 5 6
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
7
;; Package: emacs
Per Abrahamsen's avatar
Per Abrahamsen committed
8

9
;; This file is part of GNU Emacs.
Per Abrahamsen's avatar
Per Abrahamsen committed
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 14
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Per Abrahamsen's avatar
Per Abrahamsen committed
15

16 17 18 19
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
Per Abrahamsen's avatar
Per Abrahamsen committed
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/>.
Per Abrahamsen's avatar
Per Abrahamsen committed
23

24 25 26
;;; Commentary:
;;
;; See `custom.el'.
Per Abrahamsen's avatar
Per Abrahamsen committed
27

28
;;; Code:
Per Abrahamsen's avatar
Per Abrahamsen committed
29

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
30
(defalias 'custom-facep 'facep)
31

Per Abrahamsen's avatar
Per Abrahamsen committed
32 33 34
;;; Declaring a face.

(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 38 39 40 41 42
    (face-spec-set face (purecopy spec) 'face-defface-spec)
    (push (cons 'defface face) current-load-list)
    (when doc
      (set-face-documentation face (purecopy doc)))
    (custom-handle-all-keywords face args 'custom-face)
    (run-hooks 'custom-define-hook))
Per Abrahamsen's avatar
Per Abrahamsen committed
43 44
  face)

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
45 46
;;; Face attributes.

Per Abrahamsen's avatar
Per Abrahamsen committed
47
(defconst custom-face-attributes
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
48
  '((:family
49 50
     (string :tag "Font Family"
	     :help-echo "Font family or fontset alias name."))
51

52 53 54 55
    (:foundry
     (string :tag "Font Foundry"
	     :help-echo "Font foundry name."))

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
56 57 58
    (:width
     (choice :tag "Width"
	     :help-echo "Font width."
59
	     :value normal		; default
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
60 61 62 63 64 65 66 67 68 69 70 71 72 73
	     (const :tag "compressed" condensed)
	     (const :tag "condensed" condensed)
	     (const :tag "demiexpanded" semi-expanded)
	     (const :tag "expanded" expanded)
	     (const :tag "extracondensed" extra-condensed)
	     (const :tag "extraexpanded" extra-expanded)
	     (const :tag "medium" normal)
	     (const :tag "narrow" condensed)
	     (const :tag "normal" normal)
	     (const :tag "regular" normal)
	     (const :tag "semicondensed" semi-condensed)
	     (const :tag "semiexpanded" semi-expanded)
	     (const :tag "ultracondensed" ultra-condensed)
	     (const :tag "ultraexpanded" ultra-expanded)
74
	     (const :tag "wide" extra-expanded)))
75

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
76 77 78
    (:height
     (choice :tag "Height"
	     :help-echo "Face's font height."
79
	     :value 1.0			; default
Miles Bader's avatar
Miles Bader committed
80
	     (integer :tag "Height in 1/10 pt")
81
	     (number :tag "Scale" 1.0)))
Miles Bader's avatar
Miles Bader committed
82

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
83 84 85
    (:weight
     (choice :tag "Weight"
	     :help-echo "Font weight."
86
	     :value normal		; default
87
	     (const :tag "black" ultra-bold)
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
88 89 90 91 92 93 94 95 96 97 98 99 100
	     (const :tag "bold" bold)
	     (const :tag "book" semi-light)
	     (const :tag "demibold" semi-bold)
	     (const :tag "extralight" extra-light)
	     (const :tag "extrabold" extra-bold)
	     (const :tag "heavy" extra-bold)
	     (const :tag "light" light)
	     (const :tag "medium" normal)
	     (const :tag "normal" normal)
	     (const :tag "regular" normal)
	     (const :tag "semibold" semi-bold)
	     (const :tag "semilight" semi-light)
	     (const :tag "ultralight" ultra-light)
101 102
	     (const :tag "ultrabold" ultra-bold)
	     (const :tag "thin" thin)))
103

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
104 105 106
    (:slant
     (choice :tag "Slant"
	     :help-echo "Font slant."
107
	     :value normal		; default
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
108 109
	     (const :tag "italic" italic)
	     (const :tag "oblique" oblique)
110 111
	     (const :tag "normal" normal)
	     (const :tag "roman" roman)))
112

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
113 114 115
    (:underline
     (choice :tag "Underline"
	     :help-echo "Control text underlining."
116
	     (const :tag "Off" nil)
117
	     (list :tag "On"
Andreas Schwab's avatar
Andreas Schwab committed
118
		   :value (:color foreground-color :style line)
119
		   (const :format "" :value :color)
Andreas Schwab's avatar
Andreas Schwab committed
120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
		   (choice :tag "Color"
			   (const :tag "Foreground Color" foreground-color)
			   color)
		   (const :format "" :value :style)
		   (choice :tag "Style"
			   (const :tag "Line" line)
			   (const :tag "Wave" wave))))
     ;; filter to make value suitable for customize
     (lambda (real-value)
       (and real-value
	    (let ((color
		   (or (and (consp real-value) (plist-get real-value :color))
		       (and (stringp real-value) real-value)
		       'foreground-color))
		  (style
		   (or (and (consp real-value) (plist-get real-value :style))
		       'line)))
	      (list :color color :style style))))
     ;; filter to make customized-value suitable for storing
     (lambda (cus-value)
       (and cus-value
	    (let ((color (plist-get cus-value :color))
		  (style (plist-get cus-value :style)))
	      (cond ((eq style 'line)
		     ;; Use simple value for default style
		     (if (eq color 'foreground-color) t color))
		    (t
		     `(:color ,color :style ,style)))))))
148

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
149 150 151
    (:overline
     (choice :tag "Overline"
	     :help-echo "Control text overlining."
152
	     (const :tag "Off" nil)
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
153
	     (const :tag "On" t)
154
	     (color :tag "Colored")))
155

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
156 157 158
    (:strike-through
     (choice :tag "Strike-through"
	     :help-echo "Control text strike-through."
159
	     (const :tag "Off" nil)
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
160
	     (const :tag "On" t)
161
	     (color :tag "Colored")))
162

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
163
    (:box
164
     ;; Fixme: this can probably be done better.
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
165 166
     (choice :tag "Box around text"
	     :help-echo "Control box around text."
167
	     (const :tag "Off" nil)
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
168
	     (list :tag "Box"
169
		   :value (:line-width 2 :color "grey75" :style released-button)
170
		   (const :format "" :value :line-width)
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
171
		   (integer :tag "Width")
172 173 174 175 176 177 178
		   (const :format "" :value :color)
		   (choice :tag "Color" (const :tag "*" nil) color)
		   (const :format "" :value :style)
		   (choice :tag "Style"
			   (const :tag "Raised" released-button)
			   (const :tag "Sunken" pressed-button)
			   (const :tag "None" nil))))
179 180
     ;; filter to make value suitable for customize
     (lambda (real-value)
181 182 183 184 185 186 187 188 189 190 191 192 193
       (and real-value
	    (let ((lwidth
		   (or (and (consp real-value)
			    (plist-get real-value :line-width))
		       (and (integerp real-value) real-value)
		       1))
		  (color
		   (or (and (consp real-value) (plist-get real-value :color))
		       (and (stringp real-value) real-value)
		       nil))
		  (style
		   (and (consp real-value) (plist-get real-value :style))))
	      (list :line-width lwidth :color color :style style))))
194 195
     ;; filter to make customized-value suitable for storing
     (lambda (cus-value)
196 197 198 199 200 201 202 203 204 205 206 207 208 209
       (and cus-value
	    (let ((lwidth (plist-get cus-value :line-width))
		  (color (plist-get cus-value :color))
		  (style (plist-get cus-value :style)))
	      (cond ((and (null color) (null style))
		     lwidth)
		    ((and (null lwidth) (null style))
		     ;; actually can't happen, because LWIDTH is always an int
		     color)
		    (t
		     ;; Keep as a plist, but remove null entries
		     (nconc (and lwidth `(:line-width ,lwidth))
			    (and color  `(:color ,color))
			    (and style  `(:style ,style)))))))))
210

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
211 212 213
    (:inverse-video
     (choice :tag "Inverse-video"
	     :help-echo "Control whether text should be in inverse-video."
214 215
	     (const :tag "Off" nil)
	     (const :tag "On" t)))
216

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
217
    (:foreground
218
     (color :tag "Foreground"
219
	    :help-echo "Set foreground color (name or #RRGGBB hex spec)."))
220

221 222 223 224
    (:distant-foreground
     (color :tag "Distant Foreground"
	    :help-echo "Set distant foreground color (name or #RRGGBB hex spec)."))

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
225
    (:background
226
     (color :tag "Background"
227
	    :help-echo "Set background color (name or #RRGGBB hex spec)."))
228

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
229 230
    (:stipple
     (choice :tag "Stipple"
231
	     :help-echo "Background bit-mask"
232
	     (const :tag "None" nil)
233 234 235
	     (file :tag "File"
		   :help-echo "Name of bitmap file."
		   :must-match t)))
Miles Bader's avatar
Miles Bader committed
236 237 238 239 240

    (:inherit
     (repeat :tag "Inherit"
	     :help-echo "List of faces to inherit attributes from."
	     (face :Tag "Face" default))
241 242 243 244 245 246 247 248 249 250 251 252 253
     ;; filter to make value suitable for customize
     (lambda (real-value)
       (cond ((or (null real-value) (eq real-value 'unspecified))
	      nil)
	     ((symbolp real-value)
	      (list real-value))
	     (t
	      real-value)))
     ;; filter to make customized-value suitable for storing
     (lambda (cus-value)
       (if (and (consp cus-value) (null (cdr cus-value)))
	   (car cus-value)
	 cus-value))))
254

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
255 256
  "Alist of face attributes.

257 258 259 260 261 262
The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER),
where KEY is the name of the attribute, TYPE is a widget type for
editing the attribute, PRE-FILTER is a function to make the attribute's
value suitable for the customization widget, and POST-FILTER is a
function to make the customized value suitable for storing.  PRE-FILTER
and POST-FILTER are optional.
Per Abrahamsen's avatar
Per Abrahamsen committed
263

264 265 266
The PRE-FILTER should take a single argument, the attribute value as
stored, and should return a value for customization (using the
customization type TYPE).
Per Abrahamsen's avatar
Per Abrahamsen committed
267

268 269 270
The POST-FILTER should also take a single argument, the value after
being customized, and should return a value suitable for setting the
given face attribute.")
Per Abrahamsen's avatar
Per Abrahamsen committed
271 272

(defun custom-face-attributes-get (face frame)
273 274
  "For FACE on FRAME, return an alternating list describing its attributes.
The list has the form (KEYWORD VALUE KEYWORD VALUE...).
Per Abrahamsen's avatar
Per Abrahamsen committed
275 276
Each keyword should be listed in `custom-face-attributes'.

277
If FRAME is nil, use the global defaults for FACE."
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
278 279 280 281 282 283
  (let ((attrs custom-face-attributes)
	plist)
    (while attrs
      (let* ((attribute (car (car attrs)))
	     (value (face-attribute face attribute frame)))
	(setq attrs (cdr attrs))
Miles Bader's avatar
Miles Bader committed
284 285
	(unless (or (eq value 'unspecified)
		    (and (null value) (memq attribute '(:inherit))))
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
286 287
	  (setq plist (cons attribute (cons value plist))))))
    plist))
Per Abrahamsen's avatar
Per Abrahamsen committed
288 289 290 291

;;; Initializing.

(defun custom-set-faces (&rest args)
Chong Yidong's avatar
Chong Yidong committed
292 293 294
  "Apply a list of face specs for user customizations.
This works by calling `custom-theme-set-faces' for the `user'
theme, a special theme referring to settings made via Customize.
295 296 297 298
The arguments should be a list where each entry has the form:

  (FACE SPEC [NOW [COMMENT]])

Chong Yidong's avatar
Chong Yidong committed
299
See the documentation of `custom-theme-set-faces' for details."
300 301 302
  (apply 'custom-theme-set-faces 'user args))

(defun custom-theme-set-faces (theme &rest args)
Chong Yidong's avatar
Chong Yidong committed
303 304 305 306 307 308
  "Apply a list of face specs associated with theme THEME.
THEME should be a theme name (a symbol).  The special theme named
`user' refers to user settings applied via Customize.

The remaining ARGS should be a list where each entry is a list of
the form:
Per Abrahamsen's avatar
Per Abrahamsen committed
309

310
  (FACE SPEC [NOW [COMMENT]])
Per Abrahamsen's avatar
Per Abrahamsen committed
311

Chong Yidong's avatar
Chong Yidong committed
312 313
FACE should be a face name (a symbol).  If FACE is a face alias,
the setting refers to the parent face.
314

Chong Yidong's avatar
Chong Yidong committed
315 316 317 318 319 320 321 322
SPEC should be a face spec.  For details, see `defface'.

NOW, if present and non-nil, forces the face settings to take
immediate effect in the Emacs display; in particular, FACE is
initialized as a face if it is not yet one.  If NOW is omitted or
nil, the caller is responsible for making the settings take
effect later, by calling `custom-theme-recalc-face' or
`face-spec-recalc'.
Per Abrahamsen's avatar
Per Abrahamsen committed
323

Chong Yidong's avatar
Chong Yidong committed
324
COMMENT is a string comment about FACE.
325

Chong Yidong's avatar
Chong Yidong committed
326 327 328 329
This function works by calling `custom-push-theme' to record each
SPEC in each FACE's `theme-face' property, and in THEME's
`theme-settings' property.  If FACE has not already been
customized, it also stores SPEC in the `saved-face' property.
330

Chong Yidong's avatar
Chong Yidong committed
331 332 333
If THEME has a non-nil `theme-immediate' property, this is
equivalent to providing the NOW argument to all faces in the
argument list."
334 335
  (custom-check-theme theme)
  (let ((immediate (get theme 'theme-immediate)))
336 337 338 339 340 341 342 343 344
    (dolist (entry args)
      (unless (listp entry)
	(error "Incompatible Custom theme spec"))
      (let ((face (car entry))
	    (spec (nth 1 entry)))
	;; If FACE is actually an alias, customize the face it
	;; is aliased to.
	(if (get face 'face-alias)
	    (setq face (get face 'face-alias)))
345 346 347 348
	(if custom--inhibit-theme-enable
	    ;; Just update theme settings.
	    (custom-push-theme 'theme-face face theme 'set spec)
	  ;; Update theme settings and set the face spec.
349 350 351 352 353 354
	  (let ((now (nth 2 entry))
		(comment (nth 3 entry))
		(oldspec (get face 'theme-face)))
	    (when (not (and oldspec (eq 'user (caar oldspec))))
	      (put face 'saved-face spec)
	      (put face 'saved-face-comment comment))
355
	    (custom-push-theme 'theme-face face theme 'set spec)
356 357 358 359 360
	    (when (or now immediate)
	      (put face 'force-face (if now 'rogue 'immediate)))
	    (when (or now immediate (facep face))
	      (put face 'face-comment comment)
	      (face-spec-set face spec t))))))))
361

Juanma Barranquero's avatar
Juanma Barranquero committed
362
;; XEmacs compatibility function.  In XEmacs, when you reset a Custom
363 364
;; Theme, you have to specify the theme to reset it to.  We just apply
;; the next theme.
365
(defun custom-theme-reset-faces (theme &rest args)
366 367
  "Reset the specs in THEME of some faces to their specs in other themes.
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 378 379 380 381 382
  "Reset the specs of some faces to their specs in specified themes.
This creates settings in the `user' theme.

Each of the arguments ARGS has this form:

    (FACE FROM-THEME)
383

384
This means reset FACE to its value in FROM-THEME."
385
  (apply 'custom-theme-reset-faces 'user args))
Per Abrahamsen's avatar
Per Abrahamsen committed
386 387 388 389 390

;;; The End.

(provide 'cus-face)

391
;;; cus-face.el ends here