diff options
Diffstat (limited to 'lisp/faces.el')
| -rw-r--r-- | lisp/faces.el | 286 |
1 files changed, 175 insertions, 111 deletions
diff --git a/lisp/faces.el b/lisp/faces.el index 3bd1e5db6f8..2d4b7761be6 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -46,7 +46,8 @@ the terminal-initialization file to be loaded." ("vt320" . "vt200") ("vt400" . "vt200") ("vt420" . "vt200") - ("alacritty" . "xterm")) + ("alacritty" . "xterm") + ("foot" . "xterm")) "Alist of terminal type aliases. Entries are of the form (TYPE . ALIAS), where both elements are strings. This means to treat a terminal of type TYPE as if it were of type ALIAS." @@ -88,9 +89,9 @@ a font height that isn't optimal." :tag "Font selection order" :type '(list symbol symbol symbol symbol) :group 'font-selection - :set #'(lambda (symbol value) - (set-default symbol value) - (internal-set-font-selection-order value))) + :set (lambda (symbol value) + (set-default symbol value) + (internal-set-font-selection-order value))) ;; In the absence of Fontconfig support, Monospace and Sans Serif are @@ -140,9 +141,9 @@ ALTERNATIVE2 etc." :tag "Alternative font families to try" :type '(repeat (repeat string)) :group 'font-selection - :set #'(lambda (symbol value) - (set-default symbol value) - (internal-set-alternative-font-family-alist value))) + :set (lambda (symbol value) + (set-default symbol value) + (internal-set-alternative-font-family-alist value))) ;; This is defined originally in xfaces.c. @@ -167,9 +168,9 @@ REGISTRY, ALTERNATIVE1, ALTERNATIVE2, and etc." :type '(repeat (repeat string)) :version "21.1" :group 'font-selection - :set #'(lambda (symbol value) - (set-default symbol value) - (internal-set-alternative-font-registry-alist value))) + :set (lambda (symbol value) + (set-default symbol value) + (internal-set-alternative-font-registry-alist value))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -695,8 +696,10 @@ and `?' are allowed. VALUE specifies the relative proportionate width of the font to use. It must be one of the symbols `ultra-condensed', `extra-condensed', -`condensed', `semi-condensed', `normal', `semi-expanded', `expanded', -`extra-expanded', or `ultra-expanded'. +`condensed' (a.k.a. `compressed', a.k.a. `narrow'), +`semi-condensed' (a.k.a. `demi-condensed'), `normal' (a.k.a. `medium', +a.k.a. `regular'), `semi-expanded' (a.k.a. `demi-expanded'), +`expanded', `extra-expanded', or `ultra-expanded' (a.k.a. `wide'). `:height' @@ -711,9 +714,12 @@ for it to be relative to). `:weight' -VALUE specifies the weight of the font to use. It must be one of the -symbols `ultra-bold', `extra-bold', `bold', `semi-bold', `normal', -`semi-light', `light', `extra-light', `ultra-light'. +VALUE specifies the weight of the font to use. It must be one of +the symbols `ultra-heavy', `heavy' (a.k.a. `black'), +`ultra-bold' (a.k.a. `extra-bold'), `bold', +`semi-bold' (a.k.a. `demi-bold'), `medium', `normal' (a.k.a. `regular', +a.k.a. `book'), `semi-light' (a.k.a. `demi-light'), +`light', `extra-light' (a.k.a. `ultra-light'), or `thin'. `:slant' @@ -870,8 +876,8 @@ is specified, `:italic' is ignored." (defun make-face-bold (face &optional frame _noerror) "Make the font of FACE be bold, if possible. FRAME nil or not specified means change face on all frames. -Argument NOERROR is ignored and retained for compatibility. Use `set-face-attribute' for finer control of the font weight." + (declare (advertised-calling-convention (face &optional frame) "29.1")) (interactive (list (read-face-name "Make which face bold" (face-at-point t)))) (set-face-attribute face frame :weight 'bold)) @@ -879,8 +885,8 @@ Use `set-face-attribute' for finer control of the font weight." (defun make-face-unbold (face &optional frame _noerror) "Make the font of FACE be non-bold, if possible. -FRAME nil or not specified means change face on all frames. -Argument NOERROR is ignored and retained for compatibility." +FRAME nil or not specified means change face on all frames." + (declare (advertised-calling-convention (face &optional frame) "29.1")) (interactive (list (read-face-name "Make which face non-bold" (face-at-point t)))) (set-face-attribute face frame :weight 'normal)) @@ -889,8 +895,8 @@ Argument NOERROR is ignored and retained for compatibility." (defun make-face-italic (face &optional frame _noerror) "Make the font of FACE be italic, if possible. FRAME nil or not specified means change face on all frames. -Argument NOERROR is ignored and retained for compatibility. Use `set-face-attribute' for finer control of the font slant." + (declare (advertised-calling-convention (face &optional frame) "29.1")) (interactive (list (read-face-name "Make which face italic" (face-at-point t)))) (set-face-attribute face frame :slant 'italic)) @@ -898,8 +904,8 @@ Use `set-face-attribute' for finer control of the font slant." (defun make-face-unitalic (face &optional frame _noerror) "Make the font of FACE be non-italic, if possible. -FRAME nil or not specified means change face on all frames. -Argument NOERROR is ignored and retained for compatibility." +FRAME nil or not specified means change face on all frames." + (declare (advertised-calling-convention (face &optional frame) "29.1")) (interactive (list (read-face-name "Make which face non-italic" (face-at-point t)))) (set-face-attribute face frame :slant 'normal)) @@ -908,8 +914,8 @@ Argument NOERROR is ignored and retained for compatibility." (defun make-face-bold-italic (face &optional frame _noerror) "Make the font of FACE be bold and italic, if possible. FRAME nil or not specified means change face on all frames. -Argument NOERROR is ignored and retained for compatibility. Use `set-face-attribute' for finer control of font weight and slant." + (declare (advertised-calling-convention (face &optional frame) "29.1")) (interactive (list (read-face-name "Make which face bold-italic" (face-at-point t)))) (set-face-attribute face frame :weight 'bold :slant 'italic)) @@ -1069,6 +1075,9 @@ of the default face. Value is FACE." (defvar crm-separator) ; from crm.el +(defconst read-face-name-sample-text "SAMPLE" + "Text string to display as the sample text for `read-face-name'.") + (defun read-face-name (prompt &optional default multiple) "Read one or more face names, prompting with PROMPT. PROMPT should not end in a space or a colon. @@ -1085,54 +1094,72 @@ 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-message "%s (default `%s'): " prompt default) - (format "%s: " prompt))) - aliasfaces nonaliasfaces faces) - ;; Build up the completion tables. - (mapatoms (lambda (s) - (if (facep s) - (if (get s 'face-alias) - (push (symbol-name s) aliasfaces) - (push (symbol-name s) nonaliasfaces))))) - (if multiple - (progn - (dolist (face (completing-read-multiple - prompt - (completion-table-in-turn nonaliasfaces aliasfaces) - nil t nil 'face-name-history default)) - ;; Ignore elements that are not faces - ;; (for example, because DEFAULT was "all faces") - (if (facep face) (push (intern face) faces))) - (nreverse faces)) - (let ((face (completing-read - prompt - (completion-table-in-turn nonaliasfaces aliasfaces) - nil t nil 'face-name-history default))) - (if (facep face) (intern face)))))) + (let (defaults) + (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 and use them only in the + ;; "future history" retrieved via `M-n M-n ...'. + (setq defaults default 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-prompt prompt default) + (format "%s: " prompt))) + (completion-extra-properties + '(:affixation-function + (lambda (faces) + (mapcar + (lambda (face) + (list face + (concat (propertize read-face-name-sample-text + 'face face) + "\t") + "")) + faces)))) + aliasfaces nonaliasfaces faces) + ;; Build up the completion tables. + (mapatoms (lambda (s) + (if (facep s) + (if (get s 'face-alias) + (push (symbol-name s) aliasfaces) + (push (symbol-name s) nonaliasfaces))))) + (if multiple + (progn + (dolist (face (completing-read-multiple + prompt + (completion-table-in-turn nonaliasfaces aliasfaces) + nil t nil 'face-name-history default)) + ;; Ignore elements that are not faces + ;; (for example, because DEFAULT was "all faces") + (if (facep face) (push (if (stringp face) + (intern face) + face) + faces))) + (nreverse faces)) + (let ((face (completing-read + prompt + (completion-table-in-turn nonaliasfaces aliasfaces) + nil t nil 'face-name-history defaults))) + (when (facep face) (if (stringp face) + (intern face) + face))))))) ;; Not defined without X, but behind window-system test. (defvar x-bitmap-file-path) @@ -1155,42 +1182,43 @@ an integer value." (:foundry (list nil)) (:width - (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) + (mapcar (lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) font-width-table)) (:weight - (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) + (mapcar (lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) font-weight-table)) (:slant - (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) + (mapcar (lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) font-slant-table)) ((or :inverse-video :extend) - (mapcar #'(lambda (x) (cons (symbol-name x) x)) + (mapcar (lambda (x) (cons (symbol-name x) x)) (internal-lisp-face-attribute-values attribute))) ((or :underline :overline :strike-through :box) (if (window-system frame) - (nconc (mapcar #'(lambda (x) (cons (symbol-name x) x)) + (nconc (mapcar (lambda (x) (cons (symbol-name x) x)) (internal-lisp-face-attribute-values attribute)) - (mapcar #'(lambda (c) (cons c c)) + (mapcar (lambda (c) (cons c c)) (defined-colors frame))) - (mapcar #'(lambda (x) (cons (symbol-name x) x)) + (mapcar (lambda (x) (cons (symbol-name x) x)) (internal-lisp-face-attribute-values attribute)))) ((or :foreground :background) - (mapcar #'(lambda (c) (cons c c)) + (mapcar (lambda (c) (cons c c)) (defined-colors frame))) (:height 'integerp) (:stipple - (and (memq (window-system frame) '(x ns)) ; No stipple on w32 - (mapcar #'list + (and (memq (window-system frame) '(x ns pgtk haiku)) ; No stipple on w32 + (mapcar (lambda (item) + (cons item item)) (apply #'nconc (mapcar (lambda (dir) (and (file-readable-p dir) (file-directory-p dir) - (directory-files dir))) + (directory-files dir 'full))) x-bitmap-file-path))))) (:inherit (cons '("none" . nil) - (mapcar #'(lambda (c) (cons (symbol-name c) c)) + (mapcar (lambda (c) (cons (symbol-name c) c)) (face-list)))) (_ (error "Internal error"))))) @@ -1524,7 +1552,7 @@ If FRAME is nil, the current FRAME is used." match (cond ((eq req 'type) (or (memq (window-system frame) options) (and (memq 'graphic options) - (memq (window-system frame) '(x w32 ns))) + (memq (window-system frame) '(x w32 ns pgtk))) ;; FIXME: This should be revisited to use ;; display-graphic-p, provided that the ;; color selection depends on the number @@ -1726,7 +1754,15 @@ The following sources are applied in this order: (and tail (face-spec-set-2 face frame (list :extend (cadr tail)))))) (setq face-attrs (face-spec-choose (get face 'face-override-spec) frame)) - (face-spec-set-2 face frame face-attrs))) + (face-spec-set-2 face frame face-attrs) + (when (and (fboundp 'set-frame-parameter) ; This isn't available + ; during loadup. + (eq face 'scroll-bar)) + ;; Set the `scroll-bar-foreground' and `scroll-bar-background' + ;; frame parameters, because the face is handled by setting + ;; those two parameters. (bug#13476) + (set-frame-parameter frame 'scroll-bar-foreground (face-foreground face)) + (set-frame-parameter frame 'scroll-bar-background (face-background face))))) (defun face-spec-set-2 (face frame face-attrs) "Set the face attributes of FACE on FRAME according to FACE-ATTRS. @@ -1832,8 +1868,8 @@ on which one provides better contrast with COLOR." "#ffffff" "black")) (defconst color-luminance-dark-limit 0.325 - "The relative luminance below which a color is considered 'dark'. -A 'dark' color in this sense provides better contrast with white + "The relative luminance below which a color is considered \"dark\". +A \"dark\" color in this sense provides better contrast with white than with black; see `color-dark-p'. This value was determined experimentally.") @@ -2294,19 +2330,19 @@ If you set `term-file-prefix' to nil, this function does nothing." (let* (term-init-func) ;; First, load the terminal initialization file, if it is ;; available and it hasn't been loaded already. - (tty-find-type #'(lambda (type) - (let ((file (locate-library (concat term-file-prefix type)))) - (and file - (or (assoc file load-history) - (load (replace-regexp-in-string - "\\.el\\(\\.gz\\)?\\'" "" - file) - t t))))) - type) + (tty-find-type (lambda (type) + (let ((file (locate-library (concat term-file-prefix type)))) + (and file + (or (assoc file load-history) + (load (replace-regexp-in-string + "\\.el\\(\\.gz\\)?\\'" "" + file) + t t))))) + type) ;; Next, try to find a matching initialization function, and call it. - (tty-find-type #'(lambda (type) - (fboundp (setq term-init-func - (intern (concat "terminal-init-" type))))) + (tty-find-type (lambda (type) + (fboundp (setq term-init-func + (intern (concat "terminal-init-" type))))) type) (when (fboundp term-init-func) (funcall term-init-func)) @@ -2389,6 +2425,15 @@ If you set `term-file-prefix' to nil, this function does nothing." "The basic variable-pitch face." :group 'basic-faces) +(defface variable-pitch-text + '((t :inherit variable-pitch + :height 1.1)) + "The proportional face used for longer texts. +This is like the `variable-pitch' face, but is slightly bigger by +default." + :version "29.1" + :group 'basic-faces) + (defface shadow '((((class color grayscale) (min-colors 88) (background light)) :foreground "grey50") @@ -2622,11 +2667,21 @@ non-nil." :background "grey75" :foreground "black") (t :inverse-video t)) - "Basic mode line face for selected window." + "Face for the mode lines as well as header lines. +See `mode-line-active' and `mode-line-inactive' for the faces +used on mode lines." :version "21.1" :group 'mode-line-faces :group 'basic-faces) +(defface mode-line-active + '((t :inherit mode-line)) + "Face for the selected mode line. +This inherits from the `mode-line' face." + :version "29.1" + :group 'mode-line-faces + :group 'basic-faces) + (defface mode-line-inactive '((default :inherit mode-line) @@ -2791,11 +2846,9 @@ used to display the prompt text." :group 'frames :group 'basic-faces) -(defface scroll-bar - '((((background light)) :foreground "black") - (((background dark)) :foreground "white")) +(defface scroll-bar '((t nil)) "Basic face for the scroll bar colors under X." - :version "28.1" + :version "21.1" :group 'frames :group 'basic-faces) @@ -2830,7 +2883,10 @@ Note: Other faces cannot inherit from the cursor face." '((default :box (:line-width 1 :style released-button) :foreground "black") - (((type x w32 ns) (class color)) + (((type haiku)) + :foreground "B_MENU_ITEM_TEXT_COLOR" + :background "B_MENU_BACKGROUND_COLOR") + (((type x w32 ns pgtk) (class color)) :background "grey75") (((type x) (class mono)) :background "grey")) @@ -2886,14 +2942,22 @@ Note: Other faces cannot inherit from the cursor face." :background "grey96" :foreground "DarkBlue" ;; We use negative thickness of the horizontal box border line to ;; avoid enlarging the height of the echo-area display, which - ;; would then move the mode line a few pixels up. - :box (:line-width (1 . -1) :color "grey80")) + ;; would then move the mode line a few pixels up. We use + ;; negative thickness for the vertical border line to avoid + ;; making the characters wider, which then would cause unpleasant + ;; horizontal shifts of the cursor during C-n/C-p movement + ;; through a line with this face. + :box (:line-width (-1 . -1) :color "grey80") + :inherit fixed-pitch) (((class color) (min-colors 88) (background dark)) :background "grey19" :foreground "LightBlue" - :box (:line-width (1 . -1) :color "grey35")) - (((class color grayscale) (background light)) :background "grey90") - (((class color grayscale) (background dark)) :background "grey25") - (t :background "grey90")) + :box (:line-width (-1 . -1) :color "grey35") + :inherit fixed-pitch) + (((class color grayscale) (background light)) :background "grey90" + :inherit fixed-pitch) + (((class color grayscale) (background dark)) :background "grey25" + :inherit fixed-pitch) + (t :background "grey90" :inherit fixed-pitch)) "Face for keybindings in *Help* buffers. This face is added by `substitute-command-keys', which see. @@ -2945,7 +3009,7 @@ It is used for characters of no fonts too." :group 'basic-faces) (defface read-multiple-choice-face - '((t (:inherit underline + '((t (:inherit (help-key-binding underline) :weight bold))) "Face for the symbol name in `read-multiple-choice' output." :group 'basic-faces |