;;; faces.el --- Lisp faces
-;; Copyright (C) 1992-1996, 1998-2015 Free Software Foundation, Inc.
+;; Copyright (C) 1992-1996, 1998-2016 Free Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
;; Keywords: internal
(defcustom face-font-family-alternatives
(mapcar (lambda (arg) (mapcar 'purecopy arg))
'(("Monospace" "courier" "fixed")
+
+ ;; Monospace Serif is an Emacs invention, intended to work around
+ ;; portability problems when using Courier. It should work well
+ ;; when combined with Monospaced and with other standard fonts.
+ ("Monospace Serif"
+
+ ;; This looks good on GNU/Linux.
+ "Courier 10 Pitch"
+ ;; This looks good on MS-Windows and OS X.
+ "Consolas"
+ ;; This looks good on OS X. "Courier" looks good too, but is
+ ;; jagged on GNU/Linux and so is listed later as "courier".
+ "Courier Std"
+ ;; Although these are anti-aliased, they are a bit faint compared
+ ;; to the above.
+ "FreeMono" "Nimbus Mono L"
+ ;; These are aliased and look jagged.
+ "courier" "fixed"
+ ;; Omit Courier New, as it is the default MS-Windows font and so
+ ;; would look no different, and is pretty faint on other platforms.
+ )
+
+ ;; This is present for backward compatibility.
("courier" "CMU Typewriter Text" "fixed")
+
("Sans Serif" "helv" "helvetica" "arial" "fixed")
("helv" "helvetica" "arial" "fixed")))
"Alist of alternative font family names.
(not (internal-lisp-face-empty-p face frame)))
+(defun face-list-p (face-or-list)
+ "True if FACE-OR-LIST is a list of faces.
+Return nil if FACE-OR-LIST is a non-nil atom, or a cons cell whose car
+is either `foreground-color', `background-color', or a keyword."
+ ;; The logic of merge_face_ref (xfaces.c) is recreated here.
+ (and (listp face-or-list)
+ (not (memq (car face-or-list)
+ '(foreground-color background-color)))
+ (not (keywordp (car face-or-list)))))
+
+
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Setting face attributes from X resources.
(defun face-attribute-merged-with (attribute value faces &optional frame)
"Merges ATTRIBUTE, initially VALUE, with faces from FACES until absolute.
FACES may be either a single face or a list of faces.
-\[This is an internal function.]"
+[This is an internal function.]"
(cond ((not (face-attribute-relative-p attribute value))
value)
((null faces)
`:foundry'
VALUE must be a string specifying the font foundry,
-e.g. ``adobe''. If a font foundry is specified, wild-cards `*'
+e.g., \"adobe\". If a font foundry is specified, wild-cards `*'
and `?' are allowed.
`:width'
(setq args (purecopy args))
(let ((where (if (null frame) 0 frame))
(spec args)
- family foundry)
+ family foundry orig-family orig-foundry)
;; If we set the new-frame defaults, this face is modified outside Custom.
(if (memq where '(0 t))
(put (or (get face 'face-alias) face) 'face-modified t))
(when (or family foundry)
(when (and (stringp family)
(string-match "\\([^-]*\\)-\\([^-]*\\)" family))
+ (setq orig-foundry foundry
+ orig-family family)
(unless foundry
(setq foundry (match-string 1 family)))
- (setq family (match-string 2 family)))
+ (setq family (match-string 2 family))
+ ;; Reject bogus "families" that are all-digits -- those are some
+ ;; weird font names, like Foobar-12, that end in a number.
+ (when (string-match "\\`[0-9]*\\'" family)
+ (setq family orig-family)
+ (setq foundry orig-foundry)))
(when (or (stringp family) (eq family 'unspecified))
(internal-set-lisp-face-attribute face :family (purecopy family)
where))
foreground color. :style may be omitted, which means to use a line.
FRAME nil or not specified means change face on all frames.
-Use `set-face-attribute' to ``unspecify'' underlining."
+Use `set-face-attribute' to \"unspecify\" underlining."
(interactive (read-face-and-attribute :underline))
(set-face-attribute face frame :underline underline))
INVERSE-VIDEO-P non-nil means FACE displays explicitly in inverse video.
INVERSE-VIDEO-P nil means FACE explicitly is not in inverse video.
FRAME nil or not specified means change face on all frames.
-Use `set-face-attribute' to ``unspecify'' the inverse video attribute."
+Use `set-face-attribute' to \"unspecify\" the inverse video attribute."
(interactive
(let ((list (read-face-and-attribute :inverse-video)))
(list (car list) (if (cadr list) t))))
"Read one or more face names, prompting with PROMPT.
PROMPT should not end in a space or a colon.
-Return DEFAULT if the user enters the empty string.
-If DEFAULT is non-nil, it should be a single face or a list of face names
-\(symbols or strings). In the latter case, return the `car' of DEFAULT
-\(if MULTIPLE is nil, see below), or DEFAULT (if MULTIPLE is non-nil).
-
-If MULTIPLE is non-nil, this function uses `completing-read-multiple'
-to read multiple faces with \"[ \\t]*,[ \\t]*\" as the separator regexp
-and it returns a list of face names. Otherwise, it reads and returns
-a single face name."
- (if (and default (not (stringp default)))
- (setq default
- (cond ((symbolp default)
- (symbol-name default))
- (multiple
- (mapconcat (lambda (f) (if (symbolp f) (symbol-name f) f))
- default ", "))
- ;; If we only want one, and the default is more than one,
- ;; discard the unwanted ones.
- (t (symbol-name (car default))))))
+If DEFAULT is non-nil, it should be a face (a symbol) or a face
+name (a string). It can also be a list of faces or face names.
+
+If MULTIPLE is non-nil, the return value from this function is a
+list of faces. Otherwise a single face is returned.
+
+If the user enter the empty string at the prompt, DEFAULT is
+returned after a possible transformation according to MULTIPLE.
+That is, if DEFAULT is a list and MULTIPLE is nil, the first
+element of DEFAULT is returned. If DEFAULT isn't a list, but
+MULTIPLE is non-nil, a one-element list containing DEFAULT is
+returned. Otherwise, DEFAULT is returned verbatim."
+ (unless (listp default)
+ (setq default (list default)))
+ (when default
+ (setq default
+ (if multiple
+ (mapconcat (lambda (f) (if (symbolp f) (symbol-name f) f))
+ default ", ")
+ ;; If we only want one, and the default is more than one,
+ ;; discard the unwanted ones.
+ (setq default (car default))
+ (if (symbolp default)
+ (symbol-name default)
+ default))))
(when (and default (not multiple))
(require 'crm)
;; For compatibility with `completing-read-multiple' use `crm-separator'
;; to define DEFAULT if MULTIPLE is nil.
(setq default (car (split-string default crm-separator t))))
+ ;; Older versions of `read-face-name' did not append ": " to the
+ ;; prompt, so there are third party libraries that have that in the
+ ;; prompt. If so, remove it.
+ (setq prompt (replace-regexp-in-string ": ?\\'" "" prompt))
(let ((prompt (if default
- (format "%s (default `%s'): " prompt default)
+ (format-message "%s (default `%s'): " prompt default)
(format "%s: " prompt)))
aliasfaces nonaliasfaces faces)
;; Build up the completion tables.
(setq name (concat (upcase (substring name 0 1)) (substring name 1)))
(let* ((completion-ignore-case t)
(value (completing-read
- (if default
- (format "%s for face `%s' (default %s): "
- name face default)
- (format "%s for face `%s': " name face))
+ (format-message (if default
+ "%s for face `%s' (default %s): "
+ "%s for face `%s': ")
+ name face default)
completion-alist nil nil nil nil default)))
(if (equal value "") default value)))
"Read the name of a font for FACE on FRAME.
If optional argument FRAME is nil or omitted, use the selected frame."
(let ((completion-ignore-case t))
- (completing-read (format "Set font attributes of face `%s' from font: " face)
+ (completing-read (format-message
+ "Set font attributes of face `%s' from font: " face)
(append (fontset-list) (x-list-fonts "*" nil frame)))))
(when alias
(setq face alias)
(insert
- (format "\n %s is an alias for the face `%s'.\n%s"
- f alias
- (if (setq obsolete (get f 'obsolete-face))
- (format " This face is obsolete%s; use `%s' instead.\n"
- (if (stringp obsolete)
- (format " since %s" obsolete)
- "")
- alias)
- ""))))
+ (format-message
+ "\n %s is an alias for the face `%s'.\n%s"
+ f alias
+ (if (setq obsolete (get f 'obsolete-face))
+ (format-message
+ " This face is obsolete%s; use `%s' instead.\n"
+ (if (stringp obsolete)
+ (format " since %s" obsolete)
+ "")
+ alias)
+ ""))))
(insert "\nDocumentation:\n"
- (or (face-documentation face)
- "Not documented as a face.")
+ (substitute-command-keys
+ (or (face-documentation face)
+ "Not documented as a face."))
"\n\n"))
(with-current-buffer standard-output
(save-excursion
(help-xref-button 1 'help-customize-face f)))
(setq file-name (find-lisp-object-file-name f 'defface))
(when file-name
- (princ "Defined in `")
+ (princ (substitute-command-keys "Defined in `"))
(princ (file-name-nondirectory file-name))
- (princ "'")
+ (princ (substitute-command-keys "'"))
;; Make a hyperlink to the library.
(save-excursion
- (re-search-backward "`\\([^`']+\\)'" nil t)
+ (re-search-backward
+ (substitute-command-keys "`\\([^`']+\\)'") nil t)
(help-xref-button 1 'help-face-def f file-name))
(princ ".")
(terpri)
result
no-match-retval))))
+;; When over 80 faces get processed at frame creation time, all but
+;; one specifying all attributes as "unspecified", generating this
+;; list every time means a lot of consing.
+(defconst face--attributes-unspecified
+ (apply 'append
+ (mapcar (lambda (x) (list (car x) 'unspecified))
+ face-attribute-name-alist)))
(defun face-spec-reset-face (face &optional frame)
"Reset all attributes of FACE on FRAME to unspecified."
"unspecified-fg"
"unspecified-bg")))))
;; For all other faces, unspecify all attributes.
- (apply 'append
- (mapcar (lambda (x) (list (car x) 'unspecified))
- face-attribute-name-alist)))))
+ face--attributes-unspecified)))
(defun face-spec-set (face spec &optional spec-type)
"Set the face spec SPEC for FACE.
(mapcar 'car (tty-color-alist frame))))
(defalias 'x-defined-colors 'defined-colors)
+(defun defined-colors-with-face-attributes (&optional frame)
+ "Return a list of colors supported for a particular frame.
+See `defined-colors' for arguments and return value. In contrast
+to `define-colors' the elements of the returned list are color
+strings with text properties, that make the color names render
+with the color they represent as background color."
+ (mapcar
+ (lambda (color-name)
+ (let ((foreground (readable-foreground-color color-name))
+ (color (copy-sequence color-name)))
+ (propertize color 'face (list :foreground foreground
+ :background color))))
+ (defined-colors frame)))
+
+(defun readable-foreground-color (color)
+ "Return a readable foreground color for background COLOR."
+ (let* ((rgb (color-values color))
+ (max (apply #'max rgb))
+ (black (car (color-values "black")))
+ (white (car (color-values "white"))))
+ ;; Select black or white depending on which one is less similar to
+ ;; the brightest component.
+ (if (> (abs (- max black)) (abs (- max white)))
+ "black"
+ "white")))
+
(declare-function xw-color-defined-p "xfns.c" (color &optional frame))
(defun color-defined-p (color &optional frame)
(colors (or facemenu-color-alist
(append '("foreground at point" "background at point")
(if allow-empty-name '(""))
- (defined-colors))))
+ (if (display-color-p)
+ (defined-colors-with-face-attributes)
+ (defined-colors)))))
(color (completing-read
(or prompt "Color (name or #RGB triplet): ")
;; Completing function for reading colors, accepting
;; both color names and RGB triplets.
(lambda (string pred flag)
(cond
- ((null flag) ; Try completion.
+ ((null flag) ; Try completion.
(or (try-completion string colors pred)
(if (color-defined-p string)
string)))
- ((eq flag t) ; List all completions.
+ ((eq flag t) ; List all completions.
(or (all-completions string colors pred)
(if (color-defined-p string)
(list string))))
- ((eq flag 'lambda) ; Test completion.
+ ((eq flag 'lambda) ; Test completion.
(or (member string colors)
(color-defined-p string)))))
nil t)))
(get-char-property (point) 'face))))
(cond ((facep faceprop)
(push faceprop faces))
- ((and (listp faceprop)
- ;; Don't treat an attribute spec as a list of faces.
- (not (keywordp (car faceprop)))
- (not (memq (car faceprop)
- '(foreground-color background-color))))
+ ((face-list-p faceprop)
(dolist (face faceprop)
(if (facep face)
(push face faces))))))
- (setq faces (delete-dups (nreverse faces)))
- (if multiple faces (car faces))))
+ (if multiple
+ (delete-dups (nreverse faces))
+ (car (last faces)))))
+
+(defun faces--attribute-at-point (attribute &optional attribute-unnamed)
+ "Return the face ATTRIBUTE at point.
+ATTRIBUTE is a keyword.
+If ATTRIBUTE-UNNAMED is non-nil, it is a symbol to look for in
+unnamed faces (e.g, `foreground-color')."
+ ;; `face-at-point' alone is not sufficient. It only gets named faces.
+ ;; Need also pick up any face properties that are not associated with named faces.
+ (let ((faces (or (get-char-property (point) 'read-face-name)
+ ;; If `font-lock-mode' is on, `font-lock-face' takes precedence.
+ (and font-lock-mode
+ (get-char-property (point) 'font-lock-face))
+ (get-char-property (point) 'face)))
+ (found nil))
+ (dolist (face (if (face-list-p faces)
+ faces
+ (list faces)))
+ (cond (found)
+ ((and face (symbolp face))
+ (let ((value (face-attribute-specified-or
+ (face-attribute face attribute nil t)
+ nil)))
+ (unless (member value '(nil "unspecified-fg" "unspecified-bg"))
+ (setq found value))))
+ ((consp face)
+ (setq found (cond ((and attribute-unnamed
+ (memq attribute-unnamed face))
+ (cdr (memq attribute-unnamed face)))
+ ((memq attribute face) (cadr (memq attribute face))))))))
+ (or found
+ (face-attribute 'default attribute))))
(defun foreground-color-at-point ()
"Return the foreground color of the character after point."
- ;; `face-at-point' alone is not sufficient. It only gets named faces.
- ;; Need also pick up any face properties that are not associated with named faces.
- (let ((face (or (face-at-point)
- (get-char-property (point) 'read-face-name)
- (get-char-property (point) 'face))))
- (cond ((and face (symbolp face))
- (let ((value (face-foreground face nil 'default)))
- (if (member value '("unspecified-fg" "unspecified-bg"))
- nil
- value)))
- ((consp face)
- (cond ((memq 'foreground-color face) (cdr (memq 'foreground-color face)))
- ((memq ':foreground face) (cadr (memq ':foreground face)))))
- (t nil)))) ; Invalid face value.
+ (faces--attribute-at-point :foreground 'foreground-color))
(defun background-color-at-point ()
"Return the background color of the character after point."
- ;; `face-at-point' alone is not sufficient. It only gets named faces.
- ;; Need also pick up any face properties that are not associated with named faces.
- (let ((face (or (face-at-point)
- (get-char-property (point) 'read-face-name)
- (get-char-property (point) 'face))))
- (cond ((and face (symbolp face))
- (let ((value (face-background face nil 'default)))
- (if (member value '("unspecified-fg" "unspecified-bg"))
- nil
- value)))
- ((consp face)
- (cond ((memq 'background-color face) (cdr (memq 'background-color face)))
- ((memq ':background face) (cadr (memq ':background face)))))
- (t nil)))) ; Invalid face value.
+ (faces--attribute-at-point :background 'background-color))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"Create and return a frame with frame parameters PARAMETERS.
If PARAMETERS specify a frame name, handle X geometry resources
for that name. If PARAMETERS includes a `reverse' parameter, or
-the X resource ``reverseVideo'' is present, handle that."
+the X resource \"reverseVideo\" is present, handle that."
(setq parameters (x-handle-named-frame-geometry parameters))
(let* ((params (copy-tree parameters))
(visibility-spec (assq 'visibility parameters))
"The basic fixed-pitch face."
:group 'basic-faces)
+(defface fixed-pitch-serif
+ '((t :family "Monospace Serif"))
+ "The basic fixed-pitch face with serifs."
+ :group 'basic-faces)
+
(defface variable-pitch
- '((t :family "Sans Serif"))
+ '((((type w32))
+ ;; This is a kludgy workaround for an issue discussed in
+ ;; http://lists.gnu.org/archive/html/emacs-devel/2016-04/msg00746.html.
+ :font "-outline-Arial-normal-normal-normal-sans-*-*-*-*-p-*-iso8859-1")
+ (t :family "Sans Serif"))
"The basic variable-pitch face."
:group 'basic-faces)
:group 'basic-faces
:version "22.1")
+(defface nobreak-hyphen
+ '((((background dark)) :foreground "cyan")
+ (((type pc)) :foreground "magenta")
+ (t :foreground "brown"))
+ "Face for displaying nobreak hyphens."
+ :group 'basic-faces
+ :version "25.2")
+
(defgroup mode-line-faces nil
"Faces used in the mode line."
:group 'mode-line
:version "22.1"
:group 'mode-line-faces
:group 'basic-faces)
-(define-obsolete-face-alias 'modeline-inactive 'mode-line-inactive "22.1")
(defface mode-line-highlight
'((((class color) (min-colors 88))
:version "22.1"
:group 'mode-line-faces
:group 'basic-faces)
-(define-obsolete-face-alias 'modeline-highlight 'mode-line-highlight "22.1")
(defface mode-line-emphasis
'((t (:weight bold)))
:version "22.1"
:group 'mode-line-faces
:group 'basic-faces)
-(define-obsolete-face-alias 'modeline-buffer-id 'mode-line-buffer-id "22.1")
(defface header-line
'((default
drawn with the `window-divider-first-pixel' face and the last
pixel line/column with the `window-divider-last-pixel' face."
:version "24.4"
- :group 'frames
+ :group 'window-divider
:group 'basic-faces)
(defface window-divider-first-pixel
not want to accentuate the first pixel line/column, set this to
the same as `window-divider' face."
:version "24.4"
- :group 'frames
+ :group 'window-divider
:group 'basic-faces)
(defface window-divider-last-pixel
not want to accentuate the last pixel line/column, set this to
the same as `window-divider' face."
:version "24.4"
- :group 'frames
+ :group 'window-divider
:group 'basic-faces)
(defface minibuffer-prompt
:version "24.1"
:group 'basic-faces)
+(defface read-multiple-choice-face
+ '((t (:inherit underline
+ :weight bold)))
+ "Face for the symbol name in Apropos output."
+ :group 'basic-faces
+ :version "25.2")
+
;; Faces for TTY menus.
(defface tty-menu-enabled-face
'((t
:background "turquoise") ; looks OK on tty (becomes cyan)
(((class color) (background dark))
:background "steelblue3") ; looks OK on tty (becomes blue)
- (((background dark))
+ (((background dark) (min-colors 4))
:background "grey50")
+ (((background light) (min-colors 4))
+ :background "gray")
(t
- :background "gray"))
+ :inherit underline))
"Face used for a matching paren."
:group 'paren-showing-faces)