diff --git a/docs/API-REFERENCE.md b/docs/API-REFERENCE.md index 9cf8d04..ec558be 100644 --- a/docs/API-REFERENCE.md +++ b/docs/API-REFERENCE.md @@ -390,6 +390,19 @@ Report 的常用字段包括： :scope-fallback、:property-conflicts、:rolled-back、:failure、 :observer-errors、:timing。 +已经精确计算出变更区间的 producer 可以使用 `tp-commit-batch-create` 构造 +批次，再由 `tp-commit-batch-result-create` 绑定当前 prepare context；发布和 +回滚仍使用相同 surface 事务。批次绑定前后 revision、extent 和坐标映射。 +每个 patch 的 `:replacement` 是完整属性文本，也可以携带局部 +`:property-contributions`：其中 `:start`/`:end` 相对于该 replacement，按列表 +顺序使用已注册的 property merge policy 合成。策略在**构造批次时**求值； +批次只保留合成后的文本快照，不保留贡献列表，之后的调用方修改或策略替换 +不会重新计算这份批次。函数、record 等 opaque 属性身份按既有 snapshot 规则保留。 + +producer 只有在证明整个挂载拓扑、tags 和坐标均与已提交版本相同时，才能向 +`tp-commit-batch-result-create` 传 `:reuse-mount-projection t`。它不能与显式 +`:mount-specs` 同时使用；数量相同或对象没有增删都不能替代完整的不变证明。 + ### 6.3 Host range 和 tp-watch ~~~elisp diff --git a/tests/tp-surface-tests.el b/tests/tp-surface-tests.el index 9d47d22..6eeea1d 100644 --- a/tests/tp-surface-tests.el +++ b/tests/tp-surface-tests.el @@ -40,10 +40,11 @@ (quit condition))) (defun tp-surface-test--commit-batch-update - (surface root batch client-state before-stage) + (surface root batch client-state before-stage &optional project-coordinates) "Update SURFACE through BATCH after calling BEFORE-STAGE with its entry. ROOT is the retained object and CLIENT-STATE is transferred by its active -prepare context." +prepare context. PROJECT-COORDINATES asks TP to map existing mounts through +the batch instead of retaining their unchanged coordinates." (let ((execute (symbol-function 'tp--publication-batch-execute-stage))) (cl-letf (((symbol-function 'tp--publication-batch-execute-stage) (lambda (candidate) @@ -62,7 +63,7 @@ prepare context." (tp-object-reuse-subtree context root) (tp-commit-batch-result-create context batch :client-state client-state - :reuse-mount-projection t)))))) + :reuse-mount-projection (not project-coordinates))))))) (defun tp-surface-test--replacement-batch (surface replacement) "Return an equal-extent batch replacing SURFACE's middle character." @@ -175,6 +176,261 @@ prepare context." (tp-surface-client-state surface)))) (should-error (tp-surface-commit-batch surface batch))))) +(ert-deftest tp-surface-test-commit-batch-composes-patch-properties () + "Patch-local contributions use the retained-content property composer." + (let* ((replacement (propertize "abcd" 'face '(bold) 'help-echo "baseline")) + (before (copy-sequence replacement)) + (contributions + '((:start 0 :end 4 :props (face (:background "#112233"))) + (:start 1 :end 3 :props (face italic help-echo "inner")) + (:start 2 :end 3 :props (face nil help-echo nil)))) + (patch (list :old-start 1 :old-end 5 :new-start 1 :new-end 5 + :replacement replacement :property-contributions contributions)) + (expected (tp--compose-relative-property-contributions + replacement contributions)) + (batch (tp-commit-batch-create + :base-revision 1 :target-revision 2 :base-extent 6 :target-extent 6 + :patches (list patch))) + (stored (car (tp-commit-batch-patches batch)))) + (should (equal-including-properties before replacement)) + (should (eq replacement (plist-get patch :replacement))) + (should (eq contributions (plist-get patch :property-contributions))) + (should (equal-including-properties expected (plist-get stored :replacement))) + (should-not (eq replacement (plist-get stored :replacement))) + (should-not (plist-member stored :property-contributions)))) + +(ert-deftest tp-surface-test-commit-batch-freezes-property-policy-at-construction () + "Composition snapshots inputs and evaluates custom merge policy exactly once." + (let ((tp--property-policies (copy-hash-table tp--property-policies)) + (tp--property-policy-order (copy-sequence tp--property-policy-order)) + (merge-calls 0)) + (tp-define-property-policy + 'text/tp-batch-score :equality #'equal + :merge (lambda (old new) (cl-incf merge-calls) (+ old new)) + :projector (lambda (value) (list 'tp-batch-score value))) + (let* ((replacement (propertize "AB" 'tp-batch-score 10 'face '(:weight bold))) + (before (copy-sequence replacement)) + (before-props (copy-tree (text-properties-at 0 replacement))) + (contributions + (list (list :start 0 :end 2 :props (list 'tp-batch-score 1)) + (list :start 1 :end 2 :props (list 'tp-batch-score 2)))) + (before-contributions (copy-tree contributions)) + (patch (list :old-start 0 :old-end 2 :new-start 0 :new-end 2 + :replacement replacement :property-contributions contributions)) + (expected (tp--compose-relative-property-contributions + replacement contributions)) + batch) + (setq merge-calls 0 + batch (tp-commit-batch-create + :base-revision 1 :target-revision 2 :base-extent 2 :target-extent 2 + :patches (list patch))) + (should (= merge-calls 2)) + (should (equal-including-properties before replacement)) + (should (equal before-props (text-properties-at 0 replacement))) + (should (equal before-contributions contributions)) + (should (eq contributions (plist-get patch :property-contributions))) + (should (eq replacement (plist-get patch :replacement))) + (tp-define-property-policy + 'text/tp-batch-score :equality #'equal + :merge (lambda (_old _new) (error "Policy was re-evaluated after construction")) + :projector (lambda (value) (list 'tp-batch-score value))) + (tp-surface-test--with-buffer + (let ((surface (tp-surface-mount buffer (tp-surface-test--leaf 'root "zz") + '(:capability content)))) + (tp-surface-commit-batch surface batch) + (should (equal-including-properties expected (buffer-string))) + (should (= (get-text-property 1 'tp-batch-score) 11)) + (should (= (get-text-property 2 'tp-batch-score) 13)) + (should (= merge-calls 2))))))) + +(ert-deftest tp-surface-test-commit-batch-isolates-mutable-property-inputs () + "Composition owns mutable inputs while preserving opaque function identity." + (let ((tp--property-policies (copy-hash-table tp--property-policies)) + (tp--property-policy-order (copy-sequence tp--property-policy-order))) + (tp-define-property-policy + 'text/tp-batch-destructive + :merge (lambda (old new) + (setcar old 'merged-old) + (setcar new 'merged-new) + (list old new))) + (let* ((callback (lambda () 'opaque)) + (baseline (list 'baseline)) + (incoming (list 'incoming)) + (mutable (vector (list (copy-sequence "caller")) callback)) + (replacement (propertize "X" 'tp-batch-destructive baseline + 'tp-batch-mutable 'existing)) + (contributions + (list (list :start 0 :end 1 + :props (list 'tp-batch-mutable mutable + 'tp-batch-destructive incoming)))) + (patch (list :old-start 0 :old-end 1 :new-start 0 :new-end 1 + :replacement replacement :property-contributions contributions)) + (batch (tp-commit-batch-create + :base-revision 1 :target-revision 2 :base-extent 1 :target-extent 1 + :patches (list patch))) + (stored (plist-get (car (tp-commit-batch-patches batch)) :replacement)) + (stored-mutable (get-text-property 0 'tp-batch-mutable stored))) + (should (equal baseline '(baseline))) + (should (equal incoming '(incoming))) + (should (equal (aref mutable 0) '("caller"))) + (should (eq callback (aref mutable 1))) + (should (eq baseline (get-text-property 0 'tp-batch-destructive replacement))) + (should (eq 'existing (get-text-property 0 'tp-batch-mutable replacement))) + (should (eq replacement (plist-get patch :replacement))) + (should (eq contributions (plist-get patch :property-contributions))) + (should (eq callback (aref stored-mutable 1))) + (aset (car (aref mutable 0)) 0 ?X) + (setcdr (aref mutable 0) '(changed)) + (aset mutable 1 #'ignore) + (setcar baseline 'changed-baseline) + (setcar incoming 'changed-incoming) + (should (equal (aref stored-mutable 0) '("caller"))) + (should (eq callback (aref stored-mutable 1))) + (should (equal (get-text-property 0 'tp-batch-destructive stored) + '((merged-old) (merged-new))))))) + +(ert-deftest tp-surface-test-commit-batch-validates-local-contributions () + "Contribution bounds and property shape are validated inside each patch." + (dolist (case + '((tp-invalid-content-range ((:start -1 :end 1 :props (face bold)))) + (tp-invalid-content-range ((:start 0 :end 3 :props (face bold)))) + (tp-invalid-content-range ((:start 2 :end 1 :props (face bold)))) + (tp-invalid-content-range ((:start "0" :end 1 :props (face bold)))) + (tp-invalid-content-range ((:start 0 :props (face bold)))) + (tp-invalid-content-range not-a-list) + (tp-invalid-surface-plan ((:start 0 :end 1 :props (face)))))) + (ert-info ((format "invalid patch contribution=%S" (cadr case))) + (should-error + (tp-commit-batch-create + :base-revision 1 :target-revision 2 :base-extent 6 :target-extent 6 + :patches (list (list :old-start 2 :old-end 4 :new-start 2 :new-end 4 + :replacement "XY" :property-contributions (cadr case)))) + :type (car case))))) + +(ert-deftest tp-surface-test-commit-batch-composed-properties-roll-back-and-retry () + "Direct and retained batches atomically publish composed properties and state." + (dolist (mode '(direct retained)) + (ert-info ((format "composed batch mode=%S" mode)) + (tp-surface-test--with-buffer + (let* ((surface + (tp-surface-mount + buffer (lambda (context) + (tp-object-ensure context nil 'root 'text) + (tp-surface-result-create + (tp-surface-test--leaf 'root "abc" '(face bold help-echo "base")) + '(:value old))) + '(:capability content :coordinate-mounts t))) + (root (tp-object-resolve surface '(root))) + (before (buffer-string)) + (old-state (tp-surface-client-state surface)) + (mounts (tp--surface-mounts surface)) + (index (tp--surface-mount-index surface)) + (ids (tp--live-mount-ids surface)) + (next-state (list :value 'next)) + (replacement (propertize "X" 'face 'bold 'help-echo "base")) + (contributions + '((:start 0 :end 1 :props (face (:background "#112233") help-echo nil)))) + (expected (concat (substring before 0 1) + (tp--compose-relative-property-contributions + replacement contributions) + (substring before 2))) + (batch + (tp-commit-batch-create + :base-revision 1 :target-revision 2 :base-extent 3 :target-extent 3 + :patches (list (list :old-start 1 :old-end 2 :new-start 1 :new-end 2 + :replacement replacement + :property-contributions contributions)) + :client-state next-state))) + (cl-labels + ((update () + (if (eq mode 'direct) + (tp-surface-commit-batch surface batch) + (tp-surface-test--commit-batch-update + surface root batch next-state #'ignore)))) + (cl-letf (((symbol-function 'accept-change-group) + (lambda (_) (error "Reject composed batch")))) + (should (equal (should-error (update)) '(error "Reject composed batch")))) + (should (= (tp-surface-revision surface) 1)) + (should (eq old-state (tp-surface-client-state surface))) + (should (eq mounts (tp--surface-mounts surface))) + (should (eq index (tp--surface-mount-index surface))) + (should (equal ids (tp--live-mount-ids surface))) + (should (equal-including-properties before (buffer-string))) + (update)) + (should (= (tp-surface-revision surface) 2)) + (should (eq (tp-surface-client-state surface) + (if (eq mode 'direct) (tp-commit-batch-client-state batch) next-state))) + (should (eq mounts (tp--surface-mounts surface))) + (should (eq index (tp--surface-mount-index surface))) + (should (equal ids (tp--live-mount-ids surface))) + (should (equal-including-properties expected (buffer-string)))))))) + +(ert-deftest tp-surface-test-retained-batch-shadow-matches-commit-and-rollback () + "Implicit retained mounts have exact success and rollback shadow artifacts." + (dolist (coordinate-shift '(nil t)) + (dolist (phase '(rollback commit)) + (ert-info ((format "retained batch phase=%S coordinate-shift=%S" + phase coordinate-shift)) + (tp-surface-test--with-buffer + (let* ((surface + (tp-surface-mount + buffer (tp-surface-plan-create + :key 'root :kind 'group :capability 'content + :children (list (tp-surface-test--leaf 'left "a") + (tp-surface-test--leaf 'right "bc"))) + '(:capability content :coordinate-mounts t))) + (root (tp-object-resolve surface '(root))) + (mounts (tp--surface-mounts surface)) + (index (tp--surface-mount-index surface)) + (ids (tp--live-mount-ids surface)) + (batch + (if coordinate-shift + (tp-commit-batch-create + :base-revision 1 :target-revision 2 :base-extent 3 :target-extent 3 + :patches '((:old-start 0 :old-end 3 :new-start 0 :new-end 3 + :replacement "XYZ")) + :coordinate-patches + '((:old-start 0 :old-end 1 :new-start 0 :new-end 2) + (:old-start 1 :old-end 3 :new-start 2 :new-end 3))) + (tp-surface-test--replacement-batch surface "X"))) + entry) + (cl-labels + ((update () + (tp-surface-test--commit-batch-update + surface root batch '(:owned next) + (lambda (target prepared) + (setq entry target) + (should (tp--prepared-surface-retained-mount-state-p prepared)) + (should (eq (not coordinate-shift) + (null (tp--prepared-surface-mount-specs prepared)))) + (should (eq (not coordinate-shift) + (zerop (length + (tp--prepared-surface-mount-coordinate-updates + prepared)))))) + coordinate-shift))) + (if (eq phase 'rollback) + (let ((tp--surface-publication-step-function + (lambda (step _surface) + (when (eq step 'client-state) + (error "Reject retained batch shadow"))))) + (should (equal (should-error (update)) + '(error "Reject retained batch shadow")))) + (update))) + (should (equal (buffer-string) + (if (eq phase 'rollback) "abc" + (if coordinate-shift "XYZ" "aXc")))) + (should (eq mounts (tp--surface-mounts surface))) + (should (eq index (tp--surface-mount-index surface))) + (should (equal ids (tp--live-mount-ids surface))) + (let ((shadow (funcall (tp-publication-target-entry-shadow-validator entry) + entry phase))) + (ert-info ((format "expected mount count=%S actual mount count=%S" + (length (plist-get (plist-get shadow :expected) :mounts)) + (length (plist-get (plist-get shadow :actual) :mounts)))) + (should (plist-get shadow :equivalent)))) + (should (eq phase (plist-get tp--last-shadow-proof :phase))) + (should (plist-get tp--last-shadow-proof :equivalent)))))))) + (ert-deftest tp-surface-test-publication-entry-adopts-prepared-authority () "A real surface entry references its authenticated prepared values exactly." (tp-surface-test--with-buffer diff --git a/tp-surface.el b/tp-surface.el index 164fa49..0d34439 100644 --- a/tp-surface.el +++ b/tp-surface.el @@ -1982,7 +1982,10 @@ BASE-REVISION and TARGET-REVISION bind the transition; BASE-EXTENT and TARGET-EXTENT bind its coordinates. COORDINATE-PATCHES project retained mounts, and CLIENT-STATE is opaque owner state. PATCHES are ordered plists containing :old-start, :old-end, :new-start, -:new-end, and a propertized :replacement string." +:new-end, and a propertized :replacement string. Optional patch-local +:property-contributions use ordered :start, :end, and :props ranges within +that replacement. Registered merge policies are evaluated now, at batch +construction, and only the final propertized replacement is retained." (unless (and (integerp base-revision) (>= base-revision 0) (integerp target-revision) (= target-revision (1+ base-revision))) @@ -2009,7 +2012,17 @@ PATCHES are ordered plists containing :old-start, :old-end, :new-start, (stringp replacement) (= (length replacement) (- new-end new-start))) (signal 'tp-surface-error (list :commit-patch patch))) - (push (copy-tree patch) copy) + (let ((candidate + (if (plist-member patch :property-contributions) + (tp--copy-property-value patch) + (copy-tree patch)))) + (when (plist-member patch :property-contributions) + (plist-put candidate :replacement + (tp--compose-relative-property-contributions + (plist-get candidate :replacement) + (plist-get candidate :property-contributions))) + (cl-remf candidate :property-contributions)) + (push candidate copy)) (setq old-cursor old-end new-cursor new-end))) (unless (= (- base-extent old-cursor) (- target-extent new-cursor)) @@ -2484,13 +2497,27 @@ caller reads the scalar summary from the surface instead." (tp--discard-context (tp--prepared-surface-context previous))) (puthash surface new table)))) -(defun tp--prepared-mount-signature (prepared) - "Return PREPARED's stable mount attachment signature." - (mapcar (lambda (spec) - (list (plist-get spec :object) (plist-get spec :anchor) - (plist-get spec :start) (plist-get spec :end) - (plist-get spec :tags))) - (tp--prepared-surface-mount-specs prepared))) +(defun tp--prepared-mount-signature (prepared &optional retained-signature) + "Return PREPARED's exact target mount attachment signature. +RETAINED-SIGNATURE may supply the already captured live signature." + (if (tp--prepared-surface-retained-mount-state-p prepared) + (let* ((surface (tp--prepared-surface-surface prepared)) + (updates (tp--prepared-surface-mount-coordinate-updates prepared)) + (base (marker-position (tp--surface-start surface)))) + (if (zerop (length updates)) + (or retained-signature (tp--live-mount-signature surface)) + (cl-loop for index from 0 below (length updates) by 3 + for mount = (aref updates index) + collect (list (tp--surface-mount-object mount) + (tp--surface-mount-anchor mount) + (- (aref updates (1+ index)) base) + (- (aref updates (+ index 2)) base) + (tp--surface-mount-tags mount))))) + (mapcar (lambda (spec) + (list (plist-get spec :object) (plist-get spec :anchor) + (plist-get spec :start) (plist-get spec :end) + (plist-get spec :tags))) + (tp--prepared-surface-mount-specs prepared)))) (defun tp--live-mount-signature (surface) "Return SURFACE's stable live mount signature." @@ -3538,7 +3565,7 @@ batch, or nil when publication does not use a commit batch." (tp--shadow-object-ids (tp--prepared-surface-objects prepared)) :mount-ids target-mount-ids - :mounts (tp--prepared-mount-signature prepared) + :mounts (tp--prepared-mount-signature prepared old-mounts) :ledger (tp--shadow-ledger-spec-signature (tp--prepared-surface-ledger-specs prepared))