e3d7d1dfc6
Allow retained logical objects to own multiple marker-backed output fragments without leaking handles or positions into pure plans. Expose only defensive numeric mount snapshots through the public object index. Verified: 718 ERT tests, 92 doctests, WERROR compile-all, checkdoc, and git diff --check.
2057 lines
92 KiB
EmacsLisp
2057 lines
92 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)
|
|
|
|
(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
|
|
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-publication-step-function nil)
|
|
|
|
(defvar-local tp--buffer-surfaces nil)
|
|
(defvar-local tp--surface-character-tick 0)
|
|
|
|
(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--copy-opaque-value (value)
|
|
"Defensively copy conses, vectors, and strings in VALUE."
|
|
(cond ((functionp value) value)
|
|
((stringp value) (copy-sequence value))
|
|
((consp value)
|
|
(cons (tp--copy-opaque-value (car value))
|
|
(tp--copy-opaque-value (cdr value))))
|
|
((vectorp value)
|
|
(apply #'vector (mapcar #'tp--copy-opaque-value value)))
|
|
(t value)))
|
|
|
|
(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-opaque-value (tp-surface-plan-kind plan)))
|
|
(text (and (tp-surface-plan-text plan)
|
|
(copy-sequence (tp-surface-plan-text plan))))
|
|
(props (tp--copy-opaque-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-opaque-value (tp-surface-plan-key plan))
|
|
:kind kind :text text :props props :children children
|
|
:tags (tp--copy-opaque-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--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)))
|
|
(equal (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 the 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 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-opaque-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-opaque-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)
|
|
"Declare candidate OBJECT live 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-opaque-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 (copy-tree parent)))
|
|
(cl-loop for (property value) on child by #'cddr
|
|
do (setq result (plist-put result property 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 CONTEXT's planned, 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-opaque-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 the two nonempty half-open ranges overlap."
|
|
(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 absolute candidate ranges for SURFACE."
|
|
(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 overlapping ownership between SURFACE and other live surfaces."
|
|
(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--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* ((context (tp--make-context surface))
|
|
(success nil)
|
|
result)
|
|
(unwind-protect
|
|
(let* ((normalized (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))))
|
|
(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))))
|
|
(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-opaque-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--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 candidate interval boundaries in BUFFER."
|
|
(let (boundaries)
|
|
(dolist (spec mount-specs)
|
|
(push (plist-get spec :start) boundaries)
|
|
(push (plist-get spec :end) boundaries))
|
|
(dolist (entry (tp--surface-ledger surface))
|
|
(push (tp--ledger-position (tp--property-ledger-start entry)) boundaries)
|
|
(push (tp--ledger-position (tp--property-ledger-end entry)) boundaries))
|
|
(setq boundaries (sort (delete-dups boundaries) #'<))
|
|
(when boundaries
|
|
(let ((minimum (car boundaries)) (maximum (car (last boundaries))))
|
|
(with-current-buffer buffer
|
|
(dolist (property properties)
|
|
(let ((position minimum))
|
|
(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-schema-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."
|
|
(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-equal-p
|
|
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-equal-p 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 candidate ledger specs and property operations for SURFACE."
|
|
(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 surface candidate for BUFFER."
|
|
(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 (copy-tree 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 the producer binding function for SURFACE and INPUT."
|
|
(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."
|
|
(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))
|
|
|
|
(defun tp--edit-touches-span-p (beg old-length start end)
|
|
"Return non-nil when an external edit at BEG touches START..END."
|
|
(if (zerop old-length)
|
|
(and (> beg start) (< beg end))
|
|
(and (>= beg start) (< beg end))))
|
|
|
|
(defun tp--mark-anchor-after-edit (anchor beg old-length)
|
|
"Apply ANCHOR's boundary policy after an edit at BEG."
|
|
(let ((start (marker-position (tp--anchor-start anchor)))
|
|
(end (marker-position (tp--anchor-end anchor))))
|
|
(when (and start end (tp--edit-touches-span-p beg old-length start end))
|
|
(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 retained mount staleness after a host edit at BEG."
|
|
(let* ((tick (buffer-chars-modified-tick))
|
|
(character-change (/= tick tp--surface-character-tick)))
|
|
(setq tp--surface-character-tick tick)
|
|
(when (and character-change (not tp--surface-publishing))
|
|
(dolist (surface tp--buffer-surfaces)
|
|
(when (tp-surface-live-p surface)
|
|
(if (eq (tp--surface-capability surface) 'content)
|
|
(pcase-let ((`(,start . ,end) (tp--surface-range surface)))
|
|
(when (tp--edit-touches-span-p beg old-length start end)
|
|
(setf (tp--surface-stale surface) t)))
|
|
(dolist (mount (tp--surface-mounts surface))
|
|
(when-let ((anchor (tp--surface-mount-anchor mount)))
|
|
(tp--mark-anchor-after-edit anchor beg old-length)))))))))
|
|
|
|
(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 '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-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 changes 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 differs from RENDERED on FROM..TO."
|
|
(cl-loop for offset from from below to
|
|
thereis (not (equal (text-properties-at (+ start offset) buffer)
|
|
(text-properties-at offset rendered)))))
|
|
|
|
(defun tp--content-property-operations (surface rendered)
|
|
"Return exact direct-property operations for SURFACE and RENDERED."
|
|
(let* ((buffer (tp--surface-buffer surface))
|
|
(start (marker-position (tp--surface-start surface)))
|
|
(length (length rendered))
|
|
(offset 0)
|
|
operations)
|
|
(while (< offset length)
|
|
(let* ((next (next-property-change offset rendered length))
|
|
(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--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 generic commit report."
|
|
(let* ((surface (tp--prepared-surface-surface prepared))
|
|
(old-revision (tp--surface-revision surface))
|
|
(new-revision (1+ old-revision)))
|
|
(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 (length (tp--prepared-surface-rendered prepared))
|
|
:full-root t :property-conflicts nil :rolled-back nil
|
|
:failure nil :observer-errors nil :timing nil)))
|
|
|
|
(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))
|
|
(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
|
|
(tp--content-text-operation surface rendered))
|
|
(tp--publication-step 'text surface)
|
|
(setq property-operations
|
|
(tp--content-property-operations surface rendered))
|
|
(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)
|
|
(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 '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 (copy-tree (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 ()
|
|
"Accept buffer changes 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 restoration operations and conflicts for one 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)))
|
|
(copy-tree (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
|