Remove the build-time option CLASH_DETECTION
[bpt/emacs.git] / lisp / cus-face.el
CommitLineData
e8af40ee 1;;; cus-face.el --- customization support for faces
d543e20b 2;;
ba318903 3;; Copyright (C) 1996-1997, 1999-2014 Free Software Foundation, Inc.
d543e20b
PA
4;;
5;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
6;; Keywords: help, faces
bd78fa1d 7;; Package: emacs
d543e20b 8
6c283d44 9;; This file is part of GNU Emacs.
d543e20b 10
eb3fa2cf 11;; GNU Emacs is free software: you can redistribute it and/or modify
6c283d44 12;; it under the terms of the GNU General Public License as published by
eb3fa2cf
GM
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
d543e20b 15
6c283d44
RS
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.
d543e20b 20
6c283d44 21;; You should have received a copy of the GNU General Public License
eb3fa2cf 22;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
d543e20b 23
6c283d44
RS
24;;; Commentary:
25;;
26;; See `custom.el'.
d543e20b 27
6c283d44 28;;; Code:
d543e20b 29
da0b1f56 30(defalias 'custom-facep 'facep)
ccd0d40c 31
d543e20b
PA
32;;; Declaring a face.
33
d543e20b 34(defun custom-declare-face (face spec doc &rest args)
1c4f115d 35 "Like `defface', but with FACE evaluated as a normal argument."
6c283d44 36 (unless (get face 'face-defface-spec)
1c4f115d
CY
37 (face-spec-set face (purecopy spec) 'face-defface-spec)
38 (push (cons 'defface face) current-load-list)
39 (when doc
40 (set-face-documentation face (purecopy doc)))
41 (custom-handle-all-keywords face args 'custom-face)
42 (run-hooks 'custom-define-hook))
d543e20b
PA
43 face)
44
da0b1f56
GM
45;;; Face attributes.
46
d543e20b 47(defconst custom-face-attributes
da0b1f56 48 '((:family
c165ad40
MB
49 (string :tag "Font Family"
50 :help-echo "Font family or fontset alias name."))
a3997907 51
b8a9467c
KH
52 (:foundry
53 (string :tag "Font Foundry"
54 :help-echo "Font foundry name."))
55
da0b1f56
GM
56 (:width
57 (choice :tag "Width"
58 :help-echo "Font width."
c165ad40 59 :value normal ; default
da0b1f56
GM
60 (const :tag "compressed" condensed)
61 (const :tag "condensed" condensed)
62 (const :tag "demiexpanded" semi-expanded)
63 (const :tag "expanded" expanded)
64 (const :tag "extracondensed" extra-condensed)
65 (const :tag "extraexpanded" extra-expanded)
66 (const :tag "medium" normal)
67 (const :tag "narrow" condensed)
68 (const :tag "normal" normal)
69 (const :tag "regular" normal)
70 (const :tag "semicondensed" semi-condensed)
71 (const :tag "semiexpanded" semi-expanded)
72 (const :tag "ultracondensed" ultra-condensed)
73 (const :tag "ultraexpanded" ultra-expanded)
51a1edab 74 (const :tag "wide" extra-expanded)))
71296446 75
da0b1f56
GM
76 (:height
77 (choice :tag "Height"
78 :help-echo "Face's font height."
c165ad40 79 :value 1.0 ; default
6bca3005 80 (integer :tag "Height in 1/10 pt")
51a1edab 81 (number :tag "Scale" 1.0)))
6bca3005 82
da0b1f56
GM
83 (:weight
84 (choice :tag "Weight"
85 :help-echo "Font weight."
c165ad40 86 :value normal ; default
992f7c96 87 (const :tag "black" ultra-bold)
da0b1f56
GM
88 (const :tag "bold" bold)
89 (const :tag "book" semi-light)
90 (const :tag "demibold" semi-bold)
91 (const :tag "extralight" extra-light)
92 (const :tag "extrabold" extra-bold)
93 (const :tag "heavy" extra-bold)
94 (const :tag "light" light)
95 (const :tag "medium" normal)
96 (const :tag "normal" normal)
97 (const :tag "regular" normal)
98 (const :tag "semibold" semi-bold)
99 (const :tag "semilight" semi-light)
100 (const :tag "ultralight" ultra-light)
131b3b11
KH
101 (const :tag "ultrabold" ultra-bold)
102 (const :tag "thin" thin)))
71296446 103
da0b1f56
GM
104 (:slant
105 (choice :tag "Slant"
106 :help-echo "Font slant."
c165ad40 107 :value normal ; default
da0b1f56
GM
108 (const :tag "italic" italic)
109 (const :tag "oblique" oblique)
43240958
CY
110 (const :tag "normal" normal)
111 (const :tag "roman" roman)))
71296446 112
da0b1f56
GM
113 (:underline
114 (choice :tag "Underline"
115 :help-echo "Control text underlining."
c165ad40 116 (const :tag "Off" nil)
9b0e3eba 117 (list :tag "On"
c6cc78b8 118 :value (:color foreground-color :style line)
9b0e3eba 119 (const :format "" :value :color)
c6cc78b8
AS
120 (choice :tag "Color"
121 (const :tag "Foreground Color" foreground-color)
122 color)
123 (const :format "" :value :style)
124 (choice :tag "Style"
125 (const :tag "Line" line)
126 (const :tag "Wave" wave))))
127 ;; filter to make value suitable for customize
128 (lambda (real-value)
129 (and real-value
130 (let ((color
131 (or (and (consp real-value) (plist-get real-value :color))
132 (and (stringp real-value) real-value)
133 'foreground-color))
134 (style
135 (or (and (consp real-value) (plist-get real-value :style))
136 'line)))
137 (list :color color :style style))))
138 ;; filter to make customized-value suitable for storing
139 (lambda (cus-value)
140 (and cus-value
141 (let ((color (plist-get cus-value :color))
142 (style (plist-get cus-value :style)))
143 (cond ((eq style 'line)
144 ;; Use simple value for default style
145 (if (eq color 'foreground-color) t color))
146 (t
147 `(:color ,color :style ,style)))))))
71296446 148
da0b1f56
GM
149 (:overline
150 (choice :tag "Overline"
151 :help-echo "Control text overlining."
c165ad40 152 (const :tag "Off" nil)
da0b1f56 153 (const :tag "On" t)
51a1edab 154 (color :tag "Colored")))
71296446 155
da0b1f56
GM
156 (:strike-through
157 (choice :tag "Strike-through"
158 :help-echo "Control text strike-through."
c165ad40 159 (const :tag "Off" nil)
da0b1f56 160 (const :tag "On" t)
51a1edab 161 (color :tag "Colored")))
71296446 162
da0b1f56 163 (:box
1743c17a 164 ;; Fixme: this can probably be done better.
da0b1f56
GM
165 (choice :tag "Box around text"
166 :help-echo "Control box around text."
c165ad40 167 (const :tag "Off" nil)
da0b1f56 168 (list :tag "Box"
36b80a0d 169 :value (:line-width 2 :color "grey75" :style released-button)
1743c17a 170 (const :format "" :value :line-width)
da0b1f56 171 (integer :tag "Width")
1743c17a
DL
172 (const :format "" :value :color)
173 (choice :tag "Color" (const :tag "*" nil) color)
174 (const :format "" :value :style)
175 (choice :tag "Style"
176 (const :tag "Raised" released-button)
177 (const :tag "Sunken" pressed-button)
178 (const :tag "None" nil))))
51a1edab
MB
179 ;; filter to make value suitable for customize
180 (lambda (real-value)
c165ad40
MB
181 (and real-value
182 (let ((lwidth
183 (or (and (consp real-value)
184 (plist-get real-value :line-width))
185 (and (integerp real-value) real-value)
186 1))
187 (color
188 (or (and (consp real-value) (plist-get real-value :color))
189 (and (stringp real-value) real-value)
190 nil))
191 (style
192 (and (consp real-value) (plist-get real-value :style))))
193 (list :line-width lwidth :color color :style style))))
36b80a0d
MB
194 ;; filter to make customized-value suitable for storing
195 (lambda (cus-value)
c165ad40
MB
196 (and cus-value
197 (let ((lwidth (plist-get cus-value :line-width))
198 (color (plist-get cus-value :color))
199 (style (plist-get cus-value :style)))
200 (cond ((and (null color) (null style))
201 lwidth)
202 ((and (null lwidth) (null style))
203 ;; actually can't happen, because LWIDTH is always an int
204 color)
205 (t
206 ;; Keep as a plist, but remove null entries
207 (nconc (and lwidth `(:line-width ,lwidth))
208 (and color `(:color ,color))
209 (and style `(:style ,style)))))))))
71296446 210
da0b1f56
GM
211 (:inverse-video
212 (choice :tag "Inverse-video"
213 :help-echo "Control whether text should be in inverse-video."
c165ad40
MB
214 (const :tag "Off" nil)
215 (const :tag "On" t)))
71296446 216
da0b1f56 217 (:foreground
c165ad40 218 (color :tag "Foreground"
4bbe6176 219 :help-echo "Set foreground color (name or #RRGGBB hex spec)."))
71296446 220
da0b1f56 221 (:background
c165ad40 222 (color :tag "Background"
4bbe6176 223 :help-echo "Set background color (name or #RRGGBB hex spec)."))
71296446 224
da0b1f56
GM
225 (:stipple
226 (choice :tag "Stipple"
675f1fcb 227 :help-echo "Background bit-mask"
c165ad40 228 (const :tag "None" nil)
675f1fcb
MB
229 (file :tag "File"
230 :help-echo "Name of bitmap file."
231 :must-match t)))
6bca3005
MB
232
233 (:inherit
234 (repeat :tag "Inherit"
235 :help-echo "List of faces to inherit attributes from."
236 (face :Tag "Face" default))
51a1edab
MB
237 ;; filter to make value suitable for customize
238 (lambda (real-value)
239 (cond ((or (null real-value) (eq real-value 'unspecified))
240 nil)
241 ((symbolp real-value)
242 (list real-value))
243 (t
244 real-value)))
245 ;; filter to make customized-value suitable for storing
246 (lambda (cus-value)
247 (if (and (consp cus-value) (null (cdr cus-value)))
248 (car cus-value)
249 cus-value))))
71296446 250
da0b1f56
GM
251 "Alist of face attributes.
252
51a1edab
MB
253The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER),
254where KEY is the name of the attribute, TYPE is a widget type for
255editing the attribute, PRE-FILTER is a function to make the attribute's
256value suitable for the customization widget, and POST-FILTER is a
257function to make the customized value suitable for storing. PRE-FILTER
258and POST-FILTER are optional.
d543e20b 259
51a1edab
MB
260The PRE-FILTER should take a single argument, the attribute value as
261stored, and should return a value for customization (using the
262customization type TYPE).
d543e20b 263
51a1edab
MB
264The POST-FILTER should also take a single argument, the value after
265being customized, and should return a value suitable for setting the
266given face attribute.")
d543e20b
PA
267
268(defun custom-face-attributes-get (face frame)
6c283d44
RS
269 "For FACE on FRAME, return an alternating list describing its attributes.
270The list has the form (KEYWORD VALUE KEYWORD VALUE...).
d543e20b
PA
271Each keyword should be listed in `custom-face-attributes'.
272
6c283d44 273If FRAME is nil, use the global defaults for FACE."
da0b1f56
GM
274 (let ((attrs custom-face-attributes)
275 plist)
276 (while attrs
277 (let* ((attribute (car (car attrs)))
278 (value (face-attribute face attribute frame)))
279 (setq attrs (cdr attrs))
6bca3005
MB
280 (unless (or (eq value 'unspecified)
281 (and (null value) (memq attribute '(:inherit))))
da0b1f56
GM
282 (setq plist (cons attribute (cons value plist))))))
283 plist))
d543e20b 284
d543e20b
PA
285;;; Initializing.
286
d543e20b 287(defun custom-set-faces (&rest args)
bacb0e77
CY
288 "Apply a list of face specs for user customizations.
289This works by calling `custom-theme-set-faces' for the `user'
290theme, a special theme referring to settings made via Customize.
a3997907
RS
291The arguments should be a list where each entry has the form:
292
293 (FACE SPEC [NOW [COMMENT]])
294
bacb0e77 295See the documentation of `custom-theme-set-faces' for details."
a3997907
RS
296 (apply 'custom-theme-set-faces 'user args))
297
298(defun custom-theme-set-faces (theme &rest args)
bacb0e77
CY
299 "Apply a list of face specs associated with theme THEME.
300THEME should be a theme name (a symbol). The special theme named
301`user' refers to user settings applied via Customize.
302
303The remaining ARGS should be a list where each entry is a list of
304the form:
d543e20b 305
1743c17a 306 (FACE SPEC [NOW [COMMENT]])
d543e20b 307
bacb0e77
CY
308FACE should be a face name (a symbol). If FACE is a face alias,
309the setting refers to the parent face.
a3997907 310
bacb0e77
CY
311SPEC should be a face spec. For details, see `defface'.
312
313NOW, if present and non-nil, forces the face settings to take
314immediate effect in the Emacs display; in particular, FACE is
315initialized as a face if it is not yet one. If NOW is omitted or
316nil, the caller is responsible for making the settings take
317effect later, by calling `custom-theme-recalc-face' or
318`face-spec-recalc'.
d543e20b 319
bacb0e77 320COMMENT is a string comment about FACE.
a3997907 321
bacb0e77
CY
322This function works by calling `custom-push-theme' to record each
323SPEC in each FACE's `theme-face' property, and in THEME's
324`theme-settings' property. If FACE has not already been
325customized, it also stores SPEC in the `saved-face' property.
a3997907 326
bacb0e77
CY
327If THEME has a non-nil `theme-immediate' property, this is
328equivalent to providing the NOW argument to all faces in the
329argument list."
a3997907
RS
330 (custom-check-theme theme)
331 (let ((immediate (get theme 'theme-immediate)))
6b09b5d1
CY
332 (dolist (entry args)
333 (unless (listp entry)
334 (error "Incompatible Custom theme spec"))
335 (let ((face (car entry))
336 (spec (nth 1 entry)))
337 ;; If FACE is actually an alias, customize the face it
338 ;; is aliased to.
339 (if (get face 'face-alias)
340 (setq face (get face 'face-alias)))
de43f11b
CY
341 (if custom--inhibit-theme-enable
342 ;; Just update theme settings.
343 (custom-push-theme 'theme-face face theme 'set spec)
344 ;; Update theme settings and set the face spec.
6b09b5d1
CY
345 (let ((now (nth 2 entry))
346 (comment (nth 3 entry))
347 (oldspec (get face 'theme-face)))
348 (when (not (and oldspec (eq 'user (caar oldspec))))
349 (put face 'saved-face spec)
350 (put face 'saved-face-comment comment))
de43f11b 351 (custom-push-theme 'theme-face face theme 'set spec)
6b09b5d1
CY
352 (when (or now immediate)
353 (put face 'force-face (if now 'rogue 'immediate)))
354 (when (or now immediate (facep face))
6b09b5d1 355 (put face 'face-comment comment)
6b09b5d1 356 (face-spec-set face spec t))))))))
a3997907 357
135377f1 358;; XEmacs compatibility function. In XEmacs, when you reset a Custom
d358aa10
CY
359;; Theme, you have to specify the theme to reset it to. We just apply
360;; the next theme.
a3997907 361(defun custom-theme-reset-faces (theme &rest args)
2c9e973f
RS
362 "Reset the specs in THEME of some faces to their specs in other themes.
363Each of the arguments ARGS has this form:
a3997907 364
d358aa10 365 (FACE IGNORED)
a3997907 366
d358aa10 367This means reset FACE. The argument IGNORED is ignored."
a3997907 368 (custom-check-theme theme)
2c9e973f 369 (dolist (arg args)
d358aa10 370 (custom-push-theme 'theme-face (car arg) theme 'reset)))
a3997907 371
a3997907 372(defun custom-reset-faces (&rest args)
2c9e973f
RS
373 "Reset the specs of some faces to their specs in specified themes.
374This creates settings in the `user' theme.
375
376Each of the arguments ARGS has this form:
377
378 (FACE FROM-THEME)
a3997907 379
2c9e973f 380This means reset FACE to its value in FROM-THEME."
a3997907 381 (apply 'custom-theme-reset-faces 'user args))
d543e20b
PA
382
383;;; The End.
384
385(provide 'cus-face)
386
1743c17a 387;;; cus-face.el ends here