cus-face.el 13 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, 2000, 2001, 2002, 2003, 2004,
Glenn Morris's avatar
Glenn Morris committed
4
;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
Per Abrahamsen's avatar
Per Abrahamsen committed
5 6 7
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
8
;; Package: emacs
Per Abrahamsen's avatar
Per Abrahamsen committed
9

10
;; This file is part of GNU Emacs.
Per Abrahamsen's avatar
Per Abrahamsen committed
11

12
;; GNU Emacs is free software: you can redistribute it and/or modify
13
;; it under the terms of the GNU General Public License as published by
14 15
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Per Abrahamsen's avatar
Per Abrahamsen committed
16

17 18 19 20
;; 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
21

22
;; You should have received a copy of the GNU General Public License
23
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Per Abrahamsen's avatar
Per Abrahamsen committed
24

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

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

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

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

(defun custom-declare-face (face spec doc &rest args)
  "Like `defface', but FACE is evaluated as a normal argument."
37
  (unless (get face 'face-defface-spec)
Per Abrahamsen's avatar
Per Abrahamsen committed
38
    (when (fboundp 'facep)
39
      (unless (facep face)
Per Abrahamsen's avatar
Per Abrahamsen committed
40 41
	;; If the user has already created the face, respect that.
	(let ((value (or (get face 'saved-face) spec))
42
	      (have-window-system (memq initial-window-system '(x w32))))
Per Abrahamsen's avatar
Per Abrahamsen committed
43 44
	  ;; Create global face.
	  (make-empty-face face)
45
	  ;; Create frame-local faces
46
	  (dolist (frame (frame-list))
47
	    (face-spec-set-2 face frame value)
48
	    (when (memq (window-system frame) '(x w32 ns))
49 50 51 52
	      (setq have-window-system t)))
	  ;; When making a face after frames already exist
	  (if have-window-system
	      (make-face-x-resource-internal face)))))
53
    ;; Don't record SPEC until we see it causes no errors.
54
    (put face 'face-defface-spec (purecopy spec))
55
    (push (cons 'defface face) current-load-list)
56
    (when (and doc (null (face-documentation face)))
57
      (set-face-documentation face (purecopy doc)))
Per Abrahamsen's avatar
Per Abrahamsen committed
58 59 60 61
    (custom-handle-all-keywords face args 'custom-face)
    (run-hooks 'custom-define-hook))
  face)

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
62 63
;;; Face attributes.

Per Abrahamsen's avatar
Per Abrahamsen committed
64
(defconst custom-face-attributes
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
65
  '((:family
66 67
     (string :tag "Font Family"
	     :help-echo "Font family or fontset alias name."))
68

69 70 71 72
    (:foundry
     (string :tag "Font Foundry"
	     :help-echo "Font foundry name."))

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
73 74 75
    (:width
     (choice :tag "Width"
	     :help-echo "Font width."
76
	     :value normal		; default
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
77 78 79 80 81 82 83 84 85 86 87 88 89 90
	     (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)
91
	     (const :tag "wide" extra-expanded)))
92

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
93 94 95
    (:height
     (choice :tag "Height"
	     :help-echo "Face's font height."
96
	     :value 1.0			; default
Miles Bader's avatar
Miles Bader committed
97
	     (integer :tag "Height in 1/10 pt")
98
	     (number :tag "Scale" 1.0)))
Miles Bader's avatar
Miles Bader committed
99

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
100 101 102
    (:weight
     (choice :tag "Weight"
	     :help-echo "Font weight."
103
	     :value normal		; default
104
	     (const :tag "black" ultra-bold)
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
105 106 107 108 109 110 111 112 113 114 115 116 117
	     (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)
118 119
	     (const :tag "ultrabold" ultra-bold)
	     (const :tag "thin" thin)))
120

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
121 122 123
    (:slant
     (choice :tag "Slant"
	     :help-echo "Font slant."
124
	     :value normal		; default
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
125 126
	     (const :tag "italic" italic)
	     (const :tag "oblique" oblique)
127 128
	     (const :tag "normal" normal)
	     (const :tag "roman" roman)))
129

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
130 131 132
    (:underline
     (choice :tag "Underline"
	     :help-echo "Control text underlining."
133
	     (const :tag "Off" nil)
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
134
	     (const :tag "On" t)
135
	     (color :tag "Colored")))
136

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
137 138 139
    (:overline
     (choice :tag "Overline"
	     :help-echo "Control text overlining."
140
	     (const :tag "Off" nil)
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
141
	     (const :tag "On" t)
142
	     (color :tag "Colored")))
143

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
144 145 146
    (:strike-through
     (choice :tag "Strike-through"
	     :help-echo "Control text strike-through."
147
	     (const :tag "Off" nil)
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
148
	     (const :tag "On" t)
149
	     (color :tag "Colored")))
150

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
151
    (:box
152
     ;; Fixme: this can probably be done better.
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
153 154
     (choice :tag "Box around text"
	     :help-echo "Control box around text."
155
	     (const :tag "Off" nil)
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
156
	     (list :tag "Box"
157
		   :value (:line-width 2 :color "grey75" :style released-button)
158
		   (const :format "" :value :line-width)
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
159
		   (integer :tag "Width")
160 161 162 163 164 165 166
		   (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))))
167 168
     ;; filter to make value suitable for customize
     (lambda (real-value)
169 170 171 172 173 174 175 176 177 178 179 180 181
       (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))))
182 183
     ;; filter to make customized-value suitable for storing
     (lambda (cus-value)
184 185 186 187 188 189 190 191 192 193 194 195 196 197
       (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)))))))))
198

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
199 200 201
    (:inverse-video
     (choice :tag "Inverse-video"
	     :help-echo "Control whether text should be in inverse-video."
202 203
	     (const :tag "Off" nil)
	     (const :tag "On" t)))
204

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
205
    (:foreground
206
     (color :tag "Foreground"
207
	    :help-echo "Set foreground color (name or #RRGGBB hex spec)."))
208

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
209
    (:background
210
     (color :tag "Background"
211
	    :help-echo "Set background color (name or #RRGGBB hex spec)."))
212

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
213 214
    (:stipple
     (choice :tag "Stipple"
215
	     :help-echo "Background bit-mask"
216
	     (const :tag "None" nil)
217 218 219
	     (file :tag "File"
		   :help-echo "Name of bitmap file."
		   :must-match t)))
Miles Bader's avatar
Miles Bader committed
220 221 222 223 224

    (:inherit
     (repeat :tag "Inherit"
	     :help-echo "List of faces to inherit attributes from."
	     (face :Tag "Face" default))
225 226 227 228 229 230 231 232 233 234 235 236 237
     ;; 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))))
238

Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
239 240
  "Alist of face attributes.

241 242 243 244 245 246
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
247

248 249 250
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
251

252 253 254
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
255 256

(defun custom-face-attributes-get (face frame)
257 258
  "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
259 260
Each keyword should be listed in `custom-face-attributes'.

261
If FRAME is nil, use the global defaults for FACE."
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
262 263 264 265 266 267
  (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
268 269
	(unless (or (eq value 'unspecified)
		    (and (null value) (memq attribute '(:inherit))))
Gerd Moellmann's avatar
Ditto.  
Gerd Moellmann committed
270 271
	  (setq plist (cons attribute (cons value plist))))))
    plist))
Per Abrahamsen's avatar
Per Abrahamsen committed
272 273 274 275 276

;;; Initializing.

(defun custom-set-faces (&rest args)
  "Initialize faces according to user preferences.
277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294
This associates the settings with the `user' theme.
The arguments should be a list where each entry has the form:

  (FACE SPEC [NOW [COMMENT]])

SPEC is stored as the saved value for FACE, as well as the value for the
`user' theme.  The `user' theme is one of the default themes known to Emacs.
See `custom-known-themes' for more information on the known themes.
See `custom-theme-set-faces' for more information on the interplay
between themes and faces.
See `defface' for the format of SPEC.

If NOW is present and non-nil, FACE is created now, according to SPEC.
COMMENT is a string comment about FACE."
  (apply 'custom-theme-set-faces 'user args))

(defun custom-theme-set-faces (theme &rest args)
  "Initialize faces for theme THEME.
Per Abrahamsen's avatar
Per Abrahamsen committed
295 296
The arguments should be a list where each entry has the form:

297
  (FACE SPEC [NOW [COMMENT]])
Per Abrahamsen's avatar
Per Abrahamsen committed
298

299 300 301 302 303 304 305
SPEC is stored as the saved value for FACE, as well as the value for the
`user' theme.  The `user' theme is one of the default themes known to Emacs.
See `custom-known-themes' for more information on the known themes.
See `custom-theme-set-faces' for more information on the interplay
between themes and faces.
See `defface' for the format of SPEC.

306
If NOW is present and non-nil, FACE is created now, according to SPEC.
307
COMMENT is a string comment about FACE.
Per Abrahamsen's avatar
Per Abrahamsen committed
308

309 310 311 312 313 314 315 316 317 318 319 320 321
Several properties of THEME and FACE are used in the process:

If THEME property `theme-immediate' is non-nil, this is equivalent of
providing the NOW argument to all faces in the argument list: FACE is
created now.  The only difference is FACE property `force-face': if NOW
is non-nil, FACE property `force-face' is set to the symbol `rogue', else
if THEME property `theme-immediate' is non-nil, FACE property `force-face'
is set to the symbol `immediate'.

SPEC itself is saved in FACE property `saved-face' and it is stored in
FACE's list property `theme-face' \(using `custom-push-theme')."
  (custom-check-theme theme)
  (let ((immediate (get theme 'theme-immediate)))
322 323 324 325 326 327 328 329 330
    (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)))
331 332 333 334
	(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.
335 336 337 338 339 340
	  (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))
341 342
	    ;; Do this AFTER checking the `theme-face' property.
	    (custom-push-theme 'theme-face face theme 'set spec)
343 344 345 346 347 348 349 350
	    (when (or now immediate)
	      (put face 'force-face (if now 'rogue 'immediate)))
	    (when (or now immediate (facep face))
	      (unless (facep face)
		(make-empty-face face))
	      (put face 'face-comment comment)
	      (put face 'face-override-spec nil)
	      (face-spec-set face spec t))))))))
351

352 353 354
;; XEmacs compability function.  In XEmacs, when you reset a Custom
;; Theme, you have to specify the theme to reset it to.  We just apply
;; the next theme.
355
(defun custom-theme-reset-faces (theme &rest args)
356 357
  "Reset the specs in THEME of some faces to their specs in other themes.
Each of the arguments ARGS has this form:
358

359
    (FACE IGNORED)
360

361
This means reset FACE.  The argument IGNORED is ignored."
362
  (custom-check-theme theme)
363
  (dolist (arg args)
364
    (custom-push-theme 'theme-face (car arg) theme 'reset)))
365 366

(defun custom-reset-faces (&rest args)
367 368 369 370 371 372
  "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)
373

374
This means reset FACE to its value in FROM-THEME."
375
  (apply 'custom-theme-reset-faces 'user args))
Per Abrahamsen's avatar
Per Abrahamsen committed
376 377 378 379 380

;;; The End.

(provide 'cus-face)

381
;; arch-tag: 9a5c4b63-0d27-4c92-a5af-f2c7ed764c2b
382
;;; cus-face.el ends here