cus-face.el 13.5 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
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 "ultralight" ultra-light)
Gerd Moellmann's avatar
Ditto.  
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
Ditto.  
Gerd Moellmann committed
93 94
	     (const :tag "normal" normal)
	     (const :tag "regular" normal)
95
	     (const :tag "medium" normal)
Gerd Moellmann's avatar
Ditto.  
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
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 170 171 172 173
                   :value (:line-width (2 . 2) :color "grey75" :style released-button)
                   (const :format "" :value :line-width)
                   (cons :tag "Width" :extra-offset 2
                         (integer :tag "Vertical")
                         (integer :tag "Horizontal"))
174 175 176 177 178 179 180
		   (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))))
181 182
     ;; filter to make value suitable for customize
     (lambda (real-value)
183 184 185
       (and real-value
	    (let ((lwidth
		   (or (and (consp real-value)
186 187 188
                            (if (listp (cdr real-value))
                                (plist-get real-value :line-width)
                              real-value))
189
		       (and (integerp real-value) real-value)
190
                       '(1 . 1)))
191 192 193 194 195 196
		  (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))))
197 198
              (if (integerp lwidth)
                  (setq lwidth (cons (abs lwidth) lwidth)))
199
	      (list :line-width lwidth :color color :style style))))
200 201
     ;; filter to make customized-value suitable for storing
     (lambda (cus-value)
202 203 204 205 206 207 208 209 210 211 212 213 214 215
       (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)))))))))
216

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
217 218 219
    (:inverse-video
     (choice :tag "Inverse-video"
	     :help-echo "Control whether text should be in inverse-video."
220 221
	     (const :tag "Off" nil)
	     (const :tag "On" t)))
222

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
223
    (:foreground
224
     (color :tag "Foreground"
225
	    :help-echo "Set foreground color (name or #RRGGBB hex spec)."))
226

227 228 229 230
    (: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
231
    (:background
232
     (color :tag "Background"
233
	    :help-echo "Set background color (name or #RRGGBB hex spec)."))
234

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
235 236
    (:stipple
     (choice :tag "Stipple"
237
	     :help-echo "Background bit-mask"
238
	     (const :tag "None" nil)
239 240 241
	     (file :tag "File"
		   :help-echo "Name of bitmap file."
		   :must-match t)))
242 243 244 245 246
    (: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
247 248 249 250
    (:inherit
     (repeat :tag "Inherit"
	     :help-echo "List of faces to inherit attributes from."
	     (face :Tag "Face" default))
251 252 253 254 255 256 257 258 259 260 261 262 263
     ;; 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))))
264

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
265 266
  "Alist of face attributes.

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

274 275 276
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
277

278 279 280
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
281 282

(defun custom-face-attributes-get (face frame)
283 284
  "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
285 286
Each keyword should be listed in `custom-face-attributes'.

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

;;; Initializing.

(defun custom-set-faces (&rest args)
Chong Yidong's avatar
Chong Yidong committed
302 303 304
  "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.
305 306 307 308
The arguments should be a list where each entry has the form:

  (FACE SPEC [NOW [COMMENT]])

Chong Yidong's avatar
Chong Yidong committed
309
See the documentation of `custom-theme-set-faces' for details."
310 311 312
  (apply 'custom-theme-set-faces 'user args))

(defun custom-theme-set-faces (theme &rest args)
Chong Yidong's avatar
Chong Yidong committed
313 314 315 316 317 318
  "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
319

320
  (FACE SPEC [NOW [COMMENT]])
Per Abrahamsen's avatar
Per Abrahamsen committed
321

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

Chong Yidong's avatar
Chong Yidong committed
325 326 327 328 329 330 331 332
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
333

Chong Yidong's avatar
Chong Yidong committed
334
COMMENT is a string comment about FACE.
335

Chong Yidong's avatar
Chong Yidong committed
336 337 338 339
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.
340

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

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

379
    (FACE IGNORED)
380

381
This means reset FACE.  The argument IGNORED is ignored."
382
  (custom-check-theme theme)
383
  (dolist (arg args)
384
    (custom-push-theme 'theme-face (car arg) theme 'reset)))
385 386

(defun custom-reset-faces (&rest args)
387 388 389 390 391 392
  "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)
393

394
This means reset FACE to its value in FROM-THEME."
395
  (apply 'custom-theme-reset-faces 'user args))
Per Abrahamsen's avatar
Per Abrahamsen committed
396 397 398 399 400

;;; The End.

(provide 'cus-face)

401
;;; cus-face.el ends here