0d35358e05
Replace the legacy managed layer renderer with one independent retained/reactive text runtime. TP now owns exact dependencies, stable objects, marker-backed mounts, property contribution composition, atomic publication, rollback, and direct text-property facades without ECSS or Ebox dependencies.\n\nBREAKING CHANGE: remove tp-render, tp-stack, scan-driven managed layers, inline runtime metadata, TP-owned CSS cascade APIs, and dollar-variable declarations.\n\nVerified: 290/290 ERT, shuffled 290/290 (seed 20260806), 8/8 doctests, WERROR compile-all, checkdoc, package-lint, diff-check, and isolated TP-only load.
2457 lines
110 KiB
EmacsLisp
2457 lines
110 KiB
EmacsLisp
;;; 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-producer-buffer-mutation
|
|
"TP producer mutated a live surface buffer during prepare"
|
|
'tp-surface-error)
|
|
(define-error 'tp-scope-mismatch "Scoped TP update changed outside its objects"
|
|
'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)))
|
|
"A producer result carrying PLAN and opaque CLIENT-STATE."
|
|
plan client-state)
|
|
|
|
(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
|
|
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)
|
|
|
|
(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-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--copy-surface-plan (plan)
|
|
"Return a validated defensive copy of PLAN."
|
|
(unless (tp-surface-plan-p plan)
|
|
(signal 'wrong-type-argument (list 'tp-surface-plan-p plan)))
|
|
(let* ((children (mapcar #'tp--copy-surface-plan
|
|
(tp-surface-plan-children plan)))
|
|
(kind (tp--copy-property-value (tp-surface-plan-kind plan)))
|
|
(text (tp--copy-property-value (tp-surface-plan-text plan)))
|
|
(props (tp--copy-property-value (tp-surface-plan-props plan)))
|
|
(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))
|
|
:kind kind :text text :props props :children children
|
|
:tags (tp--copy-property-value (tp-surface-plan-tags plan))
|
|
: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)))
|
|
|
|
(defun tp-surface-result-create (plan &optional client-state)
|
|
"Return a producer result containing PLAN and opaque CLIENT-STATE."
|
|
(tp--make-surface-result (tp--copy-surface-plan plan) client-state))
|
|
|
|
(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-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 (marker-position (tp--surface-mount-start mount))
|
|
:end (marker-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)
|
|
: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))
|
|
(gethash object (tp--context-touched 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-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--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)
|
|
"Return a fresh plist where CHILD values override PARENT values."
|
|
(let ((result (tp--copy-property-value parent)))
|
|
(cl-loop for (property value) on child by #'cddr
|
|
do (setq result
|
|
(plist-put result property
|
|
(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)
|
|
"Return PLAN's propertized string and side records in CONTEXT."
|
|
(let (records)
|
|
(cl-labels
|
|
((walk (node path inherited offset)
|
|
(let* ((props (tp--plist-overlay
|
|
inherited (tp-surface-plan-props node)))
|
|
(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))
|
|
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)
|
|
"Normalize producer VALUE for SURFACE using OPTIONS."
|
|
(cond
|
|
((tp-surface-result-p value)
|
|
(cons (tp--copy-surface-plan (tp-surface-result-plan value))
|
|
(tp-surface-result-client-state value)))
|
|
((tp-surface-plan-p value)
|
|
(cons (tp--copy-surface-plan value)
|
|
(if (plist-member options :client-state)
|
|
(plist-get options :client-state)
|
|
(tp--surface-client-state surface))))
|
|
(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 objects."
|
|
(let (objects)
|
|
(maphash (lambda (object _present) (push object objects))
|
|
(tp--context-touched context))
|
|
objects))
|
|
|
|
(defun tp--content-mount-spec (object record &optional tags)
|
|
"Return one content mount spec for OBJECT over RECORD with TAGS."
|
|
(list :object object :start (plist-get record :start)
|
|
:end (plist-get record :end)
|
|
:tags (tp--copy-property-value
|
|
(if tags tags (plist-get record :tags)))))
|
|
|
|
(defun tp--content-mount-specs (records context)
|
|
"Return direct and logical-fragment mount specs for RECORDS in CONTEXT."
|
|
(let (specs)
|
|
(dolist (record records)
|
|
(let* ((fragment (plist-get record :object))
|
|
(attachments
|
|
(nreverse
|
|
(copy-sequence
|
|
(gethash fragment
|
|
(tp--context-fragment-attachments context))))))
|
|
(push (tp--content-mount-spec fragment record) specs)
|
|
(dolist (attachment attachments)
|
|
(push (tp--content-mount-spec
|
|
(car attachment) record (cdr attachment))
|
|
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 (marker-position (tp--surface-mount-start mount)))
|
|
(end (marker-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)
|
|
(let ((plan (tp--copy-surface-plan input)))
|
|
(tp--ensure-plan-objects context plan)
|
|
(tp--producer-result plan surface options)))))
|
|
|
|
(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--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 (marker-position (tp--surface-mount-start mount)))
|
|
(end (marker-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 (car normalized))
|
|
(client-state (cdr 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))
|
|
(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 (- (length objects) (length 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, :client-state, and :observers. 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'. Its default, `error', signals
|
|
`tp-scope-mismatch'; `root' permits an explicit full-surface fallback."
|
|
(tp--validate-live-surface surface)
|
|
(setq objects (tp--normalize-surface-scopes surface objects))
|
|
(let ((on-mismatch (or (plist-get options :on-mismatch) 'error)))
|
|
(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)))))
|
|
(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)
|
|
(- (marker-position (tp--surface-mount-start mount)) base)
|
|
(- (marker-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--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))
|
|
(insert (substring new prefix (- (length new) suffix))))
|
|
(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."
|
|
(cl-loop for offset from from below to
|
|
thereis
|
|
(not (tp--plan-props-equal-p
|
|
(text-properties-at (+ start offset) buffer)
|
|
(text-properties-at offset rendered)))))
|
|
|
|
(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)))))
|
|
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 marker-backed content mounts for PREPARED."
|
|
(let* ((surface (tp--prepared-surface-surface prepared))
|
|
(buffer (tp--surface-buffer surface))
|
|
(base (marker-position (tp--surface-start surface))))
|
|
(mapcar
|
|
(lambda (spec)
|
|
(tp--make-surface-mount
|
|
:object (plist-get spec :object)
|
|
:start (with-current-buffer buffer
|
|
(copy-marker (+ base (plist-get spec :start)) nil))
|
|
: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))
|
|
(plain (substring-no-properties replacement)))
|
|
(unless (equal (buffer-substring-no-properties start end) plain)
|
|
(delete-region start end)
|
|
(goto-char start)
|
|
(insert plain)
|
|
(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)
|
|
(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))
|
|
(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."
|
|
(let ((observers (copy-sequence (tp--surface-observers surface)))
|
|
(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)))
|
|
(tp--validate-plan-capability plan 'content)
|
|
(tp--validate-context-tree context plan)
|
|
(setq rendered (car (tp--render-plan plan context))
|
|
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 (marker-position (tp--surface-mount-start mount)))
|
|
(end (marker-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-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
|