From f0bf56d1ee2cd48a4e0f835d4524c31ea4da13c7 Mon Sep 17 00:00:00 2001 From: Craig Jennings Date: Mon, 15 Jun 2026 12:37:48 -0500 Subject: feat(face-diagnostic): Phase 4 render, command, and init wiring Phase 4 completes the face/font diagnostic. cj/describe-face-at-point renders cj/--face-diagnosis-at into a read-only *Face Diagnosis* buffer (cj/face-diagnostic-mode), with a region-scan mode over distinct face-runs (capped at 20) and an out-of-scope banner. It is required in init.el. The render is split into small section formatters tested on captured plists, and the command is smoke-tested and live-verified in the daemon, where it already surfaces the active auto-dim remaps. The command name is settled as cj/describe-face-at-point. The keybinding stays Craig's pick, and face-name buttons plus the module-header allowlist entry are filed as a follow-up. The spec is marked implemented and renamed to its lifecycle filename. 35 ERT tests, byte-compile clean. --- modules/face-diagnostic.el | 160 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 158 insertions(+), 2 deletions(-) (limited to 'modules') diff --git a/modules/face-diagnostic.el b/modules/face-diagnostic.el index 22f80cd98..83c81d92c 100644 --- a/modules/face-diagnostic.el +++ b/modules/face-diagnostic.el @@ -5,13 +5,18 @@ ;; ;; Layer: 4 (Added features). ;; Category: O (optional command). -;; Load shape: command-loaded (no startup side effects; pure defuns). +;; 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 no global key. +;; 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.org. +;; 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 @@ -291,5 +296,156 @@ mutation." :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)))))) + (provide 'face-diagnostic) ;;; face-diagnostic.el ends here -- cgit v1.2.3