feat(face-diagnostic): Phase 1 pure read model for the face/font diagnostic

modules/face-diagnostic.el carries the Phase 1 core of the face-at-point diagnostic: cj/--face-diagnosis-at returns a plist with the buffer classification (theme-faced / terminal-ansi / document-shr / image-no-text), the character context (char, codepoint, Unicode name, script), and the face stack separated by source (text-property faces, overlays by priority, active face-remapping-alist entries, default). Built from small pure helpers, no display or prompts. 17 ERT tests cover Normal/Boundary/Error per helper. Not yet wired into init.el; the interactive command, rendering, and keybinding land in Phase 4. Spec: docs/specs/face-font-diagnostic-popup-spec.org.

3 files changed, 315 insertions, 2 deletions

diff --git a/modules/face-diagnostic.el b/modules/face-diagnostic.el
new file mode 100644
index 000000000..16ba57e44
--- /dev/null
+++ b/modules/face-diagnostic.el
@@ -0,0 +1,138 @@
+;;; 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: command-loaded (no startup side effects; pure defuns).
+;;
+;; 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.
+;;
+;; 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)))
+
+;; ------------------------------- Assembled core ------------------------------
+
+(defun cj/--face-diagnosis-at (pos &optional buffer)
+  "Return the face-diagnosis plist for POS in BUFFER (Phase 1: groups 0-2).
+Keys: :classification (symbol), :char (plist or nil at end-of-buffer), :stack
+\(plist).  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)))
+
+(provide 'face-diagnostic)
+;;; face-diagnostic.el ends here
diff --git a/tests/test-face-diagnostic.el b/tests/test-face-diagnostic.el
new file mode 100644
index 000000000..7e7c7a740
--- /dev/null
+++ b/tests/test-face-diagnostic.el
@@ -0,0 +1,167 @@
+;;; test-face-diagnostic.el --- Tests for the Phase 1 face-diagnosis core -*- lexical-binding: t; -*-
+
+;;; Commentary:
+;; Tests for the pure read model of the face/font diagnostic (Phase 1):
+;; buffer classification, character context, and the face stack separated by
+;; source.  All against temp-buffer fixtures with planted text properties,
+;; overlays, and face remaps -- no display, no prompts.
+
+;;; Code:
+
+(require 'ert)
+(require 'cl-lib)
+(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory))
+(require 'face-diagnostic)
+
+;;; cj/--face-diag-classify-buffer
+
+(ert-deftest test-face-diag-classify-theme-faced ()
+  "Normal: an ordinary buffer classifies as theme-faced."
+  (with-temp-buffer
+    (fundamental-mode)
+    (should (eq (cj/--face-diag-classify-buffer) 'theme-faced))))
+
+(ert-deftest test-face-diag-classify-terminal ()
+  "Boundary: a terminal-family mode classifies as terminal-ansi."
+  (with-temp-buffer
+    (setq major-mode 'term-mode)
+    (should (eq (cj/--face-diag-classify-buffer) 'terminal-ansi))))
+
+(ert-deftest test-face-diag-classify-document ()
+  "Boundary: an shr-rendering mode classifies as document-shr."
+  (with-temp-buffer
+    (setq major-mode 'eww-mode)
+    (should (eq (cj/--face-diag-classify-buffer) 'document-shr))))
+
+(ert-deftest test-face-diag-classify-image ()
+  "Boundary: an image/document-view mode classifies as image-no-text."
+  (with-temp-buffer
+    (setq major-mode 'image-mode)
+    (should (eq (cj/--face-diag-classify-buffer) 'image-no-text))))
+
+;;; cj/--face-diag-char-context
+
+(ert-deftest test-face-diag-char-context-normal ()
+  "Normal: an ASCII letter reports char, codepoint, name, and script."
+  (with-temp-buffer
+    (insert "A")
+    (let ((ctx (cj/--face-diag-char-context (point-min))))
+      (should (= (plist-get ctx :char) ?A))
+      (should (= (plist-get ctx :codepoint) 65))
+      (should (equal (plist-get ctx :name) "LATIN CAPITAL LETTER A"))
+      (should (eq (plist-get ctx :script) 'latin)))))
+
+(ert-deftest test-face-diag-char-context-eob-nil ()
+  "Boundary/Error: end of an empty buffer has no character, so nil."
+  (with-temp-buffer
+    (should-not (cj/--face-diag-char-context (point-max)))))
+
+;;; cj/--face-diag-normalize-faces
+
+(ert-deftest test-face-diag-normalize-faces ()
+  "Normal/Boundary: symbol, list, anonymous spec, and nil normalize correctly."
+  (should (equal (cj/--face-diag-normalize-faces 'bold) '(bold)))
+  (should (equal (cj/--face-diag-normalize-faces '(bold italic)) '(bold italic)))
+  (should (equal (cj/--face-diag-normalize-faces '(:foreground "red"))
+                 '((:foreground "red"))))
+  (should-not (cj/--face-diag-normalize-faces nil)))
+
+;;; cj/--face-diag-text-property-faces
+
+(ert-deftest test-face-diag-text-property-faces-symbol ()
+  "Normal: a `face' property symbol appears in the list."
+  (with-temp-buffer
+    (insert (propertize "x" 'face 'bold))
+    (should (equal (cj/--face-diag-text-property-faces (point-min)) '(bold)))))
+
+(ert-deftest test-face-diag-text-property-faces-includes-font-lock ()
+  "Normal: `face' and `font-lock-face' are both collected, face first."
+  (with-temp-buffer
+    (insert (propertize "x" 'face 'bold 'font-lock-face 'italic))
+    (should (equal (cj/--face-diag-text-property-faces (point-min)) '(bold italic)))))
+
+(ert-deftest test-face-diag-text-property-faces-none ()
+  "Boundary: unpropertized text yields no faces."
+  (with-temp-buffer
+    (insert "x")
+    (should-not (cj/--face-diag-text-property-faces (point-min)))))
+
+;;; cj/--face-diag-overlay-faces
+
+(ert-deftest test-face-diag-overlay-faces-sorted-by-priority ()
+  "Normal: overlay faces are returned highest priority first."
+  (with-temp-buffer
+    (insert "xyz")
+    (let ((lo (make-overlay 1 3))
+          (hi (make-overlay 1 3)))
+      (overlay-put lo 'face 'region)
+      (overlay-put lo 'priority 1)
+      (overlay-put hi 'face 'highlight)
+      (overlay-put hi 'priority 10)
+      (let ((entries (cj/--face-diag-overlay-faces 1)))
+        (should (= (length entries) 2))
+        (should (eq (plist-get (car entries) :face) 'highlight))
+        (should (eq (plist-get (cadr entries) :face) 'region))))))
+
+(ert-deftest test-face-diag-overlay-faces-skips-faceless ()
+  "Boundary: an overlay without a `face' property is excluded."
+  (with-temp-buffer
+    (insert "xyz")
+    (let ((ov (make-overlay 1 3)))
+      (overlay-put ov 'help-echo "no face here")
+      (should-not (cj/--face-diag-overlay-faces 1)))))
+
+;;; cj/--face-diag-active-remaps
+
+(ert-deftest test-face-diag-active-remaps-matches-stack ()
+  "Normal: a remap of a stack face is returned; an unrelated remap is not."
+  (with-temp-buffer
+    (setq face-remapping-alist '((default :background "#111111")
+                                 (link :foreground "#222222")))
+    (let ((remaps (cj/--face-diag-active-remaps '(default))))
+      (should (assq 'default remaps))
+      (should-not (assq 'link remaps)))))
+
+(ert-deftest test-face-diag-active-remaps-empty ()
+  "Boundary: no remapping alist yields no entries."
+  (with-temp-buffer
+    (setq face-remapping-alist nil)
+    (should-not (cj/--face-diag-active-remaps '(default)))))
+
+;;; cj/--face-diag-stack
+
+(ert-deftest test-face-diag-stack-assembles-sources ()
+  "Normal: the stack carries text-property, overlay, remap, and default sources."
+  (with-temp-buffer
+    (insert (propertize "x" 'face 'bold))
+    (setq face-remapping-alist '((default :background "#111111")))
+    (let ((ov (make-overlay 1 2)))
+      (overlay-put ov 'face 'region)
+      (let ((stack (cj/--face-diag-stack 1)))
+        (should (equal (plist-get stack :text-property) '(bold)))
+        (should (eq (plist-get (car (plist-get stack :overlays)) :face) 'region))
+        (should (assq 'default (plist-get stack :remaps)))
+        (should (eq (plist-get stack :default) 'default))))))
+
+;;; cj/--face-diagnosis-at
+
+(ert-deftest test-face-diagnosis-at-shape ()
+  "Normal: the assembled core returns classification, char, and stack."
+  (with-temp-buffer
+    (fundamental-mode)
+    (insert (propertize "A" 'face 'bold))
+    (let ((diag (cj/--face-diagnosis-at (point-min))))
+      (should (eq (plist-get diag :classification) 'theme-faced))
+      (should (= (plist-get (plist-get diag :char) :char) ?A))
+      (should (equal (plist-get (plist-get diag :stack) :text-property) '(bold))))))
+
+(ert-deftest test-face-diagnosis-at-eob-char-nil ()
+  "Boundary: at end of an empty buffer the char group is nil, stack still present."
+  (with-temp-buffer
+    (fundamental-mode)
+    (let ((diag (cj/--face-diagnosis-at (point-max))))
+      (should-not (plist-get diag :char))
+      (should (eq (plist-get (plist-get diag :stack) :default) 'default)))))
+
+(provide 'test-face-diagnostic)
+;;; test-face-diagnostic.el ends here
diff --git a/todo.org b/todo.org
index 6a6765fde..d041ea5fd 100644
--- a/todo.org
+++ b/todo.org
@@ -44,8 +44,16 @@ Tags are additive. For example, a small wrong-behavior fix can be
 =:bug:quick:=, and a feature that requires internal restructuring can be
 =:feature:refactor:=.
 * Emacs Open Work
-** TODO [#A] Face and font diagnostic popup at point :feature:
-Read-only popup diagnosing why text at point paints as it does (face stack by source, merged attributes, real font vs declared family, theme/config/inherit provenance). Spec: [[id:98f065cf-8bd5-46a0-ac24-da94d66855ad][face-font-diagnostic-popup-spec.org]] (draft, one open decision). From the roam inbox — "do this one first."
+** PROJECT [#A] Face and font diagnostic popup at point :feature:
+Read-only popup diagnosing why text at point paints as it does (face stack by source, merged attributes, real font vs declared family, theme/config/inherit provenance). Spec: [[id:98f065cf-8bd5-46a0-ac24-da94d66855ad][face-font-diagnostic-popup-spec.org]]. Building in modules/face-diagnostic.el: pure core cj/--face-diagnosis-at returns the report plist; cj/describe-face-at-point renders it into a read-only help buffer. From the roam inbox — "do this one first."
+*** 2026-06-15 Mon @ 12:19:41 -0500 Phase 1 — core read model + buffer classifier landed
+modules/face-diagnostic.el: cj/--face-diagnosis-at returns groups 0-2 (buffer classification, character context, face stack by source) via small pure helpers. 17 ERT tests (tests/test-face-diagnostic.el), byte-compile clean. Not yet wired into init.el; the interactive command and keybinding land in Phase 4.
+*** TODO Phase 2 — merged attributes + real font
+Extend the core with group 3 (effective merged attributes, hand-folded and validated against describe-char on three fixtures: auto-dim default remap, overlay-with-priority, unspecified-inherit face) and group 4 (font-at real font vs declared :family, "unavailable" under batch). Settles spec decision #7.
+*** TODO Phase 3 — provenance trace
+Add group 5: per-face theme/config/inherit provenance and the unspecified->fallback resolution, behind small accessors isolating the theme-face / saved-face internals. Fixtures: a face set via a loaded theme, via set-face-attribute, and one attribute left unspecified.
+*** TODO Phase 4 — render + popup wiring
+cj/describe-face-at-point, the read-only mode with face buttons, region-scan mode, and placement/dismissal via the unified-popup rules. Settle the command name and keybinding here. Render function tested on a captured plist; live smoke test.
 ** TODO [#D] Face diagnostic popup — theme-studio bridge (vNext) :feature:
 vNext for the face/font diagnostic tool: interactivity — "send this face to theme-studio", jump-to-theme-spec, any write path. Deferred per [[id:98f065cf-8bd5-46a0-ac24-da94d66855ad][the spec]]'s scope tiers.
 ** TODO [#C] Gold text in auto-dimmed buffers :bug: