feat(face-diagnostic): Phase 2 merged attributes and real font

Extend the diagnostic core with the effective merged attributes and the real-font layer. cj/--face-diag-merged-attributes folds the ordered, remap-expanded spec stack (overlays over text-props over default), taking the first non-unspecified value per attribute, labeled "computed". cj/--face-diag-real-font reports font-at's font, or "unavailable" under batch and on terminals. cj/--face-diagnosis-at now returns groups 0-4. Settles spec decision #7 (the hand-fold approach), pinned by fixtures: overlay-over-text-prop, a default remap, a face-symbol attribute. 23 ERT tests, byte-compile clean.

1 files changed, 90 insertions, 3 deletions

diff --git a/modules/face-diagnostic.el b/modules/face-diagnostic.el
index 16ba57e44..1b7ef10d4 100644
--- a/modules/face-diagnostic.el
+++ b/modules/face-diagnostic.el
@@ -124,15 +124,102 @@ Keys: :text-property (list of faces/specs), :overlays (list of plists),
           :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)))))))
+
 ;; ------------------------------- Assembled core ------------------------------
 
 (defun cj/--face-diagnosis-at (pos &optional buffer)
-  "Return the face-diagnosis plist for POS in BUFFER (Phase 1: groups 0-2).
+  "Return the face-diagnosis plist for POS in BUFFER (groups 0-4).
 Keys: :classification (symbol), :char (plist or nil at end-of-buffer), :stack
-\(plist).  Pure: no prompts, no display, no buffer or frame mutation."
+\(plist), :attributes (computed merged plist), :font (real-font 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)))
+        :stack (cj/--face-diag-stack pos buffer)
+        :attributes (cj/--face-diag-merged-attributes pos buffer)
+        :font (cj/--face-diag-real-font pos buffer)))
 
 (provide 'face-diagnostic)
 ;;; face-diagnostic.el ends here