diff options
Diffstat (limited to 'modules/face-diagnostic.el')
| -rw-r--r-- | modules/face-diagnostic.el | 456 |
1 files changed, 456 insertions, 0 deletions
diff --git a/modules/face-diagnostic.el b/modules/face-diagnostic.el new file mode 100644 index 000000000..6b1b547f1 --- /dev/null +++ b/modules/face-diagnostic.el @@ -0,0 +1,456 @@ +;;; face-diagnostic.el --- Diagnose the face and font at point -*- lexical-binding: t; coding: utf-8; -*- +;; author Craig Jennings <c@cjennings.net> + +;;; Commentary: +;; +;; Layer: 4 (Added features). +;; Category: O (optional command). +;; Load shape: eager. +;; Eager reason: none; a diagnostic command, a command-loaded deferral candidate. +;; Top-level side effects: defines cj/face-diagnostic-mode and the +;; cj/describe-face-at-point command; binds it to C-h F in help-map. +;; Runtime requires: seq. +;; Direct test load: yes (the pure core is tested by requiring this module). +;; +;; A read-only diagnostic for "why does the character at point paint this way?" +;; It separates the face stack by source (text properties, overlays, active +;; remaps, the default) and -- in later phases -- the merged attributes, the +;; real font versus the declared family, and per-face theme/config/inherit +;; provenance. See docs/specs/face-font-diagnostic-popup-spec-implemented.org. +;; +;; This file is Phase 1: the pure read model. `cj/--face-diagnosis-at' returns +;; a plist with the buffer classification, the character context, and the face +;; stack by source. No prompts, no display -- the interactive command and the +;; rendering land in a later phase. + +;;; Code: + +(require 'seq) + +;; ------------------------------ Buffer classify ------------------------------ + +(defun cj/--face-diag-classify-buffer (&optional buffer) + "Classify BUFFER (default current) for face-diagnosis scope. +Return one of `theme-faced', `terminal-ansi', `document-shr', or +`image-no-text', from the major mode. Out-of-scope buckets get a banner and a +best-effort dump rather than a full provenance trace." + (with-current-buffer (or buffer (current-buffer)) + (cond + ((derived-mode-p 'term-mode 'comint-mode 'eshell-mode 'ghostel-mode) + 'terminal-ansi) + ((derived-mode-p 'eww-mode 'nov-mode 'elfeed-show-mode 'mu4e-view-mode) + 'document-shr) + ((derived-mode-p 'image-mode 'doc-view-mode 'pdf-view-mode) + 'image-no-text) + (t 'theme-faced)))) + +;; ----------------------------- Character context ----------------------------- + +(defun cj/--face-diag-char-context (pos &optional buffer) + "Return a plist for the character at POS in BUFFER, or nil when there is none. +Keys: :char (the character), :codepoint (its integer value), :name (the Unicode +name string or nil), :script (the script symbol or nil)." + (with-current-buffer (or buffer (current-buffer)) + (let ((ch (char-after pos))) + (when ch + (list :char ch + :codepoint ch + :name (get-char-code-property ch 'name) + :script (aref char-script-table ch)))))) + +;; ------------------------------- Face stack ---------------------------------- + +(defun cj/--face-diag-normalize-faces (val) + "Normalize a `face'-style property VAL into a list of faces or specs. +A face symbol or an anonymous (:attr val ...) plist becomes a one-element list; +a list of faces is returned as-is; nil becomes nil." + (cond + ((null val) nil) + ((symbolp val) (list val)) + ((keywordp (car-safe val)) (list val)) ; anonymous spec, e.g. (:foreground "red") + ((listp val) val) + (t (list val)))) + +(defun cj/--face-diag-text-property-faces (pos &optional buffer) + "Return the faces from the `face' and `font-lock-face' props at POS in BUFFER. +The two properties are concatenated in that order, each normalized to a list." + (with-current-buffer (or buffer (current-buffer)) + (let ((result '())) + (dolist (prop '(face font-lock-face)) + (setq result (append result + (cj/--face-diag-normalize-faces + (get-text-property pos prop))))) + result))) + +(defun cj/--face-diag-overlay-faces (pos &optional buffer) + "Return overlay face entries covering POS in BUFFER, highest priority first. +Each entry is a plist with :face, :priority (number or nil), and :overlay. +Overlays without a `face' property are skipped." + (with-current-buffer (or buffer (current-buffer)) + (let ((entries + (delq nil + (mapcar + (lambda (ov) + (let ((face (overlay-get ov 'face))) + (when face + (list :face face + :priority (overlay-get ov 'priority) + :overlay ov)))) + (overlays-at pos))))) + (sort entries + (lambda (a b) + (> (or (plist-get a :priority) 0) + (or (plist-get b :priority) 0))))))) + +(defun cj/--face-diag-active-remaps (faces &optional buffer) + "Return the `face-remapping-alist' entries in BUFFER that remap any of FACES. +FACES is a list of face symbols from the stack. Each result is the raw +\(FACE . SPEC) entry from the alist." + (with-current-buffer (or buffer (current-buffer)) + (seq-filter (lambda (entry) (memq (car-safe entry) faces)) + face-remapping-alist))) + +(defun cj/--face-diag-stack (pos &optional buffer) + "Return the face stack at POS in BUFFER as a plist separated by source. +Keys: :text-property (list of faces/specs), :overlays (list of plists), +:remaps (matching `face-remapping-alist' entries), :default (the symbol +`default')." + (let* ((tp (cj/--face-diag-text-property-faces pos buffer)) + (ov (cj/--face-diag-overlay-faces pos buffer)) + (stack-syms + (append (seq-filter #'symbolp tp) + (delq nil (mapcar (lambda (e) + (let ((f (plist-get e :face))) + (and (symbolp f) f))) + ov)) + '(default)))) + (list :text-property tp + :overlays ov + :remaps (cj/--face-diag-active-remaps stack-syms buffer) + :default 'default))) + +;; -------------------------- Effective merged attributes ---------------------- +;; Emacs exposes no single call for the final merged attribute plist at a +;; position (the C redisplay engine merges text-prop + overlay faces, applies +;; remaps, and picks a font). The core folds the ordered, remap-expanded spec +;; list itself and labels the result "computed": exotic relative-height or deep +;; :inherit cases may diverge slightly from the engine. + +(defconst cj/--face-diag-attributes + '(:family :height :weight :slant :foreground :background + :underline :overline :strike-through :box :inverse-video) + "Face attributes reported in the effective-merge group, in display order.") + +(defun cj/--face-diag-spec-attr (spec attr) + "Return ATTR's value from a single face SPEC, or the symbol `unspecified'. +A face symbol resolves through `face-attribute' (following :inherit); an +attribute plist is read directly; anything else is `unspecified'." + (cond + ((and spec (symbolp spec)) (face-attribute spec attr nil t)) + ((and (consp spec) (keywordp (car spec))) + (if (plist-member spec attr) (plist-get spec attr) 'unspecified)) + (t 'unspecified))) + +(defun cj/--face-diag-remap-specs (face &optional buffer) + "Return the remap specs for FACE from `face-remapping-alist' in BUFFER, or nil. +Only symbol faces are looked up. The remapping is normalized to a list of +specs: a lone face symbol or an attribute plist becomes a one-element list." + (with-current-buffer (or buffer (current-buffer)) + (when (symbolp face) + (let ((entry (assq face face-remapping-alist))) + (when entry + (let ((remap (cdr entry))) + (cond + ((null remap) nil) + ((keywordp (car-safe remap)) (list remap)) ; (:attr val ...) + ((listp remap) remap) ; (spec spec ...) + (t (list remap))))))))) ; a lone face symbol + +(defun cj/--face-diag-ordered-specs (pos &optional buffer) + "Return the ordered face specs at POS in BUFFER, highest priority first. +Overlay faces (priority descending), then text-property faces, then the +default. Each contributing face's remap specs come ahead of the face itself, +mirroring how a remap overrides its base." + (let ((bases (append (mapcar (lambda (e) (plist-get e :face)) + (cj/--face-diag-overlay-faces pos buffer)) + (cj/--face-diag-text-property-faces pos buffer) + '(default))) + (specs '())) + (dolist (face bases) + (setq specs (append specs + (cj/--face-diag-remap-specs face buffer) + (list face)))) + specs)) + +(defun cj/--face-diag-merged-attributes (pos &optional buffer) + "Return the computed effective attribute plist at POS in BUFFER. +For each attribute the first non-`unspecified' value down the ordered, +remap-expanded spec list wins; if none specifies it the value is `unspecified'." + (let ((specs (cj/--face-diag-ordered-specs pos buffer)) + (result '())) + (dolist (attr cj/--face-diag-attributes) + (let ((found (seq-some (lambda (spec) + (let ((v (cj/--face-diag-spec-attr spec attr))) + (unless (eq v 'unspecified) (list v)))) + specs))) + (setq result (append result (list attr (if found (car found) 'unspecified)))))) + result)) + +;; ------------------------------- Real font ----------------------------------- + +(defun cj/--face-diag-real-font (pos &optional buffer) + "Return a plist for the font actually used at POS in BUFFER. +Keys: :font (the font's name, or \"unavailable\") and :family (its family or +nil). `font-at' is nil in batch and on text terminals, reported as +\"unavailable\" rather than an error -- this exposes fontset substitution when +the real family differs from the merged :family." + (with-current-buffer (or buffer (current-buffer)) + (let ((font (ignore-errors (font-at pos)))) + (if (null font) + (list :font "unavailable" :family nil) + (list :font (or (ignore-errors (font-get font :name)) + (ignore-errors (aref (query-font font) 0)) + "unknown") + :family (ignore-errors (font-get font :family))))))) + +;; ------------------------------ Provenance ----------------------------------- +;; Where a named face's attributes come from: which themes set it, whether +;; config saved/customized it, its :inherit chain, and which attributes stay +;; unspecified so they fall through to the default. The theme-face and +;; saved-face properties are version-sensitive internals, read behind small +;; accessors and treated as absent rather than erroring when missing. + +(defun cj/--face-diag-face-themes (face) + "Return the themes that set FACE, newest first, from its `theme-face' property." + (when (symbolp face) + (mapcar #'car (get face 'theme-face)))) + +(defun cj/--face-diag-config-source (face) + "Return how config set FACE: `saved', `customized', or nil. +`saved' is a persisted customize (saved-face); `customized' is an unsaved +customize this session. A plain `set-face-attribute' leaves no marker and so +reads as nil." + (cond + ((get face 'saved-face) 'saved) + ((get face 'customized-face) 'customized) + (t nil))) + +(defun cj/--face-diag-inherit-chain (face) + "Return FACE's :inherit chain as a list of faces, nearest first. +Follows single-symbol :inherit links, guarding against cycles; a list-valued +:inherit is recorded and the walk stops there." + (let ((chain '()) (cur face) (seen '())) + (while (and cur (symbolp cur) (facep cur) (not (memq cur seen))) + (push cur seen) + (let ((inh (face-attribute cur :inherit nil))) + (cond + ((or (null inh) (eq inh 'unspecified)) (setq cur nil)) + ((symbolp inh) (setq chain (append chain (list inh))) (setq cur inh)) + ((listp inh) (setq chain (append chain inh)) (setq cur nil)) + (t (setq cur nil))))) + chain)) + +(defun cj/--face-diag-unspecified-attrs (face) + "Return attributes still unspecified on FACE after inherit-following. +These fall through to the default face -- the direct read on an +\"attribute never set\" bug like the all-white elfeed case." + (when (facep face) + (seq-filter (lambda (attr) + (eq (face-attribute face attr nil t) 'unspecified)) + cj/--face-diag-attributes))) + +(defun cj/--face-diag-face-provenance (face) + "Return the provenance plist for the named FACE. +Keys: :face, :themes (list), :config (`saved'/`customized'/nil), +:inherit-chain (list of faces), :unspecified (attributes falling to default)." + (list :face face + :themes (cj/--face-diag-face-themes face) + :config (cj/--face-diag-config-source face) + :inherit-chain (cj/--face-diag-inherit-chain face) + :unspecified (cj/--face-diag-unspecified-attrs face))) + +(defun cj/--face-diag-provenance (pos &optional buffer) + "Return per-face provenance for the named faces in the stack at POS in BUFFER. +A list of provenance plists for the distinct real faces contributing at POS: +text-property and overlay face symbols, then the default." + (let* ((tp (seq-filter #'symbolp (cj/--face-diag-text-property-faces pos buffer))) + (ov (delq nil (mapcar (lambda (e) + (let ((f (plist-get e :face))) + (and (symbolp f) f))) + (cj/--face-diag-overlay-faces pos buffer)))) + (faces (seq-filter #'facep (seq-uniq (append ov tp '(default)))))) + (mapcar #'cj/--face-diag-face-provenance faces))) + +;; ------------------------------- Assembled core ------------------------------ + +(defun cj/--face-diagnosis-at (pos &optional buffer) + "Return the face-diagnosis plist for POS in BUFFER (groups 0-5). +Keys: :classification (symbol), :char (plist or nil at end-of-buffer), :stack +\(plist), :attributes (computed merged plist), :font (real-font plist), +:provenance (per-face list). Pure: no prompts, no display, no buffer or frame +mutation." + (list :classification (cj/--face-diag-classify-buffer buffer) + :char (cj/--face-diag-char-context pos buffer) + :stack (cj/--face-diag-stack pos buffer) + :attributes (cj/--face-diag-merged-attributes pos buffer) + :font (cj/--face-diag-real-font pos buffer) + :provenance (cj/--face-diag-provenance pos buffer))) + +;; ------------------------------- Rendering ----------------------------------- + +(defun cj/--face-diag-render-banner (classification) + "Return a one-line banner for an out-of-scope CLASSIFICATION, or \"\"." + (pcase classification + ('terminal-ansi + "NOTE: terminal buffer -- colors come from the ANSI palette, not the theme.\n\n") + ('document-shr + "NOTE: document buffer -- colors come from the rendered document, not the theme.\n\n") + ('image-no-text + "NOTE: image/no-text buffer -- little face information applies here.\n\n") + (_ ""))) + +(defun cj/--face-diag-render-char (char) + "Render the CHAR context plist as a line, or a no-character notice." + (if (null char) + "Character: none at point.\n\n" + (format "Character: %S (U+%04X %s, script: %s)\n\n" + (plist-get char :char) + (plist-get char :codepoint) + (or (plist-get char :name) "no name") + (or (plist-get char :script) "none")))) + +(defun cj/--face-diag-render-faces (faces) + "Render a list of FACES (symbols or specs) comma-separated, or \"(none)\"." + (if faces (mapconcat (lambda (f) (format "%s" f)) faces ", ") "(none)")) + +(defun cj/--face-diag-render-stack (stack) + "Render the STACK plist (faces by source) as a block." + (concat + "Face stack (highest priority first):\n" + (format " text properties: %s\n" + (cj/--face-diag-render-faces (plist-get stack :text-property))) + (format " overlays: %s\n" + (let ((ov (plist-get stack :overlays))) + (if ov + (mapconcat (lambda (e) + (format "%s (priority %s)" + (plist-get e :face) + (or (plist-get e :priority) "nil"))) + ov ", ") + "(none)"))) + (format " active remaps: %s\n" + (let ((rm (plist-get stack :remaps))) + (if rm (mapconcat (lambda (e) (format "%s" (car e))) rm ", ") "(none)"))) + " default: default\n\n")) + +(defun cj/--face-diag-render-attributes (attrs) + "Render the merged ATTRS plist as a block." + (concat + "Effective attributes (computed):\n" + (mapconcat (lambda (attr) (format " %s: %s" attr (plist-get attrs attr))) + cj/--face-diag-attributes "\n") + "\n\n")) + +(defun cj/--face-diag-render-font (font attrs) + "Render the real FONT plist beside the merged ATTRS declared :family." + (let ((real (plist-get font :font)) + (declared (plist-get attrs :family)) + (real-family (plist-get font :family))) + (concat + (format "Real font: %s\n" real) + (format "Declared family: %s\n" declared) + (if (and (stringp real-family) (stringp declared) + (not (string-equal-ignore-case real-family declared))) + (format " (substituted: real family %s differs from declared %s)\n\n" + real-family declared) + "\n")))) + +(defun cj/--face-diag-render-provenance (prov) + "Render the per-face PROV list as a block." + (concat + "Provenance:\n" + (if prov + (mapconcat + (lambda (p) + (format (concat " %s\n themes: %s\n config: %s\n" + " inherits: %s\n unspecified (-> default): %s") + (plist-get p :face) + (or (plist-get p :themes) "(none)") + (or (plist-get p :config) "(none)") + (or (plist-get p :inherit-chain) "(none)") + (or (plist-get p :unspecified) "(none)"))) + prov "\n") + " (no named faces)") + "\n")) + +(defun cj/--face-diag-render (diag) + "Render the face-diagnosis DIAG plist into a report string." + (concat + (cj/--face-diag-render-banner (plist-get diag :classification)) + (cj/--face-diag-render-char (plist-get diag :char)) + (cj/--face-diag-render-stack (plist-get diag :stack)) + (cj/--face-diag-render-attributes (plist-get diag :attributes)) + (cj/--face-diag-render-font (plist-get diag :font) (plist-get diag :attributes)) + (cj/--face-diag-render-provenance (plist-get diag :provenance)))) + +;; ------------------------------- Region mode --------------------------------- + +(defun cj/--face-diag-run-starts (beg end) + "Return the positions in [BEG, END) where the `face' property run begins." + (let ((pos beg) (starts (list beg))) + (while (and (setq pos (next-single-property-change pos 'face nil end)) + (< pos end)) + (push pos starts)) + (nreverse starts))) + +(defun cj/--face-diag-render-region (beg end) + "Render a diagnosis for each distinct face-run in [BEG, END), capped at 20." + (let* ((starts (cj/--face-diag-run-starts beg end)) + (cap 20) + (shown (seq-take starts cap))) + (concat + (mapconcat (lambda (pos) + (concat (format "=== position %d ===\n" pos) + (cj/--face-diag-render (cj/--face-diagnosis-at pos)))) + shown "\n") + (when (> (length starts) cap) + (format "\n... %d more face-runs not shown (cap %d).\n" + (- (length starts) cap) cap))))) + +;; ------------------------------- Command ------------------------------------- + +(define-derived-mode cj/face-diagnostic-mode special-mode "Face-Diag" + "Major mode for the read-only face/font diagnosis report.") + +(defun cj/--face-diag-display (report) + "Show REPORT in the read-only *Face Diagnosis* buffer; return the buffer." + (let ((buf (get-buffer-create "*Face Diagnosis*"))) + (with-current-buffer buf + (cj/face-diagnostic-mode) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert report) + (goto-char (point-min)))) + (display-buffer buf) + buf)) + +(defun cj/describe-face-at-point () + "Pop up a read-only diagnosis of the face and font at point. +With an active region, diagnose each distinct face-run in the region. The +report separates the face stack by source, shows the computed merged +attributes, the real font versus the declared family, and per-face +theme/config/inherit provenance. Read-only; never mutates buffer or frame. +See docs/specs/face-font-diagnostic-popup-spec-implemented.org." + (interactive) + (cj/--face-diag-display + (if (use-region-p) + (cj/--face-diag-render-region (region-beginning) (region-end)) + (cj/--face-diag-render (cj/--face-diagnosis-at (point)))))) + +;; Bound on C-h F (Face) in the help cluster. This shadows helpful-function, +;; which also sits on C-h F here; face-diagnostic loads after help-config, so +;; this binding wins. +(keymap-set help-map "F" #'cj/describe-face-at-point) + +(provide 'face-diagnostic) +;;; face-diagnostic.el ends here |