79f5bc23d1
Normalize size units and intrinsic sizing across Elisp and native layout. Add help, pointer, hover-style and keymap support with reusable interaction adapters. Keep content updates local, preserve scroll caches and hover borders, and avoid rebuilding retained plans and ownership metadata for stable geometry. Validation: make check and native-rust-tests passed; targeted native interaction and scroll publication regressions passed.
363 lines
14 KiB
EmacsLisp
363 lines
14 KiB
EmacsLisp
;;; ebox-visual-check.el --- Visual verification helper for ebox -*- lexical-binding: t; -*-
|
|
|
|
;; Usage:
|
|
;; Batch/property report:
|
|
;; emacs -Q -L . -l scripts/ebox-visual-check.el -f ebox-visual-check-batch
|
|
;;
|
|
;; GUI inspection:
|
|
;; emacs -Q -L . -l scripts/ebox-visual-check.el \
|
|
;; --eval '(ebox-visual-check-run t)'
|
|
|
|
(require 'cl-lib)
|
|
|
|
(let ((root (file-name-directory
|
|
(directory-file-name
|
|
(file-name-directory (or load-file-name buffer-file-name))))))
|
|
(add-to-list 'load-path root))
|
|
|
|
(require 'ebox)
|
|
|
|
(defconst ebox-visual-check-buffer "*ebox-visual-check*"
|
|
"Buffer used for visual inspection.")
|
|
|
|
(defcustom ebox-visual-check-output-dir
|
|
(expand-file-name "ebox-visual-check" temporary-file-directory)
|
|
"Directory used for optional screenshots and reports."
|
|
:type 'directory
|
|
:group 'ebox)
|
|
|
|
(defun ebox-visual-check-layout ()
|
|
"Return the fixed layout used by visual verification."
|
|
(ebox-build
|
|
'(column :id dashboard
|
|
(box :id title :box-sizing border-box :width (ch 74)
|
|
:padding ((lh 0) (ch 1)) :border "#4A90D9"
|
|
:color "#EAF6FF" :bgcolor "#203040"
|
|
"Ebox Visual Check")
|
|
(row :id cards
|
|
(box :id hidden :box-sizing border-box :width (ch 24) :height (lh 3)
|
|
:padding ((lh 1) (ch 1)) :border "#27AE60"
|
|
:color "#F0FFF4" :bgcolor "#17351F" :overflow hidden
|
|
"Hidden: visible line\nHIDDEN-CLIPPED-LINE")
|
|
(box :id scroll :box-sizing border-box :width (ch 24) :height (lh 3)
|
|
:padding ((lh 1) (ch 1)) :border "#E67E22"
|
|
:color "#FFF4E6" :bgcolor "#3A2410" :overflow scroll
|
|
"Scroll: first\nSCROLL-SECOND\nSCROLL-THIRD")
|
|
(box :id sized :box-sizing border-box :width (ch 26) :max-height (lh 3)
|
|
:padding ((lh 1) (ch 1)) :border "#9B59B6"
|
|
:color "#F8EEFF" :bgcolor "#2F1B3A" :overflow hidden
|
|
"border-box max-height\nline 2\nSIZED-CLIPPED"))
|
|
(box :id footer :box-sizing border-box :width (ch 74)
|
|
:padding ((lh 0) (ch 1)) :border "#7F8C8D"
|
|
:color "#F8F9F9" :bgcolor "#2C3E50"
|
|
"Checks: text properties + display specs + GUI screenshot"))))
|
|
|
|
(defun ebox-visual-check--max-line-pixel-width (string)
|
|
"Return maximum pixel width among STRING lines."
|
|
(apply #'max (mapcar #'string-pixel-width (ebox-string-lines string))))
|
|
|
|
(defun ebox-visual-check--some-property-p (string property)
|
|
"Return non-nil when STRING has PROPERTY anywhere."
|
|
(let ((pos 0)
|
|
(len (length string))
|
|
found)
|
|
(while (and (< pos len) (not found))
|
|
(when (get-text-property pos property string)
|
|
(setq found t))
|
|
(setq pos (or (next-single-property-change pos property string)
|
|
(1+ pos))))
|
|
found))
|
|
|
|
(defun ebox-visual-check--face-has-key-p (face key)
|
|
"Return non-nil when FACE contains plist KEY."
|
|
(cond
|
|
((null face) nil)
|
|
((and (listp face) (keywordp (car face)))
|
|
(plist-member face key))
|
|
((listp face)
|
|
(cl-some (lambda (item)
|
|
(ebox-visual-check--face-has-key-p item key))
|
|
face))
|
|
(t nil)))
|
|
|
|
(defun ebox-visual-check--some-face-key-p (string key)
|
|
"Return non-nil when any face property in STRING contains KEY."
|
|
(let ((pos 0)
|
|
(len (length string))
|
|
found)
|
|
(while (and (< pos len) (not found))
|
|
(when (ebox-visual-check--face-has-key-p
|
|
(get-text-property pos 'face string)
|
|
key)
|
|
(setq found t))
|
|
(setq pos (or (next-single-property-change pos 'face string)
|
|
(1+ pos))))
|
|
found))
|
|
|
|
(defun ebox-visual-check--check (name ok detail)
|
|
"Return a check plist with NAME, OK, and DETAIL."
|
|
(list :name name :ok (and ok t) :detail detail))
|
|
|
|
(defun ebox-visual-check-report ()
|
|
"Return visual verification report based on rendered text properties."
|
|
(let* ((layout (ebox-visual-check-layout))
|
|
(ids-before
|
|
(ebox-region-ids
|
|
(ebox-canonical-input--single-root layout "Ebox visual check")))
|
|
(buffer (generate-new-buffer " *ebox-visual-check-report*")))
|
|
(unwind-protect
|
|
(progn
|
|
(ebox-render-to-buffer buffer layout)
|
|
(let* ((runtime-root (ebox--buffer-root-node buffer))
|
|
(ids-after (ebox-region-ids runtime-root))
|
|
(rendered
|
|
(with-current-buffer buffer
|
|
(buffer-substring (point-min) (point-max))))
|
|
(plain (substring-no-properties rendered))
|
|
(metrics (list :height (ebox-string-height rendered)
|
|
:pixel-width
|
|
(ebox-visual-check--max-line-pixel-width
|
|
rendered)
|
|
:region-count (length ids-before))))
|
|
(list
|
|
(list
|
|
:name "dashboard-contract"
|
|
:metrics metrics
|
|
:checks
|
|
(list
|
|
(ebox-visual-check--check
|
|
"source and mounted identities agree"
|
|
(equal ids-before ids-after)
|
|
(format "source=%S mounted=%S" ids-before ids-after))
|
|
(ebox-visual-check--check
|
|
"expected visible labels rendered"
|
|
(cl-every (lambda (label) (string-match-p label plain))
|
|
'("Ebox Visual Check" "Hidden: visible line"
|
|
"Scroll: first" "border-box max-height"
|
|
"Checks: text properties"))
|
|
"all non-clipped fixture sections are present")
|
|
(ebox-visual-check--check
|
|
"display specs exist"
|
|
(ebox-visual-check--some-property-p rendered 'display)
|
|
"pixel spaces are represented with display properties")
|
|
(ebox-visual-check--check
|
|
"foreground faces exist"
|
|
(ebox-visual-check--some-face-key-p rendered :foreground)
|
|
"checks :color render path")
|
|
(ebox-visual-check--check
|
|
"background faces exist"
|
|
(ebox-visual-check--some-face-key-p rendered :background)
|
|
"checks :bgcolor render path")
|
|
(ebox-visual-check--check
|
|
"hidden overflow is clipped"
|
|
(not (string-match-p "HIDDEN-CLIPPED-LINE" plain))
|
|
"hidden box should not expose clipped line")
|
|
(ebox-visual-check--check
|
|
"scroll overflow keeps initial window"
|
|
(and (string-match-p "Scroll: first" plain)
|
|
(not (string-match-p "SCROLL-SECOND" plain)))
|
|
"scroll box should show first window only")
|
|
(ebox-visual-check--check
|
|
"border-box max-height clips outer box"
|
|
(not (string-match-p "SIZED-CLIPPED" plain))
|
|
"max-height includes vertical padding"))))))
|
|
(when (buffer-live-p buffer)
|
|
(kill-buffer buffer)))))
|
|
|
|
(defun ebox-visual-check--format-report (report)
|
|
"Format REPORT as human-readable text."
|
|
(mapconcat
|
|
(lambda (scenario)
|
|
(let ((name (plist-get scenario :name))
|
|
(metrics (plist-get scenario :metrics))
|
|
(checks (plist-get scenario :checks)))
|
|
(concat
|
|
(format "Scenario: %s\nMetrics: %S\n" name metrics)
|
|
(mapconcat
|
|
(lambda (check)
|
|
(format "%s %s -- %s"
|
|
(if (plist-get check :ok) "PASS" "FAIL")
|
|
(plist-get check :name)
|
|
(plist-get check :detail)))
|
|
checks
|
|
"\n"))))
|
|
report
|
|
"\n\n"))
|
|
|
|
(defun ebox-visual-check-all-passed-p (report)
|
|
"Return non-nil when every check in REPORT passed."
|
|
(cl-every
|
|
(lambda (scenario)
|
|
(cl-every (lambda (check) (plist-get check :ok))
|
|
(plist-get scenario :checks)))
|
|
report))
|
|
|
|
(defun ebox-visual-check-render-buffer ()
|
|
"Render the visual check layout into `ebox-visual-check-buffer'."
|
|
(ebox-render-to-buffer ebox-visual-check-buffer
|
|
(ebox-visual-check-layout)))
|
|
|
|
(defun ebox-visual-check-capture-screenshot ()
|
|
"Capture a macOS screenshot for the current GUI Emacs frame.
|
|
Return the screenshot path, or nil when screenshot capture is unavailable."
|
|
(when (and (display-graphic-p)
|
|
(executable-find "screencapture"))
|
|
(make-directory ebox-visual-check-output-dir t)
|
|
(raise-frame)
|
|
(select-frame-set-input-focus (selected-frame))
|
|
(when (and (eq system-type 'darwin)
|
|
(executable-find "osascript"))
|
|
(call-process "osascript" nil nil nil
|
|
"-e" "tell application id \"org.gnu.Emacs\" to activate"))
|
|
(let ((file (expand-file-name
|
|
(format-time-string "ebox-visual-check-%Y%m%d-%H%M%S.png")
|
|
ebox-visual-check-output-dir)))
|
|
(redisplay t)
|
|
(sit-for 1)
|
|
(when (zerop (call-process "screencapture" nil nil nil "-x" file))
|
|
file))))
|
|
|
|
(defun ebox-visual-check--tokenize-ppm (file)
|
|
"Return PPM FILE tokens, ignoring comments."
|
|
(with-temp-buffer
|
|
(insert-file-contents file)
|
|
(goto-char (point-min))
|
|
(let (tokens)
|
|
(while (not (eobp))
|
|
(cond
|
|
((looking-at "[ \t\r\n]+")
|
|
(goto-char (match-end 0)))
|
|
((looking-at "#.*$")
|
|
(forward-line 1))
|
|
((looking-at "[^ \t\r\n#]+")
|
|
(push (match-string 0) tokens)
|
|
(goto-char (match-end 0)))
|
|
(t
|
|
(forward-char 1))))
|
|
(nreverse tokens))))
|
|
|
|
(defun ebox-visual-check--read-ppm (file)
|
|
"Read an ASCII P3 PPM FILE into a plist."
|
|
(let* ((tokens (ebox-visual-check--tokenize-ppm file))
|
|
(magic (pop tokens)))
|
|
(unless (equal magic "P3")
|
|
(error "Only ASCII P3 PPM files are supported directly: %s" file))
|
|
(let* ((width (string-to-number (pop tokens)))
|
|
(height (string-to-number (pop tokens)))
|
|
(max-value (string-to-number (pop tokens)))
|
|
pixels)
|
|
(dotimes (_ (* width height))
|
|
(let ((r (string-to-number (pop tokens)))
|
|
(g (string-to-number (pop tokens)))
|
|
(b (string-to-number (pop tokens))))
|
|
(push (vector r g b) pixels)))
|
|
(list :width width
|
|
:height height
|
|
:max-value max-value
|
|
:pixels (vconcat (nreverse pixels))))))
|
|
|
|
(defun ebox-visual-check--maybe-convert-to-ppm (file)
|
|
"Return FILE as a PPM path, converting image formats with sips when needed."
|
|
(if (string-match-p "\\.ppm\\'" file)
|
|
file
|
|
(unless (executable-find "sips")
|
|
(error "Cannot convert image without sips: %s" file))
|
|
(let ((out (make-temp-file "ebox-visual-check-" nil ".ppm")))
|
|
(unless (zerop (call-process "sips" nil nil nil
|
|
"-s" "format" "ppm"
|
|
file "--out" out))
|
|
(error "Failed to convert image to PPM: %s" file))
|
|
out)))
|
|
|
|
(defun ebox-visual-check--pixel-at (image x y)
|
|
"Return IMAGE pixel at X,Y."
|
|
(let ((width (plist-get image :width))
|
|
(pixels (plist-get image :pixels)))
|
|
(aref pixels (+ (* y width) x))))
|
|
|
|
(defun ebox-visual-check--pixel-delta (p1 p2)
|
|
"Return the maximum RGB channel delta between P1 and P2."
|
|
(max (abs (- (aref p1 0) (aref p2 0)))
|
|
(abs (- (aref p1 1) (aref p2 1)))
|
|
(abs (- (aref p1 2) (aref p2 2)))))
|
|
|
|
(defun ebox-visual-check-compare-region (expected actual region &optional tolerance)
|
|
"Compare EXPECTED and ACTUAL images inside REGION.
|
|
REGION is a plist with :x, :y, :width, and :height. TOLERANCE is the
|
|
allowed maximum per-channel RGB delta, defaulting to 0.
|
|
|
|
The direct parser supports ASCII P3 PPM. Other image files are converted to
|
|
PPM with macOS `sips' when available."
|
|
(let* ((tolerance (or tolerance 0))
|
|
(expected-ppm (ebox-visual-check--maybe-convert-to-ppm expected))
|
|
(actual-ppm (ebox-visual-check--maybe-convert-to-ppm actual))
|
|
(expected-image (ebox-visual-check--read-ppm expected-ppm))
|
|
(actual-image (ebox-visual-check--read-ppm actual-ppm))
|
|
(x (plist-get region :x))
|
|
(y (plist-get region :y))
|
|
(width (plist-get region :width))
|
|
(height (plist-get region :height))
|
|
(samples 0)
|
|
(mismatches 0)
|
|
(max-delta 0))
|
|
(unless (and (= (plist-get expected-image :width)
|
|
(plist-get actual-image :width))
|
|
(= (plist-get expected-image :height)
|
|
(plist-get actual-image :height)))
|
|
(error "Image dimensions differ: %S vs %S"
|
|
(list (plist-get expected-image :width)
|
|
(plist-get expected-image :height))
|
|
(list (plist-get actual-image :width)
|
|
(plist-get actual-image :height))))
|
|
(dotimes (dy height)
|
|
(dotimes (dx width)
|
|
(let* ((px (+ x dx))
|
|
(py (+ y dy))
|
|
(delta (ebox-visual-check--pixel-delta
|
|
(ebox-visual-check--pixel-at expected-image px py)
|
|
(ebox-visual-check--pixel-at actual-image px py))))
|
|
(setq samples (1+ samples))
|
|
(setq max-delta (max max-delta delta))
|
|
(when (> delta tolerance)
|
|
(setq mismatches (1+ mismatches))))))
|
|
(list :ok (= mismatches 0)
|
|
:samples samples
|
|
:mismatches mismatches
|
|
:max-delta max-delta
|
|
:tolerance tolerance)))
|
|
|
|
(defun ebox-visual-check-run (&optional capture)
|
|
"Render visual check buffer for GUI inspection.
|
|
With CAPTURE non-nil, also save a screenshot when possible."
|
|
(interactive "P")
|
|
(let* ((buffer (ebox-visual-check-render-buffer))
|
|
(report (ebox-visual-check-report))
|
|
(passed (ebox-visual-check-all-passed-p report))
|
|
screenshot)
|
|
(switch-to-buffer buffer)
|
|
(delete-other-windows)
|
|
(goto-char (point-min))
|
|
(when capture
|
|
(setq screenshot (ebox-visual-check-capture-screenshot)))
|
|
(message "ebox visual check: %s%s"
|
|
(if passed "PASS" "FAIL")
|
|
(if screenshot
|
|
(format " screenshot=%s" screenshot)
|
|
""))
|
|
(list :passed passed :screenshot screenshot :report report)))
|
|
|
|
(defun ebox-visual-check-batch ()
|
|
"Run property-based visual checks and print a report."
|
|
(interactive)
|
|
(let* ((report (ebox-visual-check-report))
|
|
(passed (ebox-visual-check-all-passed-p report)))
|
|
(princ (ebox-visual-check--format-report report))
|
|
(princ (format "\n\n%s\n" (if passed "ALL CHECKS PASSED"
|
|
"CHECKS FAILED")))
|
|
(when noninteractive
|
|
(kill-emacs (if passed 0 1)))))
|
|
|
|
(provide 'ebox-visual-check)
|
|
|
|
;;; ebox-visual-check.el ends here
|