Line data Source code
1 : ;;; cus-face.el --- customization support for faces
2 : ;;
3 : ;; Copyright (C) 1996-1997, 1999-2017 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 with FACE evaluated as a normal argument."
36 92 : (unless (get face 'face-defface-spec)
37 2 : (face-spec-set face (purecopy spec) 'face-defface-spec)
38 4 : (push (cons 'defface face) current-load-list)
39 2 : (when doc
40 2 : (set-face-documentation face (purecopy doc)))
41 2 : (custom-handle-all-keywords face args 'custom-face)
42 92 : (run-hooks 'custom-define-hook))
43 92 : face)
44 :
45 : ;;; Face attributes.
46 :
47 : (defconst custom-face-attributes
48 : '((:family
49 : (string :tag "Font Family"
50 : :help-echo "Font family or fontset alias name."))
51 :
52 : (:foundry
53 : (string :tag "Font Foundry"
54 : :help-echo "Font foundry name."))
55 :
56 : (:width
57 : (choice :tag "Width"
58 : :help-echo "Font width."
59 : :value normal ; default
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)
74 : (const :tag "wide" extra-expanded)))
75 :
76 : (:height
77 : (choice :tag "Height"
78 : :help-echo "Face's font height."
79 : :value 1.0 ; default
80 : (integer :tag "Height in 1/10 pt")
81 : (number :tag "Scale" 1.0)))
82 :
83 : (:weight
84 : (choice :tag "Weight"
85 : :help-echo "Font weight."
86 : :value normal ; default
87 : (const :tag "black" ultra-bold)
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)
101 : (const :tag "ultrabold" ultra-bold)
102 : (const :tag "thin" thin)))
103 :
104 : (:slant
105 : (choice :tag "Slant"
106 : :help-echo "Font slant."
107 : :value normal ; default
108 : (const :tag "italic" italic)
109 : (const :tag "oblique" oblique)
110 : (const :tag "normal" normal)
111 : (const :tag "roman" roman)))
112 :
113 : (:underline
114 : (choice :tag "Underline"
115 : :help-echo "Control text underlining."
116 : (const :tag "Off" nil)
117 : (list :tag "On"
118 : :value (:color foreground-color :style line)
119 : (const :format "" :value :color)
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)))))))
148 :
149 : (:overline
150 : (choice :tag "Overline"
151 : :help-echo "Control text overlining."
152 : (const :tag "Off" nil)
153 : (const :tag "On" t)
154 : (color :tag "Colored")))
155 :
156 : (:strike-through
157 : (choice :tag "Strike-through"
158 : :help-echo "Control text strike-through."
159 : (const :tag "Off" nil)
160 : (const :tag "On" t)
161 : (color :tag "Colored")))
162 :
163 : (:box
164 : ;; Fixme: this can probably be done better.
165 : (choice :tag "Box around text"
166 : :help-echo "Control box around text."
167 : (const :tag "Off" nil)
168 : (list :tag "Box"
169 : :value (:line-width 2 :color "grey75" :style released-button)
170 : (const :format "" :value :line-width)
171 : (integer :tag "Width")
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))))
179 : ;; filter to make value suitable for customize
180 : (lambda (real-value)
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))))
194 : ;; filter to make customized-value suitable for storing
195 : (lambda (cus-value)
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)))))))))
210 :
211 : (:inverse-video
212 : (choice :tag "Inverse-video"
213 : :help-echo "Control whether text should be in inverse-video."
214 : (const :tag "Off" nil)
215 : (const :tag "On" t)))
216 :
217 : (:foreground
218 : (color :tag "Foreground"
219 : :help-echo "Set foreground color (name or #RRGGBB hex spec)."))
220 :
221 : (:distant-foreground
222 : (color :tag "Distant Foreground"
223 : :help-echo "Set distant foreground color (name or #RRGGBB hex spec)."))
224 :
225 : (:background
226 : (color :tag "Background"
227 : :help-echo "Set background color (name or #RRGGBB hex spec)."))
228 :
229 : (:stipple
230 : (choice :tag "Stipple"
231 : :help-echo "Background bit-mask"
232 : (const :tag "None" nil)
233 : (file :tag "File"
234 : :help-echo "Name of bitmap file."
235 : :must-match t)))
236 :
237 : (:inherit
238 : (repeat :tag "Inherit"
239 : :help-echo "List of faces to inherit attributes from."
240 : (face :Tag "Face" default))
241 : ;; filter to make value suitable for customize
242 : (lambda (real-value)
243 : (cond ((or (null real-value) (eq real-value 'unspecified))
244 : nil)
245 : ((symbolp real-value)
246 : (list real-value))
247 : (t
248 : real-value)))
249 : ;; filter to make customized-value suitable for storing
250 : (lambda (cus-value)
251 : (if (and (consp cus-value) (null (cdr cus-value)))
252 : (car cus-value)
253 : cus-value))))
254 :
255 : "Alist of face attributes.
256 :
257 : The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER),
258 : where KEY is the name of the attribute, TYPE is a widget type for
259 : editing the attribute, PRE-FILTER is a function to make the attribute's
260 : value suitable for the customization widget, and POST-FILTER is a
261 : function to make the customized value suitable for storing. PRE-FILTER
262 : and POST-FILTER are optional.
263 :
264 : The PRE-FILTER should take a single argument, the attribute value as
265 : stored, and should return a value for customization (using the
266 : customization type TYPE).
267 :
268 : The POST-FILTER should also take a single argument, the value after
269 : being customized, and should return a value suitable for setting the
270 : given face attribute.")
271 :
272 : (defun custom-face-attributes-get (face frame)
273 : "For FACE on FRAME, return an alternating list describing its attributes.
274 : The list has the form (KEYWORD VALUE KEYWORD VALUE...).
275 : Each keyword should be listed in `custom-face-attributes'.
276 :
277 : If FRAME is nil, use the global defaults for FACE."
278 0 : (let ((attrs custom-face-attributes)
279 : plist)
280 0 : (while attrs
281 0 : (let* ((attribute (car (car attrs)))
282 0 : (value (face-attribute face attribute frame)))
283 0 : (setq attrs (cdr attrs))
284 0 : (unless (or (eq value 'unspecified)
285 0 : (and (null value) (memq attribute '(:inherit))))
286 0 : (setq plist (cons attribute (cons value plist))))))
287 0 : plist))
288 :
289 : ;;; Initializing.
290 :
291 : (defun custom-set-faces (&rest args)
292 : "Apply a list of face specs for user customizations.
293 : This works by calling `custom-theme-set-faces' for the `user'
294 : theme, a special theme referring to settings made via Customize.
295 : The arguments should be a list where each entry has the form:
296 :
297 : (FACE SPEC [NOW [COMMENT]])
298 :
299 : See the documentation of `custom-theme-set-faces' for details."
300 0 : (apply 'custom-theme-set-faces 'user args))
301 :
302 : (defun custom-theme-set-faces (theme &rest args)
303 : "Apply a list of face specs associated with theme THEME.
304 : THEME should be a theme name (a symbol). The special theme named
305 : `user' refers to user settings applied via Customize.
306 :
307 : The remaining ARGS should be a list where each entry is a list of
308 : the form:
309 :
310 : (FACE SPEC [NOW [COMMENT]])
311 :
312 : FACE should be a face name (a symbol). If FACE is a face alias,
313 : the setting refers to the parent face.
314 :
315 : SPEC should be a face spec. For details, see `defface'.
316 :
317 : NOW, if present and non-nil, forces the face settings to take
318 : immediate effect in the Emacs display; in particular, FACE is
319 : initialized as a face if it is not yet one. If NOW is omitted or
320 : nil, the caller is responsible for making the settings take
321 : effect later, by calling `custom-theme-recalc-face' or
322 : `face-spec-recalc'.
323 :
324 : COMMENT is a string comment about FACE.
325 :
326 : This function works by calling `custom-push-theme' to record each
327 : SPEC in each FACE's `theme-face' property, and in THEME's
328 : `theme-settings' property. If FACE has not already been
329 : customized, it also stores SPEC in the `saved-face' property.
330 :
331 : If THEME has a non-nil `theme-immediate' property, this is
332 : equivalent to providing the NOW argument to all faces in the
333 : argument list."
334 0 : (custom-check-theme theme)
335 0 : (let ((immediate (get theme 'theme-immediate)))
336 0 : (dolist (entry args)
337 0 : (unless (listp entry)
338 0 : (error "Incompatible Custom theme spec"))
339 0 : (let ((face (car entry))
340 0 : (spec (nth 1 entry)))
341 : ;; If FACE is actually an alias, customize the face it
342 : ;; is aliased to.
343 0 : (if (get face 'face-alias)
344 0 : (setq face (get face 'face-alias)))
345 0 : (if custom--inhibit-theme-enable
346 : ;; Just update theme settings.
347 0 : (custom-push-theme 'theme-face face theme 'set spec)
348 : ;; Update theme settings and set the face spec.
349 0 : (let ((now (nth 2 entry))
350 0 : (comment (nth 3 entry))
351 0 : (oldspec (get face 'theme-face)))
352 0 : (when (not (and oldspec (eq 'user (caar oldspec))))
353 0 : (put face 'saved-face spec)
354 0 : (put face 'saved-face-comment comment))
355 0 : (custom-push-theme 'theme-face face theme 'set spec)
356 0 : (when (or now immediate)
357 0 : (put face 'force-face (if now 'rogue 'immediate)))
358 0 : (when (or now immediate (facep face))
359 0 : (put face 'face-comment comment)
360 0 : (face-spec-set face spec t))))))))
361 :
362 : ;; XEmacs compatibility function. In XEmacs, when you reset a Custom
363 : ;; Theme, you have to specify the theme to reset it to. We just apply
364 : ;; the next theme.
365 : (defun custom-theme-reset-faces (theme &rest args)
366 : "Reset the specs in THEME of some faces to their specs in other themes.
367 : Each of the arguments ARGS has this form:
368 :
369 : (FACE IGNORED)
370 :
371 : This means reset FACE. The argument IGNORED is ignored."
372 0 : (custom-check-theme theme)
373 0 : (dolist (arg args)
374 0 : (custom-push-theme 'theme-face (car arg) theme 'reset)))
375 :
376 : (defun custom-reset-faces (&rest args)
377 : "Reset the specs of some faces to their specs in specified themes.
378 : This creates settings in the `user' theme.
379 :
380 : Each of the arguments ARGS has this form:
381 :
382 : (FACE FROM-THEME)
383 :
384 : This means reset FACE to its value in FROM-THEME."
385 0 : (apply 'custom-theme-reset-faces 'user args))
386 :
387 : ;;; The End.
388 :
389 : (provide 'cus-face)
390 :
391 : ;;; cus-face.el ends here
|