From 4c623eff69aca86026a4985f0ebf004989ab0d2d Mon Sep 17 00:00:00 2001 From: Craig Jennings Date: Mon, 15 Jun 2026 12:27:29 -0500 Subject: 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. --- modules/face-diagnostic.el | 93 ++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 90 insertions(+), 3 deletions(-) (limited to 'modules') 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 -- cgit v1.2.3