diff --git a/tests/tp-surface-tests.el b/tests/tp-surface-tests.el index 98c19b5..4dd7b42 100644 --- a/tests/tp-surface-tests.el +++ b/tests/tp-surface-tests.el @@ -2376,13 +2376,16 @@ :key 'root :kind 'range :props '(help-echo "tp") :capability 'properties))) (surface (tp-surface-mount - buffer producer '(:capability properties))) + buffer producer + (list :capability 'properties + :observers (list #'ignore)))) (id (tp--surface-id surface)) (ledger (tp--surface-ledger surface)) (mounts (tp--surface-mounts surface))) (should (eq (gethash id tp--surfaces) surface)) (tp-surface-unmount surface) (should-not (gethash id tp--surfaces)) + (should-not (tp--surface-observers surface)) (should-not (tp-range-anchor-live-p anchor)) (dolist (entry ledger) (should-not (marker-position (tp--property-ledger-start entry))) @@ -2424,10 +2427,12 @@ (let* ((buffer (generate-new-buffer " *tp-surface-kill*")) (surface (tp-surface-mount buffer (tp-surface-test--leaf 'root "x") - '(:capability content))) + (list :capability 'content + :observers (list #'ignore)))) (object (tp-object-resolve surface '(root)))) (kill-buffer buffer) (should-not (tp-surface-live-p surface)) + (should-not (tp--surface-observers surface)) (should-not (tp-object-live-p object)))) (ert-deftest tp-surface-test-omitted-binding-defaults-to-deletion () @@ -2497,18 +2502,113 @@ (tp-surface-unmount surface)))) (ert-deftest tp-surface-test-no-observer-skips-report-snapshot () - "A surface without observers does not copy an unused asynchronous report." + "A surface without observers constructs no observation event or timing." (tp-surface-test--with-buffer (let ((copies 0) + (clock-calls 0) + surface (original (symbol-function 'tp-surface-report))) (cl-letf (((symbol-function 'tp-surface-report) (lambda (&rest arguments) (cl-incf copies) - (apply original arguments)))) + (apply original arguments))) + ((symbol-function 'tp--surface-observation-clock) + (lambda () + (cl-incf clock-calls) + 1.0))) + (setq surface + (tp-surface-mount + buffer (tp-surface-test--leaf 'root "committed") + '(:capability content)))) + (should (= copies 0)) + (should (= clock-calls 0)) + (let ((report (tp-surface-report surface))) + (should-not (plist-get report :provider)) + (should-not (plist-get report :stage)) + (should-not (plist-get report :duration-ms)) + (should-not (plist-get report :timing)))))) + +(ert-deftest tp-surface-test-observer-registration-is-public-and-idempotent () + "Observers can be added and removed without duplicates." + (tp-surface-test--with-buffer + (let* ((calls 0) + (observer (lambda (_surface _report) (cl-incf calls))) + (surface + (tp-surface-mount + buffer (tp-surface-test--leaf 'root "one") + '(:capability content)))) + (should-error (tp-surface-add-observer surface 'not-a-function) + :type 'wrong-type-argument) + (should-error (tp-surface-remove-observer surface 'not-a-function) + :type 'wrong-type-argument) + (should (eq (tp-surface-add-observer surface observer) surface)) + (should (eq (tp-surface-add-observer surface observer) surface)) + (should (= (length (tp--surface-observers surface)) 1)) + (tp-surface-update surface (tp-surface-test--leaf 'root "two")) + (should (= calls 1)) + (should (eq (tp-surface-remove-observer surface observer) surface)) + (tp-surface-update surface (tp-surface-test--leaf 'root "three")) + (should (= calls 1))))) + +(ert-deftest tp-surface-test-observer-report-has-publication-metadata () + "An enabled observer receives provider, stage, and duration metadata." + (tp-surface-test--with-buffer + (let ((clock-values '(10.0 10.025)) + observed-report) + (cl-letf (((symbol-function 'tp--surface-observation-clock) + (lambda () (pop clock-values)))) (tp-surface-mount buffer (tp-surface-test--leaf 'root "committed") - '(:capability content))) - (should (= copies 0))))) + (list :capability 'content + :observers + (list (lambda (_surface report) + (setq observed-report report)))))) + (should (eq (plist-get observed-report :provider) 'tp)) + (should (eq (plist-get observed-report :stage) 'publication)) + (should (< (abs (- (plist-get observed-report :duration-ms) 25.0)) + 0.001)) + (should (plist-member observed-report :transaction-id)) + (should (plist-member observed-report :scope-count)) + (should (plist-member observed-report :text-operations))))) + +(ert-deftest tp-surface-test-observation-does-not-change-committed-state () + "Observed and unobserved surfaces commit equivalent text and state." + (let ((plain-buffer (generate-new-buffer " *tp-plain*")) + (observed-buffer (generate-new-buffer " *tp-observed*"))) + (unwind-protect + (let* ((plan (tp-surface-test--leaf + 'root "same" '(face bold help-echo "same"))) + (plain (tp-surface-mount + plain-buffer plan '(:capability content))) + (observed (tp-surface-mount + observed-buffer plan + (list :capability 'content + :observers (list #'ignore))))) + (should (equal-including-properties + (with-current-buffer plain-buffer + (buffer-substring (point-min) (point-max))) + (with-current-buffer observed-buffer + (buffer-substring (point-min) (point-max))))) + (should (= (tp-surface-revision plain) + (tp-surface-revision observed))) + (should (equal (tp-surface-client-state plain) + (tp-surface-client-state observed))) + (let ((next (tp-surface-test--leaf + 'root "updated" + '(face italic help-echo "updated")))) + (tp-surface-update plain next) + (tp-surface-update observed next)) + (should (equal-including-properties + (with-current-buffer plain-buffer + (buffer-substring (point-min) (point-max))) + (with-current-buffer observed-buffer + (buffer-substring (point-min) (point-max))))) + (should (= (tp-surface-revision plain) + (tp-surface-revision observed))) + (should (equal (tp-surface-client-state plain) + (tp-surface-client-state observed)))) + (when (buffer-live-p plain-buffer) (kill-buffer plain-buffer)) + (when (buffer-live-p observed-buffer) (kill-buffer observed-buffer))))) (ert-deftest tp-surface-test-observer-failure-does-not-roll-back () "Observer errors are recorded after a successful publication." @@ -2525,6 +2625,36 @@ :observer-errors)) 1))))) +(ert-deftest tp-surface-test-observer-runs-only-after-accepted-publication () + "A rolled-back publication emits no observation; a retry emits one." + (tp-surface-test--with-buffer + (let* ((calls 0) + (observer (lambda (_surface _report) (cl-incf calls))) + (surface + (tp-surface-mount + buffer + (tp-surface-test--leaf + 'root "old" '(face bold help-echo "old")) + (list :capability 'content :observers (list observer)))) + (revision (tp-surface-revision surface)) + (old (buffer-substring (point-min) (point-max))) + (next (tp-surface-test--leaf + 'root "new" '(face italic help-echo "new")))) + (setq calls 0) + (cl-letf (((symbol-function 'accept-change-group) + (lambda (_group) (error "Injected final-accept failure")))) + (should-error (tp-surface-update surface next))) + (should (= calls 0)) + (should (= (tp-surface-revision surface) revision)) + (should (equal-including-properties + old (buffer-substring (point-min) (point-max)))) + (tp-surface-update surface next) + (should (= calls 1)) + (should (= (tp-surface-revision surface) (1+ revision))) + (should (equal-including-properties + (buffer-substring (point-min) (point-max)) + (propertize "new" 'face 'italic 'help-echo "new")))))) + (ert-deftest tp-surface-test-observer-write-starts-a-new-transaction () "An observer signal write runs after the publishing transaction exits." (tp-surface-test--with-buffer diff --git a/tp-surface.el b/tp-surface.el index 2d6b731..7b38ff2 100644 --- a/tp-surface.el +++ b/tp-surface.el @@ -162,6 +162,22 @@ producer result to the active prepare transaction." (defconst tp--surface-producer-key '(tp/surface . producer)) (defconst tp--surface-extension-key 'tp-surface) +(defun tp--normalize-surface-observers (observers) + "Validate OBSERVERS and return them once each, in declaration order." + (unless (listp observers) + (signal 'wrong-type-argument (list 'listp observers))) + (let (normalized) + (dolist (observer observers) + (unless (functionp observer) + (signal 'wrong-type-argument (list 'functionp observer))) + (unless (memq observer normalized) + (push observer normalized))) + (nreverse normalized))) + +(defun tp--surface-observation-clock () + "Return the current time for optional surface publication observation." + (float-time)) + (defun tp--plist-shape-p (value) "Return non-nil when VALUE is an even property list with symbol keys." (and (listp value) @@ -2190,7 +2206,8 @@ to the committed projection, as with `tp-object-reuse-subtree'." :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))))) + :observers + (tp--normalize-surface-observers (plist-get options :observers))))) (defun tp--surface-compute-function (surface input options initial) "Return SURFACE's producer binding for INPUT, OPTIONS, and INITIAL state." @@ -2277,6 +2294,30 @@ handle." surface plan-or-producer (tp--surface-options surface) nil) (tp-surface-report surface)) +;;;###autoload +(defun tp-surface-add-observer (surface observer) + "Add function OBSERVER to live SURFACE and return SURFACE. +OBSERVER receives SURFACE and a defensive REPORT copy after each successful +publication. Adding the same function more than once has no effect." + (tp--validate-live-surface surface) + (unless (functionp observer) + (signal 'wrong-type-argument (list 'functionp observer))) + (unless (memq observer (tp--surface-observers surface)) + (setf (tp--surface-observers surface) + (append (tp--surface-observers surface) (list observer)))) + surface) + +;;;###autoload +(defun tp-surface-remove-observer (surface observer) + "Remove function OBSERVER from live SURFACE and return SURFACE. +Removing a function that is not registered has no effect." + (tp--validate-live-surface surface) + (unless (functionp observer) + (signal 'wrong-type-argument (list 'functionp observer))) + (setf (tp--surface-observers surface) + (delq observer (tp--surface-observers surface))) + surface) + ;;;###autoload (defun tp-surface-update-scoped (surface objects plan-or-producer &optional options) @@ -2992,8 +3033,9 @@ the generic property-operation ledger." (defun tp--publish-one-surface (prepared) "Publish PREPARED buffer and side state." - (let* ((started (float-time)) - (surface (tp--prepared-surface-surface prepared)) + (let* ((surface (tp--prepared-surface-surface prepared)) + (observed (tp--surface-observers surface)) + (started (and observed (tp--surface-observation-clock))) (counts (if (eq (tp--surface-capability surface) 'content) (tp--publish-buffer-content prepared) (tp--publish-buffer-properties prepared)))) @@ -3008,10 +3050,17 @@ the generic property-operation ledger." (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)))) + (when started + (let* ((duration-ms + (* 1000.0 (- (tp--surface-observation-clock) started))) + (report (tp--surface-report surface))) + (setq report (plist-put report :provider 'tp) + report (plist-put report :stage 'publication) + report (plist-put report :duration-ms duration-ms) + report (plist-put report :timing + (list :publication (/ duration-ms 1000.0)))) + (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." @@ -3871,7 +3920,8 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback." (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))) + (tp--surface-client-state surface) nil + (tp--surface-observers surface) nil))) ;;;###autoload (defun tp-surface-unmount (surface)