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.
364 lines
20 KiB
EmacsLisp
364 lines
20 KiB
EmacsLisp
;;; ebox-box-line-flow-tests.el --- Box line flow contracts -*- lexical-binding: t; -*-
|
|
|
|
(require 'cl-lib)
|
|
(require 'ert)
|
|
(setq load-prefer-newer t)
|
|
(load-file (expand-file-name "../ebox.el"
|
|
(file-name-directory load-file-name)))
|
|
|
|
(defun ebox-box-line-test--previous-pad (string height &optional offset padding)
|
|
"Apply the frozen string padding algorithm to STRING at HEIGHT."
|
|
(let* ((lines (ebox-string-lines string))
|
|
(count (length lines)))
|
|
(when (> height count)
|
|
(let* ((fill (or padding
|
|
(ebox--pixel-blank (ebox--string-pixel-width string) 1)))
|
|
(rest (- height count))
|
|
(shift (or offset 0))
|
|
(top (if (>= shift 0) (min shift rest)
|
|
(max 0 (+ shift rest)))))
|
|
(setq lines (append (make-list top fill) lines
|
|
(make-list (- rest top) fill)))))
|
|
(ebox-lines-join (seq-take lines height))))
|
|
|
|
(defun ebox-box-line-test--previous-prepare (box formatted height region-id filler)
|
|
"Freeze BOX's old join/align/split/blank-normalization front half.
|
|
FORMATTED is captured before decoration; HEIGHT and REGION-ID are the actual
|
|
render constraints. This oracle does not call the new line operation."
|
|
(let* ((text-height (ebox-string-height formatted))
|
|
(scroll-p (eq (ebox-get box :overflow) 'scroll))
|
|
(start (if scroll-p
|
|
(max 0 (min (or (ebox-get box :scroll-offset) 0)
|
|
(max 0 (- text-height height))))
|
|
0))
|
|
(lines (ebox-string-lines formatted))
|
|
(visible (if scroll-p
|
|
(seq-subseq lines start (min (+ start height) text-height))
|
|
(seq-take lines height)))
|
|
(ebox--propertize-private-content-line-p
|
|
(not (and scroll-p (> text-height height))))
|
|
(decorated
|
|
(ebox-lines-join
|
|
(cl-loop for line in visible for index from 0
|
|
collect (ebox--propertize-content-line
|
|
line region-id index filler))))
|
|
(count (ebox-string-height decorated))
|
|
(offset (pcase (ebox-get box :vertical-align)
|
|
('bottom (- height count))
|
|
('center (/ (- height count) 2))
|
|
(_ 0)))
|
|
(aligned (ebox-box-line-test--previous-pad decorated height offset)))
|
|
(mapcar
|
|
(lambda (line)
|
|
(if (and (string-empty-p (string-trim line))
|
|
(ebox--line-content-metadata-uniform-p line)
|
|
(not (ebox--line-has-non-content-properties-p line)))
|
|
(let ((id (get-text-property 0 'ebox-content line))
|
|
(index (get-text-property 0 'ebox-content-idx line)))
|
|
(propertize filler 'ebox-content (or id region-id)
|
|
'ebox-content-idx (if id index 0)
|
|
'ebox-content-owner region-id))
|
|
line))
|
|
(ebox-string-lines aligned))))
|
|
|
|
(defun ebox-box-line-test--reference-render (input &optional actual-p)
|
|
"Render INPUT with the old front half, or current code when ACTUAL-P.
|
|
Check opaque identity between the actual formatted source and compositor output;
|
|
the surrounding ephemeral TP surface has its own snapshot value ownership."
|
|
(let ((format-function (symbol-function 'ebox--format-content))
|
|
(compositor (symbol-function 'ebox--window-render-flat-wrapper-chunk-lines))
|
|
(formatted (make-hash-table :test 'eq)))
|
|
(cl-letf (((symbol-function 'ebox--format-content)
|
|
(lambda (box)
|
|
(let ((result (funcall format-function box)))
|
|
(puthash box
|
|
(list (copy-sequence result)
|
|
(plist-get ebox--scroll-window-render-result
|
|
:content-height))
|
|
formatted)
|
|
result)))
|
|
((symbol-function 'ebox--window-render-flat-wrapper-chunk-lines)
|
|
(lambda (&rest args)
|
|
(when (and (nth 7 args) (not actual-p))
|
|
(let* ((box (car args))
|
|
(record (gethash box formatted))
|
|
(text (car record))
|
|
(height (or (cadr record)
|
|
(ebox--content-height
|
|
box (ebox-string-height text)))))
|
|
(should record)
|
|
(setf (nth 1 args)
|
|
(ebox-box-line-test--previous-prepare
|
|
box text height (nth 3 args) (nth 4 args)))))
|
|
(let* ((result (apply compositor args))
|
|
(source (car (gethash (car args) formatted)))
|
|
(source-pos (and source (string-match "Open" source)))
|
|
(line (cl-find-if (lambda (value) (string-match "Open" value))
|
|
result)))
|
|
(when (and source-pos line)
|
|
(let ((pos (string-match "Open" line)))
|
|
(dolist (property '(keymap help-echo))
|
|
(should (eq (get-text-property pos property line)
|
|
(get-text-property source-pos property source))))))
|
|
result))))
|
|
(ebox-render input))))
|
|
|
|
(defun ebox-box-line-test--materializations (input)
|
|
"Record actual intermediate newline joins/splits while rendering INPUT's root."
|
|
(let* ((handle (ebox-node-source-handle (car (ebox-canonical-input-roots input))))
|
|
(render (symbol-function 'ebox--render-box))
|
|
(format-function (symbol-function 'ebox--format-content))
|
|
(join (symbol-function 'mapconcat))
|
|
(slice (symbol-function 'substring))
|
|
(joined (make-hash-table :test 'eq))
|
|
(joins 0) (splits 0) active formatting output)
|
|
(cl-letf (((symbol-function 'ebox--render-box)
|
|
(lambda (box)
|
|
(let ((previous active))
|
|
(setq active (eq (ebox-node-source-handle box) handle))
|
|
(unwind-protect (funcall render box)
|
|
(setq active previous)))))
|
|
((symbol-function 'ebox--format-content)
|
|
(lambda (box)
|
|
(let ((previous formatting))
|
|
(setq formatting t)
|
|
(unwind-protect (funcall format-function box)
|
|
(setq formatting previous)))))
|
|
((symbol-function 'mapconcat)
|
|
(lambda (function sequence separator)
|
|
(let ((result (funcall join function sequence separator)))
|
|
(when (and active (not formatting) (equal separator "\n")
|
|
(string-match-p "alpha" result))
|
|
(cl-incf joins)
|
|
(puthash result t joined))
|
|
result)))
|
|
((symbol-function 'substring)
|
|
(lambda (string from &optional to)
|
|
(when (and active (not formatting) (gethash string joined))
|
|
(cl-incf splits))
|
|
(funcall slice string from to))))
|
|
(setq output (ebox-render input)))
|
|
(list :output output :joins joins :splits splits)))
|
|
|
|
(ert-deftest ebox-box-line-flow-avoids-intermediate-join-and-split ()
|
|
"Ordinary decoration should join only at the existing compositor exit."
|
|
(let* ((input (ebox-build
|
|
'(box :width (px 120) :height (lh 8) :overflow hidden
|
|
:padding ((lh 1) (px 3)) :border ((px 1) solid "#112233")
|
|
:bgcolor "#ddeeff" (text "alpha\nbeta"))))
|
|
(expected (ebox-box-line-test--reference-render input))
|
|
(observed (ebox-box-line-test--materializations input)))
|
|
(should (equal-including-properties (plist-get observed :output) expected))
|
|
(ert-info ((format "Actual content joins=%S, joined-string substrings=%S"
|
|
(plist-get observed :joins) (plist-get observed :splits)))
|
|
(should (= (plist-get observed :joins) 1))
|
|
(should (= (plist-get observed :splits) 0)))))
|
|
|
|
(ert-deftest ebox-box-line-flow-preserves-old-front-half-output ()
|
|
"Composition, chrome, visibility and ownership match the frozen string path."
|
|
(let* ((map (make-sparse-keymap))
|
|
(callback (let ((value 'opened)) (lambda () value)))
|
|
(rich (concat (propertize "Open 中" 'keymap map 'help-echo callback)
|
|
(propertize "\n" 'help-echo "newline only")
|
|
(propertize " " 'help-echo "rich blank") "\ntail\n")))
|
|
(define-key map [mouse-1] #'ignore)
|
|
(dolist (kind '(box row column flex grid))
|
|
(dolist (height '(0 4 8))
|
|
(dolist (align '(top center bottom))
|
|
(dolist (overflow '(hidden visible scroll))
|
|
(let* ((child (pcase kind
|
|
('box `(box (text ,rich)))
|
|
('grid `(grid :grid-template-columns ((px 110)) (text ,rich)))
|
|
(_ `(,kind (text ,rich)))))
|
|
(input
|
|
(ebox-build
|
|
`(box :width (px 140) :height (lh ,height) :overflow ,overflow
|
|
:padding ((lh 1) (px 3))
|
|
:border ((px 1) solid "#112233") :margin ((lh 1) (px 2))
|
|
:color "#123456" :bgcolor "#ddeeff" ,child)))
|
|
(_alignment
|
|
(plist-put (car (ebox-canonical-input-roots input))
|
|
:vertical-align align))
|
|
(source-before (copy-sequence rich))
|
|
(actual (ebox-box-line-test--reference-render input t))
|
|
(expected (ebox-box-line-test--reference-render input)))
|
|
(ert-info ((format "%S height=%S align=%S overflow=%S"
|
|
kind height align overflow))
|
|
(should (equal-including-properties actual expected))
|
|
(should (equal-including-properties rich source-before))
|
|
(when-let* ((pos (string-match "Open" actual)))
|
|
(should (eq (lookup-key (get-text-property pos 'keymap actual)
|
|
[mouse-1]) #'ignore))
|
|
(should (eq (funcall (get-text-property pos 'help-echo actual))
|
|
'opened))
|
|
(should (> (length (get-text-property
|
|
pos 'ebox-content-owners actual)) 1)))))))))))
|
|
|
|
(ert-deftest ebox-box-line-flow-keeps-string-padding-contract ()
|
|
"String padding retains nil, empty, first-line width and multiline filler."
|
|
(dolist (input (list nil "" "A" "A\nlonger" "\n" "A\n"))
|
|
(dolist (height '(0 1 2 4))
|
|
(dolist (offset '(nil -2 0 2))
|
|
(dolist (filler (list nil "" (propertize "L\nR" 'help-echo "fill")))
|
|
(should (equal-including-properties
|
|
(ebox--lines-pad-vertical input height offset filler)
|
|
(ebox-box-line-test--previous-pad input height offset filler)))))))
|
|
(let* ((input "A\nlonger")
|
|
(output (ebox-string-lines (ebox--lines-pad-vertical input 3)))
|
|
(fill (car (last output))))
|
|
(should (= (ebox--string-pixel-width fill) (ebox--string-pixel-width "A")))))
|
|
|
|
(ert-deftest ebox-box-line-flow-keeps-simple-scroll-output ()
|
|
"Complete simple scroll keeps its single join for overflow and underfill."
|
|
(dolist (text '("alpha\nbeta" "alpha\n2\n3\n4\n5\n6\n7\n8\n9"))
|
|
(let* ((input (ebox-build
|
|
`(box :width (px 120) :height (lh 8) :overflow scroll
|
|
:bgcolor "#ddeeff" (text ,text))))
|
|
(expected (ebox-box-line-test--reference-render input))
|
|
(observed (ebox-box-line-test--materializations input)))
|
|
(should (equal-including-properties (plist-get observed :output) expected))
|
|
(should (= (plist-get observed :joins) 1))
|
|
(should (= (plist-get observed :splits) 0)))))
|
|
|
|
(ert-deftest ebox-box-line-flow-list-core-borrows-without-mutating ()
|
|
"Line padding preserves the original spine, strings and opaque property values."
|
|
(let* ((map (make-sparse-keymap))
|
|
(callback (let ((value 'opened)) (lambda () value)))
|
|
(rich (propertize "Open 中" 'keymap map 'help-echo callback
|
|
'ebox-content 17 'ebox-content-idx 2
|
|
'ebox-content-owner 18 'ebox-content-owners '(18 17)))
|
|
(blank (propertize " " 'display '(space :width (7))
|
|
'ebox-content-owner 19)))
|
|
;; Use the explicit one-line string representation for string/list parity.
|
|
;; A raw empty list entry is covered separately below.
|
|
(dolist (lines (list nil (list (ebox-lines-join '("")))
|
|
(list rich) (list rich "" blank)))
|
|
(dolist (height '(0 1 3 5))
|
|
(dolist (align '(top center bottom))
|
|
(let* ((spine (cl-loop for tail on lines
|
|
collect (list tail (car tail) (cdr tail)
|
|
(copy-sequence (car tail)))))
|
|
(count (length lines))
|
|
(offset (pcase align
|
|
('bottom (- height count))
|
|
('center (/ (- height count) 2))
|
|
(_ 0)))
|
|
(expected (ebox-box-line-test--previous-pad
|
|
(and lines (ebox-lines-join lines)) height offset))
|
|
(actual (ebox--pad-lines-vertical lines height offset))
|
|
(output (ebox-lines-join actual)))
|
|
(should (equal-including-properties output expected))
|
|
(when (= height count) (should (eq actual lines)))
|
|
(when-let* ((pos (string-match "Open" output)))
|
|
(should (eq (get-text-property pos 'keymap output) map))
|
|
(should (eq (get-text-property pos 'help-echo output) callback)))
|
|
;; Only the string boundary grants independent mutable ownership.
|
|
(when (> (length output) 0)
|
|
(put-text-property 0 1 'help-echo "output-only" output)
|
|
(aset output 0 ?Z))
|
|
(dolist (record spine)
|
|
(should (eq (car (nth 0 record)) (nth 1 record)))
|
|
(should (eq (cdr (nth 0 record)) (nth 2 record)))
|
|
(should (equal-including-properties (nth 1 record) (nth 3 record)))))))))
|
|
(let* ((empty-line "")
|
|
(lines (list empty-line))
|
|
(padded (ebox--pad-lines-vertical lines 3)))
|
|
(should (eq (ebox--pad-lines-vertical lines 1) lines))
|
|
(should (eq (car padded) empty-line))
|
|
(should (equal lines '("")))
|
|
(should (= (ebox-string-height (ebox-lines-join padded)) 3)))
|
|
(should-not (ebox--pad-lines-vertical nil 0))
|
|
(should-not (ebox--pad-lines-vertical (list "A") 0)))
|
|
|
|
(ert-deftest ebox-box-line-flow-empty-content-retains-only-declared-chrome ()
|
|
"Empty content and zero used height preserve only the declared chrome."
|
|
(dolist (formatted '(nil "" "A\nB"))
|
|
(dolist (height '(0 1 3))
|
|
(let* ((input (ebox-build
|
|
'(box :width (px 40) :height (lh 3) :overflow hidden :padding ((lh 1) (px 2))
|
|
:border ((px 1) solid "#112233") (text "unused"))))
|
|
(root (car (ebox-canonical-input-roots input)))
|
|
(handle (ebox-node-source-handle root))
|
|
(format-function (symbol-function 'ebox--format-content))
|
|
(height-function (symbol-function 'ebox--content-height)))
|
|
;; Isolate the decoration boundary, including zero used content height.
|
|
(cl-letf (((symbol-function 'ebox--format-content)
|
|
(lambda (box)
|
|
(if (eq (ebox-node-source-handle box) handle)
|
|
formatted
|
|
(funcall format-function box))))
|
|
((symbol-function 'ebox--content-height)
|
|
(lambda (box natural &optional rendered)
|
|
(if (eq (ebox-node-source-handle box) handle)
|
|
height
|
|
(funcall height-function box natural rendered)))))
|
|
(let ((actual (ebox-box-line-test--reference-render input t))
|
|
(expected (ebox-box-line-test--reference-render input)))
|
|
(should (equal-including-properties actual expected))
|
|
(when (= height 0)
|
|
(should (= (ebox-string-height actual) 2)))))))))
|
|
|
|
(ert-deftest ebox-box-line-flow-zero-width-default-padding-is-a-line ()
|
|
"Zero-width default blanks remain empty string lines at the list boundary."
|
|
(dolist (padding '(((lh 0) (px 0)) ((lh 1) (px 2))))
|
|
(let* ((input (ebox-build
|
|
`(box :width (px 0) :height (lh 3) :overflow hidden
|
|
:padding ,padding (text ""))))
|
|
(actual (ebox-box-line-test--reference-render input t))
|
|
(expected (ebox-box-line-test--reference-render input)))
|
|
(should (equal-including-properties actual expected)))))
|
|
|
|
(ert-deftest ebox-box-line-flow-scroll-to-end-and-back-preserves-source ()
|
|
"Real decorated scroll A→B→A keeps stored lines intact and reaches the end."
|
|
(let* ((buffer (generate-new-buffer " *ebox-box-line-scroll*"))
|
|
(map (make-sparse-keymap))
|
|
(_key (define-key map [mouse-1] #'ignore))
|
|
(text (mapconcat (lambda (index) (format "Open %02d" index))
|
|
(number-sequence 0 9) "\n"))
|
|
(input (ebox-build
|
|
`(box :width (px 120) :height (lh 4) :overflow scroll
|
|
:padding ((lh 0) (px 2)) :border ((px 1) solid "#112233")
|
|
(text ,(propertize text 'keymap map 'help-echo "action")))))
|
|
(ebox-runtime-idle-prewarm nil)
|
|
(ebox-runtime-idle-reflow-cache-prewarm nil))
|
|
(unwind-protect
|
|
(progn
|
|
(ebox-render-to-buffer buffer input)
|
|
(with-current-buffer buffer
|
|
(let* ((root (plist-get (ebox--buffer-render-state buffer) :root-node))
|
|
(id (plist-get root :region-id))
|
|
(state (ebox--scroll-get-state id))
|
|
(lines (plist-get state :content-lines))
|
|
(spine (cl-loop for tail on lines
|
|
collect (list tail (car tail) (cdr tail)
|
|
(copy-sequence (car tail)))))
|
|
(initial (buffer-string))
|
|
(end (max 0 (- (length lines) (plist-get state :content-height)))))
|
|
(should state)
|
|
(goto-char (point-min))
|
|
(ebox-scroll-down end)
|
|
(let* ((current (ebox--scroll-get-state id))
|
|
(render-state (ebox--buffer-render-state buffer))
|
|
(fresh-input
|
|
(ebox-canonical-input-create
|
|
(list (plist-get render-state :root-node))
|
|
(plist-get render-state :source-index))))
|
|
(should (= end (max 0 (- (length (plist-get current :content-lines))
|
|
(plist-get current :content-height)))))
|
|
(should (= (plist-get current :scroll-offset) end))
|
|
(should (> end 0))
|
|
(should (string-match-p "Open 09" (buffer-string)))
|
|
(should (equal-including-properties
|
|
(buffer-string) (ebox-box-line-test--reference-render fresh-input))))
|
|
(ebox-scroll-up end)
|
|
(should (= (plist-get (ebox--scroll-get-state id) :scroll-offset) 0))
|
|
(should (equal-including-properties (buffer-string) initial))
|
|
(dolist (record spine)
|
|
(should (eq (car (nth 0 record)) (nth 1 record)))
|
|
(should (eq (cdr (nth 0 record)) (nth 2 record)))
|
|
(should (equal-including-properties (nth 1 record) (nth 3 record)))))))
|
|
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
|
|
|
(provide 'ebox-box-line-flow-tests)
|
|
;;; ebox-box-line-flow-tests.el ends here
|