fix: preserve native interaction properties in incremental publication

Preserve keymap ownership and hover grouping while applying minimal text patches. Reduce retained publication allocations without weakening policy comparisons or transactional rollback.

Validation: 451 ERT tests, README doctests, strict byte compilation and checkdoc passed.

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-core-tests.el

@@ -161,6 +161,49 @@
       (should (equal (nth 0 copy) "value"))
       (should (equal (nth 1 copy) ["nested"])))))
 
+(ert-deftest tp-core-test-property-value-copy-isolates-full-keymaps ()
+  "Full keymaps, parent maps and self-references retain an isolated graph."
+  (let* ((map (make-keymap))
+         (parent (make-keymap))
+         (callback (lambda () "callback")))
+    (define-key map (kbd "RET") callback)
+    (define-key parent (kbd "x") #'ignore)
+    (define-key map [prefix] map)
+    (set-keymap-parent map parent)
+    (let ((copy (tp-property-value-copy map)))
+      (should-not (eq copy map))
+      (should-not (eq (keymap-parent copy) parent))
+      (should (eq (lookup-key copy [prefix]) copy))
+      (should (eq (lookup-key copy (kbd "RET")) callback))
+      (define-key map (kbd "RET") #'forward-char)
+      (define-key parent (kbd "x") #'backward-char)
+      (should (eq (lookup-key copy (kbd "RET")) callback))
+      (should (eq (lookup-key copy (kbd "x")) #'ignore)))))
+
+(ert-deftest tp-core-test-property-value-copy-preserves-character-table-structure ()
+  "Local ranges, defaults, parents, extra slots and cycles are copied faithfully."
+  (let ((purpose (make-symbol "tp-copy-table")))
+    (put purpose 'char-table-extra-slots 1)
+    (let* ((parent (make-char-table purpose))
+           (table (make-char-table purpose))
+           (value (list 'value)))
+      (set-char-table-range parent ?p value)
+      (set-char-table-range table ?x value)
+      (set-char-table-range table ?s table)
+      (set-char-table-extra-slot table 0 value)
+      (set-char-table-parent table parent)
+      (let ((copy (tp-property-value-copy table)))
+        (should (eq (char-table-range copy ?s) copy))
+        (should (eq (char-table-range copy ?x) (char-table-extra-slot copy 0)))
+        (should (eq (char-table-range copy ?x)
+                    (char-table-range (char-table-parent copy) ?p)))
+        (set-char-table-range (char-table-parent copy) ?p 'new)
+        (should (eq (char-table-range copy ?p) 'new))
+        (set-char-table-range copy nil 'default)
+        (should (eq (char-table-range copy ?z) 'default))
+        (setcar value 'mutated)
+        (should (equal (char-table-range copy ?x) '(value)))))))
+
 (ert-deftest tp-core-test-property-value-copy-keeps-list-functions-opaque ()
   "Property copies keep list-shaped function values opaque."
   (let ((function-value '(lambda () 1)))

tests/tp-style-tests.el

@@ -14,6 +14,46 @@
 (require 'tp-style)
 (require 'tp-layer)
 
+(ert-deftest tp-style-test-native-keymaps-preserve-all-binding-facts ()
+  "Snapshots compare by prompts, menu order, parents and literal commands."
+  (let* ((factory (eval '(lambda ()
+                          (let ((n 0))
+                            (lambda () (setq n (1+ n))))) t))
+         (first (funcall factory)) (second (funcall factory))
+         (map (make-keymap "Root"))
+         (prefix (make-sparse-keymap "Prefix"))
+         (parent (make-sparse-keymap "Parent")))
+    (define-key map (kbd "RET") first)
+    (define-key map [t] #'ignore)
+    (define-key prefix [self] prefix)
+    (define-key prefix [one] '(menu-item "One" ignore))
+    (define-key prefix [two] '(menu-item "Two" forward-char))
+    (define-key map [prefix] prefix)
+    (define-key parent [inherited] #'backward-char)
+    (set-keymap-parent map parent)
+    (should (equal first second))
+    (should (tp--native-property-value-equal-p map (tp-property-value-copy map)))
+    (dolist (kind '(root-prompt prefix-prompt parent-prompt menu-order
+                   callback default inherited))
+      (let ((copy (tp-property-value-copy map)))
+        (pcase kind
+          ((or 'root-prompt 'prefix-prompt 'parent-prompt)
+           (let* ((target (pcase kind
+                            ('root-prompt copy)
+                            ('prefix-prompt (lookup-key copy [prefix]))
+                            ('parent-prompt (keymap-parent copy))))
+                  (cell (memq (keymap-prompt target) target)))
+             (setcar cell "Changed")))
+          ('menu-order
+           (let* ((target (lookup-key copy [prefix]))
+                  (one (lookup-key target [one])))
+             (define-key target [one] nil t)
+             (define-key target [one] one)))
+          ('callback (define-key copy (kbd "RET") second))
+          ('default (define-key copy [t] #'forward-char))
+          ('inherited (define-key (keymap-parent copy) [inherited] #'ignore)))
+        (should-not (tp--native-property-value-equal-p map copy))))))
+
 (defmacro tp-style-test--isolated (&rest body)
   "Run BODY with isolated TP property and named-style registries."
   (declare (indent 0) (debug t))

tests/tp-transaction-tests.el

@@ -99,6 +99,30 @@
    :final-accept #'ignore
    :diagnostics nil))
 
+(ert-deftest tp-transaction-test-unique-identities-use-equal-semantics ()
+  "Distinct identity values stay distinct; equal values remain duplicates."
+  (dolist (items (list nil '(nil) '(1 1.0) '(nil mount-a "mount-a")
+                      (number-sequence 1 2000)))
+    (let ((before (copy-tree items)))
+      (should (tp--proper-unique-list-p items))
+      (should (equal items before))))
+  (dolist (items (list '(nil nil) '(mount-a mount-a)
+                      (list (copy-sequence "mount") (copy-sequence "mount"))
+                      (list (list 'owner 1) (list 'owner 1))
+                      (list (vector 'owner 1) (vector 'owner 1))))
+    (should-not (tp--proper-unique-list-p items))
+    (should-error (tp-transaction-test--entry :mount-ids items)
+                  :type 'tp-publication-binding-error)))
+
+(ert-deftest tp-transaction-test-unique-identities-reject-improper-lists ()
+  "Malformed identity sequences cannot enter publication authority bindings."
+  (let ((cycle (list 'mount-a 'mount-b)))
+    (setcdr (last cycle) cycle)
+    (dolist (items (list 'mount-a [mount-a] '(mount-a . mount-b) cycle))
+      (should-not (tp--proper-unique-list-p items))
+      (should-error (tp-transaction-test--entry :mount-ids items)
+                    :type 'tp-publication-binding-error))))
+
 (defun tp-transaction-test--slot-writes (target values)
   "Return fixed slot writes assigning VALUES into TARGET from index zero."
   (vconcat
@@ -312,10 +336,17 @@
    :type 'tp-publication-binding-error)
   (with-temp-buffer
     (let* ((mount-ids (list 'mount-a))
-           (entry (tp-transaction-test--entry :mount-ids mount-ids))
+           (diff (list :replace (list 1 2)))
+           (client-state (list :client (list 'candidate)))
+           (entry (tp-transaction-test--entry
+                   :mount-ids mount-ids
+                   :diff diff
+                   :client-state client-state))
            (entries (list entry))
            (batch (tp-transaction-test--batch entries)))
       (setcar mount-ids 'mutated-after-create)
+      (setcar (plist-get diff :replace) 'mutated-after-create)
+      (setcar (plist-get client-state :client) 'mutated-after-create)
       (setcar entries (tp-transaction-test--entry
                        :candidate-id 'replacement
                        :surface-id 'replacement-surface
@@ -326,6 +357,10 @@
       (should (equal (tp-publication-target-entry-mount-ids
                       (car (tp-publication-batch-candidate-entries batch)))
                      '(mount-a)))
+      (should (equal (tp-publication-target-entry-diff entry)
+                     '(:replace (1 2))))
+      (should (equal (tp-publication-target-entry-client-state entry)
+                     '(:client (candidate))))
       (should (eq (car (tp-publication-batch-candidate-entries batch)) entry))
       (should-error
        (tp-transaction-test--batch (list entry entry))

tp-core.el

@@ -279,6 +279,7 @@ Otherwise, START-OR-STRING and END define the range."
   (and (not (functionp value))
        (or (consp value)
            (stringp value)
+           (char-table-p value)
            (and (vectorp value) (not (recordp value))))))
 
 (defun tp--copy-cons-spine (value cache)
@@ -309,6 +310,7 @@ so dotted tails, shared suffixes, and cycles retain their source topology."
                (if (and (not (functionp item))
                         (or (consp item)
                             (stringp item)
+                            (char-table-p item)
                             (and (vectorp item) (not (recordp item)))))
                    (tp--copy-property-value item cache)
                  item)))
@@ -344,6 +346,7 @@ back-references from cars while `copy-sequence' supplies the spine cheaply."
             (when (and (not (functionp item))
                        (or (consp item)
                            (stringp item)
+                           (char-table-p item)
                            (and (vectorp item) (not (recordp item)))))
               (setcar target (tp--copy-property-value item cache))))
           (setq source (cdr source)
@@ -406,7 +409,8 @@ values are recursively isolated."
 (defun tp--copy-property-value (value &optional cache)
   "Return a defensive copy of mutable containers in property VALUE.
 Optional CACHE preserves sharing and cycles across recursive copies.
-Cons cells, strings, and vectors are copied recursively.  Functions, records,
+Cons cells, strings, vectors and character tables are copied recursively.
+Functions, records,
 and other opaque objects keep their identity; functions are never executed."
   (if (not (tp--copy-mutable-property-value-p value))
       value
@@ -420,6 +424,29 @@ and other opaque objects keep their identity; functions are never executed."
               (tp--copy-proper-cons-list value cache)
             (tp--copy-cons-spine value cache)))
          ((stringp value) (tp--copy-string-with-properties value cache))
+         ((char-table-p value)
+          (let ((copy (copy-sequence value))
+                (default (char-table-range value nil))
+                entries)
+            (puthash value copy cache)
+            ;; Enumerate only local assignments, without inherited/default
+            ;; ranges becoming explicit assignments in the copied table.
+            (set-char-table-parent copy nil)
+            (set-char-table-range copy nil nil)
+            (map-char-table (lambda (range item) (push (cons range item) entries))
+                            copy)
+            (dolist (entry entries)
+              (set-char-table-range
+               copy (car entry) (tp--copy-property-value (cdr entry) cache)))
+            (set-char-table-range copy nil (tp--copy-property-value default cache))
+            (set-char-table-parent
+             copy (tp--copy-property-value (char-table-parent value) cache))
+            (dotimes (index (or (get (char-table-subtype value)
+                                     'char-table-extra-slots) 0))
+              (set-char-table-extra-slot
+               copy index (tp--copy-property-value
+                           (char-table-extra-slot value index) cache)))
+            copy))
          ((vectorp value)
           (let ((copy (copy-sequence value)))
             (puthash value copy cache)
@@ -431,7 +458,8 @@ and other opaque objects keep their identity; functions are never executed."
 (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."
+string, character-table 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)

tp-style.el

@@ -205,12 +205,51 @@ OPTIONS support :normalizer, :validator, :equality, :merge, and :projector."
       #'tp--merge-face-values
     (lambda (_old new) new)))
 
+(defun tp--native-keymap-equal-p (left right)
+  "Compare native snapshots LEFT and RIGHT, retaining commands and menu order."
+  (let ((seen (make-hash-table :test #'eq)))
+    (cl-labels
+        ((bindings (map)
+           (let ((local (copy-sequence (if (symbolp map)
+                                           (indirect-function map) map)))
+                 entries)
+             (set-keymap-parent local nil)
+             (map-keymap (lambda (key value) (push (cons key value) entries)) local)
+             entries))
+         (same (old new)
+           (cond
+            ((eq old new) t)
+            ((memq new (gethash old seen)) t)
+            ((and (keymapp old) (keymapp new))
+             (puthash old (cons new (gethash old seen)) seen)
+             (and (equal-including-properties (keymap-prompt old)
+                                               (keymap-prompt new))
+                  (same (bindings old) (bindings new))
+                  (same (keymap-parent old) (keymap-parent new))))
+            ((or (functionp old) (functionp new)) nil)
+            ((and (consp old) (consp new))
+             (puthash old (cons new (gethash old seen)) seen)
+             (and (same (car old) (car new)) (same (cdr old) (cdr new))))
+            ((and (vectorp old) (vectorp new) (= (length old) (length new)))
+             (puthash old (cons new (gethash old seen)) seen)
+             (cl-loop for index below (length old)
+                      always (same (aref old index) (aref new index))))
+            (t (equal old new)))))
+      (same left right))))
+
+(defun tp--native-property-value-equal-p (left right)
+  "Compare native values LEFT and RIGHT while preserving callable identity."
+  (cond
+   ((and (keymapp left) (keymapp right)) (tp--native-keymap-equal-p left right))
+   ((or (functionp left) (functionp right)) (eq left right))
+   (t (equal left right))))
+
 (defun tp-register-text-property (property)
   "Register and return a direct policy for Emacs PROPERTY."
   (let ((id (tp-text-property-id property)))
     (or (tp-property-policy id)
         (tp-define-property-policy
-         id :equality #'equal
+         id :equality #'tp--native-property-value-equal-p
          :merge (tp--text-property-merge-function property)
          :projector (lambda (value) (list property value))))))
 

tp-transaction.el

@@ -83,11 +83,12 @@
 (defun tp--proper-unique-list-p (items)
   "Return non-nil when ITEMS is a proper list with no equal duplicates."
   (and (proper-list-p items)
-       (let (seen (unique t))
+       (let ((seen (make-hash-table :test #'equal))
+             (unique t))
          (dolist (item items unique)
-           (if (member item seen)
+           (if (gethash item seen)
                (setq unique nil)
-             (push item seen))))))
+             (puthash item t seen))))))
 
 (cl-defstruct (tp-publication-target-entry
                (:constructor tp--make-publication-target-entry)
@@ -115,6 +116,20 @@
   (shadow-validator nil :read-only t)
   rollback-result post-rollback-state shadow-actual shadow-proven-p)
 
+(defun tp--publication-target-entry-arguments-valid-p
+    (transaction-id batch-id candidate-id surface-id mount-ids buffer
+                    old-revision new-revision authority-token shadow-validator)
+  "Return non-nil when target arguments bind TRANSACTION-ID and BATCH-ID.
+CANDIDATE-ID, SURFACE-ID, MOUNT-IDS, BUFFER, OLD-REVISION, NEW-REVISION,
+AUTHORITY-TOKEN, and SHADOW-VALIDATOR must have valid publication shapes."
+  (and transaction-id batch-id candidate-id surface-id
+       (bufferp buffer) (buffer-live-p buffer)
+       (integerp old-revision) (>= old-revision 0)
+       (integerp new-revision) (= new-revision (1+ old-revision))
+       (tp--proper-unique-list-p mount-ids)
+       authority-token
+       (or (null shadow-validator) (functionp shadow-validator))))
+
 (cl-defun tp--publication-target-entry-create
     (&key transaction-id batch-id candidate-id surface-id mount-ids buffer
           old-revision new-revision plan diff ledger objects ranges client-state
@@ -126,13 +141,9 @@ DIFF, LEDGER, OBJECTS, RANGES, CLIENT-STATE, ROLLBACK-SNAPSHOT, and
 AUTHORITY-TOKEN describe the target.  MAPPING-GENERATION is optional.
 OPERATION-COUNTS is filled from the live report.  SHADOW-EXPECTED and
 SHADOW-VALIDATOR are private comparison artifacts."
-  (unless (and transaction-id batch-id candidate-id surface-id
-               (bufferp buffer) (buffer-live-p buffer)
-               (integerp old-revision) (>= old-revision 0)
-               (integerp new-revision) (= new-revision (1+ old-revision))
-               (tp--proper-unique-list-p mount-ids)
-               authority-token
-               (or (null shadow-validator) (functionp shadow-validator)))
+  (unless (tp--publication-target-entry-arguments-valid-p
+           transaction-id batch-id candidate-id surface-id mount-ids buffer
+           old-revision new-revision authority-token shadow-validator)
     (signal 'tp-publication-binding-error
             (list :target-entry transaction-id batch-id candidate-id surface-id
                   buffer old-revision new-revision mount-ids authority-token)))