From 34b65b338fa5cf32ad7be0610ef9636d710a0e63 Mon Sep 17 00:00:00 2001 From: Kinneyzhang Date: Tue, 25 Aug 2026 17:16:55 +0800 Subject: [PATCH] perf: retain surface state and layered paint slots --- docs/API-REFERENCE.md | 6 + tests/tp-binding-tests.el | 17 + tests/tp-builtins-tests.el | 8 + tests/tp-core-tests.el | 11 + tests/tp-style-tests.el | 33 ++ tests/tp-surface-tests.el | 363 ++++++++++++++++++ tp-core.el | 6 + tp-palette.el | 48 +-- tp-reactive.el | 49 +++ tp-style.el | 97 +++++ tp-surface.el | 751 +++++++++++++++++++++++++++++++++---- 11 files changed, 1286 insertions(+), 103 deletions(-) diff --git a/docs/API-REFERENCE.md b/docs/API-REFERENCE.md index 8788986..c5e34eb 100644 --- a/docs/API-REFERENCE.md +++ b/docs/API-REFERENCE.md @@ -271,6 +271,12 @@ properties。 result； - tp-surface-result-create-owned 只可对当前 active prepare context 使用， 结果只消费一次。 +- tp-surface-retained-content-result-create 用于对象拓扑不变的 content + candidate；最后一个可选 `property-contributions` 参数接受按顺序排列的 + `(:start N :end N :props PLIST)` 相对范围。TP 使用已注册 property merge + policy 在 prepare 内组合这些贡献，再通过同一个 content surface 原子 diff、 + 发布和回滚；调用者不需要创建重叠的 properties surface，也不应预先压平 + Theme/状态/inline face。 producer 接收一个 prepare context，并应返回 plan 或 result： diff --git a/tests/tp-binding-tests.el b/tests/tp-binding-tests.el index 4edd1c8..0c8676c 100644 --- a/tests/tp-binding-tests.el +++ b/tests/tp-binding-tests.el @@ -777,5 +777,22 @@ (when (buffer-live-p buffer) (kill-buffer buffer)) (makunbound symbol))))) +(ert-deftest tp-binding-test-precomputed-keeps-explicit-edge-reactive () + "A precomputed binding skips first compute and reacts through its edge." + (let* ((signal (tp-signal-create 1)) + (parent (tp-bind 'parent 'value (lambda () (tp-signal-read signal)))) + (runs 0) + (child + (tp-bind-precomputed + 'child 'value + (lambda () (cl-incf runs) (1+ (tp-binding-read parent))) + 2 (list parent)))) + (should (= (tp-binding-read child) 2)) + (should (= runs 0)) + (should (= (tp-binding-dependency-count child) 1)) + (tp-signal-set signal 4) + (should (= (tp-binding-read child) 5)) + (should (= runs 1)))) + (provide 'tp-binding-tests) ;;; tp-binding-tests.el ends here diff --git a/tests/tp-builtins-tests.el b/tests/tp-builtins-tests.el index db719ca..ec76736 100644 --- a/tests/tp-builtins-tests.el +++ b/tests/tp-builtins-tests.el @@ -252,6 +252,14 @@ tp-builtins restores the shipped layer definitions." (tp-builtins-test--with-background-mode 'dark (should (equal (tp-palette-color 'info :fg) "#58a6ff")))) +(ert-deftest tp-builtins-test-palette-color-resolves-explicit-mode () + "Resolve a palette for an application mode without reading the frame." + (should (equal "#0969da" + (tp-palette-color-for-mode 'info :fg 'light))) + (should (equal "#58a6ff" + (tp-palette-color-for-mode 'info :fg 'dark))) + (should-error (tp-palette-color-for-mode 'info :fg 'sepia))) + (ert-deftest tp-builtins-test-palette-has-p () "tp-palette-has-p tests palette registration and per-key presence." (should (tp-palette-has-p 'info)) diff --git a/tests/tp-core-tests.el b/tests/tp-core-tests.el index 70904d9..7e59681 100644 --- a/tests/tp-core-tests.el +++ b/tests/tp-core-tests.el @@ -287,6 +287,17 @@ (should-not (eq copy value)) (should (eq (cdr copy) copy))))) +(ert-deftest tp-core-test-public-property-value-copy-is-defensive () + "The public copy boundary preserves opaque values and isolates containers." + (let* ((function (lambda () t)) + (source (list :nested (vector "value") :function function)) + (copy (tp-property-value-copy source))) + (should (equal copy source)) + (should-not (eq copy source)) + (should-not (eq (plist-get copy :nested) + (plist-get source :nested))) + (should (eq (plist-get copy :function) function)))) + ;;; API-COORD-01: ABSOLUTE coordinates in tp-intervals / tp-intervals-map (ert-deftest tp-core-test-intervals-buffer-relative-default () diff --git a/tests/tp-style-tests.el b/tests/tp-style-tests.el index 4697f3d..b1c079d 100644 --- a/tests/tp-style-tests.el +++ b/tests/tp-style-tests.el @@ -33,6 +33,33 @@ :projector (lambda (value) (list 'face (list :foreground value))))) +(ert-deftest tp-style-test-paint-slot-keeps-one-face-address () + "Updating a paint slot changes its face without rewriting text properties." + (let* ((slot (tp-paint-slot-create '(:foreground "red"))) + (face (tp-paint-slot-face slot)) + (text (propertize "x" 'face face)) + (buffer (generate-new-buffer " *tp-paint-slot-test*"))) + (should (facep face)) + (should (eq face (get-text-property 0 'face text))) + (tp-paint-slot-update slot '(:foreground "red")) + (should (equal "red" (face-attribute face :foreground nil nil))) + (tp-paint-slot-update slot '(:foreground "blue")) + (should (eq face (get-text-property 0 'face text))) + (should (equal "blue" (face-attribute face :foreground nil nil))) + (unwind-protect + (let ((journal + (tp-paint-slot-apply-updates + buffer (list (cons slot '(:foreground "green")))))) + (with-current-buffer buffer + (should + (equal '(:foreground "green") + (cadr (assq face face-remapping-alist))))) + (tp-paint-slot-rollback-updates journal) + (with-current-buffer buffer + (should-not (assq face face-remapping-alist))) + (should (equal "blue" (face-attribute face :foreground nil nil)))) + (kill-buffer buffer)))) + (ert-deftest tp-style-test-policy-registration-is-atomic () "Invalid replacement leaves the previous valid policy installed." (tp-style-test--isolated @@ -155,6 +182,12 @@ (should (= compute-calls 1)) (should (= result-calls 0)))))) +(ert-deftest tp-style-test-computed-p-distinguishes-literal-functions () + "Only explicit computed wrappers satisfy the public predicate." + (let ((function (lambda () "value"))) + (should-not (tp-computed-p function)) + (should (tp-computed-p (tp-computed function))))) + (ert-deftest tp-style-test-public-resolver-only-executes-computed-sources () "The public resolver preserves literal functions and evaluates tags." (let ((literal (lambda () 'literal)) diff --git a/tests/tp-surface-tests.el b/tests/tp-surface-tests.el index 12aa3a2..98c19b5 100644 --- a/tests/tp-surface-tests.el +++ b/tests/tp-surface-tests.el @@ -57,6 +57,211 @@ (with-silent-modifications (put-text-property beg end 'face 'corrupt)))) +(ert-deftest tp-surface-test-commit-batch-is-atomic-and-revision-bound () + "A precomputed batch commits text/properties/state once and rolls back." + (tp-surface-test--with-buffer + (let* ((surface + (tp-surface-mount + (current-buffer) + (tp-surface-test--leaf 'root "abc" '(face bold)) + '(:capability content))) + (replacement (propertize "XY" 'face 'italic)) + (batch + (tp-commit-batch-create + :base-revision (tp-surface-revision surface) + :target-revision (1+ (tp-surface-revision surface)) + :base-extent 3 :target-extent 4 + :patches + (list (list :old-start 1 :old-end 2 + :new-start 1 :new-end 3 + :replacement replacement)) + :coordinate-patches + (list (list :old-start 1 :old-end 2 + :new-start 1 :new-end 3)) + :client-state '(:value next)))) + (tp-surface-commit-batch surface batch) + (should (equal "aXYc" (buffer-string))) + (should (eq 'italic (get-text-property 2 'face))) + (should (= 2 (tp-surface-revision surface))) + (should (equal '(:value next) (tp-surface-client-state surface))) + (should (plist-get (tp-surface-report surface) :commit-batch)) + (let ((failing + (tp-commit-batch-create + :base-revision 2 :target-revision 3 + :base-extent 4 :target-extent 4 + :patches + (list (list :old-start 1 :old-end 3 + :new-start 1 :new-end 3 + :replacement "ZZ")) + :client-state '(:value rejected)))) + (add-hook 'after-change-functions + #'tp-surface-test--corrupt-after-change nil t) + (setq-local tp-surface-test--corrupt-next t) + (unwind-protect + (should-error (tp-surface-commit-batch surface failing)) + (remove-hook 'after-change-functions + #'tp-surface-test--corrupt-after-change t)) + (should (equal "aXYc" (buffer-string))) + (should (= 2 (tp-surface-revision surface))) + (should (equal '(:value next) + (tp-surface-client-state surface)))) + (should-error (tp-surface-commit-batch surface batch))))) + +(ert-deftest tp-surface-test-producer-can-return-equal-coordinate-batch () + "A retained producer can publish a strict batch through normal TP phases." + (tp-surface-test--with-buffer + (let* ((surface + (tp-surface-mount + (current-buffer) (tp-surface-test--leaf 'root "abc") + '(:capability content :coordinate-mounts t))) + root) + (maphash (lambda (_path object) + (unless (tp--surface-object-parent object) + (setq root object))) + (tp--surface-objects surface)) + (let ((old-mounts (copy-sequence (tp--surface-mounts surface))) + (old-index (tp--surface-mount-index surface)) + (batch + (tp-commit-batch-create + :base-revision 1 :target-revision 2 + :base-extent 3 :target-extent 4 + :patches + (list (list :old-start 1 :old-end 2 + :new-start 1 :new-end 3 + :replacement (propertize "XY" 'face 'bold))) + :coordinate-patches + (list (list :old-start 1 :old-end 2 + :new-start 1 :new-end 3)) + :client-state '(:batch committed)))) + (tp-surface-update + surface + (lambda (context) + (tp-object-reuse-subtree context root) + (tp-commit-batch-result-create context batch))) + (should (equal "aXYc" (buffer-string))) + (should (eq 'bold (get-text-property 2 'face))) + (should (= 2 (tp-surface-revision surface))) + (should (equal '(:batch committed) + (tp-surface-client-state surface))) + (should (eq old-index (tp--surface-mount-index surface))) + (should (cl-every #'identity + (cl-mapcar #'eq old-mounts + (tp--surface-mounts surface)))) + (should + (cl-every (lambda (mount) + (<= (tp--mount-position (tp--surface-mount-end mount)) + (point-max))) + (tp--surface-mounts surface))) + (should (plist-get (tp-surface-report surface) :commit-batch)) + (let ((before-mounts (tp-object-mounts root)) + (before-live (copy-sequence (tp--surface-mounts surface))) + (failing + (tp-commit-batch-create + :base-revision 2 :target-revision 3 + :base-extent 4 :target-extent 5 + :patches + (list (list :old-start 1 :old-end 3 + :new-start 1 :new-end 4 + :replacement "XYZ")) + :coordinate-patches + (list (list :old-start 1 :old-end 3 + :new-start 1 :new-end 4))))) + (let ((tp--surface-publication-step-function + (lambda (step _surface) + (when (eq step 'client-state) + (error "Injected retained mount rollback"))))) + (should-error + (tp-surface-update + surface + (lambda (context) + (tp-object-reuse-subtree context root) + (tp-commit-batch-result-create context failing))))) + (should (equal "aXYc" (buffer-string))) + (should (= 2 (tp-surface-revision surface))) + (should (equal before-mounts (tp-object-mounts root))) + (should (cl-every #'identity + (cl-mapcar #'eq before-live + (tp--surface-mounts surface))))))))) + +(ert-deftest tp-surface-test-commit-batch-promotes-exact-target-mounts () + "A shrinking batch publishes producer-supplied target mounts atomically." + (tp-surface-test--with-buffer + (let ((owned-state (list :batch 'exact-mounts)) root logical) + (let* ((producer + (lambda (context) + (setq root (tp-object-ensure context nil 'root 'text) + logical + (tp-object-ensure context root 'logical 'item)) + (tp-object-attach-content-range + context logical root 4 6 '(:slot old)) + (tp-surface-test--leaf 'root "abcdef"))) + (surface + (tp-surface-mount + buffer producer + '(:capability content :coordinate-mounts t)))) + (tp-surface-update + surface + (lambda (context) + (tp-object-reuse-subtree context root) + (tp-commit-batch-result-create + context + (tp-commit-batch-create + :base-revision 1 :target-revision 2 + :base-extent 6 :target-extent 2 + :patches + (list (list :old-start 0 :old-end 6 + :new-start 0 :new-end 2 + :replacement "XY")) + :coordinate-patches + (list (list :old-start 0 :old-end 6 + :new-start 0 :new-end 2))) + :mount-specs + (list (list :object root :start 0 :end 2 :tags nil) + (list :object logical :start 0 :end 2 + :tags '(:slot new))) + :client-state owned-state))) + (should (equal (buffer-string) "XY")) + (should (= (tp-surface-revision surface) 2)) + (should (eq (tp-surface-client-state surface) owned-state)) + (should (plist-get (tp-surface-report surface) :commit-batch)) + (should (equal (tp-object-mounts logical) + '((:start 1 :end 3 :tags (:slot new))))))))) + +(ert-deftest tp-surface-test-commit-batch-reuses-proven-mount-projection () + "A producer proof can retain mounts despite nonidentity text coordinates." + (tp-surface-test--with-buffer + (let* ((surface + (tp-surface-mount + buffer (tp-surface-test--leaf 'root "abcd") + '(:capability content :coordinate-mounts t))) + (root (tp-object-resolve surface '(root))) + (mounts (tp--surface-mounts surface)) + (mount-index (tp--surface-mount-index surface)) + (batch + (tp-commit-batch-create + :base-revision 1 :target-revision 2 + :base-extent 4 :target-extent 4 + :patches + (list (list :old-start 1 :old-end 3 + :new-start 1 :new-end 3 + :replacement "XY")) + :coordinate-patches + (list (list :old-start 1 :old-end 2 + :new-start 1 :new-end 1) + (list :old-start 3 :old-end 3 + :new-start 2 :new-end 3))))) + (tp-surface-update + surface + (lambda (context) + (tp-object-reuse-subtree context root) + (tp-commit-batch-result-create + context batch :reuse-mount-projection t))) + (should (equal (buffer-string) "aXYd")) + (should (eq mounts (tp--surface-mounts surface))) + (should (eq mount-index (tp--surface-mount-index surface))) + (should (plist-get (tp-surface-report surface) + :retained-mount-state))))) + (ert-deftest tp-surface-test-plan-validates-and-defensively-copies () "Plans reject duplicate keys and own their caller-provided values." (let* ((callback (byte-compile @@ -121,6 +326,110 @@ (should (eq (get-text-property 0 'face rendered) 'bold))) (should (equal (tp-surface-plan-tags child) '(:role leaf))))))) +(ert-deftest tp-surface-test-retained-content-composes-property-contributions () + "A content surface should layer property contributions without text work." + (tp-surface-test--with-buffer + (let* ((plan + (tp-surface-plan-create + :key 'root :kind 'group :capability 'content + :children + (list + (tp-surface-plan-create + :key 'fragments :kind 'group :capability 'content + :children (list (tp-surface-test--leaf 'text "abcd")))))) + (surface (tp-surface-mount buffer plan '(:capability content))) + (producer + (lambda (contributions) + (lambda (context) + (let* ((root (tp-object-ensure context nil 'root 'group)) + (fragments + (tp-object-ensure context root 'fragments 'group)) + (_text + (tp-object-ensure context fragments 'text 'text)) + (owned-plan + (tp-surface-plan-create-owned + :key 'root :kind 'group :capability 'content + :children + (list + (tp-surface-plan-create-owned + :key 'fragments :kind 'group :capability 'content + :children + (list + (tp-surface-plan-create-owned + :key 'text :kind 'text :text "abcd" + :capability 'content))))))) + (tp-surface-retained-content-result-create + context owned-plan "abcd" nil nil t contributions))))) + (base + (list :start 0 :end 4 + :props '(face (:foreground "white" + :background "black")))) + (specific + (list :start 1 :end 3 + :props '(face (:foreground "red"))))) + (tp-surface-update surface (funcall producer (list base specific))) + (should (equal (buffer-string) "abcd")) + (let ((outer (get-text-property 1 'face)) + (inner (get-text-property 2 'face))) + (should (equal (plist-get outer :foreground) "white")) + (should (equal (plist-get outer :background) "black")) + (should (equal (plist-get inner :foreground) "red")) + (should (equal (plist-get inner :background) "black"))) + (let* ((next-base + (list :start 0 :end 4 + :props '(face (:foreground "#EEEEEE" + :background "#111111")))) + (report + (tp-surface-update + surface (funcall producer (list next-base specific))))) + (should (equal (buffer-string) "abcd")) + (should (= 0 (plist-get report :text-operations))) + (should (> (plist-get report :property-operations) 0)) + (let ((outer (get-text-property 1 'face)) + (inner (get-text-property 2 'face))) + (should (equal (plist-get outer :foreground) "#EEEEEE")) + (should (equal (plist-get outer :background) "#111111")) + (should (equal (plist-get inner :foreground) "red")) + (should (equal (plist-get inner :background) "#111111"))))))) + +(ert-deftest tp-surface-test-retained-content-rejects-invalid-contribution () + "Invalid contribution ranges must fail before mutating published content." + (tp-surface-test--with-buffer + (let* ((plan + (tp-surface-plan-create + :key 'root :kind 'group :capability 'content + :children + (list + (tp-surface-plan-create + :key 'fragments :kind 'group :capability 'content + :children (list (tp-surface-test--leaf 'text "safe")))))) + (surface (tp-surface-mount buffer plan '(:capability content)))) + (should-error + (tp-surface-update + surface + (lambda (context) + (let* ((root (tp-object-ensure context nil 'root 'group)) + (fragments + (tp-object-ensure context root 'fragments 'group)) + (_text (tp-object-ensure context fragments 'text 'text)) + (owned-plan + (tp-surface-plan-create-owned + :key 'root :kind 'group :capability 'content + :children + (list + (tp-surface-plan-create-owned + :key 'fragments :kind 'group :capability 'content + :children + (list + (tp-surface-plan-create-owned + :key 'text :kind 'text :text "safe" + :capability 'content))))))) + (tp-surface-retained-content-result-create + context owned-plan "safe" nil nil t + '((:start 0 :end 9 :props (face bold))))))) + :type 'tp-invalid-content-range) + (should (equal (buffer-string) "safe"))))) + (ert-deftest tp-surface-test-owned-plan-result-transfers-candidate-tree () "Owned plan and result constructors skip a duplicate candidate snapshot." (tp-surface-test--with-buffer @@ -1227,6 +1536,60 @@ (should (tp-binding-live-p binding)) (should (equal (buffer-string) "after"))))))) +(ert-deftest tp-surface-test-reuse-one-preserves-only-proven-object () + "Single-object reuse retains that identity without retaining a removed peer." + (tp-surface-test--with-buffer + (let ((value "before") kept removed) + (cl-labels + ((producer (context) + (let ((root (tp-object-ensure context nil 'root 'group))) + (if kept + (tp-object-reuse context kept) + (setq kept (tp-object-ensure context root 'kept 'item) + removed (tp-object-ensure context root 'removed 'item)) + (tp-object-retain context kept) + (tp-object-retain context removed)) + (tp-object-ensure context root 'text 'text)) + (tp-surface-plan-create + :key 'root :kind 'group :capability 'content + :children (list (tp-surface-test--leaf 'text value))))) + (let ((surface (tp-surface-mount + buffer #'producer '(:capability content)))) + (setq value "after") + (tp-surface-update surface #'producer) + (should (eq kept (tp-object-resolve surface '(root kept)))) + (should-not (tp-object-live-p removed)) + (should (equal (buffer-string) "after"))))))) + +(ert-deftest tp-surface-test-ensure-at-reuses-anonymous-slot-without-prefix-replay () + "Compiled topology can address one anonymous slot directly." + (tp-surface-test--with-buffer + (let (second) + (cl-labels + ((producer (context) + (let ((root (tp-object-ensure context nil 'root 'group))) + (if second + (progn + (tp-object-reuse + context + (tp-object-resolve + (tp--context-surface context) + '(root (:position 0 :kind item)))) + (setq second + (tp-object-ensure-at context root nil 'item 1))) + (tp-object-retain + context (tp-object-ensure context root nil 'item)) + (setq second (tp-object-ensure context root nil 'item)) + (tp-object-retain context second)) + (tp-object-retain context second)) + (tp-surface-plan-create + :key 'root :kind 'group :capability 'content))) + (let ((surface (tp-surface-mount + buffer #'producer '(:capability content))) + (identity second)) + (tp-surface-update surface #'producer) + (should (eq identity second))))))) + (ert-deftest tp-surface-test-logical-object-owns-leaf-local-ranges () "One logical object can own multiple ranges in one content leaf." (tp-surface-test--with-buffer diff --git a/tp-core.el b/tp-core.el index 630ff5d..c28a43b 100644 --- a/tp-core.el +++ b/tp-core.el @@ -425,6 +425,12 @@ and other opaque objects keep their identity; functions are never executed." (tp--copy-property-value (aref copy index) cache))) copy))))))) +(defun tp-property-value-copy (value) + "Return a defensive copy of mutable text-property VALUE. +Functions, records, and other opaque identities are retained; mutable cons, +string, and non-record vector graphs are copied with sharing and cycles intact." + (tp--copy-property-value value (make-hash-table :test #'eq))) + (defun tp--deep-merge-plist (base new) "Deep merge NEW plist into BASE plist. For nested plists (starting with keyword), recursively merge. diff --git a/tp-palette.el b/tp-palette.el index 681991e..68d8709 100644 --- a/tp-palette.el +++ b/tp-palette.el @@ -261,45 +261,43 @@ documentation of NAME and PLIST.") "Return non-nil when the current frame's background mode is light." (eq (frame-parameter nil 'background-mode) 'light)) -(defun tp-parse-color (color) - "Resolve COLOR to a color string for the current theme. +(defun tp-parse-color (color &optional mode) + "Resolve COLOR to a color string for MODE or the current frame theme. COLOR may be: - a color string, returned as is: \"red\" - a (LIGHT . DARK) cons: (\"red\" . \"green\"); either side may be nil, meaning no color for that mode - a (:light LIGHT :dark DARK) plist: (:light \"red\" :dark \"green\") -Return nil when COLOR is nil, or when the side selected by the -current theme is nil. When the theme cannot be determined, fall -back to the light color." - (cond ((stringp color) color) +MODE may be `light' or `dark'. When MODE is nil, use the current +frame's background mode. Return nil when COLOR is nil, or when the +selected side is nil. An unknown frame mode falls back to `light'." + (let ((mode (or mode (if (tp-theme-dark-p) 'dark 'light)))) + (unless (memq mode '(light dark)) + (signal 'wrong-type-argument (list '(member light dark) mode))) + (cond ((stringp color) color) ((and (consp color) (or (stringp (car color)) (null (car color))) (or (stringp (cdr color)) (null (cdr color)))) - (cond - ((tp-theme-light-p) (car color)) - ((tp-theme-dark-p) (cdr color)) - ;; Default to light color when background-mode is unknown - (t (car color)))) + (if (eq mode 'dark) (cdr color) (car color))) ((and (tp-palette--plistp color) (or (plist-member color :light) (plist-member color :dark))) - (cond - ((tp-theme-light-p) (plist-get color :light)) - ((tp-theme-dark-p) (plist-get color :dark)) - ;; Default to light color when background-mode is unknown - (t (plist-get color :light)))) + (if (eq mode 'dark) + (plist-get color :dark) + (plist-get color :light))) ((null color) nil) - (t (error "Invalid format of color %S" color)))) + (t (error "Invalid format of color %S" color))))) -(defun tp-palette--get-color (symbol key) - "Get color value for KEY from the palette named SYMBOL. +(defun tp-palette--get-color (symbol key &optional mode) + "Get color value for KEY from palette SYMBOL, resolving MODE. SYMBOL is looked up in `tp-palette-alist'. KEY should be one of :fg, :bg, or :border. Return nil if SYMBOL names no registered palette or its definition doesn't contain KEY. -The public entry point delegating here is `tp-palette-color'." +The public entry points are `tp-palette-color' and +`tp-palette-color-for-mode'." (let ((plist (alist-get symbol tp-palette-alist))) (when (tp-palette--plistp plist) - (tp-parse-color (plist-get plist key))))) + (tp-parse-color (plist-get plist key) mode)))) (defun tp-palette-color (symbol key) "Return the KEY color of the palette named SYMBOL, theme-resolved. @@ -317,6 +315,14 @@ conveniences equivalent to calling it with a fixed KEY. See also color." (tp-palette--get-color symbol key)) +(defun tp-palette-color-for-mode (symbol key mode) + "Return palette SYMBOL KEY resolved explicitly for MODE. +MODE must be `light' or `dark'. Unlike `tp-palette-color', this +function does not inspect the selected frame, so a higher-level +application Theme can switch palettes without changing the Emacs +frame's own background mode." + (tp-palette--get-color symbol key mode)) + (defun tp-palette-has-p (symbol &optional kind) "Return non-nil when KIND is available in SYMBOL's palette. With nil KIND, test only that SYMBOL names a palette registered in diff --git a/tp-reactive.el b/tp-reactive.el index 83042a3..93d0fbc 100644 --- a/tp-reactive.el +++ b/tp-reactive.el @@ -490,6 +490,55 @@ or `retain'." (lambda () (tp--bind-in-transaction owner key compute equality lifecycle))))) +(defun tp--bind-precomputed-in-transaction + (owner key compute value dependencies equality lifecycle) + "Install one new initialized binding with explicit DEPENDENCIES." + (let ((table (tp--owner-binding-table owner t))) + (when (gethash key table) + (signal 'tp-reactive-error (list :precomputed-binding-exists key))) + (dolist (dependency dependencies) + (cond ((tp-signal-p dependency) (tp--validate-live-signal dependency)) + ((tp-binding-p dependency) (tp--validate-live-binding dependency)) + (t (signal 'wrong-type-argument + (list '(or tp-signal-p tp-binding-p) dependency))))) + (let ((binding + (tp--make-binding + :id (cl-incf tp--binding-id-counter) + :owner owner :key (tp--copy-property-value key) :compute compute + :equality equality :last-value value :initialized-p t + :dependencies (copy-sequence dependencies) + :subscribers (make-hash-table :test #'eq) + :dirty nil :state 'clean :revision 1 :lifecycle lifecycle))) + (tp--register-binding binding) + (push binding tp--transaction-created-bindings) + (dolist (dependency dependencies) + (tp--subscription-add dependency binding)) + (when tp--binding-touch-function + (funcall tp--binding-touch-function binding)) + binding))) + +(cl-defun tp-bind-precomputed + (owner key compute value dependencies + &key (equality #'equal) (lifecycle 'delete)) + "Install a new binding with precomputed VALUE and explicit DEPENDENCIES. +COMPUTE remains the authoritative recomputation function after any dependency +changes. This entry avoids evaluating COMPUTE merely to rediscover a value +and graph edges already produced by a compiler or pure projection pass." + (when (null owner) + (signal 'tp-reactive-error (list :owner owner))) + (when (null key) + (signal 'tp-reactive-error (list :binding-key key))) + (tp--validate-binding-options compute equality lifecycle) + (unless (proper-list-p dependencies) + (signal 'wrong-type-argument (list 'proper-list-p dependencies))) + (if tp--transaction-active + (tp--bind-precomputed-in-transaction + owner key compute value dependencies equality lifecycle) + (tp--call-with-transaction + (lambda () + (tp--bind-precomputed-in-transaction + owner key compute value dependencies equality lifecycle))))) + (defun tp--detach-binding-dependencies (binding) "Remove BINDING from all dependency subscriber tables." (dolist (dependency (tp-binding-dependencies binding)) diff --git a/tp-style.el b/tp-style.el index b2c9944..3f7d80e 100644 --- a/tp-style.el +++ b/tp-style.el @@ -28,6 +28,13 @@ (cl-defstruct (tp--computed-source (:constructor tp--make-computed-source)) function) +(cl-defstruct (tp-paint-slot (:constructor tp--make-paint-slot)) + "Stable named-face address for one mutable paint contribution." + face spec installed-p) + +(defvar tp--paint-slot-counter 0 + "Monotonic id source for private paint-slot faces.") + (defconst tp--property-policy-option-keys '(:normalizer :validator :equality :merge :projector) "Accepted property policy option keys.") @@ -41,6 +48,92 @@ (defvar tp--named-styles (make-hash-table :test #'eq) "Named direct declaration sets.") +(defun tp--paint-slot-face-spec (spec) + "Return validated face SPEC for a paint slot." + (unless (and (listp spec) (zerop (% (length spec) 2)) + (cl-loop for key in spec by #'cddr always (keywordp key))) + (signal 'tp-invalid-declaration (list :paint-slot spec))) + (copy-tree spec)) + +;;;###autoload +(defun tp-paint-slot-create (spec) + "Create a stable paint slot initialized from anonymous face SPEC." + (let* ((face (intern (format "tp-paint-slot-%d" + (cl-incf tp--paint-slot-counter)))) + (slot (tp--make-paint-slot + :face face :spec (tp--paint-slot-face-spec spec) + :installed-p nil))) + (make-face face) + slot)) + +;;;###autoload +(defun tp-paint-slot-update (slot spec) + "Update SLOT to anonymous face SPEC without changing its address." + (unless (tp-paint-slot-p slot) + (signal 'wrong-type-argument (list 'tp-paint-slot-p slot))) + (let* ((face (tp-paint-slot-face slot)) + (next (tp--paint-slot-face-spec spec)) + (previous (tp-paint-slot-spec slot))) + (condition-case err + (progn + (face-spec-reset-face face) + (when next + (face-spec-set face `((t ,next)))) + (setf (tp-paint-slot-spec slot) next)) + (error + (face-spec-reset-face face) + (when previous + (face-spec-set face `((t ,previous)))) + (signal (car err) (cdr err)))) + slot)) + +(defun tp-paint-slot-apply-updates (buffer updates) + "Apply `(SLOT . SPEC)' UPDATES to BUFFER in one face-remap swap. +Return a rollback journal containing the previous buffer map and slot specs." + (unless (buffer-live-p buffer) + (signal 'wrong-type-argument (list 'buffer-live-p buffer))) + (let ((normalized + (mapcar + (lambda (entry) + (unless (tp-paint-slot-p (car entry)) + (signal 'wrong-type-argument + (list 'tp-paint-slot-p (car entry)))) + (cons (car entry) (tp--paint-slot-face-spec (cdr entry)))) + updates)) + slot-journal next) + (with-current-buffer buffer + (setq next (copy-tree face-remapping-alist)) + (dolist (entry normalized) + (let* ((slot (car entry)) + (spec (cdr entry)) + (face (tp-paint-slot-face slot))) + (push (list slot (copy-tree (tp-paint-slot-spec slot)) + (tp-paint-slot-installed-p slot)) + slot-journal) + (setq next (assq-delete-all face next)) + (when spec + (push (list face spec) next)) + (setf (tp-paint-slot-spec slot) spec + (tp-paint-slot-installed-p slot) t))) + (prog1 + (list :buffer buffer + :face-remapping-alist (copy-tree face-remapping-alist) + :slot-specs (nreverse slot-journal)) + (setq-local face-remapping-alist next))))) + +(defun tp-paint-slot-rollback-updates (journal) + "Restore paint slots from reverse-safe JOURNAL." + (when-let ((buffer (plist-get journal :buffer))) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (setq-local face-remapping-alist + (copy-tree + (plist-get journal :face-remapping-alist)))))) + (dolist (entry (reverse (plist-get journal :slot-specs))) + (setf (tp-paint-slot-spec (nth 0 entry)) (copy-tree (nth 1 entry)) + (tp-paint-slot-installed-p (nth 0 entry)) (nth 2 entry))) + nil) + (defun tp--canonical-property-id-p (id) "Return non-nil when ID is a namespaced property symbol." (and (symbolp id) @@ -142,6 +235,10 @@ OPTIONS support :normalizer, :validator, :equality, :merge, and :projector." (signal 'wrong-type-argument (list 'functionp function))) (tp--make-computed-source :function function)) +(defun tp-computed-p (value) + "Return non-nil when VALUE is an explicit computed source." + (tp--computed-source-p value)) + ;;;###autoload (defun tp-resolve-value (value &optional _property _subject) "Resolve VALUE only when it is an explicit `tp-computed' source. diff --git a/tp-surface.el b/tp-surface.el index fb8ab75..07c91fd 100644 --- a/tp-surface.el +++ b/tp-surface.el @@ -74,10 +74,23 @@ owned result is bound to OWNER-CONTEXT and consumed once during prepare." (:constructor tp--make-retained-content-candidate)) "Candidate for a content-only update on an unchanged TP object tree. PLAN is the candidate's unchanged object topology with a new text leaf, -RENDERED is the already-propertized candidate text, and RANGES are the -candidate-owned content-range attachments. CONTEXT authenticates the -one-shot producer result to the active prepare transaction." - plan rendered ranges client-state context full-surface-p consumed-p) +RENDERED is the candidate text, RANGES are the candidate-owned content-range +attachments, and PROPERTY-CONTRIBUTIONS are ordered relative range property +layers composed by TP during prepare. CONTEXT authenticates the one-shot +producer result to the active prepare transaction." + plan rendered ranges property-contributions client-state context + full-surface-p consumed-p) + +(cl-defstruct (tp-commit-batch (:constructor tp--make-commit-batch)) + "One precomputed content commit for a stable retained surface topology." + base-revision target-revision base-extent target-extent patches + coordinate-patches client-state) + +(cl-defstruct (tp-commit-batch-candidate + (:constructor tp--make-commit-batch-candidate)) + "One prepare-context-authenticated precomputed commit result." + batch context mount-specs exact-mount-specs-p client-state + exact-client-state-p reuse-mount-projection-p consumed-p) (cl-defstruct (tp-surface (:constructor tp--make-surface) @@ -122,7 +135,8 @@ one-shot producer result to the active prepare transaction." surface context plan rendered mount-specs ledger-specs property-operations objects client-state producer initial created removed moved reconciled scope-objects scope-patches scope-fallback live-mounts live-mount-index - live-ledger report retained-content-p) + live-ledger report retained-content-p commit-batch + retained-mount-state-p mount-coordinate-updates mount-coordinate-undo) (cl-defstruct (tp--surface-snapshot (:constructor tp--make-surface-snapshot)) plan objects mounts index mount-index ledger client-state producer revision @@ -261,14 +275,17 @@ Use `tp-surface-result-create' for ordinary caller-owned plans." (tp--validate-surface-plan-tree plan) client-state t context)) (defun tp-surface-retained-content-result-create - (context plan rendered ranges &optional client-state full-surface-p) + (context plan rendered ranges &optional client-state full-surface-p + property-contributions) "Create a one-shot retained content candidate for CONTEXT. PLAN must preserve the committed TP object topology and contain the new text leaf. RENDERED is the final propertized text and RANGES are candidate-local -content attachments already associated with PLAN's text leaf. This entry -point is intentionally narrow: callers must prove that object topology is -unchanged; TP still validates every object, range, scope, and publication -phase before accepting the candidate." +content attachments already associated with PLAN's text leaf. +PROPERTY-CONTRIBUTIONS is an ordered list of relative `:start', `:end', and +`:props' plists. TP composes them over RENDERED using registered property +merge policy before diff and publication. This entry point is intentionally +narrow: callers must prove that object topology is unchanged; TP still +validates every object, range, scope, and publication phase." (tp--validate-prepare-context context) (unless (eq context tp--current-prepare-context) (signal 'tp-owned-result-error @@ -279,8 +296,53 @@ phase before accepting the candidate." (signal 'tp-invalid-surface-plan (list :retained-content plan rendered ranges))) (tp--make-retained-content-candidate - :plan plan :rendered rendered :ranges ranges :client-state client-state - :context context :full-surface-p full-surface-p)) + :plan plan :rendered rendered :ranges ranges + :property-contributions property-contributions + :client-state client-state :context context + :full-surface-p full-surface-p)) + +(defun tp--compose-relative-property-contributions (rendered contributions) + "Compose ordered relative CONTRIBUTIONS over RENDERED. +Each contribution contains `:start', `:end', and direct `:props'." + (unless (proper-list-p contributions) + (signal 'tp-invalid-content-range + (list :property-contributions contributions))) + (let ((result (copy-sequence rendered)) + (limit (length rendered))) + (dolist (contribution contributions) + (let ((start (plist-get contribution :start)) + (end (plist-get contribution :end)) + (props (plist-get contribution :props))) + (unless (and (integerp start) (integerp end) + (<= 0 start) (<= start end) (<= end limit)) + (signal 'tp-invalid-content-range + (list :property-contribution contribution + :leaf-length limit))) + (unless (tp--plist-shape-p props) + (signal 'tp-invalid-surface-plan + (list :property-contribution-props props))) + (cl-loop for (property value) on props by #'cddr + do + (let ((position start) + (merge + (tp-property-policy-merge + (tp-register-text-property property)))) + (while (< position end) + (let* ((next + (or (next-single-property-change + position property result end) + end)) + (cell + (plist-member + (text-properties-at position result) property)) + (target + (cond + ((null value) nil) + (cell (funcall merge (cadr cell) value)) + (t (tp--copy-property-value value))))) + (put-text-property position next property target result) + (setq position next))))))) + result)) (defun tp--property-value-equal-p (property left right) "Return non-nil when PROPERTY values LEFT and RIGHT are policy-equal." @@ -399,6 +461,36 @@ phase before accepting the candidate." (puthash object t (tp--context-touched context)) object)) +(defun tp-object-ensure-at (context parent key kind position) + "Return candidate identity at explicit sibling POSITION below PARENT. +KEYED objects retain their normal explicit-key identity; POSITION is used only +for anonymous objects. This is the compiled-topology entry point and does not +depend on replaying preceding siblings to discover the same slot." + (tp--validate-prepare-context context) + (tp--validate-context-parent context parent) + (unless kind + (signal 'tp-invalid-surface-plan (list :kind kind))) + (unless (and (integerp position) (>= position 0)) + (signal 'tp-invalid-surface-plan (list :position position))) + (let* ((segment + (if key + (let ((seen (tp--context-child-table context parent))) + (when (gethash key seen) + (signal 'tp-duplicate-object-key (list key))) + (puthash key t seen) + key) + (list :position position :kind kind))) + (path (append (and parent (tp--surface-object-path parent)) + (list segment))) + (objects (tp--context-objects context)) + (old (gethash path objects)) + (object (if (and old (equal kind (tp--surface-object-kind old))) + old + (tp--new-candidate-object context parent key kind path)))) + (puthash path object objects) + (puthash object t (tp--context-touched context)) + object)) + (defun tp-object-live-p (object) "Return non-nil when OBJECT is committed on a live surface." (and (tp-object-p object) (tp--surface-object-live object) @@ -472,6 +564,27 @@ When EPHEMERAL is non-nil, no identity may be promoted." (puthash object t (tp--context-retained context)) object) +(defun tp-object-reuse (context object) + "Reuse one proven unchanged live OBJECT in CONTEXT. +The object and its live bindings remain in the candidate without being marked +as touched. The caller owns the proof that identity, parent path, output, and +lifecycle are unchanged." + (tp--validate-prepare-context context) + (unless (tp-object-p object) + (signal 'wrong-type-argument (list 'tp-object-p object))) + (let* ((surface (tp--context-surface context)) + (path (tp--surface-object-path object)) + (objects (tp--context-objects context))) + (unless (and (tp-object-live-p object) + (eq (tp--surface-object-surface object) surface) + (eq object (gethash path objects))) + (signal 'tp-stale-object (list object))) + (puthash object t (tp--context-retained context)) + (dolist (binding (tp-binding-owner-bindings object)) + (when (tp-binding-live-p binding) + (puthash binding t (tp--context-bindings context))))) + object) + (defun tp--object-path-prefix-p (prefix path) "Return non-nil when PREFIX is a path prefix of PATH." (and (<= (length prefix) (length path)) @@ -730,9 +843,12 @@ OWNED-P transfers candidate-local property values through the render pass." (let ((expected (make-hash-table :test #'equal)) (actual (make-hash-table :test #'equal))) (dolist (path (tp--plan-paths plan)) (puthash path t expected)) - (maphash (lambda (object _present) - (puthash (tp--surface-object-path object) object actual)) - (tp--context-touched context)) + (maphash + (lambda (_path object) + (when (or (gethash object (tp--context-touched context)) + (gethash object (tp--context-retained context))) + (puthash (tp--surface-object-path object) object actual))) + (tp--context-objects context)) (maphash (lambda (path _present) (unless (gethash path actual) @@ -765,6 +881,16 @@ OWNED-P transfers candidate-local property values through the render pass." (defun tp--producer-result (value surface options context) "Normalize producer VALUE for SURFACE and active CONTEXT using OPTIONS." (cond + ((tp-commit-batch-candidate-p value) + (unless (and context + (tp--context-active context) + (eq context tp--current-prepare-context) + (eq context (tp-commit-batch-candidate-context value)) + (not (tp-commit-batch-candidate-consumed-p value))) + (signal 'tp-owned-result-error (list value context))) + (setf (tp-commit-batch-candidate-consumed-p value) t + (tp-commit-batch-candidate-context value) nil) + (list :commit-batch value)) ((tp-retained-content-candidate-p value) (unless (and context (tp--context-active context) @@ -1243,7 +1369,10 @@ still validated and published through the ordinary TP transaction phases." (unless (eq (tp--surface-capability surface) 'content) (signal 'tp-capability-error (list :retained-content 'properties))) (let* ((plan (tp-retained-content-candidate-plan candidate)) - (rendered (tp-retained-content-candidate-rendered candidate)) + (rendered + (tp--compose-relative-property-contributions + (tp-retained-content-candidate-rendered candidate) + (tp-retained-content-candidate-property-contributions candidate))) (ranges (tp-retained-content-candidate-ranges candidate)) (objects (tp--context-objects context)) (root-path (list (tp--plan-segment plan 0))) @@ -1283,7 +1412,7 @@ still validated and published through the ordinary TP transaction phases." (unless (<= end (length rendered)) (signal 'tp-invalid-content-range (list :start start :end end - :leaf-length (length rendered))))) + :leaf-length (length rendered)))))) (puthash text-leaf ranges (tp--context-content-range-attachments context))) (let* ((length (length rendered)) @@ -1339,7 +1468,163 @@ still validated and published through the ordinary TP transaction phases." :reconciled 0 :scope-objects scope-objects :scope-patches scope-patches :scope-fallback (plist-get scope-analysis :fallback) - :retained-content-p retained-content-p))))) + :retained-content-p retained-content-p)))) + +(defun tp--commit-batch-rebase-position (patches position end-p) + "Map old POSITION through ordered coordinate PATCHES. +END-P selects the right boundary when POSITION lies inside a replacement." + (let ((delta 0) result) + (while (and patches (null result)) + (let* ((patch (car patches)) + (old-start (plist-get patch :old-start)) + (old-end (plist-get patch :old-end)) + (new-start (plist-get patch :new-start)) + (new-end (plist-get patch :new-end))) + (cond + ((< position old-start) (setq result (+ position delta))) + ((= position old-start) (setq result new-start)) + ((< position old-end) (setq result (if end-p new-end new-start))) + ((= position old-end) (setq result new-end)) + (t (setq delta (- new-end old-end) + patches (cdr patches)))))) + (or result (+ position delta)))) + +(defun tp--commit-batch-mount-specs (surface batch) + "Return SURFACE coordinate mounts rebased through BATCH." + (let ((base (marker-position (tp--surface-start surface)))) + (mapcar + (lambda (mount) + (let ((start (- (tp--mount-position + (tp--surface-mount-start mount)) base)) + (end (- (tp--mount-position + (tp--surface-mount-end mount)) base)) + (patches (tp-commit-batch-coordinate-patches batch))) + (list :object (tp--surface-mount-object mount) + :start (tp--commit-batch-rebase-position patches start nil) + :end (tp--commit-batch-rebase-position patches end t) + :tags (copy-tree (tp--surface-mount-tags mount))))) + (tp--surface-mounts surface)))) + +(defun tp--commit-batch-retained-mount-state + (surface mount-specs context target-extent) + "Return exact coordinate updates when SURFACE can retain MOUNT-SPECS. +The returned cons distinguishes an exact empty update set from a proof miss." + (let ((base (marker-position (tp--surface-start surface))) + (mounts (tp--surface-mounts surface)) + (specs mount-specs) + (retainable + (and (plist-get (tp--surface-options surface) :coordinate-mounts) t)) + (updates + (and (plist-get (tp--surface-options surface) :coordinate-mounts) + (make-vector (* 3 (length mount-specs)) nil))) + (update-index 0)) + (while specs + (let* ((spec (pop specs)) + (mount (and mounts (pop mounts))) + (object (plist-get spec :object)) + (start (plist-get spec :start)) + (end (plist-get spec :end))) + (unless (and (tp-object-p object) + (or (gethash object (tp--context-touched context)) + (gethash object (tp--context-retained context))) + (integerp start) (integerp end) + (<= 0 start end target-extent)) + (signal 'tp-surface-error + (list :commit-mount-range start end target-extent))) + (if (and retainable mount + (integerp (tp--surface-mount-start mount)) + (integerp (tp--surface-mount-end mount)) + (eq (tp--surface-mount-object mount) object) + (eq (tp--surface-mount-tags mount) + (plist-get spec :tags))) + (progn + (aset updates update-index mount) + (aset updates (1+ update-index) (+ base start)) + (aset updates (+ update-index 2) (+ base end)) + (setq update-index (+ update-index 3))) + (setq retainable nil + updates nil)))) + (when mounts (setq retainable nil)) + (and retainable (cons t updates)))) + +(defun tp--commit-batch-stable-object-set-p (surface objects) + "Return non-nil when OBJECTS are exactly SURFACE's retained identities." + (let ((live (tp--surface-objects surface))) + (and (hash-table-p live) + (= (hash-table-count live) (length objects)) + (cl-every + (lambda (object) + (eq (gethash (tp--surface-object-path object) live) object)) + objects)))) + +(defun tp--commit-batch-coordinate-identity-p (batch) + "Return non-nil when BATCH cannot move any retained coordinate." + (and (= (tp-commit-batch-base-extent batch) + (tp-commit-batch-target-extent batch)) + (cl-every + (lambda (patch) + (and (= (plist-get patch :old-start) + (plist-get patch :new-start)) + (= (plist-get patch :old-end) + (plist-get patch :new-end)))) + (tp-commit-batch-coordinate-patches batch)))) + +(defun tp--prepare-commit-batch + (surface candidate context scope-objects input initial) + "Prepare strict equal-coordinate CANDIDATE for stable SURFACE topology." + (when initial + (signal 'tp-invalid-surface-plan (list :commit-batch-initial t))) + (unless (and (eq (tp--surface-capability surface) 'content) + (plist-get (tp--surface-options surface) :coordinate-mounts)) + (signal 'tp-capability-error (list :commit-batch-coordinate-surface))) + (let* ((batch (tp-commit-batch-candidate-batch candidate)) + (extent (- (marker-position (tp--surface-end surface)) + (marker-position (tp--surface-start surface)))) + (objects (tp--candidate-object-list context)) + (reuse-mount-projection-p + (tp-commit-batch-candidate-reuse-mount-projection-p candidate)) + (coordinate-identity-p + (and (not reuse-mount-projection-p) + (not (tp-commit-batch-candidate-exact-mount-specs-p candidate)) + (tp--commit-batch-coordinate-identity-p batch))) + (mount-specs + (cond + ((tp-commit-batch-candidate-exact-mount-specs-p candidate) + (tp-commit-batch-candidate-mount-specs candidate)) + (reuse-mount-projection-p nil) + (coordinate-identity-p nil) + (t (tp--commit-batch-mount-specs surface batch)))) + (retained-mount-state + (if (or reuse-mount-projection-p coordinate-identity-p) + (cons t []) + (tp--commit-batch-retained-mount-state + surface mount-specs context + (tp-commit-batch-target-extent batch))))) + (unless (and (= (tp-commit-batch-base-revision batch) + (tp--surface-revision surface)) + (= (tp-commit-batch-target-revision batch) + (1+ (tp--surface-revision surface))) + (= extent (tp-commit-batch-base-extent batch)) + (or (not reuse-mount-projection-p) + (= (tp-commit-batch-base-extent batch) + (tp-commit-batch-target-extent batch)))) + (signal 'tp-surface-error (list :unsupported-commit-batch batch))) + (unless (tp--commit-batch-stable-object-set-p surface objects) + (signal 'tp-orphan-object (list :commit-batch-object-set))) + (tp--make-prepared-surface + :surface surface :context context :plan (tp--surface-plan surface) + :rendered nil :mount-specs mount-specs + :objects objects + :client-state + (if (tp-commit-batch-candidate-exact-client-state-p candidate) + (tp-commit-batch-candidate-client-state candidate) + (tp-commit-batch-client-state batch)) + :producer input :initial nil :created nil :removed nil :moved 0 + :reconciled 0 :scope-objects scope-objects + :scope-patches (tp-commit-batch-patches batch) + :scope-fallback nil :commit-batch batch + :retained-mount-state-p (and retained-mount-state t) + :mount-coordinate-updates (cdr retained-mount-state)))) (defun tp--prepare-surface (surface input options initial) "Prepare INPUT for SURFACE without publishing it. @@ -1362,11 +1647,15 @@ OPTIONS configure the mount and INITIAL is non-nil for first publication." surface (lambda () (tp--prepare-input surface input options context))))) - (if (eq (car normalized) :retained-content) + (if (memq (car normalized) '(:retained-content :commit-batch)) (setq result - (tp--prepare-retained-content - surface (cadr normalized) context scope-objects - scope-options initial)) + (if (eq (car normalized) :retained-content) + (tp--prepare-retained-content + surface (cadr normalized) context scope-objects + scope-options initial) + (tp--prepare-commit-batch + surface (cadr normalized) context scope-objects + input initial))) (let* ((plan (nth 0 normalized)) (client-state (nth 1 normalized)) (owned-p (nth 2 normalized)) @@ -1665,6 +1954,199 @@ MOUNT-SPECS and SURFACE provide ranges for PROPERTIES." (tp--validate-live-surface surface) (tp--surface-client-state surface)) +(cl-defun tp-commit-batch-create + (&key base-revision target-revision base-extent target-extent + patches coordinate-patches client-state) + "Create a validated precomputed content commit batch. +PATCHES are ordered plists containing :old-start, :old-end, :new-start, +:new-end, and a propertized :replacement string." + (unless (and (integerp base-revision) (>= base-revision 0) + (integerp target-revision) + (= target-revision (1+ base-revision))) + (signal 'tp-surface-error + (list :commit-revision base-revision target-revision))) + (unless (and (integerp base-extent) (>= base-extent 0) + (integerp target-extent) (>= target-extent 0) + (proper-list-p patches) (proper-list-p coordinate-patches)) + (signal 'tp-surface-error + (list :commit-extents base-extent target-extent))) + (let ((old-cursor 0) (new-cursor 0) copy coordinate-copy) + (dolist (patch patches) + (let ((old-start (plist-get patch :old-start)) + (old-end (plist-get patch :old-end)) + (new-start (plist-get patch :new-start)) + (new-end (plist-get patch :new-end)) + (replacement (plist-get patch :replacement))) + (unless (and (integerp old-start) (integerp old-end) + (integerp new-start) (integerp new-end) + (<= old-cursor old-start old-end base-extent) + (<= new-cursor new-start new-end target-extent) + (= (- old-start old-cursor) + (- new-start new-cursor)) + (stringp replacement) + (= (length replacement) (- new-end new-start))) + (signal 'tp-surface-error (list :commit-patch patch))) + (push (copy-tree patch) copy) + (setq old-cursor old-end new-cursor new-end))) + (unless (= (- base-extent old-cursor) + (- target-extent new-cursor)) + (signal 'tp-surface-error + (list :commit-tail old-cursor new-cursor))) + (setq old-cursor 0 new-cursor 0) + (dolist (patch coordinate-patches) + (let ((old-start (plist-get patch :old-start)) + (old-end (plist-get patch :old-end)) + (new-start (plist-get patch :new-start)) + (new-end (plist-get patch :new-end))) + (unless (and (integerp old-start) (integerp old-end) + (integerp new-start) (integerp new-end) + (<= old-cursor old-start old-end base-extent) + (<= new-cursor new-start new-end target-extent) + (= (- old-start old-cursor) + (- new-start new-cursor))) + (signal 'tp-surface-error + (list :commit-coordinate-patch patch))) + (push (copy-tree patch) coordinate-copy) + (setq old-cursor old-end new-cursor new-end))) + (unless (= (- base-extent old-cursor) + (- target-extent new-cursor)) + (signal 'tp-surface-error + (list :commit-coordinate-tail old-cursor new-cursor))) + (tp--make-commit-batch + :base-revision base-revision :target-revision target-revision + :base-extent base-extent :target-extent target-extent + :patches (nreverse copy) + :coordinate-patches (nreverse coordinate-copy) + :client-state (tp--copy-property-value client-state)))) + +(cl-defun tp-commit-batch-result-create + (context batch + &key (mount-specs nil mount-specs-p) + (client-state nil client-state-p) + reuse-mount-projection) + "Return one authenticated producer result carrying precomputed BATCH. +When MOUNT-SPECS is supplied, it is the complete target coordinate projection +for the batch. Each spec contains `:object', `:start', `:end', and optional +`:tags'. When CLIENT-STATE is supplied, it replaces BATCH's defensive state +snapshot. The active prepare context owns and transfers these candidate +values without another materialization. REUSE-MOUNT-PROJECTION asserts that +the producer proved the complete target mount topology and coordinates equal +to the committed projection, as with `tp-object-reuse-subtree'." + (unless (and (tp-prepare-context-p context) + (tp--context-active context) + (eq context tp--current-prepare-context) + (tp-commit-batch-p batch)) + (signal 'tp-owned-result-error (list :commit-batch context batch))) + (when (and mount-specs-p reuse-mount-projection) + (signal 'tp-surface-error (list :conflicting-commit-mount-projection))) + (when mount-specs-p + (unless (proper-list-p mount-specs) + (signal 'tp-surface-error (list :commit-mount-specs)))) + (tp--make-commit-batch-candidate + :batch batch :context context :mount-specs mount-specs + :exact-mount-specs-p mount-specs-p :client-state client-state + :exact-client-state-p client-state-p + :reuse-mount-projection-p (and reuse-mount-projection t))) + +(defun tp--commit-batch-apply-patches (surface batch) + "Apply BATCH's already validated patches to SURFACE." + (let ((buffer (tp--surface-buffer surface)) + (base (marker-position (tp--surface-start surface)))) + (with-current-buffer buffer + (save-restriction + (widen) + (let ((inhibit-read-only + (plist-get (tp--surface-options surface) + :inhibit-read-only))) + (dolist (patch (reverse (tp-commit-batch-patches batch))) + (let ((start (+ base (plist-get patch :old-start))) + (end (+ base (plist-get patch :old-end))) + (replacement (plist-get patch :replacement))) + (delete-region start end) + (goto-char start) + (insert replacement)))))) + (set-marker (tp--surface-start surface) base buffer) + (set-marker (tp--surface-end surface) + (+ base (tp-commit-batch-target-extent batch)) buffer))) + +(defun tp--commit-batch-validate-buffer (surface batch) + "Validate BATCH's published extent and changed spans on SURFACE." + (let ((buffer (tp--surface-buffer surface)) + (base (marker-position (tp--surface-start surface)))) + (let ((actual (- (marker-position (tp--surface-end surface)) base)) + (expected (tp-commit-batch-target-extent batch))) + (unless (= actual expected) + (signal 'tp-publication-mismatch + (list :commit-extent :actual actual :expected expected)))) + (dolist (patch (tp-commit-batch-patches batch)) + (let ((start (+ base (plist-get patch :new-start))) + (end (+ base (plist-get patch :new-end))) + (replacement (plist-get patch :replacement))) + (unless (equal-including-properties + (with-current-buffer buffer (buffer-substring start end)) + replacement) + (signal 'tp-publication-mismatch + (list :commit-patch patch))))))) + +(defun tp--commit-batch-validate-mounts (surface batch mounts) + "Validate target MOUNTS for BATCH inside SURFACE." + (let ((base (marker-position (tp--surface-start surface))) + (limit (+ (marker-position (tp--surface-start surface)) + (tp-commit-batch-target-extent batch)))) + (dolist (mount mounts) + (let ((start (tp--mount-position (tp--surface-mount-start mount))) + (end (tp--mount-position (tp--surface-mount-end mount)))) + (unless (and start end (<= base start end limit)) + (signal 'tp-publication-mismatch + (list :commit-mount mount))))))) + +;;;###autoload +(defun tp-surface-commit-batch (surface batch) + "Atomically apply precomputed BATCH to stable content SURFACE." + (tp--validate-live-surface surface) + (unless (and (tp-commit-batch-p batch) + (eq (tp--surface-capability surface) 'content) + (= (tp--surface-revision surface) + (tp-commit-batch-base-revision batch)) + (= (- (marker-position (tp--surface-end surface)) + (marker-position (tp--surface-start surface))) + (tp-commit-batch-base-extent batch))) + (signal 'tp-surface-error (list :stale-commit-batch surface batch))) + (let* ((buffer (tp--surface-buffer surface)) + (old-revision (tp--surface-revision surface)) + (old-client-state (tp--surface-client-state surface)) + (old-report (tp--surface-report surface)) + (views (tp--capture-view-state (list buffer))) + (group (tp--prepare-change-group-for-buffers (list buffer))) + success) + (unwind-protect + (progn + (tp--commit-batch-apply-patches surface batch) + (tp--commit-batch-validate-buffer surface batch) + (tp--commit-batch-validate-mounts + surface batch (tp--surface-mounts surface)) + (setf (tp--surface-client-state surface) + (tp-commit-batch-client-state batch) + (tp--surface-revision surface) + (tp-commit-batch-target-revision batch) + (tp--surface-report surface) + (list :transaction-id (cl-incf tp--surface-transaction-id) + :surface-id (tp--surface-id surface) + :old-revision old-revision + :new-revision (tp-commit-batch-target-revision batch) + :text-operations (length (tp-commit-batch-patches batch)) + :property-operations 0 :commit-batch t + :rolled-back nil :failure nil)) + (accept-change-group group) + (setq success t) + (tp-surface-report surface)) + (unless success + (tp--cancel-change-group-safely group) + (setf (tp--surface-client-state surface) old-client-state + (tp--surface-revision surface) old-revision + (tp--surface-report surface) old-report)) + (tp--restore-view-state views)))) + (defun tp--validate-surface-buffer (surface initial) "Validate SURFACE's buffer before prepare; INITIAL permits a candidate." (let ((buffer (tp--surface-buffer surface))) @@ -2233,6 +2715,48 @@ When SCOPED is non-nil, inspect only RANGES, including an empty set." (tp--prepared-surface-live-ledger prepared) ledger) mounts)) +(defun tp--retain-candidate-mount-state (prepared) + "Apply PREPARED coordinate updates while retaining mount identity and index." + (let* ((surface (tp--prepared-surface-surface prepared)) + (mounts (tp--surface-mounts surface)) + (updates (tp--prepared-surface-mount-coordinate-updates prepared)) + (undo (make-vector (* 2 (/ (length updates) 3)) nil)) + (update-index 0) + (undo-index 0)) + (while (< update-index (length updates)) + (let ((mount (aref updates update-index))) + (aset undo undo-index (tp--surface-mount-start mount)) + (aset undo (1+ undo-index) (tp--surface-mount-end mount)) + (setf (tp--surface-mount-start mount) + (aref updates (1+ update-index)) + (tp--surface-mount-end mount) + (aref updates (+ update-index 2))) + (setq update-index (+ update-index 3) + undo-index (+ undo-index 2)))) + (setf (tp--prepared-surface-mount-coordinate-undo prepared) + undo + (tp--prepared-surface-live-mounts prepared) mounts + (tp--prepared-surface-live-mount-index prepared) + (tp--surface-mount-index surface) + (tp--prepared-surface-live-ledger prepared) + (tp--surface-ledger surface)) + mounts)) + +(defun tp--restore-retained-mount-state (prepared) + "Restore PREPARED retained mount coordinates after rollback." + (let ((updates (tp--prepared-surface-mount-coordinate-updates prepared)) + (undo (tp--prepared-surface-mount-coordinate-undo prepared)) + (update-index 0) + (undo-index 0)) + (when (and (vectorp updates) (vectorp undo)) + (while (< update-index (length updates)) + (let ((mount (aref updates update-index))) + (setf (tp--surface-mount-start mount) (aref undo undo-index) + (tp--surface-mount-end mount) (aref undo (1+ undo-index))) + (setq update-index (+ update-index 3) + undo-index (+ undo-index 2)))))) + (setf (tp--prepared-surface-mount-coordinate-undo prepared) nil)) + (defun tp--surface-snapshot (surface) "Return a rollback snapshot of SURFACE side state." (tp--make-surface-snapshot @@ -2261,12 +2785,15 @@ When SCOPED is non-nil, inspect only RANGES, including an empty set." (fallback (tp--prepared-surface-scope-fallback prepared)) (patches (tp--prepared-surface-scope-patches prepared)) (touched - (if (and scoped (not fallback)) + (if-let ((batch (tp--prepared-surface-commit-batch prepared))) + (cl-loop for patch in (tp-commit-batch-patches batch) + sum (length (plist-get patch :replacement))) + (if (and scoped (not fallback)) (cl-loop for patch in patches sum (if (eq (tp--surface-capability surface) 'content) (length (plist-get patch :replacement)) (- (cdr patch) (car patch)))) - (length (tp--prepared-surface-rendered prepared))))) + (length (tp--prepared-surface-rendered prepared)))))) (list :transaction-id tp--surface-transaction-id :surface-id (tp--surface-id surface) :old-revision old-revision :new-revision new-revision @@ -2287,6 +2814,9 @@ When SCOPED is non-nil, inspect only RANGES, including an empty set." :scope-range-count (and scoped (length patches)) :scope-fallback fallback :property-conflicts nil :rolled-back nil + :commit-batch (and (tp--prepared-surface-commit-batch prepared) t) + :retained-mount-state + (and (tp--prepared-surface-retained-mount-state-p prepared) t) :failure nil :observer-errors nil :timing nil))) (defun tp--scoped-content-ranges (patches) @@ -2363,6 +2893,15 @@ the generic property-operation ledger." (defun tp--publish-buffer-content (prepared) "Publish PREPARED's text and properties, returning operation counts." + (cl-block publish + (when-let ((batch (tp--prepared-surface-commit-batch prepared))) + (let ((surface (tp--prepared-surface-surface prepared))) + (tp--commit-batch-apply-patches surface batch) + (tp--publication-step 'text surface) + (tp--commit-batch-validate-buffer surface batch) + (tp--publication-step 'property surface) + (cl-return-from publish + (cons (length (tp-commit-batch-patches batch)) 0)))) (let* ((surface (tp--prepared-surface-surface prepared)) (buffer (tp--surface-buffer surface)) (rendered (tp--prepared-surface-rendered prepared)) @@ -2399,7 +2938,7 @@ the generic property-operation ledger." (when (tp--prepared-surface-retained-content-p prepared) (tp--publication-step 'property surface)))) (goto-char (min point-before (point-max))))) - (cons text-operations (length property-operations)))))) + (cons text-operations (length property-operations))))))) (defun tp--publish-buffer-properties (prepared) "Publish PREPARED's host-range property operations." @@ -2430,7 +2969,10 @@ the generic property-operation ledger." (tp--promote-prepared-objects prepared) (setf (tp--surface-plan surface) (tp--prepared-surface-plan prepared) (tp--surface-objects surface) - (tp--surface-object-table (tp--prepared-surface-objects prepared)) + (if (tp--prepared-surface-retained-mount-state-p prepared) + (tp--surface-objects surface) + (tp--surface-object-table + (tp--prepared-surface-objects prepared))) (tp--surface-mounts surface) mounts (tp--surface-index surface) mounts (tp--surface-mount-index surface) @@ -2455,7 +2997,14 @@ the generic property-operation ledger." (counts (if (eq (tp--surface-capability surface) 'content) (tp--publish-buffer-content prepared) (tp--publish-buffer-properties prepared)))) - (tp--create-candidate-mount-state prepared) + (if (tp--prepared-surface-retained-mount-state-p prepared) + (tp--retain-candidate-mount-state prepared) + (tp--create-candidate-mount-state prepared)) + (when-let ((batch (and (not (tp--prepared-surface-retained-mount-state-p + prepared)) + (tp--prepared-surface-commit-batch prepared)))) + (tp--commit-batch-validate-mounts + surface batch (tp--prepared-surface-live-mounts prepared))) (tp--publication-step 'marker surface) (tp--publication-step 'index surface) (tp--swap-surface-state prepared counts) @@ -2627,6 +3176,7 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback." (defun tp--restore-surface-snapshot (prepared snapshot) "Restore PREPARED's surface from SNAPSHOT after failed publication." (let ((surface (tp--prepared-surface-surface prepared))) + (tp--restore-retained-mount-state prepared) (tp--dispose-content-mounts (tp--prepared-surface-live-mounts prepared)) (tp--dispose-ledger (tp--prepared-surface-live-ledger prepared)) @@ -2729,6 +3279,36 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback." (when tp--surface-precommit-step-function (funcall tp--surface-precommit-step-function step state))) +(defun tp--validate-retained-batch-precommit (prepared snapshot) + "Validate PREPARED retained batch from constant-time committed identities." + (let* ((surface (tp--prepared-surface-surface prepared)) + (batch (tp--prepared-surface-commit-batch prepared)) + (mounts (tp--surface-mounts surface)) + (mount-index (tp--surface-mount-index surface))) + (tp--validate-live-surface surface) + (unless (and batch + (eq (tp--surface-plan surface) + (tp--prepared-surface-plan prepared)) + (eq (tp--surface-objects surface) + (tp--surface-snapshot-objects snapshot)) + (eq mounts (tp--surface-snapshot-mounts snapshot)) + (eq mount-index + (tp--surface-snapshot-mount-index snapshot)) + (eq (tp--surface-index surface) mounts) + (eq (tp--prepared-surface-live-mounts prepared) mounts) + (eq (tp--prepared-surface-live-mount-index prepared) + mount-index) + (= (tp--surface-revision surface) + (tp-commit-batch-target-revision batch)) + (not (tp--context-active + (tp--prepared-surface-context prepared))) + (plist-get (tp--surface-report surface) :commit-batch) + (plist-get (tp--surface-report surface) + :retained-mount-state)) + (signal 'tp-surface-error + (list :invalid-retained-batch-precommit + (tp--surface-id surface)))))) + (defun tp--validate-surface-precommit (state) "Validate final published semantics and rollback ownership in STATE." (unless (and (gethash 'change-group state) @@ -2746,15 +3326,18 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback." (unless (and (tp--prepared-surface-p (car entry)) (tp--surface-snapshot-p (cdr entry))) (signal 'tp-surface-error (list :invalid-surface-cleanup entry))) - (let* ((prepared (car entry)) - (surface (tp--prepared-surface-surface prepared)) - (plan (tp--surface-plan surface)) - (objects (tp--surface-objects surface)) - (mounts (tp--surface-mounts surface)) - (mount-index (tp--surface-mount-index surface)) - (capability (tp--surface-capability surface)) - (mount-set (make-hash-table :test #'eq)) - (indexed-mount-set (make-hash-table :test #'eq))) + (let ((prepared (car entry)) + (snapshot (cdr entry))) + (if (tp--prepared-surface-retained-mount-state-p prepared) + (tp--validate-retained-batch-precommit prepared snapshot) + (let* ((surface (tp--prepared-surface-surface prepared)) + (plan (tp--surface-plan surface)) + (objects (tp--surface-objects surface)) + (mounts (tp--surface-mounts surface)) + (mount-index (tp--surface-mount-index surface)) + (capability (tp--surface-capability surface)) + (mount-set (make-hash-table :test #'eq)) + (indexed-mount-set (make-hash-table :test #'eq))) (tp--validate-live-surface surface) (unless (eq plan (tp--prepared-surface-plan prepared)) (signal 'tp-surface-error (list :invalid-published-plan surface))) @@ -2823,31 +3406,32 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback." (list :invalid-published-anchor mount)))) (when (tp--surface-mount-anchor mount) (signal 'tp-surface-error - (list :invalid-content-anchor mount))))))) + (list :invalid-content-anchor mount))))))))) state)) (defun tp--surface-prevalidate-cleanup (state) "Validate marker-backed cleanup lists retained in surface STATE." (dolist (entry (gethash 'snapshots state)) - (let* ((prepared (car entry)) - (snapshot (cdr entry)) - (surface (tp--prepared-surface-surface prepared)) - (coordinate-p - (plist-get (tp--surface-options surface) :coordinate-mounts))) - (dolist (mount (tp--surface-snapshot-mounts snapshot)) - (when (eq (tp--surface-mount-capability mount) 'content) - (unless (or (and (markerp (tp--surface-mount-start mount)) - (markerp (tp--surface-mount-end mount))) - (and coordinate-p - (integerp (tp--surface-mount-start mount)) - (integerp (tp--surface-mount-end mount)))) - (signal 'tp-surface-error - (list :invalid-mount-cleanup mount))))) - (dolist (ledger (tp--surface-snapshot-ledger snapshot)) - (unless (and (markerp (tp--property-ledger-start ledger)) - (markerp (tp--property-ledger-end ledger))) - (signal 'tp-surface-error - (list :invalid-ledger-cleanup ledger)))))) + (let ((prepared (car entry))) + (unless (tp--prepared-surface-retained-mount-state-p prepared) + (let* ((snapshot (cdr entry)) + (surface (tp--prepared-surface-surface prepared)) + (coordinate-p + (plist-get (tp--surface-options surface) :coordinate-mounts))) + (dolist (mount (tp--surface-snapshot-mounts snapshot)) + (when (eq (tp--surface-mount-capability mount) 'content) + (unless (or (and (markerp (tp--surface-mount-start mount)) + (markerp (tp--surface-mount-end mount))) + (and coordinate-p + (integerp (tp--surface-mount-start mount)) + (integerp (tp--surface-mount-end mount)))) + (signal 'tp-surface-error + (list :invalid-mount-cleanup mount))))) + (dolist (ledger (tp--surface-snapshot-ledger snapshot)) + (unless (and (markerp (tp--property-ledger-start ledger)) + (markerp (tp--property-ledger-end ledger))) + (signal 'tp-surface-error + (list :invalid-ledger-cleanup ledger)))))))) state) (defun tp--surface-final-accept () @@ -2873,12 +3457,13 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback." (let* ((prepared (car entry)) (snapshot (cdr entry)) (surface (tp--prepared-surface-surface prepared))) - (dolist (mounts - (list (tp--surface-snapshot-mounts snapshot) - (tp--surface-mounts surface))) - (dolist (mount mounts) - (when-let ((anchor (tp--surface-mount-anchor mount))) - (push anchor anchors)))))) + (unless (tp--prepared-surface-retained-mount-state-p prepared) + (dolist (mounts + (list (tp--surface-snapshot-mounts snapshot) + (tp--surface-mounts surface))) + (dolist (mount mounts) + (when-let ((anchor (tp--surface-mount-anchor mount))) + (push anchor anchors))))))) (puthash 'anchor-undo (tp--capture-anchor-ownership-undo (nreverse anchors)) state)) @@ -2886,9 +3471,10 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback." (let* ((prepared (car entry)) (snapshot (cdr entry)) (surface (tp--prepared-surface-surface prepared))) - (tp--apply-anchor-ownership - surface (tp--surface-snapshot-mounts snapshot) - (tp--surface-mounts surface))))) + (unless (tp--prepared-surface-retained-mount-state-p prepared) + (tp--apply-anchor-ownership + surface (tp--surface-snapshot-mounts snapshot) + (tp--surface-mounts surface)))))) (tp--surface-precommit-step 'lifecycle state) (dolist (prepared all-prepared) (tp--finalize-object-lifecycle prepared) @@ -3097,23 +3683,24 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback." (let* ((prepared (car entry)) (snapshot (cdr entry)) (surface (tp--prepared-surface-surface prepared))) - (dolist (anchor - (tp--anchors-in-mounts - (tp--surface-snapshot-mounts snapshot))) - (when (null (tp--anchor-surfaces anchor)) - (cleanup - surface (list 'old-anchor (tp--anchor-id anchor)) - (lambda () (tp--dispose-anchor anchor))))) - (cleanup - surface 'old-mounts - (lambda () - (tp--dispose-content-mounts - (tp--surface-snapshot-mounts snapshot)))) - (cleanup - surface 'old-ledger - (lambda () - (tp--dispose-ledger - (tp--surface-snapshot-ledger snapshot)))))) + (unless (tp--prepared-surface-retained-mount-state-p prepared) + (dolist (anchor + (tp--anchors-in-mounts + (tp--surface-snapshot-mounts snapshot))) + (when (null (tp--anchor-surfaces anchor)) + (cleanup + surface (list 'old-anchor (tp--anchor-id anchor)) + (lambda () (tp--dispose-anchor anchor))))) + (cleanup + surface 'old-mounts + (lambda () + (tp--dispose-content-mounts + (tp--surface-snapshot-mounts snapshot)))) + (cleanup + surface 'old-ledger + (lambda () + (tp--dispose-ledger + (tp--surface-snapshot-ledger snapshot))))))) (when-let ((table (gethash 'prepared state))) (dolist (prepared (tp--all-prepared-surfaces table)) (let* ((surface (tp--prepared-surface-surface prepared))