feat: compose property contributions in retained commit batches

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

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

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)
+(defun tp--prepared-mount-signature (prepared &optional retained-signature)
-  "Return PREPARED's stable mount attachment signature."
+  "Return PREPARED's exact target mount attachment signature.
-  (mapcar (lambda (spec)
+RETAINED-SIGNATURE may supply the already captured live signature."
-            (list (plist-get spec :object) (plist-get spec :anchor)
+  (if (tp--prepared-surface-retained-mount-state-p prepared)
-                  (plist-get spec :start) (plist-get spec :end)
+      (let* ((surface (tp--prepared-surface-surface prepared))
-                  (plist-get spec :tags)))
+             (updates (tp--prepared-surface-mount-coordinate-updates prepared))
-          (tp--prepared-surface-mount-specs 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))