cus-face.el 13.1 KB
Newer Older
1
;;; cus-face.el --- customization support for faces
Per Abrahamsen's avatar
Per Abrahamsen committed
2
;;
Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1996-1997, 1999-2020 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 <https://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
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
Gerd Moellmann committed
45 46
;;; Face attributes.

Per Abrahamsen's avatar
Per Abrahamsen committed
47
(defconst custom-face-attributes
Gerd Moellmann's avatar
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
Gerd Moellmann committed
56 57 58
    (:width
     (choice :tag "Width"
	     :help-echo "Font width."
59
	     :value normal		; default
Gerd Moellmann's avatar
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
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
Gerd Moellmann committed
83 84 85
    (:weight
     (choice :tag "Weight"
	     :help-echo "Font weight."
86
	     :value normal		; default
87
	     (const :tag "ultralight" ultra-light)
Gerd Moellmann's avatar
Gerd Moellmann committed
88 89
	     (const :tag "extralight" extra-light)
	     (const :tag "light" light)
90 91 92
	     (const :tag "thin" thin)
	     (const :tag "semilight" semi-light)
	     (const :tag "book" semi-light)
Gerd Moellmann's avatar
Gerd Moellmann committed
93 94
	     (const :tag "normal" normal)
	     (const :tag "regular" normal)
95
	     (const :tag "medium" normal)
Gerd Moellmann's avatar
Gerd Moellmann committed
96
	     (const :tag "semibold" semi-bold)
97 98 99 100
	     (const :tag "demibold" semi-bold)
	     (const :tag "bold" bold)
	     (const :tag "extrabold" extra-bold)
	     (const :tag "heavy" extra-bold)
101
	     (const :tag "ultrabold" ultra-bold)
102
	     (const :tag "black" ultra-bold)))
103

Gerd Moellmann's avatar
Gerd Moellmann committed
104 105 106
    (:slant
     (choice :tag "Slant"
	     :help-echo "Font slant."
107
	     :value normal		; default
Gerd Moellmann's avatar
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
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
Gerd Moellmann committed
149 150 151
    (:overline
     (choice :tag "Overline"
	     :help-echo "Control text overlining."
152
	     (const :tag "Off" nil)
Gerd Moellmann's avatar
Gerd Moellmann committed
153
	     (const :tag "On" t)
154
	     (color :tag "Colored")))
155

Gerd Moellmann's avatar
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
Gerd Moellmann committed
160
	     (const :tag "On" t)
161
	     (color :tag "Colored")))
162

Gerd Moellmann's avatar
Gerd Moellmann committed
163
    (:box
164
     ;; Fixme: this can probably be done better.
Gerd Moellmann's avatar
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
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
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
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
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
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
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)))
236 237 238 239 240
    (:extend
     (choice :tag "Extend"
	     :help-echo "Control whether attributes should be extended after EOL."
	     (const :tag "Off" nil)
	     (const :tag "On" t)))
Miles Bader's avatar
Miles Bader committed
241 242 243 244
    (:inherit
     (repeat :tag "Inherit"
	     :help-echo "List of faces to inherit attributes from."
	     (face :Tag "Face" default))
245 246 247 248 249 250 251 252 253 254 255 256 257
     ;; 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))))
258

Gerd Moellmann's avatar
Gerd Moellmann committed
259 260
  "Alist of face attributes.

261 262 263 264 265 266
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
267

268 269 270
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
271

272 273 274
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
275 276

(defun custom-face-attributes-get (face frame)
277 278
  "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
279 280
Each keyword should be listed in `custom-face-attributes'.

281
If FRAME is nil, use the global defaults for FACE."
Gerd Moellmann's avatar
Gerd Moellmann committed
282 283 284 285 286 287
  (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
288 289
	(unless (or (eq value 'unspecified)
		    (and (null value) (memq attribute '(:inherit))))
Gerd Moellmann's avatar
Gerd Moellmann committed
290 291
	  (setq plist (cons attribute (cons value plist))))))
    plist))
Per Abrahamsen's avatar
Per Abrahamsen committed
292 293 294 295

;;; Initializing.

(defun custom-set-faces (&rest args)
Chong Yidong's avatar
Chong Yidong committed
296 297 298
  "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.
299 300 301 302
The arguments should be a list where each entry has the form:

  (FACE SPEC [NOW [COMMENT]])

Chong Yidong's avatar
Chong Yidong committed
303
See the documentation of `custom-theme-set-faces' for details."
304 305 306
  (apply 'custom-theme-set-faces 'user args))

(defun custom-theme-set-faces (theme &rest args)
Chong Yidong's avatar
Chong Yidong committed
307 308 309 310 311 312
  "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
313

314
  (FACE SPEC [NOW [COMMENT]])
Per Abrahamsen's avatar
Per Abrahamsen committed
315

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

Chong Yidong's avatar
Chong Yidong committed
319 320 321 322 323 324 325 326
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
327

Chong Yidong's avatar
Chong Yidong committed
328
COMMENT is a string comment about FACE.
329

Chong Yidong's avatar
Chong Yidong committed
330 331 332 333
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.
334

Chong Yidong's avatar
Chong Yidong committed
335 336 337
If THEME has a non-nil `theme-immediate' property, this is
equivalent to providing the NOW argument to all faces in the
argument list."
338 339
  (custom-check-theme theme)
  (let ((immediate (get theme 'theme-immediate)))
340 341 342 343 344 345 346 347 348
    (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)))
Daniel Colascione's avatar
Daniel Colascione committed
349
	(if (not (custom--should-apply-setting theme))
350 351 352
	    ;; Just update theme settings.
	    (custom-push-theme 'theme-face face theme 'set spec)
	  ;; Update theme settings and set the face spec.
353 354 355 356 357 358
	  (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))
359
	    (custom-push-theme 'theme-face face theme 'set spec)
360 361 362 363 364
	    (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))))))))
365

Juanma Barranquero's avatar
Juanma Barranquero committed
366
;; XEmacs compatibility function.  In XEmacs, when you reset a Custom
367 368
;; Theme, you have to specify the theme to reset it to.  We just apply
;; the next theme.
369
(defun custom-theme-reset-faces (theme &rest args)
370 371
  "Reset the specs in THEME of some faces to their specs in other themes.
Each of the arguments ARGS has this form:
372

373
    (FACE IGNORED)
374

375
This means reset FACE.  The argument IGNORED is ignored."
376
  (custom-check-theme theme)
377
  (dolist (arg args)
378
    (custom-push-theme 'theme-face (car arg) theme 'reset)))
379 380

(defun custom-reset-faces (&rest args)
381 382 383 384 385 386
  "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)
387

388
This means reset FACE to its value in FROM-THEME."
389
  (apply 'custom-theme-reset-faces 'user args))
Per Abrahamsen's avatar
Per Abrahamsen committed
390 391 392 393 394

;;; The End.

(provide 'cus-face)

395
;;; cus-face.el ends here