8a8e862098
Split the verified renderer, layout engine, Grid support, native boundary, tests, examples, and paired documentation into the independent Ebox repository. Keep ETAF and application concerns outside this package.
377 lines
14 KiB
EmacsLisp
377 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."
|
|
(let* ((title (ebox-create
|
|
:content "Ebox Visual Check"
|
|
:box-sizing 'border-box
|
|
:width 74
|
|
:padding '(0 1)
|
|
:border t
|
|
:border-color "#4A90D9"
|
|
:color "#EAF6FF"
|
|
:bgcolor "#203040"))
|
|
(hidden (ebox-create
|
|
:content "Hidden: visible line\nHIDDEN-CLIPPED-LINE"
|
|
:box-sizing 'border-box
|
|
:width 24
|
|
:height 3
|
|
:padding '(1 1)
|
|
:border t
|
|
:border-color "#27AE60"
|
|
:color "#F0FFF4"
|
|
:bgcolor "#17351F"
|
|
:overflow 'hidden))
|
|
(scroll (ebox-create
|
|
:content "Scroll: first\nSCROLL-SECOND\nSCROLL-THIRD"
|
|
:box-sizing 'border-box
|
|
:width 24
|
|
:height 3
|
|
:padding '(1 1)
|
|
:border t
|
|
:border-color "#E67E22"
|
|
:color "#FFF4E6"
|
|
:bgcolor "#3A2410"
|
|
:overflow 'scroll))
|
|
(sized (ebox-create
|
|
:content "border-box max-height\nline 2\nSIZED-CLIPPED"
|
|
:box-sizing 'border-box
|
|
:width 26
|
|
:max-height 3
|
|
:padding '(1 1)
|
|
:border t
|
|
:border-color "#9B59B6"
|
|
:color "#F8EEFF"
|
|
:bgcolor "#2F1B3A"
|
|
:overflow 'hidden))
|
|
(footer (ebox-create
|
|
:content "Checks: text properties + display specs + GUI screenshot"
|
|
:box-sizing 'border-box
|
|
:width 74
|
|
:padding '(0 1)
|
|
:border t
|
|
:border-color "#7F8C8D"
|
|
:color "#F8F9F9"
|
|
:bgcolor "#2C3E50")))
|
|
(ebox-column title (ebox-row hidden scroll sized) footer)))
|
|
|
|
(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 layout))
|
|
(rendered (ebox-render layout))
|
|
(plain (substring-no-properties rendered))
|
|
(ids-after (ebox-region-ids 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
|
|
"region ids are stable"
|
|
(equal ids-before ids-after)
|
|
(format "before=%S after=%S" ids-before ids-after))
|
|
(ebox-visual-check--check
|
|
"all expected boxes rendered"
|
|
(= (length ids-before) 5)
|
|
(format "region-count=%d" (length ids-before)))
|
|
(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"))))))
|
|
|
|
(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
|