geekinney/tp
1
0
Fork 0
Code Issues Pull Requests Actions 2 Packages Projects Releases Wiki Activity
db5864141a
tp/tp-surface.el
Kinneyzhang db5864141a update
2026-08-13 14:40:44 +08:00

2852 lines
129 KiB
EmacsLisp
Raw Blame History

;;; tp-surface.el --- Retained text surfaces and publication -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney
;; Author: Geekinney (kinneyzhang666@gmail.com)
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3 of
;; the License, or (at your option) any later version.
;;; Commentary:
;; Generic retained plans, candidate object identity, marker-backed mounts,
;; range property ownership, side indexes, and atomic buffer publication.
;; This module knows nothing about a consumer's layout or domain vocabulary.
;;; Code:
(require 'cl-lib)
(require 'seq)
(require 'tp-core)
(require 'tp-style)
(require 'tp-reactive)
(define-error 'tp-surface-error "TP retained surface error")
(define-error 'tp-invalid-surface-plan "Invalid TP surface plan"
'tp-surface-error)
(define-error 'tp-duplicate-object-key "Duplicate TP object key"
'tp-invalid-surface-plan)
(define-error 'tp-invalid-prepare-context "Invalid TP prepare context"
'tp-surface-error)
(define-error 'tp-stale-object "Stale TP object" 'tp-surface-error)
(define-error 'tp-cross-surface-object "Cross-surface TP object"
'tp-surface-error)
(define-error 'tp-orphan-object "Orphan TP object" 'tp-surface-error)
(define-error 'tp-capability-error "TP mount capability violation"
'tp-surface-error)
(define-error 'tp-stale-mount "Stale TP mount" 'tp-surface-error)
(define-error 'tp-property-conflict "TP property ownership conflict"
'tp-surface-error)
(define-error 'tp-dead-surface "Dead TP surface" 'tp-surface-error)
(define-error 'tp-invalid-range-anchor "Invalid TP range anchor"
'tp-surface-error)
(define-error 'tp-invalid-content-range "Invalid TP content leaf range"
'tp-surface-error)
(define-error 'tp-producer-buffer-mutation
"TP producer mutated a live surface buffer during prepare"
'tp-surface-error)
(define-error 'tp-publication-mismatch
"TP publication was changed by an external buffer hook"
'tp-surface-error)
(define-error 'tp-scope-mismatch "Scoped TP update changed outside its objects"
'tp-surface-error)
(define-error 'tp-owned-result-error "Invalid TP owned producer result"
'tp-surface-error)
(cl-defstruct (tp-surface-plan (:constructor tp--make-surface-plan))
"Pure retained node data accepted by a TP surface."
key kind text props children tags capability)
(cl-defstruct (tp-surface-result
(:constructor tp--make-surface-result
(plan client-state &optional plan-owned-p
owner-context)))
"A producer result carrying PLAN and opaque CLIENT-STATE.
PLAN-OWNED-P marks an explicit candidate-local ownership transfer. The
owned result is bound to OWNER-CONTEXT and consumed once during prepare."
plan client-state plan-owned-p owner-context consumed-p)
(cl-defstruct (tp-surface
(:constructor tp--make-surface)
(:conc-name tp--surface-))
"One live retained tree mounted in a buffer."
id buffer capability start end options producer producer-binding plan objects
mounts index mount-index ledger client-state revision report live stale
observers)
(cl-defstruct (tp-object
(:constructor tp--make-surface-object)
(:conc-name tp--surface-object-))
"Opaque retained identity local to one surface."
id surface parent key kind path live disposed candidate-context)
(cl-defstruct (tp-prepare-context
(:constructor tp--make-prepare-context)
(:conc-name tp--context-))
"Short-lived candidate identity and attachment owner."
surface objects touched retained bindings attachments fragment-attachments
content-range-attachments child-seen
child-positions new-objects created-anchors active ephemeral)
(cl-defstruct (tp-range-anchor
(:constructor tp--make-range-anchor)
(:conc-name tp--anchor-))
"Opaque marker-backed host text range."
id buffer start end boundary-policy live stale surfaces candidate-context)
(cl-defstruct (tp--surface-mount (:constructor tp--make-surface-mount))
object start end tags capability anchor)
(defun tp--mount-position (position)
"Return numeric POSITION for a marker or coordinate mount endpoint."
(if (markerp position) (marker-position position) position))
(cl-defstruct (tp--property-ledger (:constructor tp--make-property-ledger))
start end property baseline-present baseline-value published-present
published-value anchors)
(cl-defstruct (tp--prepared-surface (:constructor tp--make-prepared-surface))
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)
(cl-defstruct (tp--surface-snapshot (:constructor tp--make-surface-snapshot))
plan objects mounts index mount-index ledger client-state producer revision
report live stale)
(defvar tp--surface-id-counter 0)
(defvar tp--object-id-counter 0)
(defvar tp--anchor-id-counter 0)
(defvar tp--surface-transaction-id 0)
(defvar tp--surfaces (make-hash-table :test #'eql :weakness 'value))
(defvar tp--current-prepare-context nil)
(defvar tp--surface-publishing nil)
(defvar tp--surface-guarding-prepare nil)
(defvar tp--surface-publication-step-function nil)
(defvar tp--content-published-ranges nil)
(defvar-local tp--buffer-surfaces nil)
(defvar-local tp--surface-character-tick 0)
(defvar-local tp--surface-before-change-state nil)
(defconst tp--surface-producer-key '(tp/surface . producer))
(defconst tp--surface-extension-key 'tp-surface)
(defun tp--plist-shape-p (value)
"Return non-nil when VALUE is an even property list with symbol keys."
(and (listp value)
(zerop (% (length value) 2))
(cl-loop for (key _value) on value by #'cddr always (symbolp key))))
(defun tp--validate-plan-fields (kind text props children capability)
"Validate plan KIND, TEXT, PROPS, CHILDREN, and CAPABILITY."
(unless kind
(signal 'tp-invalid-surface-plan (list :kind kind)))
(unless (or (null text) (stringp text))
(signal 'tp-invalid-surface-plan (list :text text)))
(unless (tp--plist-shape-p props)
(signal 'tp-invalid-surface-plan (list :props props)))
(unless (and (listp children) (cl-every #'tp-surface-plan-p children))
(signal 'tp-invalid-surface-plan (list :children children)))
(when (and text children)
(signal 'tp-invalid-surface-plan (list :text-and-children kind)))
(unless (memq capability '(nil content properties))
(signal 'tp-capability-error (list capability))))
(defun tp--validate-sibling-keys (children)
"Reject duplicate explicit keys among CHILDREN."
(let ((seen (make-hash-table :test #'equal)))
(dolist (child children)
(when-let ((key (tp-surface-plan-key child)))
(when (gethash key seen)
(signal 'tp-duplicate-object-key (list key)))
(puthash key t seen)))))
(defun tp--validate-surface-plan-tree (plan)
"Validate PLAN recursively without copying its caller-owned values."
(unless (tp-surface-plan-p plan)
(signal 'wrong-type-argument (list 'tp-surface-plan-p plan)))
(let ((children (tp-surface-plan-children plan)))
(tp--validate-plan-fields
(tp-surface-plan-kind plan)
(tp-surface-plan-text plan)
(tp-surface-plan-props plan)
children
(tp-surface-plan-capability plan))
(tp--validate-sibling-keys children)
(dolist (child children)
(tp--validate-surface-plan-tree child)))
plan)
(defun tp--copy-surface-plan (plan &optional cache)
"Return a validated defensive snapshot of PLAN.
CACHE is shared by one top-level snapshot so repeated source identities retain
one copied identity across sibling nodes without canonicalizing equal values."
(unless (tp-surface-plan-p plan)
(signal 'wrong-type-argument (list 'tp-surface-plan-p plan)))
(let* ((cache (or cache (make-hash-table :test #'eq)))
(children
(mapcar (lambda (child)
(tp--copy-surface-plan child cache))
(tp-surface-plan-children plan)))
(kind (tp--copy-property-value (tp-surface-plan-kind plan) cache))
(text (tp--copy-property-value (tp-surface-plan-text plan) cache))
(props (tp--copy-property-value (tp-surface-plan-props plan) cache))
(capability (tp-surface-plan-capability plan)))
(tp--validate-plan-fields kind text props children capability)
(tp--validate-sibling-keys children)
(tp--make-surface-plan
:key (tp--copy-property-value (tp-surface-plan-key plan) cache)
:kind kind :text text :props props :children children
:tags (tp--copy-property-value (tp-surface-plan-tags plan) cache)
:capability capability)))
(cl-defun tp-surface-plan-create
(&key key kind text props children tags capability)
"Create a defensive surface plan node.
KEY is sibling-local identity, KIND is an opaque discriminator, TEXT is a
leaf string, PROPS are final direct text properties, CHILDREN are ordered
plans, TAGS are opaque metadata, and CAPABILITY is `content' or `properties'."
(tp--copy-surface-plan
(tp--make-surface-plan
:key key :kind kind :text text :props props :children children
:tags tags :capability capability)))
(cl-defun tp-surface-plan-create-owned
(&key key kind text props children tags capability)
"Create a candidate-local surface plan without copying its values.
KEY, KIND, TEXT, PROPS, CHILDREN, TAGS, and CAPABILITY have the same meanings
as in `tp-surface-plan-create'. The caller transfers ownership of those
values; after this call they must not be mutated or exposed to another owner.
Use `tp-surface-plan-create' for ordinary caller-owned values."
(tp--validate-surface-plan-tree
(tp--make-surface-plan
:key key :kind kind :text text :props props :children children
:tags tags :capability capability)))
(defun tp-surface-result-create (plan &optional client-state)
"Return a producer result containing PLAN and opaque CLIENT-STATE.
TP always renders the submitted plan inside its prepare transaction. This
keeps the plan as the single authoritative source for published content."
(tp--make-surface-result
(tp--copy-surface-plan plan) client-state))
(defun tp-surface-result-create-owned (context plan &optional client-state)
"Create a one-shot result by adopting candidate-local PLAN.
CONTEXT must be the active prepare context that owns PLAN. PLAN and all
nested values must be freshly allocated for that candidate and must not be
mutated or exposed after this call. CLIENT-STATE is opaque producer state.
Use `tp-surface-result-create' for ordinary caller-owned plans."
(tp--validate-prepare-context context)
(unless (eq context tp--current-prepare-context)
(signal 'tp-owned-result-error
(list :context-not-current context tp--current-prepare-context)))
(tp--make-surface-result
(tp--validate-surface-plan-tree plan) client-state t context))
(defun tp--property-value-equal-p (property left right)
"Return non-nil when PROPERTY values LEFT and RIGHT are policy-equal."
(funcall (tp-property-policy-equality (tp-register-text-property property))
left right))
(defun tp--plan-props-equal-p (left right)
"Return non-nil when text property plists LEFT and RIGHT are policy-equal."
(and (= (length left) (length right))
(cl-loop for (property value) on left by #'cddr
for cell = (plist-member right property)
always (and cell
(tp--property-value-equal-p
property value (cadr cell))))))
(defun tp--plan-equal-p (left right)
"Return non-nil when LEFT and RIGHT plans are semantically equal."
(and (equal (tp-surface-plan-key left) (tp-surface-plan-key right))
(equal (tp-surface-plan-kind left) (tp-surface-plan-kind right))
(let ((a (tp-surface-plan-text left))
(b (tp-surface-plan-text right)))
(if (and (stringp a) (stringp b))
(equal-including-properties a b)
(equal a b)))
(tp--plan-props-equal-p (tp-surface-plan-props left)
(tp-surface-plan-props right))
(equal (tp-surface-plan-tags left) (tp-surface-plan-tags right))
(eq (tp-surface-plan-capability left)
(tp-surface-plan-capability right))
(let ((a (tp-surface-plan-children left))
(b (tp-surface-plan-children right)))
(and (= (length a) (length b))
(cl-every #'identity
(cl-mapcar #'tp--plan-equal-p a b))))))
(defun tp--hash-copy (table)
"Return a shallow copy of hash TABLE."
(let ((copy (make-hash-table :test (hash-table-test table))))
(maphash (lambda (key value) (puthash key value copy)) table)
copy))
(defun tp--context-parent-key (context parent)
"Return the child-table key for PARENT in CONTEXT."
(or parent (tp--context-surface context)))
(defun tp--context-child-table (context parent)
"Return CONTEXT's explicit child-key table for PARENT."
(let* ((owner (tp--context-parent-key context parent))
(tables (tp--context-child-seen context)))
(or (gethash owner tables)
(let ((table (make-hash-table :test #'equal)))
(puthash owner table tables)
table))))
(defun tp--context-next-position (context parent)
"Return and advance CONTEXT's unkeyed child position for PARENT."
(let* ((owner (tp--context-parent-key context parent))
(positions (tp--context-child-positions context))
(position (gethash owner positions 0)))
(puthash owner (1+ position) positions)
position))
(defun tp--object-path-segment (context parent key kind)
"Return CONTEXT's candidate path segment for KEY and KIND below PARENT."
(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 (tp--context-next-position context parent) :kind kind)))
(defun tp--validate-context-parent (context parent)
"Validate PARENT for candidate CONTEXT."
(when parent
(unless (tp-object-p parent)
(signal 'wrong-type-argument (list 'tp-object-p parent)))
(unless (eq (tp--surface-object-surface parent)
(tp--context-surface context))
(signal 'tp-cross-surface-object (list parent)))
(unless (gethash (tp--surface-object-path parent)
(tp--context-objects context))
(signal 'tp-stale-object (list parent)))))
(defun tp--validate-prepare-context (context)
"Signal unless CONTEXT is active."
(unless (and (tp-prepare-context-p context) (tp--context-active context))
(signal 'tp-invalid-prepare-context (list context))))
(defun tp--new-candidate-object (context parent key kind path)
"Create a candidate object for KEY and KIND in CONTEXT below PARENT at PATH."
(let ((object (tp--make-surface-object
:id (cl-incf tp--object-id-counter)
:surface (tp--context-surface context) :parent parent
:key (tp--copy-property-value key)
:kind kind :path path
:candidate-context context)))
(push object (tp--context-new-objects context))
object))
(defun tp-object-ensure (context parent key kind)
"Return candidate identity for KEY and KIND below PARENT in CONTEXT."
(tp--validate-prepare-context context)
(tp--validate-context-parent context parent)
(unless kind
(signal 'tp-invalid-surface-plan (list :kind kind)))
(let* ((segment (tp--object-path-segment context parent key 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)
(not (tp--surface-object-disposed object))
(tp-surface-live-p (tp--surface-object-surface object))))
(defun tp-object-resolve (surface key-path)
"Resolve live object in SURFACE by explicit KEY-PATH without scanning text."
(tp--validate-live-surface surface)
(let ((object (gethash key-path (tp--surface-objects surface))))
(and (tp-object-live-p object) object)))
(defun tp-object-mounted-p (object)
"Return non-nil when live OBJECT owns at least one published mount.
This predicate does not copy mount tags; use `tp-object-mounts' when callers
need the public coordinate and metadata snapshots."
(unless (tp-object-live-p object)
(signal 'tp-stale-object (list object)))
(and (gethash object
(tp--surface-mount-index
(tp--surface-object-surface object)))
t))
(defun tp-object-mounts (object)
"Return OBJECT's live numeric mount ranges and opaque tags.
Each result is a plist with `:start', `:end', and `:tags'. Marker objects
remain private so callers cannot mutate TP's publication coordinates."
(unless (tp-object-live-p object)
(signal 'tp-stale-object (list object)))
(let* ((surface (tp--surface-object-surface object))
(mounts (gethash object (tp--surface-mount-index surface))))
(mapcar
(lambda (mount)
(list :start (tp--mount-position (tp--surface-mount-start mount))
:end (tp--mount-position (tp--surface-mount-end mount))
:tags (tp--copy-property-value
(tp--surface-mount-tags mount))))
mounts)))
(defun tp--make-context (surface &optional ephemeral)
"Create a prepare context for SURFACE.
When EPHEMERAL is non-nil, no identity may be promoted."
(tp--make-prepare-context
:surface surface
:objects (if (tp--surface-objects surface)
(tp--hash-copy (tp--surface-objects surface))
(make-hash-table :test #'equal))
:touched (make-hash-table :test #'eq)
:retained (make-hash-table :test #'eq)
:bindings (make-hash-table :test #'eq)
:attachments (make-hash-table :test #'eq)
:fragment-attachments (make-hash-table :test #'eq)
:content-range-attachments (make-hash-table :test #'eq)
:child-seen (make-hash-table :test #'eq)
:child-positions (make-hash-table :test #'eq)
:active t :ephemeral ephemeral))
(defun tp--validate-context-object (context object)
"Require OBJECT to be a candidate in active CONTEXT."
(tp--validate-prepare-context context)
(unless (and (tp-object-p object)
(eq (tp--surface-object-surface object)
(tp--context-surface context))
(or (gethash object (tp--context-touched context))
(gethash object (tp--context-retained context))))
(signal 'tp-stale-object (list object))))
(defun tp-object-retain (context object)
"Retain candidate OBJECT in CONTEXT even when it owns no output fragment."
(tp--validate-context-object context object)
(puthash object t (tp--context-retained 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))
(equal prefix (cl-subseq path 0 (length prefix)))))
(defun tp-object-retain-subtree (context root)
"Retain the existing object subtree rooted at live ROOT in CONTEXT.
ROOT must be a live object already owned by CONTEXT's surface. The operation
marks ROOT and every already-known descendant as touched and retained, and
also keeps their live bindings in the candidate lifecycle. It does not
create missing objects or prove that an omitted subtree is unchanged; the
producer must provide that proof and a complete candidate plan separately."
(tp--validate-prepare-context context)
(unless (tp-object-p root)
(signal 'wrong-type-argument (list 'tp-object-p root)))
(let* ((surface (tp--context-surface context))
(path (tp--surface-object-path root))
(objects (tp--context-objects context)))
(unless (and (tp-object-live-p root)
(eq root (gethash path objects)))
(signal 'tp-stale-object (list root)))
(maphash
(lambda (_candidate-path object)
(when (tp--object-path-prefix-p
path (tp--surface-object-path object))
(unless (and (eq (tp--surface-object-surface object) surface)
(tp-object-live-p object))
(signal 'tp-stale-object (list object)))
(puthash object t (tp--context-touched context))
(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))))))
objects))
root)
(defun tp-object-reuse-subtree (context root)
"Reuse a proven unchanged live subtree in CONTEXT.
ROOT must be a live object already owned by CONTEXT's surface. The subtree's
objects and live bindings remain in the candidate, but are not marked touched
or reconciled. The caller must still provide a complete candidate plan and
prove that the subtree's identity, output, and lifecycle are unchanged."
(tp--validate-prepare-context context)
(unless (tp-object-p root)
(signal 'wrong-type-argument (list 'tp-object-p root)))
(let* ((surface (tp--context-surface context))
(path (tp--surface-object-path root))
(objects (tp--context-objects context)))
(unless (and (tp-object-live-p root)
(eq root (gethash path objects)))
(signal 'tp-stale-object (list root)))
(maphash
(lambda (_candidate-path object)
(when (tp--object-path-prefix-p
path (tp--surface-object-path object))
(unless (and (eq (tp--surface-object-surface object) surface)
(tp-object-live-p object))
(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))))))
objects))
root)
(defun tp-object-attach-fragment (context object fragment &optional tags)
"Attach logical OBJECT to output FRAGMENT with opaque TAGS in CONTEXT.
OBJECT and FRAGMENT must be candidate handles from the same content surface.
The plan remains pure; this side attachment may give OBJECT several disjoint
marker-backed mounts after publication."
(tp--validate-context-object context object)
(tp--validate-context-object context fragment)
(unless (eq (tp--surface-capability (tp--context-surface context)) 'content)
(signal 'tp-capability-error (list :fragment-attachment)))
(let ((attachments (gethash fragment
(tp--context-fragment-attachments context))))
(when (assq object attachments)
(signal 'tp-surface-error (list :duplicate-fragment object fragment)))
(puthash fragment
(cons (cons object (tp--copy-property-value tags)) attachments)
(tp--context-fragment-attachments context)))
(tp-object-retain context object))
(defun tp--validate-content-range (start end)
"Signal unless START and END describe a nonempty local leaf range."
(unless (and (integerp start) (integerp end)
(>= start 0) (> end start))
(signal 'tp-invalid-content-range (list :start start :end end))))
(defun tp--copy-content-range-tags (tags &optional copies)
"Return a defensive copy of non-nil content-range TAGS.
COPIES, when non-nil, is a call-local `eq' cache owned by one bulk attach
operation. A singular attach always snapshots TAGS independently, so later
caller mutation cannot alter an earlier attachment."
(if (null tags)
nil
(let ((copy (and copies (gethash tags copies))))
(or copy
(let ((copy (tp--copy-property-value tags)))
(when copies
(puthash tags copy copies))
copy)))))
(defun tp-object-attach-content-range
(context object leaf start end &optional tags)
"Attach OBJECT to [START, END) in candidate content LEAF for CONTEXT.
START and END are character offsets relative to LEAF's text, not buffer
positions. LEAF must be a candidate text leaf in the same content surface;
the range is validated against its rendered length during prepare. TAGS are
opaque metadata copied into the eventual marker-backed mount."
(tp--validate-context-object context object)
(tp--validate-context-object context leaf)
(tp--validate-content-range start end)
(let ((attachments
(gethash leaf (tp--context-content-range-attachments context))))
(puthash leaf
(cons (list :object object :start start :end end
:tags (tp--copy-content-range-tags tags))
attachments)
(tp--context-content-range-attachments context)))
(unless (gethash object (tp--context-retained context))
(tp-object-retain context object)))
(defun tp--attach-content-ranges (context leaf ranges copy-tags-p)
"Attach RANGES to LEAF for CONTEXT, copying TAGS when COPY-TAGS-P is non-nil."
(tp--validate-context-object context leaf)
(let ((attachments (gethash leaf
(tp--context-content-range-attachments context)))
(copies (and copy-tags-p (make-hash-table :test #'eq)))
added)
(dolist (range ranges)
(let ((object (plist-get range :object))
(start (plist-get range :start))
(end (plist-get range :end))
(tags (plist-get range :tags)))
(tp--validate-context-object context object)
(tp--validate-content-range start end)
(push (list :object object :start start :end end
:tags (if copy-tags-p
(tp--copy-content-range-tags tags copies)
tags))
added)
(unless (gethash object (tp--context-retained context))
(tp-object-retain context object))))
(puthash leaf (nconc added attachments)
(tp--context-content-range-attachments context)))
ranges)
(defun tp-object-attach-content-ranges (context leaf ranges)
"Attach multiple OBJECT ranges to candidate content LEAF for CONTEXT.
RANGES contains plists with `:object', `:start', `:end', and optional `:tags'.
TP defensively copies every non-nil TAGS value. The ranges retain input order
after publication and reuse a snapshot only when the same TAGS object recurs
in one bulk attach."
(tp--attach-content-ranges context leaf ranges t))
(defun tp-object-attach-content-ranges-owned (context leaf ranges)
"Attach candidate RANGES to LEAF for CONTEXT with owned TAGS snapshots.
Use this only when each non-nil TAGS value was freshly allocated for the
candidate and will not be mutated or exposed to caller mutation after this
call. TP transfers those values without copying; failed candidates discard
the transferred values with the rest of their prepare state."
(tp--attach-content-ranges context leaf ranges nil))
(defun tp--touch-context-binding (context binding)
"Record BINDING as touched by CONTEXT."
(let ((owner (tp-binding-owner binding)))
(unless (and (tp-object-p owner)
(eq (tp--surface-object-surface owner)
(tp--context-surface context)))
(signal 'tp-cross-surface-object (list owner)))
(puthash binding t (tp--context-bindings context))))
(defun tp--plist-overlay (parent child &optional owned-p)
"Return a fresh plist where CHILD values override PARENT values.
When OWNED-P is non-nil, reuse candidate-owned property values while copying
only the plist spine. The non-owned path keeps the defensive value copies
needed by ordinary TP callers."
(let ((result (if owned-p
(copy-sequence parent)
(tp--copy-property-value parent))))
(cl-loop for (property value) on child by #'cddr
do (setq result
(plist-put result property
(if owned-p
value
(tp--copy-property-value value)))))
result))
(defun tp--plan-segment (plan position)
"Return PLAN's path segment at sibling POSITION."
(or (tp-surface-plan-key plan)
(list :position position :kind (tp-surface-plan-kind plan))))
(defun tp--render-plan (plan context &optional owned-p)
"Return PLAN's propertized string and side records in CONTEXT.
OWNED-P transfers candidate-local property values through the render pass."
(let (records)
(cl-labels
((walk (node path inherited offset)
(let* ((props (tp--plist-overlay
inherited (tp-surface-plan-props node) owned-p))
(begin offset)
(children (tp-surface-plan-children node))
pieces)
(if children
(cl-loop for child in children for position from 0
for child-path =
(append path (list (tp--plan-segment child position)))
for result = (walk child child-path props offset)
do (push (car result) pieces)
do (setq offset (cdr result)))
(let ((text (copy-sequence
(or (tp-surface-plan-text node) ""))))
(when (> (length text) 0)
(add-text-properties 0 (length text) props text))
(push text pieces)
(setq offset (+ offset (length text)))))
(let ((object (gethash path (tp--context-objects context))))
(unless object
(signal 'tp-orphan-object (list path)))
(push (list :path path :object object :start begin :end offset
:props props :tags (tp-surface-plan-tags node)
:leaf (null children))
records))
(cons (apply #'concat (nreverse pieces)) offset))))
(let* ((path (list (tp--plan-segment plan 0)))
(result (walk plan path nil 0)))
(cons (car result) (nreverse records))))))
(defun tp--ensure-plan-objects (context plan &optional parent)
"Ensure identities for PLAN recursively below PARENT in CONTEXT."
(let ((object (tp-object-ensure
context parent (tp-surface-plan-key plan)
(tp-surface-plan-kind plan))))
(dolist (child (tp-surface-plan-children plan))
(tp--ensure-plan-objects context child object))
object))
(defun tp--plan-paths (plan)
"Return PLAN's object paths in traversal order."
(let (paths)
(cl-labels
((walk (node path)
(push path paths)
(cl-loop for child in (tp-surface-plan-children node)
for position from 0
do (walk child
(append path
(list (tp--plan-segment child position)))))))
(walk plan (list (tp--plan-segment plan 0))))
(nreverse paths)))
(defun tp--validate-context-tree (context plan)
"Validate PLAN and CONTEXT's retained and fragment object paths."
(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 _present)
(unless (gethash path actual)
(signal 'tp-orphan-object (list :missing path))))
expected)
(maphash
(lambda (path object)
(unless (or (gethash path expected)
(gethash object (tp--context-retained context)))
(signal 'tp-orphan-object (list :extra path))))
actual)
(maphash
(lambda (fragment _attachments)
(unless (gethash (tp--surface-object-path fragment) expected)
(signal 'tp-orphan-object
(list :unplanned-fragment
(tp--surface-object-path fragment)))))
(tp--context-fragment-attachments context))))
(defun tp--validate-plan-capability (plan capability)
"Validate PLAN recursively against mount CAPABILITY."
(let ((declared (tp-surface-plan-capability plan)))
(when (and declared (not (eq declared capability)))
(signal 'tp-capability-error (list declared capability)))
(when (and (eq capability 'properties) (tp-surface-plan-text plan))
(signal 'tp-capability-error (list :properties-text)))
(dolist (child (tp-surface-plan-children plan))
(tp--validate-plan-capability child capability))))
(defun tp--producer-result (value surface options context)
"Normalize producer VALUE for SURFACE and active CONTEXT using OPTIONS."
(cond
((tp-surface-result-p value)
(let ((owned-p (tp-surface-result-plan-owned-p value)))
(if owned-p
(progn
(unless (and context
(tp--context-active context)
(eq context tp--current-prepare-context)
(eq context (tp-surface-result-owner-context value))
(not (tp-surface-result-consumed-p value)))
(signal 'tp-owned-result-error (list value context)))
(let ((plan (tp-surface-result-plan value))
(client-state (tp-surface-result-client-state value)))
(setf (tp-surface-result-consumed-p value) t
(tp-surface-result-plan value) nil
(tp-surface-result-client-state value) nil
(tp-surface-result-owner-context value) nil)
(list plan client-state t)))
(list (tp--copy-surface-plan (tp-surface-result-plan value))
(tp-surface-result-client-state value) nil))))
((tp-surface-plan-p value)
(list (tp--copy-surface-plan value)
(if (plist-member options :client-state)
(plist-get options :client-state)
(tp--surface-client-state surface))
nil))
(t (signal 'tp-invalid-surface-plan (list value)))))
(defun tp--context-binding-removals (context objects)
"Return default-lifecycle bindings omitted from CONTEXT among OBJECTS."
(cl-loop for object in objects append
(cl-loop for binding in (tp-binding-owner-bindings object)
unless (or (gethash binding (tp--context-bindings context))
(eq (tp-binding-lifecycle binding) 'retain))
collect binding)))
(defun tp--context-live-objects (surface)
"Return SURFACE's current objects."
(let (objects)
(when (tp--surface-objects surface)
(maphash (lambda (_path object) (push object objects))
(tp--surface-objects surface)))
objects))
(defun tp--object-set-difference (left right)
"Return objects in LEFT that are not `eq' to an object in RIGHT."
(cl-remove-if (lambda (object) (memq object right)) left))
(defun tp--plan-key-positions (plan)
"Return an alist from PLAN keyed paths to sibling positions."
(let (positions)
(cl-labels
((walk (node path)
(cl-loop for child in (tp-surface-plan-children node)
for position from 0
for key = (tp-surface-plan-key child)
for child-path = (and key (append path (list key)))
when key do (push (cons child-path position) positions)
do (walk child
(or child-path
(append path
(list (tp--plan-segment
child position))))))))
(walk plan (list (tp--plan-segment plan 0))))
positions))
(defun tp--plan-moved-count (old new)
"Return the number of keyed objects moved between OLD and NEW plans."
(if (null old)
0
(let ((old-positions (tp--plan-key-positions old)))
(cl-loop for (path . position) in (tp--plan-key-positions new)
for old-position = (alist-get path old-positions nil nil #'equal)
count (and old-position (/= old-position position))))))
(defun tp--candidate-object-list (context)
"Return CONTEXT's touched and retained candidate objects."
(let (objects)
(maphash
(lambda (_path object)
(when (or (gethash object (tp--context-touched context))
(gethash object (tp--context-retained context)))
(push object objects)))
(tp--context-objects context))
objects))
(defun tp--candidate-reconciled-count (context created)
"Return the number of touched retained objects in CONTEXT excluding CREATED."
(- (hash-table-count (tp--context-touched context))
(length created)))
(defun tp--content-mount-spec (object record &optional tags tags-owned-p)
"Return one content mount spec for OBJECT over RECORD with TAGS.
TAGS-OWNED-P skips a second snapshot when TAGS already belongs to the candidate."
(list :object object :start (plist-get record :start)
:end (plist-get record :end)
:tags (if tags-owned-p
tags
(tp--copy-property-value
(if tags tags (plist-get record :tags))))))
(defun tp--content-mount-specs (records context)
"Return direct and logical range mount specs for RECORDS in CONTEXT."
(let (specs)
(dolist (record records)
(let* ((leaf (plist-get record :object))
(fragment-attachments
(nreverse
(copy-sequence
(gethash leaf
(tp--context-fragment-attachments context)))))
(range-attachments
(nreverse
(copy-sequence
(gethash leaf
(tp--context-content-range-attachments context))))))
(push (tp--content-mount-spec leaf record) specs)
(dolist (attachment fragment-attachments)
(push (tp--content-mount-spec
(car attachment) record (cdr attachment) t)
specs))
(when range-attachments
(unless (plist-get record :leaf)
(signal 'tp-invalid-content-range
(list :leaf leaf :reason 'not-a-text-leaf)))
(let ((leaf-start (plist-get record :start))
(leaf-length (- (plist-get record :end)
(plist-get record :start))))
(dolist (attachment range-attachments)
(let ((start (plist-get attachment :start))
(end (plist-get attachment :end)))
(unless (and (<= end leaf-length)
(<= start end))
(signal 'tp-invalid-content-range
(list :start start :end end
:leaf-length leaf-length)))
(push (list :object (plist-get attachment :object)
:start (+ leaf-start start)
:end (+ leaf-start end)
:tags (plist-get attachment :tags))
specs)))))))
(nreverse specs)))
(defun tp--plan-record-mount-specs (records capability context)
"Build candidate mount specs from RECORDS for CAPABILITY in CONTEXT."
(if (eq capability 'content)
(tp--content-mount-specs records context)
(tp--properties-mount-specs records context)))
(defun tp--ranges-overlap-p (left-start left-end right-start right-end)
"Return non-nil when LEFT-START..LEFT-END overlaps RIGHT-START..RIGHT-END."
(and (< left-start left-end) (< right-start right-end)
(< left-start right-end) (< right-start left-end)))
(defun tp--candidate-ranges (surface mount-specs rendered)
"Return SURFACE ranges described by MOUNT-SPECS and RENDERED."
(if (eq (tp--surface-capability surface) 'content)
(let ((start (marker-position (tp--surface-start surface))))
(list (cons start (+ start (length rendered)))))
(mapcar (lambda (spec)
(cons (plist-get spec :start) (plist-get spec :end)))
mount-specs)))
(defun tp--validate-cross-surface-ranges (surface mount-specs rendered)
"Reject MOUNT-SPECS and RENDERED when SURFACE overlaps another surface."
(let ((ranges (tp--candidate-ranges surface mount-specs rendered)))
(with-current-buffer (tp--surface-buffer surface)
(dolist (other tp--buffer-surfaces)
(unless (eq other surface)
(dolist (mount (tp--surface-mounts other))
(let ((start (tp--mount-position (tp--surface-mount-start mount)))
(end (tp--mount-position (tp--surface-mount-end mount))))
(when (cl-some (lambda (range)
(tp--ranges-overlap-p
(car range) (cdr range) start end))
ranges)
(signal 'tp-capability-error
(list :cross-surface-overlap
(tp--surface-id other)))))))))))
(defun tp--prepare-input (surface input options context)
"Run INPUT for SURFACE in CONTEXT and normalize its result."
(let ((tp--current-prepare-context context)
(tp--binding-touch-function
(lambda (binding) (tp--touch-context-binding context binding))))
(if (functionp input)
(tp--producer-result (funcall input context) surface options context)
(let ((plan (tp--copy-surface-plan input)))
(tp--ensure-plan-objects context plan)
(list plan
(if (plist-member options :client-state)
(plist-get options :client-state)
(tp--surface-client-state surface)))))))
(defun tp--call-with-prepare-buffer-guard (surface function)
"Call FUNCTION while rejecting producer edits to SURFACE's buffer."
(let* ((buffer (tp--surface-buffer surface))
(before-tick (with-current-buffer buffer
(buffer-modified-tick)))
(group (tp--prepare-change-group-for-buffers (list buffer)))
(tp--surface-guarding-prepare t))
(unwind-protect
(let ((result (funcall function)))
(unless (= before-tick
(with-current-buffer buffer
(buffer-modified-tick)))
(signal 'tp-producer-buffer-mutation
(list (tp--surface-id surface))))
result)
(tp--cancel-change-group-safely group))))
(defun tp--normalize-surface-scopes (surface objects)
"Return validated retained OBJECTS owned by SURFACE."
(unless (and (proper-list-p objects) objects)
(signal 'wrong-type-argument (list 'non-empty-proper-list-p objects)))
(setq objects
(cl-delete-duplicates (copy-sequence objects) :test #'eq))
(dolist (object objects)
(unless (tp-object-p object)
(signal 'wrong-type-argument (list 'tp-object-p object)))
(unless (tp-object-live-p object)
(signal 'tp-stale-object (list object)))
(unless (eq (tp--surface-object-surface object) surface)
(signal 'tp-cross-surface-object (list object surface))))
objects)
(defun tp--coalesce-ranges (ranges)
"Return sorted, merged nonempty RANGES."
(setq ranges
(sort (cl-remove-if (lambda (range) (>= (car range) (cdr range)))
(mapcar (lambda (range)
(cons (car range) (cdr range)))
ranges))
(lambda (left right) (< (car left) (car right)))))
(let (merged)
(dolist (range ranges (nreverse merged))
(if (and merged (<= (car range) (cdar merged)))
(setcdr (car merged) (max (cdar merged) (cdr range)))
(push range merged)))))
(defun tp--subtract-ranges (ranges exclusions)
"Return RANGES with EXCLUSIONS removed.
Both arguments contain numeric half-open relative intervals."
(let (result)
(dolist (range ranges (nreverse result))
(let ((cursor (car range))
(end (cdr range)))
(dolist (exclusion exclusions)
(when (and (< cursor end) (> (cdr exclusion) cursor))
(when (< cursor (car exclusion))
(push (cons cursor (min end (car exclusion))) result))
(setq cursor (max cursor (cdr exclusion)))))
(when (< cursor end)
(push (cons cursor end) result))))))
(defun tp--live-scope-ranges (surface objects &optional relative)
"Return live mount ranges for OBJECTS on SURFACE.
When RELATIVE is non-nil, return offsets from the surface start."
(let ((base (if relative
(marker-position (tp--surface-start surface))
0))
ranges)
(dolist (object objects)
(dolist (mount (gethash object (tp--surface-mount-index surface)))
(let ((start (tp--mount-position (tp--surface-mount-start mount)))
(end (tp--mount-position (tp--surface-mount-end mount))))
(unless (and start end)
(signal 'tp-stale-mount (list object)))
(push (cons (- start base) (- end base)) ranges))))
(tp--coalesce-ranges ranges)))
(defun tp--candidate-scope-ranges (mount-specs objects)
"Return relative candidate MOUNT-SPECS ranges owned by OBJECTS."
(let ((scope-set (make-hash-table :test #'eq)) ranges)
(dolist (object objects) (puthash object t scope-set))
(dolist (spec mount-specs)
(when (gethash (plist-get spec :object) scope-set)
(push (cons (plist-get spec :start) (plist-get spec :end)) ranges)))
(tp--coalesce-ranges ranges)))
(defun tp--surface-content-string (surface)
"Return SURFACE's current propertized content string."
(pcase-let ((`(,start . ,end) (tp--surface-range surface)))
(with-current-buffer (tp--surface-buffer surface)
(save-restriction
(widen)
(buffer-substring start end)))))
(defun tp--complement-ranges (length ranges)
"Return the nonempty complement of RANGES inside zero to LENGTH."
(let ((cursor 0) complement)
(dolist (range ranges)
(when (< cursor (car range))
(push (cons cursor (car range)) complement))
(setq cursor (cdr range)))
(when (< cursor length)
(push (cons cursor length) complement))
(nreverse complement)))
(defun tp--substring-ranges (string ranges)
"Return STRING content from RANGES concatenated with properties."
(apply #'concat
(mapcar (lambda (range)
(substring string (car range) (cdr range)))
ranges)))
(defun tp--pair-outside-ranges (old-ranges new-ranges)
"Pair equal-length pieces of OLD-RANGES and NEW-RANGES in order."
(let ((old-ranges (copy-tree old-ranges))
(new-ranges (copy-tree new-ranges))
pairs)
(while (and old-ranges new-ranges)
(let* ((old (car old-ranges))
(new (car new-ranges))
(length (min (- (cdr old) (car old))
(- (cdr new) (car new)))))
(push (list (car old) (+ (car old) length)
(car new) (+ (car new) length))
pairs)
(setcar old-ranges (cons (+ (car old) length) (cdr old)))
(setcar new-ranges (cons (+ (car new) length) (cdr new)))
(when (= (caar old-ranges) (cdar old-ranges)) (pop old-ranges))
(when (= (caar new-ranges) (cdar new-ranges)) (pop new-ranges))))
(nreverse pairs)))
(defun tp--scope-patches-between-anchors (old new anchors)
"Return patches between equal outside ANCHORS in OLD and NEW."
(let ((old-position 0) (new-position 0) patches)
(dolist (anchor (append anchors
(list (list (length old) (length old)
(length new) (length new)))))
(let* ((old-end (nth 0 anchor))
(new-end (nth 2 anchor))
(replacement (substring new new-position new-end)))
(unless (equal-including-properties
(substring old old-position old-end) replacement)
(push (list :old-start old-position :old-end old-end
:new-start new-position :new-end new-end
:replacement replacement)
patches)))
(setq old-position (nth 1 anchor)
new-position (nth 3 anchor)))
(nreverse patches)))
(defun tp--scope-replacement-analysis (old new old-ranges new-ranges)
"Compare OLD-RANGES and NEW-RANGES from OLD to NEW.
Return scoped replacement metadata, or nil on mismatch."
(let* ((old-outside (tp--complement-ranges (length old) old-ranges))
(new-outside (tp--complement-ranges (length new) new-ranges)))
(when (equal-including-properties
(tp--substring-ranges old old-outside)
(tp--substring-ranges new new-outside))
(list :patches
(tp--scope-patches-between-anchors
old new (tp--pair-outside-ranges old-outside new-outside))))))
(defun tp--prepare-content-scope
(surface rendered mount-specs objects options)
"Return scoped publication metadata for RENDERED on SURFACE.
MOUNT-SPECS describe the candidate OBJECTS. OPTIONS accepts
`:on-mismatch' as `error' or `root'."
(let* ((old (tp--surface-content-string surface))
(old-ranges (tp--live-scope-ranges surface objects t))
(new-ranges (tp--candidate-scope-ranges mount-specs objects))
(analysis
(tp--scope-replacement-analysis
old rendered old-ranges new-ranges)))
(cond
(analysis (list :patches (plist-get analysis :patches) :fallback nil))
((eq (plist-get options :on-mismatch) 'root)
(list :patches nil :fallback t))
(t
(signal 'tp-scope-mismatch
(list :surface (tp--surface-id surface)
:old-ranges old-ranges :new-ranges new-ranges))))))
(defun tp--range-contained-in-p (start end ranges)
"Return non-nil when START..END is inside one of RANGES."
(cl-some (lambda (range)
(and (<= (car range) start) (<= end (cdr range))))
ranges))
(defun tp--prepare-properties-scope
(surface mount-specs operations objects options)
"Validate scoped property OPERATIONS for OBJECTS on SURFACE.
MOUNT-SPECS describe the candidate object ranges and OPTIONS controls mismatch."
(let* ((old-ranges (tp--live-scope-ranges surface objects))
(new-ranges (tp--candidate-scope-ranges mount-specs objects))
(ranges (tp--coalesce-ranges
(append old-ranges new-ranges)))
(outside
(cl-find-if
(lambda (operation)
(not (tp--range-contained-in-p
(plist-get operation :start) (plist-get operation :end)
ranges)))
operations)))
(cond
((not outside) (list :patches ranges :fallback nil))
((eq (plist-get options :on-mismatch) 'root)
(list :patches nil :fallback t))
(t
(signal 'tp-scope-mismatch
(list :surface (tp--surface-id surface)
:operation outside :ranges ranges))))))
(defun tp--prepare-surface (surface input options initial)
"Prepare INPUT for SURFACE without publishing it.
OPTIONS configure the mount and INITIAL is non-nil for first publication."
(tp--validate-surface-buffer surface initial)
(when (and (not initial) (tp--surface-stale surface))
(signal 'tp-stale-mount (list (tp--surface-id surface))))
(let* ((scope-request (tp--surface-scope-request surface))
(context (tp--make-context surface))
(scope-objects
(and scope-request
(tp--normalize-surface-scopes
surface (plist-get scope-request :objects))))
(scope-options (plist-get scope-request :options))
(success nil)
result)
(unwind-protect
(let* ((normalized
(tp--call-with-prepare-buffer-guard
surface
(lambda ()
(tp--prepare-input surface input options context))))
(plan (nth 0 normalized))
(client-state (nth 1 normalized))
(owned-p (nth 2 normalized))
(_capability (tp--validate-plan-capability
plan (tp--surface-capability surface)))
(_tree (tp--validate-context-tree context plan))
(render-result (tp--render-plan plan context owned-p))
(rendered (car render-result))
(records (cdr render-result))
(objects (tp--candidate-object-list context))
(old-objects (tp--context-live-objects surface))
(created (tp--object-set-difference objects old-objects))
(removed (tp--object-set-difference old-objects objects))
(mount-specs (tp--plan-record-mount-specs
records (tp--surface-capability surface) context))
(_ranges (tp--validate-cross-surface-ranges
surface mount-specs rendered))
(property-result
(when (eq (tp--surface-capability surface) 'properties)
(tp--prepare-property-ledger surface mount-specs)))
(scope-analysis
(when scope-objects
(if (eq (tp--surface-capability surface) 'content)
(tp--prepare-content-scope
surface rendered mount-specs scope-objects
scope-options)
(tp--prepare-properties-scope
surface mount-specs (cdr property-result) scope-objects
scope-options)))))
(setq result
(tp--make-prepared-surface
:surface surface :context context :plan plan :rendered rendered
:mount-specs mount-specs :ledger-specs (car property-result)
:property-operations (cdr property-result) :objects objects
:client-state client-state :producer input :initial initial
:created created :removed removed
:moved (tp--plan-moved-count (tp--surface-plan surface) plan)
:reconciled (tp--candidate-reconciled-count context created)
:scope-objects scope-objects
:scope-patches (plist-get scope-analysis :patches)
:scope-fallback (plist-get scope-analysis :fallback)))
(setq success t)
result)
(unless success (tp--discard-context context)))))
(cl-defun tp-range-anchor-create
(buffer start end &key (start-insertion-type nil) (end-insertion-type t)
(boundary-policy 'stale))
"Create an opaque marker-backed range in BUFFER from START to END.
START-INSERTION-TYPE and END-INSERTION-TYPE control marker movement.
BOUNDARY-POLICY is `stale', `shorten', or `remove'."
(tp--validate-buffer-range buffer start end)
(unless (memq boundary-policy '(stale shorten remove))
(signal 'tp-invalid-range-anchor (list boundary-policy)))
(let ((anchor (tp--make-range-anchor
:id (cl-incf tp--anchor-id-counter) :buffer buffer
:start (copy-marker start start-insertion-type)
:end (copy-marker end end-insertion-type)
:boundary-policy boundary-policy :live t
:candidate-context tp--current-prepare-context)))
(when tp--current-prepare-context
(push anchor (tp--context-created-anchors tp--current-prepare-context)))
anchor))
(defun tp-range-anchor-live-p (anchor)
"Return non-nil when ANCHOR still has live markers."
(and (tp-range-anchor-p anchor) (tp--anchor-live anchor)
(buffer-live-p (tp--anchor-buffer anchor))
(marker-position (tp--anchor-start anchor))
(marker-position (tp--anchor-end anchor))))
(defun tp--validate-anchor (anchor surface)
"Validate ANCHOR for SURFACE."
(unless (tp-range-anchor-live-p anchor)
(signal 'tp-invalid-range-anchor (list anchor)))
(unless (eq (tp--anchor-buffer anchor) (tp--surface-buffer surface))
(signal 'tp-cross-surface-object (list anchor surface)))
(when (and (tp--anchor-surfaces anchor)
(not (memq surface (tp--anchor-surfaces anchor))))
(signal 'tp-cross-surface-object (list anchor surface)))
(when (tp--anchor-stale anchor)
(signal 'tp-stale-mount (list (tp--anchor-id anchor)))))
(defun tp-object-attach-range (context object anchor)
"Attach OBJECT to marker-backed ANCHOR in candidate CONTEXT."
(tp--validate-context-object context object)
(tp--validate-anchor anchor (tp--context-surface context))
(when (gethash object (tp--context-attachments context))
(signal 'tp-invalid-range-anchor (list :duplicate object)))
(puthash object anchor (tp--context-attachments context))
object)
(defun tp--properties-mount-specs (records context)
"Return properties mount specs from RECORDS and CONTEXT attachments."
(let (specs)
(dolist (record records)
(let* ((object (plist-get record :object))
(anchor (gethash object (tp--context-attachments context))))
(when anchor
(push (list :object object :anchor anchor
:start (marker-position (tp--anchor-start anchor))
:end (marker-position (tp--anchor-end anchor))
:props (plist-get record :props)
:tags (tp--copy-property-value
(plist-get record :tags)))
specs))))
(maphash
(lambda (object _anchor)
(unless (cl-find object records :key (lambda (item)
(plist-get item :object))
:test #'eq)
(signal 'tp-orphan-object (list object))))
(tp--context-attachments context))
(nreverse specs)))
(defun tp--property-state-at (buffer position property)
"Return direct PROPERTY presence and value at POSITION in BUFFER."
(with-current-buffer buffer
(let ((cell (plist-member (text-properties-at position buffer) property)))
(cons (and cell t) (and cell (cadr cell))))))
(defun tp--property-state-equal-p (left right)
"Return non-nil when property states LEFT and RIGHT are equal."
(and (eq (car left) (car right))
(equal (cdr left) (cdr right))))
(defun tp--property-state-policy-equal-p (property left right)
"Return non-nil when PROPERTY states LEFT and RIGHT are policy-equal."
(and (eq (car left) (car right))
(or (not (car left))
(tp--property-value-equal-p property (cdr left) (cdr right)))))
(defun tp--ledger-position (marker)
"Return live MARKER position or signal a stale-mount error."
(or (marker-position marker)
(signal 'tp-stale-mount (list marker))))
(defun tp--old-ledger-at (surface position property)
"Return SURFACE ledger entry covering POSITION for PROPERTY."
(cl-find-if
(lambda (entry)
(and (eq property (tp--property-ledger-property entry))
(<= (tp--ledger-position (tp--property-ledger-start entry)) position)
(< position (tp--ledger-position (tp--property-ledger-end entry)))))
(tp--surface-ledger surface)))
(defun tp--contribution-properties (mount-specs surface)
"Return all property names in MOUNT-SPECS and SURFACE's old ledger."
(let (properties)
(dolist (spec mount-specs)
(cl-loop for (property _value) on (plist-get spec :props) by #'cddr
do (cl-pushnew property properties :test #'eq)))
(dolist (entry (tp--surface-ledger surface))
(cl-pushnew (tp--property-ledger-property entry) properties :test #'eq))
properties))
(defun tp--property-boundaries (buffer mount-specs surface properties)
"Return sorted interval boundaries in BUFFER.
MOUNT-SPECS and SURFACE provide ranges for PROPERTIES."
(let (boundaries intervals)
(dolist (spec mount-specs)
(let ((start (plist-get spec :start))
(end (plist-get spec :end)))
(push start boundaries)
(push end boundaries)
(push (cons start end) intervals)))
(dolist (entry (tp--surface-ledger surface))
(let ((start (tp--ledger-position (tp--property-ledger-start entry)))
(end (tp--ledger-position (tp--property-ledger-end entry))))
(push start boundaries)
(push end boundaries)
(push (cons start end) intervals)))
(setq boundaries (sort (delete-dups boundaries) #'<))
(with-current-buffer buffer
(dolist (interval (tp--coalesce-ranges intervals))
(dolist (property properties)
(let ((position (car interval))
(maximum (cdr interval)))
(while (< position maximum)
(setq position (next-single-property-change
position property buffer maximum))
(push position boundaries))))))
(sort (delete-dups boundaries) #'<)))
(defun tp--covering-contributions (mount-specs start end property)
"Return ordered MOUNT-SPECS covering START..END and declaring PROPERTY."
(cl-remove-if-not
(lambda (spec)
(and (<= (plist-get spec :start) start)
(>= (plist-get spec :end) end)
(plist-member (plist-get spec :props) property)))
mount-specs))
(defun tp--merge-property-contributions (baseline contributions property)
"Merge PROPERTY CONTRIBUTIONS over BASELINE property state."
(let ((state baseline)
(merge (tp-property-policy-merge
(tp-register-text-property property))))
(dolist (spec contributions)
(let ((value (plist-get (plist-get spec :props) property)))
(setq state
(cons t (if (null value)
nil
(if (car state)
(funcall merge (cdr state) value)
value))))))
state))
(defun tp--ledger-baseline-state (old current)
"Return OLD ledger baseline state, or CURRENT when there is no OLD entry."
(if old
(cons (tp--property-ledger-baseline-present old)
(tp--property-ledger-baseline-value old))
current))
(defun tp--ledger-published-state (entry)
"Return ENTRY's last published property state."
(cons (tp--property-ledger-published-present entry)
(tp--property-ledger-published-value entry)))
(defun tp--property-segment-result
(surface mount-specs start end property)
"Prepare one PROPERTY segment from START to END for SURFACE and MOUNT-SPECS."
(let* ((buffer (tp--surface-buffer surface))
(current (tp--property-state-at buffer start property))
(old (tp--old-ledger-at surface start property))
(contributions
(tp--covering-contributions mount-specs start end property)))
(when (and old (not (tp--property-state-policy-equal-p
property current (tp--ledger-published-state old))))
(signal 'tp-property-conflict
(list (tp--surface-id surface) start end property current)))
(let* ((baseline (tp--ledger-baseline-state old current))
(target (tp--merge-property-contributions
baseline contributions property))
(anchors (delete-dups
(mapcar (lambda (spec) (plist-get spec :anchor))
contributions))))
(list :operation
(unless (tp--property-state-policy-equal-p property current target)
(list :start start :end end :property property
:present (car target) :value (cdr target)))
:ledger
(when contributions
(list :start start :end end :property property
:baseline-present (car baseline)
:baseline-value (cdr baseline)
:published-present (car target)
:published-value (cdr target) :anchors anchors))))))
(defun tp--prepare-property-ledger (surface mount-specs)
"Return ledger specs and property operations for SURFACE and MOUNT-SPECS."
(let* ((buffer (tp--surface-buffer surface))
(properties (tp--contribution-properties mount-specs surface))
(boundaries (tp--property-boundaries
buffer mount-specs surface properties))
ledger operations)
(cl-loop for (start end) on boundaries while end do
(dolist (property properties)
(let ((result (tp--property-segment-result
surface mount-specs start end property)))
(when-let ((entry (plist-get result :ledger)))
(push entry ledger))
(when-let ((operation (plist-get result :operation)))
(push operation operations)))))
(cons (nreverse ledger) (nreverse operations))))
(defun tp--validate-live-surface (surface)
"Signal unless SURFACE is live and its buffer exists."
(unless (tp-surface-p surface)
(signal 'wrong-type-argument (list 'tp-surface-p surface)))
(unless (and (tp--surface-live surface)
(buffer-live-p (tp--surface-buffer surface)))
(signal 'tp-dead-surface (list (and (tp-surface-p surface)
(tp--surface-id surface))))))
(defun tp-surface-live-p (surface)
"Return non-nil when SURFACE is mounted in a live buffer."
(and (tp-surface-p surface) (tp--surface-live surface)
(buffer-live-p (tp--surface-buffer surface))))
(defun tp-surface-revision (surface)
"Return SURFACE's committed revision."
(unless (tp-surface-p surface)
(signal 'wrong-type-argument (list 'tp-surface-p surface)))
(tp--surface-revision surface))
(defun tp-surface-client-state (surface)
"Return SURFACE's opaque committed client state."
(tp--validate-live-surface surface)
(tp--surface-client-state surface))
(defun tp--validate-surface-buffer (surface initial)
"Validate SURFACE's buffer before prepare; INITIAL permits a candidate."
(let ((buffer (tp--surface-buffer surface)))
(unless (buffer-live-p buffer)
(signal 'tp-dead-surface (list (tp--surface-id surface))))
(when (buffer-base-buffer buffer)
(signal 'tp-unsupported-buffer (list :indirect buffer)))
(unless (or initial (tp--surface-live surface))
(signal 'tp-dead-surface (list (tp--surface-id surface))))
(with-current-buffer buffer
(when (and buffer-read-only
(not (plist-get (tp--surface-options surface)
:inhibit-read-only)))
(signal 'buffer-read-only (list buffer))))))
(defun tp--surface-range (surface)
"Return SURFACE's live start and end positions."
(let ((start (marker-position (tp--surface-start surface)))
(end (marker-position (tp--surface-end surface))))
(unless (and start end)
(signal 'tp-stale-mount (list (tp--surface-id surface))))
(cons start end)))
(defun tp--create-surface (buffer capability options)
"Create an unmounted BUFFER surface with CAPABILITY and OPTIONS."
(unless (memq capability '(content properties))
(signal 'tp-capability-error (list capability)))
(when (buffer-base-buffer buffer)
(signal 'tp-unsupported-buffer (list :indirect buffer)))
(let* ((range (with-current-buffer buffer
(save-restriction
(widen)
(cons (or (plist-get options :start) (point-min))
(or (plist-get options :end) (point-max))))))
(_valid (tp--validate-buffer-range buffer (car range) (cdr range))))
(tp--make-surface
:id (cl-incf tp--surface-id-counter) :buffer buffer
:capability capability :start (copy-marker (car range) nil)
:end (copy-marker (cdr range) t)
:options (tp--copy-property-value options)
:objects (make-hash-table :test #'equal) :mounts nil :index nil
:mount-index (make-hash-table :test #'eq)
:ledger nil :revision 0 :live nil :stale nil
:observers (copy-sequence (plist-get options :observers)))))
(defun tp--surface-compute-function (surface input options initial)
"Return SURFACE's producer binding for INPUT, OPTIONS, and INITIAL state."
(lambda ()
(tp--prepare-surface
surface input options (and initial (not (tp--surface-live surface))))))
(defun tp--install-surface-producer (surface input options initial)
"Install INPUT as SURFACE's producer binding."
(tp--clear-surface-scope-request surface)
(let ((binding
(tp-bind surface tp--surface-producer-key
(tp--surface-compute-function surface input options initial)
:equality (lambda (_old _new) nil) :lifecycle 'retain)))
(setf (tp--surface-producer-binding surface) binding)
binding))
(defun tp--dispose-marker (marker)
"Detach MARKER when it is live."
(when (markerp marker) (set-marker marker nil)))
(defun tp--dispose-anchor (anchor)
"Invalidate ANCHOR and detach its markers."
(when (and (tp-range-anchor-p anchor) (tp--anchor-live anchor))
(tp--dispose-marker (tp--anchor-start anchor))
(tp--dispose-marker (tp--anchor-end anchor))
(setf (tp--anchor-live anchor) nil
(tp--anchor-stale anchor) t
(tp--anchor-surfaces anchor) nil)))
(defun tp--discard-new-objects (context)
"Invalidate CONTEXT's uncommitted object handles."
(dolist (object (tp--context-new-objects context))
(unless (tp--surface-object-live object)
(tp-binding-dispose-owner object)
(setf (tp--surface-object-disposed object) t
(tp--surface-object-candidate-context object) nil))))
(defun tp--discard-context (context)
"Release unpromoted handles owned by CONTEXT."
(when (and (tp-prepare-context-p context) (tp--context-active context))
(setf (tp--context-active context) nil)
(tp--discard-new-objects context)
(dolist (anchor (tp--context-created-anchors context))
(unless (tp--anchor-surfaces anchor) (tp--dispose-anchor anchor)))))
(defun tp--surface-mount-cleanup (surface)
"Release candidate markers and bindings for failed SURFACE mount."
(tp-binding-dispose-owner surface)
(tp--dispose-marker (tp--surface-start surface))
(tp--dispose-marker (tp--surface-end surface))
(setf (tp--surface-live surface) nil))
;;;###autoload
(defun tp-surface-mount (buffer plan-or-producer &optional options)
"Mount PLAN-OR-PRODUCER into BUFFER according to OPTIONS.
OPTIONS accepts :capability (`content' or `properties'), :start, :end,
:inhibit-read-only, :coordinate-mounts, :client-state, and :observers. When
:coordinate-mounts is non-nil, content mounts store numeric coordinates rather
than private markers; use it only when host edits make the whole content
surface stale and all writes are published through TP. Return a surface
handle."
(let* ((target (get-buffer buffer))
(_live (unless (buffer-live-p target)
(signal 'tp-unsupported-buffer (list buffer))))
(capability (or (plist-get options :capability)
(and (tp-surface-plan-p plan-or-producer)
(tp-surface-plan-capability plan-or-producer))
'content))
(surface (tp--create-surface target capability options))
success)
(unwind-protect
(progn
(tp--install-surface-producer surface plan-or-producer options t)
(setq success t)
surface)
(unless success (tp--surface-mount-cleanup surface)))))
;;;###autoload
(defun tp-surface-update (surface plan-or-producer)
"Atomically update SURFACE from PLAN-OR-PRODUCER and return its report."
(tp--validate-live-surface surface)
(tp--install-surface-producer
surface plan-or-producer (tp--surface-options surface) nil)
(tp-surface-report surface))
;;;###autoload
(defun tp-surface-update-scoped
(surface objects plan-or-producer &optional options)
"Atomically update SURFACE within retained OBJECTS.
PLAN-OR-PRODUCER has the same full candidate contract as
`tp-surface-update'. TP resolves OBJECTS through its mount index and rejects
any candidate output change outside their ranges before publication.
OPTIONS accepts `:on-mismatch' and `:return-report'. Its default mismatch
policy, `error', signals `tp-scope-mismatch'; `root' permits an explicit
full-surface fallback. The report is returned as a defensive snapshot by
default; `:return-report nil' avoids materializing that snapshot when the
caller reads the scalar summary from the surface instead."
(tp--validate-live-surface surface)
(setq objects (tp--normalize-surface-scopes surface objects))
(let ((on-mismatch (or (plist-get options :on-mismatch) 'error))
(return-report (if (plist-member options :return-report)
(plist-get options :return-report)
t)))
(unless (memq on-mismatch '(error root))
(signal 'wrong-type-argument
(list '(member error root) on-mismatch)))
(tp--call-with-transaction
(lambda ()
(tp--install-surface-producer
surface plan-or-producer (tp--surface-options surface) nil)
(tp--set-surface-scope-request
surface objects (list :on-mismatch on-mismatch))))
(when return-report
(tp-surface-report surface))))
(defun tp--edit-touches-span-p (beg edit-end start end)
"Return non-nil when BEG..EDIT-END touches the old START..END span."
(if (= beg edit-end)
(and (> beg start) (< beg end))
(and (< beg end) (> edit-end start))))
(defun tp--surface-before-change (beg end)
"Capture retained ranges before a BUFFER edit from BEG to END."
(setq tp--surface-before-change-state nil)
(unless (or tp--surface-publishing tp--surface-guarding-prepare)
(let ((anchors (make-hash-table :test #'eq)) content anchor-ranges)
(dolist (surface tp--buffer-surfaces)
(when (tp-surface-live-p surface)
(if (eq (tp--surface-capability surface) 'content)
(pcase-let ((`(,start . ,finish) (tp--surface-range surface)))
(push (list surface start finish) content))
(dolist (mount (tp--surface-mounts surface))
(when-let ((anchor (tp--surface-mount-anchor mount)))
(unless (gethash anchor anchors)
(puthash anchor t anchors)
(push (list anchor
(marker-position (tp--anchor-start anchor))
(marker-position (tp--anchor-end anchor)))
anchor-ranges)))))))
(setq tp--surface-before-change-state
(list :beg beg :end end
:content content :anchors anchor-ranges)))))
(defun tp--mark-anchor-from-old-range (entry beg end)
"Apply ENTRY anchor policy for an old edit range BEG..END."
(pcase-let ((`(,anchor ,start ,finish) entry))
(when (and start finish
(tp--edit-touches-span-p beg end start finish))
(pcase (tp--anchor-boundary-policy anchor)
('shorten nil)
('remove (setf (tp--anchor-stale anchor) 'remove))
(_ (setf (tp--anchor-stale anchor) t))))))
(defun tp--surface-after-change (_beg _end _old-length)
"Maintain mount staleness after a host text edit."
(let* ((tick (buffer-chars-modified-tick))
(character-change (/= tick tp--surface-character-tick))
(state tp--surface-before-change-state))
(setq tp--surface-character-tick tick)
(setq tp--surface-before-change-state nil)
(when (and character-change state
(not tp--surface-publishing)
(not tp--surface-guarding-prepare))
(let ((old-beg (plist-get state :beg))
(old-end (plist-get state :end)))
(dolist (entry (plist-get state :content))
(pcase-let ((`(,surface ,start ,end) entry))
(when (and (tp-surface-live-p surface)
(tp--edit-touches-span-p old-beg old-end start end))
(setf (tp--surface-stale surface) t))))
(dolist (entry (plist-get state :anchors))
(tp--mark-anchor-from-old-range entry old-beg old-end))))))
(defun tp--surface-buffer-killed ()
"Dispose every retained surface owned by the current buffer."
(let ((surfaces tp--buffer-surfaces))
(setq tp--buffer-surfaces nil)
(dolist (surface surfaces) (tp--teardown-surface surface t))))
(defun tp--register-live-surface (surface)
"Register committed SURFACE under its buffer lifecycle owner."
(puthash (tp--surface-id surface) surface tp--surfaces)
(with-current-buffer (tp--surface-buffer surface)
(cl-pushnew surface tp--buffer-surfaces :test #'eq)
(setq tp--surface-character-tick (buffer-chars-modified-tick))
(add-hook 'before-change-functions #'tp--surface-before-change nil t)
(add-hook 'after-change-functions #'tp--surface-after-change nil t)
(add-hook 'kill-buffer-hook #'tp--surface-buffer-killed nil t)))
(defun tp--surface-extension-state ()
"Return the surface extension state for the active transaction."
(tp--transaction-extension tp--surface-extension-key t))
(defun tp--surface-scope-table (&optional create)
"Return the transaction-local scope table, creating it when CREATE is non-nil."
(when-let ((state (tp--transaction-extension
tp--surface-extension-key create)))
(or (gethash 'scopes state)
(when create
(let ((table (make-hash-table :test #'eq)))
(puthash 'scopes table state)
table)))))
(defun tp--surface-scope-request (surface)
"Return SURFACE's one-shot scope request in the active transaction."
(when-let ((table (tp--surface-scope-table)))
(gethash surface table)))
(defun tp--clear-surface-scope-request (surface)
"Clear SURFACE's pending one-shot scope request when one exists."
(when tp--transaction-active
(when-let ((table (tp--surface-scope-table)))
(remhash surface table))))
(defun tp--set-surface-scope-request (surface objects options)
"Set SURFACE's one-shot scope request to OBJECTS and OPTIONS."
(puthash surface
(list :objects (copy-sequence objects)
:options (tp--copy-property-value options))
(tp--surface-scope-table t)))
(defun tp--surface-prepared-table ()
"Return the transaction-local surface candidate table."
(let ((state (tp--surface-extension-state)))
(or (gethash 'prepared state)
(let ((table (make-hash-table :test #'eq)))
(puthash 'prepared table state)
table))))
(defun tp--surface-binding-changed (binding _old new)
"Queue NEW when BINDING is a retained surface producer."
(when (and (equal (tp-binding-key binding) tp--surface-producer-key)
(tp-surface-p (tp-binding-owner binding)))
(unless (tp--prepared-surface-p new)
(signal 'tp-invalid-surface-plan (list :producer-result new)))
(let* ((table (tp--surface-prepared-table))
(surface (tp-binding-owner binding))
(previous (gethash surface table)))
(when previous
(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--live-mount-signature (surface)
"Return SURFACE's stable live mount signature."
(let ((base (if (eq (tp--surface-capability surface) 'content)
(marker-position (tp--surface-start surface))
0)))
(mapcar (lambda (mount)
(list (tp--surface-mount-object mount)
(tp--surface-mount-anchor mount)
(- (tp--mount-position (tp--surface-mount-start mount)) base)
(- (tp--mount-position (tp--surface-mount-end mount)) base)
(tp--surface-mount-tags mount)))
(tp--surface-mounts surface))))
(defun tp--content-output-equal-p (prepared)
"Return non-nil when PREPARED already matches its content mount."
(let ((surface (tp--prepared-surface-surface prepared)))
(if (not (eq (tp--surface-capability surface) 'content))
t
(pcase-let ((`(,start . ,end) (tp--surface-range surface)))
(with-current-buffer (tp--surface-buffer surface)
(save-restriction
(widen)
(equal-including-properties
(buffer-substring start end)
(tp--prepared-surface-rendered prepared))))))))
(defun tp--prepared-changed-p (prepared)
"Return non-nil when PREPARED differs from its committed surface."
(let ((surface (tp--prepared-surface-surface prepared)))
(or (tp--prepared-surface-initial prepared)
(not (tp--plan-equal-p (tp--surface-plan surface)
(tp--prepared-surface-plan prepared)))
(not (equal (tp--surface-client-state surface)
(tp--prepared-surface-client-state prepared)))
(not (eq (tp--surface-producer surface)
(tp--prepared-surface-producer prepared)))
(tp--prepared-surface-created prepared)
(tp--prepared-surface-removed prepared)
(not (tp--content-output-equal-p prepared))
(not (equal (tp--live-mount-signature surface)
(tp--prepared-mount-signature prepared))))))
(defun tp--sorted-prepared-surfaces (table)
"Return changed candidates in TABLE ordered by surface id."
(let (prepared)
(maphash (lambda (_surface candidate)
(when (tp--prepared-changed-p candidate)
(push candidate prepared)))
table)
(sort prepared
(lambda (left right)
(< (tp--surface-id (tp--prepared-surface-surface left))
(tp--surface-id (tp--prepared-surface-surface right)))))))
(defun tp--publication-step (step surface)
"Run the internal publication failure hook for STEP and SURFACE."
(when tp--surface-publication-step-function
(funcall tp--surface-publication-step-function step surface)))
(defun tp--common-prefix-length (left right)
"Return the common character prefix length of LEFT and RIGHT."
(let ((limit (min (length left) (length right))) (index 0))
(while (and (< index limit) (= (aref left index) (aref right index)))
(setq index (1+ index)))
index))
(defun tp--common-suffix-length (left right prefix)
"Return LEFT and RIGHT's common suffix length after PREFIX."
(let ((limit (- (min (length left) (length right)) prefix)) (count 0))
(while (and (< count limit)
(= (aref left (- (length left) count 1))
(aref right (- (length right) count 1))))
(setq count (1+ count)))
count))
(defun tp--validate-published-content-range (buffer start rendered)
"Validate inserted BUFFER text from START with RENDERED.
Return whether the properties match.
An external `after-change-functions' hook may alter the inserted properties;
return nil for that recoverable case so TP reapplies the rendered runs. A
character rewrite is not recoverable at the property layer and signals before
the transaction can commit."
(with-current-buffer buffer
(let ((end (+ start (length rendered))))
(unless (and (<= (point-min) start) (<= end (point-max))
(equal (buffer-substring-no-properties start end)
(substring-no-properties rendered)))
(signal 'tp-publication-mismatch
(list :buffer buffer :start start :end end)))
(equal-including-properties
(buffer-substring start end) rendered))))
(defun tp--content-text-operation (surface rendered)
"Publish SURFACE's minimal character replacement for RENDERED."
(pcase-let* ((`(,start . ,end) (tp--surface-range surface))
(old (buffer-substring-no-properties start end))
(new (substring-no-properties rendered))
(prefix (tp--common-prefix-length old new))
(suffix (tp--common-suffix-length old new prefix)))
(unless (equal old new)
(delete-region (+ start prefix) (- end suffix))
(goto-char (+ start prefix))
(let ((inserted (substring rendered prefix (- (length rendered) suffix))))
(insert inserted)
(when (tp--validate-published-content-range
(tp--surface-buffer surface) (+ start prefix) inserted)
(push (cons prefix (- (length new) suffix))
tp--content-published-ranges))))
(set-marker (tp--surface-start surface) start)
(set-marker (tp--surface-end surface) (+ start (length new)))
(if (equal old new) 0 1)))
(defun tp--string-property-run-diff-p (buffer start rendered from to)
"Return non-nil when BUFFER at START differs from RENDERED on FROM..TO.
The rendered interval is already one direct-property run. Compare its
boundary value once and reject an interior buffer boundary; scanning every
character makes a large rendered surface quadratic in its number of runs."
(let* ((buffer-start (+ start from))
(buffer-end (+ start to))
(buffer-next (or (next-property-change
buffer-start buffer buffer-end)
buffer-end)))
(or (not (tp--plan-props-equal-p
(text-properties-at buffer-start buffer)
(text-properties-at from rendered)))
(< buffer-next buffer-end))))
(defun tp--content-property-operations-in-range
(buffer start rendered from to)
"Return property operations for RENDERED FROM..TO at BUFFER position START."
(let ((offset from) operations)
(while (< offset to)
(let* ((next (next-property-change offset rendered to))
(props (text-properties-at offset rendered)))
(when (tp--string-property-run-diff-p
buffer start rendered offset next)
(push (list :start (+ start offset) :end (+ start next)
:props props)
operations))
(setq offset next)))
(nreverse operations)))
(defun tp--content-property-operations
(surface rendered &optional ranges scoped)
"Return exact direct-property operations for SURFACE and RENDERED.
When SCOPED is non-nil, inspect only RANGES, including an empty set."
(let* ((buffer (tp--surface-buffer surface))
(start (marker-position (tp--surface-start surface)))
(ranges (if scoped ranges (list (cons 0 (length rendered)))))
(ranges
(if tp--content-published-ranges
(tp--subtract-ranges
ranges (tp--coalesce-ranges tp--content-published-ranges))
ranges))
operations)
(dolist (range ranges operations)
(setq operations
(nconc operations
(tp--content-property-operations-in-range
buffer start rendered (car range) (cdr range)))))))
(defun tp--apply-content-property-operations (buffer operations)
"Apply content property OPERATIONS in BUFFER silently."
(with-current-buffer buffer
(with-silent-modifications
(dolist (operation operations)
(set-text-properties (plist-get operation :start)
(plist-get operation :end)
(plist-get operation :props) buffer)))))
(defun tp--apply-property-operation (buffer operation)
"Apply one host-range property OPERATION in BUFFER."
(let ((start (plist-get operation :start))
(end (plist-get operation :end))
(property (plist-get operation :property)))
(if (plist-get operation :present)
(put-text-property start end property
(plist-get operation :value) buffer)
(remove-list-of-text-properties start end (list property) buffer))))
(defun tp--apply-properties-operations (surface operations)
"Apply properties-only OPERATIONS for SURFACE silently."
(let ((buffer (tp--surface-buffer surface)))
(with-current-buffer buffer
(with-silent-modifications
(dolist (operation operations)
(tp--apply-property-operation buffer operation))))))
(defun tp--make-content-mounts (prepared)
"Create content mounts for PREPARED using its declared coordinate policy."
(let* ((surface (tp--prepared-surface-surface prepared))
(buffer (tp--surface-buffer surface))
(base (marker-position (tp--surface-start surface)))
(coordinate-p (plist-get (tp--surface-options surface)
:coordinate-mounts)))
(mapcar
(lambda (spec)
(tp--make-surface-mount
:object (plist-get spec :object)
:start (if coordinate-p
(+ base (plist-get spec :start))
(with-current-buffer buffer
(copy-marker (+ base (plist-get spec :start)) nil)))
:end (if coordinate-p
(+ base (plist-get spec :end))
(with-current-buffer buffer
(copy-marker (+ base (plist-get spec :end)) t)))
:tags (plist-get spec :tags) :capability 'content))
(tp--prepared-surface-mount-specs prepared))))
(defun tp--make-properties-mounts (prepared)
"Create property mounts for PREPARED from its live anchors."
(mapcar
(lambda (spec)
(let ((anchor (plist-get spec :anchor)))
(tp--make-surface-mount
:object (plist-get spec :object)
:start (tp--anchor-start anchor) :end (tp--anchor-end anchor)
:tags (plist-get spec :tags) :capability 'properties :anchor anchor)))
(tp--prepared-surface-mount-specs prepared)))
(defun tp--make-live-ledger (prepared)
"Create marker-backed property ledger entries for PREPARED."
(let ((buffer (tp--surface-buffer (tp--prepared-surface-surface prepared))))
(mapcar
(lambda (spec)
(tp--make-property-ledger
:start (with-current-buffer buffer
(copy-marker (plist-get spec :start) nil))
:end (with-current-buffer buffer
(copy-marker (plist-get spec :end) t))
:property (plist-get spec :property)
:baseline-present (plist-get spec :baseline-present)
:baseline-value (plist-get spec :baseline-value)
:published-present (plist-get spec :published-present)
:published-value (plist-get spec :published-value)
:anchors (plist-get spec :anchors)))
(tp--prepared-surface-ledger-specs prepared))))
(defun tp--index-mounts-by-object (mounts)
"Return an object-keyed index of marker-backed MOUNTS."
(let ((index (make-hash-table :test #'eq)))
(dolist (mount mounts)
(push mount (gethash (tp--surface-mount-object mount) index)))
(maphash (lambda (object entries)
(puthash object (nreverse entries) index))
index)
index))
(defun tp--create-candidate-mount-state (prepared)
"Create PREPARED's marker-backed mount, ledger, and index candidates."
(let* ((surface (tp--prepared-surface-surface prepared))
(mounts (if (eq (tp--surface-capability surface) 'content)
(tp--make-content-mounts prepared)
(tp--make-properties-mounts prepared)))
(ledger (and (eq (tp--surface-capability surface) 'properties)
(tp--make-live-ledger prepared))))
(setf (tp--prepared-surface-live-mounts prepared) mounts
(tp--prepared-surface-live-mount-index prepared)
(tp--index-mounts-by-object mounts)
(tp--prepared-surface-live-ledger prepared) ledger)
mounts))
(defun tp--surface-snapshot (surface)
"Return a rollback snapshot of SURFACE side state."
(tp--make-surface-snapshot
:plan (tp--surface-plan surface) :objects (tp--surface-objects surface)
:mounts (tp--surface-mounts surface) :index (tp--surface-index surface)
:mount-index (tp--surface-mount-index surface)
:ledger (tp--surface-ledger surface)
:client-state (tp--surface-client-state surface)
:producer (tp--surface-producer surface)
:revision (tp--surface-revision surface) :report (tp--surface-report surface)
:live (tp--surface-live surface) :stale (tp--surface-stale surface)))
(defun tp--surface-object-table (objects)
"Return a path-indexed hash table containing OBJECTS."
(let ((table (make-hash-table :test #'equal)))
(dolist (object objects)
(puthash (tp--surface-object-path object) object table))
table))
(defun tp--surface-report-value (prepared text-ops property-ops)
"Build PREPARED's report from TEXT-OPS and PROPERTY-OPS."
(let* ((surface (tp--prepared-surface-surface prepared))
(old-revision (tp--surface-revision surface))
(new-revision (1+ old-revision))
(scoped (tp--prepared-surface-scope-objects prepared))
(fallback (tp--prepared-surface-scope-fallback prepared))
(patches (tp--prepared-surface-scope-patches prepared))
(touched
(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)))))
(list :transaction-id tp--surface-transaction-id
:surface-id (tp--surface-id surface)
:old-revision old-revision :new-revision new-revision
:candidate-source-writes (length tp--transaction-signals)
:invalidated-bindings (tp--transaction-counter-delta :invalidated)
:recomputed-bindings (tp--transaction-counter-delta :recomputed)
:skipped-bindings (tp--transaction-counter-delta :skipped)
:reconciled-objects (tp--prepared-surface-reconciled prepared)
:created-objects (length (tp--prepared-surface-created prepared))
:removed-objects (length (tp--prepared-surface-removed prepared))
:moved-objects (tp--prepared-surface-moved prepared)
:text-operations text-ops :property-operations property-ops
:touched-characters touched
:full-root (or (null scoped) fallback)
:scope-count (length scoped)
:scope-range-count (and scoped (length patches))
:scope-fallback fallback
:property-conflicts nil :rolled-back nil
:failure nil :observer-errors nil :timing nil)))
(defun tp--scoped-content-ranges (patches)
"Return candidate relative ranges from scoped PATCHES."
(mapcar (lambda (patch)
(cons (plist-get patch :new-start)
(plist-get patch :new-end)))
patches))
(defun tp--publish-scoped-content-text (surface rendered patches)
"Publish scoped PATCHES from RENDERED for SURFACE.
Return the number of text operations."
(let ((base (marker-position (tp--surface-start surface)))
(count 0))
(dolist (patch (reverse patches))
(let* ((start (+ base (plist-get patch :old-start)))
(end (+ base (plist-get patch :old-end)))
(replacement (plist-get patch :replacement))
(old-plain (buffer-substring-no-properties start end))
(new-plain (substring-no-properties replacement))
(prefix (tp--common-prefix-length old-plain new-plain))
(suffix (tp--common-suffix-length old-plain new-plain prefix))
(old-end (- end suffix))
(new-end (- (length replacement) suffix)))
(unless (equal old-plain new-plain)
(delete-region (+ start prefix) old-end)
(goto-char (+ start prefix))
(let ((inserted (substring replacement prefix new-end)))
(insert inserted)
(when (tp--validate-published-content-range
(tp--surface-buffer surface) (+ start prefix) inserted)
(push (cons (+ (plist-get patch :new-start) prefix)
(+ (plist-get patch :new-start) new-end))
tp--content-published-ranges)))
(cl-incf count))))
(set-marker (tp--surface-start surface) base)
(set-marker (tp--surface-end surface) (+ base (length rendered)))
count))
(defun tp--publish-buffer-content (prepared)
"Publish PREPARED's text and properties, returning operation counts."
(let* ((surface (tp--prepared-surface-surface prepared))
(buffer (tp--surface-buffer surface))
(rendered (tp--prepared-surface-rendered prepared))
(scoped (tp--prepared-surface-scope-objects prepared))
(fallback (tp--prepared-surface-scope-fallback prepared))
(patches (tp--prepared-surface-scope-patches prepared))
(text-operations 0)
property-operations)
(let (tp--content-published-ranges)
(with-current-buffer buffer
(save-restriction
(widen)
(let ((inhibit-read-only
(plist-get (tp--surface-options surface) :inhibit-read-only)))
(setq text-operations
(if (and scoped (not fallback))
(tp--publish-scoped-content-text
surface rendered patches)
(tp--content-text-operation surface rendered)))
(tp--publication-step 'text surface)
(setq property-operations
(tp--content-property-operations
surface rendered
(and scoped (not fallback)
(tp--scoped-content-ranges patches))
(and scoped (not fallback))))
(tp--apply-content-property-operations buffer property-operations)
(tp--publication-step 'property surface))))
(cons text-operations (length property-operations)))))
(defun tp--publish-buffer-properties (prepared)
"Publish PREPARED's host-range property operations."
(let* ((surface (tp--prepared-surface-surface prepared))
(operations (tp--prepared-surface-property-operations prepared)))
(tp--publication-step 'text surface)
(tp--apply-properties-operations surface operations)
(tp--publication-step 'property surface)
(cons 0 (length operations))))
(defun tp--promote-prepared-objects (prepared)
"Promote PREPARED's touched identities to live state."
(let ((surface (tp--prepared-surface-surface prepared))
(context (tp--prepared-surface-context prepared)))
(dolist (object (tp--prepared-surface-objects prepared))
(setf (tp--surface-object-surface object) surface
(tp--surface-object-live object) t
(tp--surface-object-disposed object) nil
(tp--surface-object-candidate-context object) nil))
(setf (tp--context-active context) nil)))
(defun tp--swap-surface-state (prepared counts)
"Promote PREPARED side state using operation COUNTS."
(let* ((surface (tp--prepared-surface-surface prepared))
(mounts (tp--prepared-surface-live-mounts prepared))
(ledger (tp--prepared-surface-live-ledger prepared))
(report (tp--surface-report-value prepared (car counts) (cdr counts))))
(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))
(tp--surface-mounts surface) mounts
(tp--surface-index surface) mounts
(tp--surface-mount-index surface)
(tp--prepared-surface-live-mount-index prepared)
(tp--surface-ledger surface) ledger
(tp--surface-client-state surface)
(tp--prepared-surface-client-state prepared)
(tp--surface-producer surface) (tp--prepared-surface-producer prepared)
(tp--surface-revision surface) (1+ (tp--surface-revision surface))
(tp--surface-report surface) report
(tp--surface-live surface) t
(tp--surface-stale surface) nil
(tp--prepared-surface-report prepared) report)
(tp--publication-step 'client-state surface)
(when (tp--prepared-surface-initial prepared)
(tp--register-live-surface surface))))
(defun tp--publish-one-surface (prepared)
"Publish PREPARED buffer and side state."
(let* ((started (float-time))
(surface (tp--prepared-surface-surface prepared))
(counts (if (eq (tp--surface-capability surface) 'content)
(tp--publish-buffer-content prepared)
(tp--publish-buffer-properties prepared))))
(tp--create-candidate-mount-state prepared)
(tp--publication-step 'marker surface)
(tp--publication-step 'index surface)
(tp--swap-surface-state prepared counts)
(let ((report (plist-put (tp--surface-report surface) :timing
(list :publication (- (float-time) started)))))
(setf (tp--surface-report surface) report
(tp--prepared-surface-report prepared) report))))
(defun tp--journal-intervals (prepared-list)
"Return buffer intervals whose properties PREPARED-LIST may mutate."
(let (entries)
(dolist (prepared prepared-list)
(let ((surface (tp--prepared-surface-surface prepared)))
(if (eq (tp--surface-capability surface) 'content)
(if (and (tp--prepared-surface-scope-objects prepared)
(not (tp--prepared-surface-scope-fallback prepared)))
(let ((base (marker-position (tp--surface-start surface))))
(dolist (patch (tp--prepared-surface-scope-patches prepared))
(push (list (tp--surface-buffer surface)
(+ base (plist-get patch :old-start))
(+ base (plist-get patch :old-end)))
entries)))
(pcase-let ((`(,start . ,end) (tp--surface-range surface)))
(push (list (tp--surface-buffer surface) start end) entries)))
(dolist (operation
(tp--prepared-surface-property-operations prepared))
(push (list (tp--surface-buffer surface)
(plist-get operation :start)
(plist-get operation :end))
entries)))))
entries))
(defun tp--merge-buffer-intervals (entries)
"Merge overlapping journal ENTRIES per buffer."
(let ((by-buffer (make-hash-table :test #'eq)) result)
(dolist (entry entries)
(push (cdr entry) (gethash (car entry) by-buffer)))
(maphash
(lambda (buffer intervals)
(setq intervals (sort intervals (lambda (a b) (< (car a) (car b)))))
(let (merged)
(dolist (interval intervals)
(if (and merged (<= (car interval) (cadar merged)))
(setcar (cdar merged) (max (cadar merged) (cadr interval)))
(push (copy-sequence interval) merged)))
(dolist (interval (nreverse merged))
(push (list buffer (car interval) (cadr interval)) result))))
by-buffer)
result))
(defun tp--capture-property-journals (prepared-list)
"Capture direct property journals for PREPARED-LIST."
(mapcar
(lambda (entry)
(pcase-let ((`(,buffer ,start ,end) entry))
(list buffer start end
(with-current-buffer buffer
(save-restriction
(widen) (buffer-substring start end))))))
(tp--merge-buffer-intervals (tp--journal-intervals prepared-list))))
(defun tp--replay-string-properties (buffer start string)
"Restore STRING's direct properties into BUFFER starting at START."
(let ((length (length string)) (offset 0))
(when (> length 0)
(set-text-properties start (+ start length) nil buffer)
(while (< offset length)
(let ((next (next-property-change offset string length)))
(set-text-properties (+ start offset) (+ start next)
(text-properties-at offset string) buffer)
(setq offset next))))))
(defun tp--restore-property-journals (journals)
"Restore direct property JOURNALS after buffer change cancellation."
(dolist (journal journals)
(pcase-let ((`(,buffer ,start ,_end ,string) journal))
(when (buffer-live-p buffer)
(with-current-buffer buffer
(save-restriction
(widen)
(let ((inhibit-read-only t))
(with-silent-modifications
(tp--replay-string-properties buffer start string)))))))))
(defun tp--prepared-buffers (prepared-list)
"Return distinct live buffers affected by PREPARED-LIST."
(delete-dups
(mapcar (lambda (prepared)
(tp--surface-buffer (tp--prepared-surface-surface prepared)))
prepared-list)))
(defun tp--capture-view-state (buffers)
"Capture point, windows, and modified state for BUFFERS."
(mapcar
(lambda (buffer)
(with-current-buffer buffer
(list buffer (copy-marker (point) t) (buffer-modified-p)
(mapcar (lambda (window)
(cons window (copy-marker (window-start window) nil)))
(get-buffer-window-list buffer nil t)))))
buffers))
(defun tp--restore-view-state (states)
"Restore captured point, window, and modified STATES."
(dolist (state states)
(pcase-let ((`(,buffer ,point-marker ,modified ,windows) state))
(when (buffer-live-p buffer)
(with-current-buffer buffer
(when-let ((position (marker-position point-marker)))
(goto-char (min (point-max) (max (point-min) position))))
(set-buffer-modified-p modified))
(dolist (entry windows)
(when (window-live-p (car entry))
(when-let ((position (marker-position (cdr entry))))
(set-window-start (car entry) position t)))))
(tp--dispose-marker point-marker)
(dolist (entry windows) (tp--dispose-marker (cdr entry))))))
(defun tp--dispose-content-mounts (mounts)
"Detach private markers owned by content MOUNTS."
(dolist (mount mounts)
(when (eq (tp--surface-mount-capability mount) 'content)
(tp--dispose-marker (tp--surface-mount-start mount))
(tp--dispose-marker (tp--surface-mount-end mount)))))
(defun tp--dispose-ledger (ledger)
"Detach interval markers owned by property LEDGER entries."
(dolist (entry ledger)
(tp--dispose-marker (tp--property-ledger-start entry))
(tp--dispose-marker (tp--property-ledger-end entry))))
(defun tp--unregister-surface (surface)
"Remove SURFACE from weak and buffer-local registries."
(remhash (tp--surface-id surface) tp--surfaces)
(when (buffer-live-p (tp--surface-buffer surface))
(with-current-buffer (tp--surface-buffer surface)
(setq tp--buffer-surfaces (delq surface tp--buffer-surfaces))
(unless tp--buffer-surfaces
(remove-hook 'before-change-functions #'tp--surface-before-change t)
(remove-hook 'after-change-functions #'tp--surface-after-change t)
(remove-hook 'kill-buffer-hook #'tp--surface-buffer-killed t)))))
(defun tp--restore-surface-snapshot (prepared snapshot)
"Restore PREPARED's surface from SNAPSHOT after failed publication."
(let ((surface (tp--prepared-surface-surface prepared)))
(tp--dispose-content-mounts
(tp--prepared-surface-live-mounts prepared))
(tp--dispose-ledger (tp--prepared-surface-live-ledger prepared))
(if (not (buffer-live-p (tp--surface-buffer surface)))
(progn
(when (tp--surface-snapshot-objects snapshot)
(maphash (lambda (_path object)
(setf (tp--surface-object-live object) nil
(tp--surface-object-disposed object) t))
(tp--surface-snapshot-objects snapshot)))
(setf (tp--surface-live surface) nil
(tp--surface-stale surface) 'killed
(tp--surface-objects surface)
(tp--surface-snapshot-objects snapshot)
(tp--surface-mounts surface)
(tp--surface-snapshot-mounts snapshot)
(tp--surface-index surface)
(tp--surface-snapshot-index snapshot)
(tp--surface-mount-index surface)
(tp--surface-snapshot-mount-index snapshot)
(tp--surface-ledger surface)
(tp--surface-snapshot-ledger snapshot)))
(when (and (tp--surface-live surface)
(not (tp--surface-snapshot-live snapshot)))
(tp--unregister-surface surface))
(dolist (object (tp--prepared-surface-created prepared))
(setf (tp--surface-object-live object) nil
(tp--surface-object-disposed object) t))
(when (tp--surface-snapshot-objects snapshot)
(maphash (lambda (_path object)
(setf (tp--surface-object-live object)
(tp--surface-snapshot-live snapshot)
(tp--surface-object-disposed object) nil))
(tp--surface-snapshot-objects snapshot)))
(setf (tp--surface-plan surface) (tp--surface-snapshot-plan snapshot)
(tp--surface-objects surface) (tp--surface-snapshot-objects snapshot)
(tp--surface-mounts surface) (tp--surface-snapshot-mounts snapshot)
(tp--surface-index surface) (tp--surface-snapshot-index snapshot)
(tp--surface-mount-index surface)
(tp--surface-snapshot-mount-index snapshot)
(tp--surface-ledger surface) (tp--surface-snapshot-ledger snapshot)
(tp--surface-client-state surface)
(tp--surface-snapshot-client-state snapshot)
(tp--surface-producer surface)
(tp--surface-snapshot-producer snapshot)
(tp--surface-revision surface)
(tp--surface-snapshot-revision snapshot)
(tp--surface-report surface) (tp--surface-snapshot-report snapshot)
(tp--surface-live surface) (tp--surface-snapshot-live snapshot)
(tp--surface-stale surface) (tp--surface-snapshot-stale snapshot)))))
(defun tp--prepare-change-group-for-buffers (buffers)
"Prepare and activate one multi-buffer change group for BUFFERS."
(let (handle)
(dolist (buffer buffers)
(unless (buffer-live-p buffer)
(signal 'tp-dead-surface (list buffer)))
(setq handle (nconc handle (prepare-change-group buffer))))
(activate-change-group handle)
handle))
(defun tp--surface-state-snapshots (prepared-list)
"Return side-state snapshots for PREPARED-LIST."
(mapcar (lambda (prepared)
(cons prepared
(tp--surface-snapshot
(tp--prepared-surface-surface prepared))))
prepared-list))
(defun tp--surface-publish-transaction ()
"Prepare journals and publish every queued changed surface atomically."
(let* ((state (tp--surface-extension-state))
(table (gethash 'prepared state))
(prepared (and table (tp--sorted-prepared-surfaces table))))
(when prepared
(let* ((buffers (tp--prepared-buffers prepared))
(journals (tp--capture-property-journals prepared))
(views (tp--capture-view-state buffers))
(snapshots (tp--surface-state-snapshots prepared))
(group (tp--prepare-change-group-for-buffers buffers)))
(puthash 'changed prepared state)
(puthash 'journals journals state)
(puthash 'views views state)
(puthash 'snapshots snapshots state)
(puthash 'change-group group state)
(cl-incf tp--surface-transaction-id)
(let ((tp--surface-publishing t))
(dolist (candidate prepared)
(tp--publish-one-surface candidate)))))))
(defun tp--cancel-change-group-safely (group)
"Cancel active change GROUP without allowing quit to interrupt rollback."
(when group
(let ((inhibit-quit t)
(inhibit-modification-hooks t)
(tp--surface-publishing t))
(condition-case nil
(cancel-change-group group)
(error nil)))))
(defun tp--surface-rollback-transaction ()
"Rollback buffers, side state, markers, and contexts for this transaction."
(when-let ((state (tp--transaction-extension tp--surface-extension-key)))
(tp--cancel-change-group-safely (gethash 'change-group state))
(tp--restore-property-journals (gethash 'journals state))
(dolist (entry (gethash 'snapshots state))
(tp--restore-surface-snapshot (car entry) (cdr entry)))
(tp--restore-view-state (gethash 'views state))
(when-let ((table (gethash 'prepared state)))
(maphash (lambda (_surface prepared)
(let ((context (tp--prepared-surface-context prepared)))
(setf (tp--context-active context) t)
(tp--discard-context context)))
table))))
(defun tp--surface-finalize-killed-rollback ()
"Reapply authoritative teardown after graph rollback for killed buffers."
(when-let ((state (tp--transaction-extension tp--surface-extension-key)))
(when-let ((table (gethash 'prepared state)))
(maphash
(lambda (surface _prepared)
(unless (buffer-live-p (tp--surface-buffer surface))
(tp--teardown-surface surface t)))
table))))
(defun tp--anchors-in-mounts (mounts)
"Return distinct range anchors referenced by MOUNTS."
(delete-dups
(delq nil (mapcar #'tp--surface-mount-anchor mounts))))
(defun tp--update-anchor-ownership (surface old-mounts new-mounts)
"Update anchor ownership for SURFACE from OLD-MOUNTS to NEW-MOUNTS."
(let ((old (tp--anchors-in-mounts old-mounts))
(new (tp--anchors-in-mounts new-mounts)))
(dolist (anchor old)
(unless (memq anchor new)
(setf (tp--anchor-surfaces anchor)
(delq surface (tp--anchor-surfaces anchor)))
(unless (tp--anchor-surfaces anchor) (tp--dispose-anchor anchor))))
(dolist (anchor new)
(cl-pushnew surface (tp--anchor-surfaces anchor) :test #'eq)
(setf (tp--anchor-candidate-context anchor) nil))))
(defun tp--finalize-object-lifecycle (prepared)
"Delete omitted bindings and removed objects after PREPARED commits."
(let* ((context (tp--prepared-surface-context prepared))
(objects (tp--prepared-surface-objects prepared))
(omitted (tp--context-binding-removals context objects)))
(dolist (binding omitted)
(when (tp-binding-live-p binding) (tp-binding-dispose binding)))
(dolist (object (tp--prepared-surface-removed prepared))
(tp-binding-dispose-owner object)
(setf (tp--surface-object-live object) nil
(tp--surface-object-disposed object) t))
(setf (tp--context-active context) nil)))
(defun tp--finalize-context (prepared published)
"Finalize PREPARED after commit; PUBLISHED means side state was swapped."
(let* ((surface (tp--prepared-surface-surface prepared))
(context (tp--prepared-surface-context prepared)))
(if published
(progn
(tp--finalize-object-lifecycle prepared)
(dolist (anchor (tp--context-created-anchors context))
(unless (tp--anchor-surfaces anchor) (tp--dispose-anchor anchor))))
(tp--finalize-object-lifecycle prepared)
(dolist (object (tp--context-new-objects context))
(unless (tp--surface-object-live object)
(setf (tp--surface-object-disposed object) t)))
(dolist (anchor (tp--context-created-anchors context))
(unless (memq surface (tp--anchor-surfaces anchor))
(tp--dispose-anchor anchor))))))
(defun tp--record-observer-error (surface observer failure)
"Record OBSERVER FAILURE in SURFACE's latest report."
(let ((report (tp--copy-property-value (tp--surface-report surface))))
(setq report
(plist-put report :observer-errors
(append (plist-get report :observer-errors)
(list (list :observer observer :error failure)))))
(setf (tp--surface-report surface) report)))
(defun tp--run-surface-observers (surface observers report)
"Run SURFACE OBSERVERS with REPORT and record their errors."
(dolist (observer observers)
(condition-case failure
(funcall observer surface report)
(error (tp--record-observer-error surface observer failure)))))
(defun tp--enqueue-surface-observers (surface)
"Schedule SURFACE observers outside the publishing transaction."
(when-let ((observers (tp--surface-observers surface)))
(let ((observers (copy-sequence observers))
(report (tp-surface-report surface)))
(tp--enqueue-after-commit
(lambda () (tp--run-surface-observers surface observers report))))))
(defun tp--surface-commit-transaction ()
"Commit buffer edits and finalize every transaction surface."
(when-let ((state (tp--transaction-extension tp--surface-extension-key)))
(when-let ((group (gethash 'change-group state)))
(accept-change-group group))
(tp--restore-view-state (gethash 'views state))
(let ((changed (gethash 'changed state))
(snapshots (gethash 'snapshots state)))
(dolist (entry snapshots)
(let* ((prepared (car entry))
(snapshot (cdr entry))
(surface (tp--prepared-surface-surface prepared)))
(tp--update-anchor-ownership
surface (tp--surface-snapshot-mounts snapshot)
(tp--surface-mounts surface))
(tp--dispose-content-mounts (tp--surface-snapshot-mounts snapshot))
(tp--dispose-ledger (tp--surface-snapshot-ledger snapshot))))
(when-let ((table (gethash 'prepared state)))
(maphash (lambda (_surface prepared)
(tp--finalize-context prepared (memq prepared changed)))
table))
(dolist (prepared changed)
(tp--enqueue-surface-observers
(tp--prepared-surface-surface prepared))))))
(defun tp-surface-materialize-string (plan-or-producer)
"Materialize PLAN-OR-PRODUCER without creating live runtime state."
(let* ((surface (tp--make-surface
:id 0 :capability 'content :options nil
:objects (make-hash-table :test #'equal)))
(context (tp--make-context surface t))
(success nil)
rendered)
(unwind-protect
(let* ((normalized
(tp--prepare-input surface plan-or-producer nil context))
(plan (car normalized))
(owned-p (nth 2 normalized)))
(tp--validate-plan-capability plan 'content)
(tp--validate-context-tree context plan)
(setq rendered (car (tp--render-plan plan context owned-p))
success t)
rendered)
(setf (tp--context-active context) t)
(tp--discard-context context)
(unless success (setq rendered nil)))))
(defun tp--rebase-ledger-entry (surface entry)
"Return current-property segments rebased from ledger ENTRY on SURFACE."
(let* ((buffer (tp--surface-buffer surface))
(start (tp--ledger-position (tp--property-ledger-start entry)))
(end (tp--ledger-position (tp--property-ledger-end entry)))
(property (tp--property-ledger-property entry))
segments)
(while (< start end)
(let* ((next (with-current-buffer buffer
(next-single-property-change start property buffer end)))
(state (tp--property-state-at buffer start property)))
(push (tp--make-property-ledger
:start (with-current-buffer buffer (copy-marker start nil))
:end (with-current-buffer buffer (copy-marker next t))
:property property :baseline-present (car state)
:baseline-value (cdr state) :published-present (car state)
:published-value (cdr state)
:anchors (tp--property-ledger-anchors entry))
segments)
(setq start next)))
(tp--dispose-marker (tp--property-ledger-start entry))
(tp--dispose-marker (tp--property-ledger-end entry))
(nreverse segments)))
(defun tp-range-rebase (anchor)
"Accept current host properties as the new baseline for ANCHOR."
(unless (tp-range-anchor-live-p anchor)
(signal 'tp-invalid-range-anchor (list anchor)))
(dolist (surface (copy-sequence (tp--anchor-surfaces anchor)))
(when (tp-surface-live-p surface)
(let (ledger)
(dolist (entry (tp--surface-ledger surface))
(setq ledger
(nconc ledger
(if (memq anchor (tp--property-ledger-anchors entry))
(tp--rebase-ledger-entry surface entry)
(list entry)))))
(setf (tp--surface-ledger surface) ledger))))
(setf (tp--anchor-stale anchor) nil)
anchor)
(defun tp--unmount-ledger-segments (surface entry)
"Return SURFACE restoration operations and conflicts for ledger ENTRY."
(let* ((buffer (tp--surface-buffer surface))
(start (tp--ledger-position (tp--property-ledger-start entry)))
(end (tp--ledger-position (tp--property-ledger-end entry)))
(property (tp--property-ledger-property entry))
(published (tp--ledger-published-state entry))
operations conflicts)
(while (< start end)
(let* ((next (with-current-buffer buffer
(next-single-property-change start property buffer end)))
(current (tp--property-state-at buffer start property)))
(if (tp--property-state-equal-p current published)
(push (list :start start :end next :property property
:present (tp--property-ledger-baseline-present entry)
:value (tp--property-ledger-baseline-value entry))
operations)
(push (list :start start :end next :property property
:current current :published published)
conflicts))
(setq start next)))
(cons (nreverse operations) (nreverse conflicts))))
(defun tp--unmount-property-operations (surface)
"Return restoration operations and conflicts for SURFACE."
(let (operations conflicts)
(dolist (entry (tp--surface-ledger surface))
(pcase-let ((`(,entry-operations . ,entry-conflicts)
(tp--unmount-ledger-segments surface entry)))
(setq operations (nconc operations entry-operations)
conflicts (nconc conflicts entry-conflicts))))
(cons operations conflicts)))
(defun tp--unmount-journals (surface operations)
"Capture property rollback journals for SURFACE and OPERATIONS."
(let ((entries
(if (eq (tp--surface-capability surface) 'content)
(pcase-let ((`(,start . ,end) (tp--surface-range surface)))
(list (list (tp--surface-buffer surface) start end)))
(mapcar (lambda (operation)
(list (tp--surface-buffer surface)
(plist-get operation :start)
(plist-get operation :end)))
operations))))
(mapcar
(lambda (entry)
(pcase-let ((`(,buffer ,start ,end) entry))
(list buffer start end
(with-current-buffer buffer (buffer-substring start end)))))
(tp--merge-buffer-intervals entries))))
(defun tp--publish-unmount (surface operations)
"Remove SURFACE content or apply property restoration OPERATIONS."
(let ((buffer (tp--surface-buffer surface))
(tp--surface-publishing t))
(with-current-buffer buffer
(save-restriction
(widen)
(let ((inhibit-read-only
(plist-get (tp--surface-options surface) :inhibit-read-only)))
(if (eq (tp--surface-capability surface) 'content)
(pcase-let ((`(,start . ,end) (tp--surface-range surface)))
(delete-region start end))
(with-silent-modifications
(dolist (operation operations)
(tp--apply-property-operation buffer operation)))))))))
(defun tp--remove-surface-anchor-ownership (surface)
"Detach SURFACE from every range anchor it owns."
(dolist (anchor (tp--anchors-in-mounts (tp--surface-mounts surface)))
(setf (tp--anchor-surfaces anchor)
(delq surface (tp--anchor-surfaces anchor)))
(unless (tp--anchor-surfaces anchor) (tp--dispose-anchor anchor))))
(defun tp--teardown-surface (surface killed)
"Release SURFACE runtime state; KILLED means its buffer is gone."
(when (tp-surface-p surface)
(tp--unregister-surface surface)
(tp-binding-dispose-owner surface)
(when (tp--surface-objects surface)
(maphash
(lambda (_path object)
(tp-binding-dispose-owner object)
(setf (tp--surface-object-live object) nil
(tp--surface-object-disposed object) t))
(tp--surface-objects surface)))
(tp--remove-surface-anchor-ownership surface)
(tp--dispose-content-mounts (tp--surface-mounts surface))
(tp--dispose-ledger (tp--surface-ledger surface))
(tp--dispose-marker (tp--surface-start surface))
(tp--dispose-marker (tp--surface-end surface))
(setf (tp--surface-live surface) nil
(tp--surface-stale surface) (and killed 'killed)
(tp--surface-objects surface) (make-hash-table :test #'equal)
(tp--surface-mounts surface) nil (tp--surface-index surface) nil
(tp--surface-mount-index surface) (make-hash-table :test #'eq)
(tp--surface-ledger surface) nil
(tp--surface-client-state surface) nil)))
;;;###autoload
(defun tp-surface-unmount (surface)
"Unmount SURFACE and return a generic report.
Properties-only mounts restore their baseline only when TP's last value still
owns the property; conflicting host values are preserved and reported."
(tp--validate-live-surface surface)
(when tp--transaction-active
(signal 'tp-surface-error (list :unmount-during-transaction)))
(let* ((property-result
(if (eq (tp--surface-capability surface) 'properties)
(tp--unmount-property-operations surface)
(cons nil nil)))
(operations (car property-result))
(conflicts (cdr property-result))
(journals (tp--unmount-journals surface operations))
(views (tp--capture-view-state (list (tp--surface-buffer surface))))
(group (tp--prepare-change-group-for-buffers
(list (tp--surface-buffer surface))))
success)
(unwind-protect
(progn
(tp--publish-unmount surface operations)
(accept-change-group group)
(setq success t))
(unless success
(tp--cancel-change-group-safely group)
(tp--restore-property-journals journals))
(tp--restore-view-state views))
(let ((report (list :transaction-id (cl-incf tp--surface-transaction-id)
:surface-id (tp--surface-id surface)
:old-revision (tp--surface-revision surface)
:new-revision nil :text-operations
(if (eq (tp--surface-capability surface) 'content) 1 0)
:property-operations (length operations)
:property-conflicts conflicts :unmounted t)))
(tp--teardown-surface surface nil)
report)))
(defun tp-surface-at-point (&optional position buffer)
"Return live objects mounted at POSITION in BUFFER from side indexes."
(let ((target (if buffer (get-buffer buffer) (current-buffer)))
objects)
(unless (buffer-live-p target)
(signal 'tp-unsupported-buffer (list buffer)))
(with-current-buffer target
(let ((point (or position (point))))
(dolist (surface tp--buffer-surfaces)
(dolist (mount (tp--surface-index surface))
(let ((start (tp--mount-position (tp--surface-mount-start mount)))
(end (tp--mount-position (tp--surface-mount-end mount))))
(when (and start end (<= start point) (< point end))
(cl-pushnew (tp--surface-mount-object mount) objects
:test #'eq)))))))
(sort objects
(lambda (left right)
(< (length (tp--surface-object-path left))
(length (tp--surface-object-path right)))))))
(defun tp-surface-report (surface)
"Return a defensive copy of SURFACE's latest generic commit report."
(unless (tp-surface-p surface)
(signal 'wrong-type-argument (list 'tp-surface-p surface)))
(tp--copy-property-value (tp--surface-report surface)))
(defun tp-surface-report-summary (surface)
"Return scalar commit metrics for SURFACE without copying its full report.
The returned plist contains only numbers, symbols, booleans, or nil. Use
`tp-surface-report' when callers need arbitrary report payloads or a defensive
snapshot of nested values."
(unless (tp-surface-p surface)
(signal 'wrong-type-argument (list 'tp-surface-p surface)))
(let ((report (tp--surface-report surface)))
(list :transaction-id (plist-get report :transaction-id)
:text-operations (plist-get report :text-operations)
:property-operations (plist-get report :property-operations)
:full-root (plist-get report :full-root)
:scope-count (plist-get report :scope-count)
:scope-range-count (plist-get report :scope-range-count)
:scope-fallback (plist-get report :scope-fallback)
:reconciled-objects (plist-get report :reconciled-objects)
:created-objects (plist-get report :created-objects)
:removed-objects (plist-get report :removed-objects)
:moved-objects (plist-get report :moved-objects))))
(defun tp-surface-inspect (surface)
"Return read-only retained diagnostics for SURFACE."
(tp--validate-live-surface surface)
(list :surface surface :id (tp--surface-id surface)
:buffer (tp--surface-buffer surface)
:capability (tp--surface-capability surface)
:revision (tp--surface-revision surface)
:object-count (hash-table-count (tp--surface-objects surface))
:mount-count (length (tp--surface-mounts surface))
:client-state (tp--surface-client-state surface)
:report (tp-surface-report surface)))
(defun tp--watch-producer (anchor compute)
"Return a properties producer backed by ANCHOR and COMPUTE."
(lambda (context)
(let* ((object (tp-object-ensure
context nil 'watch 'text-properties))
(binding
(tp-bind object '(tp/watch . declarations)
(lambda ()
(tp--project-text-declarations (funcall compute))))))
(tp-object-attach-range context object anchor)
(tp-surface-plan-create
:key 'watch :kind 'text-properties
:props (tp-binding-read binding) :capability 'properties))))
;;;###autoload
(defun tp-watch (buffer start end compute)
"Reactively apply declarations from COMPUTE to BUFFER from START to END.
COMPUTE is a zero-argument function returning native text declarations.
Return the underlying properties-only surface for inspection or unmounting."
(unless (functionp compute)
(signal 'wrong-type-argument (list 'functionp compute)))
(let ((anchor (tp-range-anchor-create buffer start end)) surface)
(unwind-protect
(setq surface
(tp-surface-mount
buffer (tp--watch-producer anchor compute)
'(:capability properties :inhibit-read-only t)))
(unless surface (tp--dispose-anchor anchor)))
surface))
(add-hook 'tp--binding-changed-functions #'tp--surface-binding-changed)
(add-hook 'tp--transaction-publish-functions #'tp--surface-publish-transaction)
(add-hook 'tp--transaction-rollback-functions #'tp--surface-rollback-transaction)
(add-hook 'tp--transaction-rollback-final-functions
#'tp--surface-finalize-killed-rollback)
(add-hook 'tp--transaction-committed-functions #'tp--surface-commit-transaction)
(provide 'tp-surface)
;;; tp-surface.el ends here
Reference in New Issue View Git Blame Copy Permalink