geekinney/tp
1
0
Fork 0
Code Issues Pull Requests Actions 2 Packages Projects Releases Wiki Activity

chore: migrate conditional bindings for Emacs 31

Browse Source
This commit is contained in:
Kinneyzhang 2026-08-26 00:09:44 +08:00
parent 34b65b338f
commit edc51194b6
9 changed files with 51 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
examples/reactive-status.el
View File

@ -58,15 +58,15 @@ The returned state has keys:
(defun tp-example-reactive-status-dispose (state)
"Unmount reactive status STATE and dispose internal signals."
(when-let ((surface (plist-get state :surface)))
(when-let* ((surface (plist-get state :surface)))
(when (tp-surface-live-p surface)
(tp-surface-unmount surface))
(setf (plist-get state :surface) nil))
(when-let ((status (plist-get state :status)))
(when-let* ((status (plist-get state :status)))
(when (tp-signal-live-p status)
(tp-signal-dispose status))
(setf (plist-get state :status) nil))
(when-let ((noise (plist-get state :noise)))
(when-let* ((noise (plist-get state :noise)))
(when (tp-signal-live-p noise)
(tp-signal-dispose noise))
(setf (plist-get state :noise) nil)))

2
tp-core.el
View File

@ -99,7 +99,7 @@ FORMAT-STRING and ARGS are passed to `format'."
(defun tp-debug-clear ()
"Clear the *tp-debug* buffer."
(interactive)
(when-let ((buf (get-buffer "*tp-debug*")))
(when-let* ((buf (get-buffer "*tp-debug*")))
(with-current-buffer buf
(erase-buffer))))

16
tp-layer.el
View File

@ -117,22 +117,22 @@ Each entry has the form (NAME ARGLIST BODY-FORM).")
(defun tp-layer-parameterized-p (name)
"Return non-nil when layer recipe NAME accepts arguments."
(when-let ((entry (tp--recipe-entry name tp-layer-alist)))
(when-let* ((entry (tp--recipe-entry name tp-layer-alist)))
(and (car entry) t)))
(defun tp-layer-arglist (name)
"Return a defensive copy of layer recipe NAME's argument list."
(when-let ((entry (tp--recipe-entry name tp-layer-alist)))
(when-let* ((entry (tp--recipe-entry name tp-layer-alist)))
(copy-sequence (car entry))))
(defun tp-group-parameterized-p (name)
"Return non-nil when group recipe NAME accepts arguments."
(when-let ((entry (tp--recipe-entry name tp-layer-groups)))
(when-let* ((entry (tp--recipe-entry name tp-layer-groups)))
(and (car entry) t)))
(defun tp--group-arglist (name)
"Return a defensive copy of group recipe NAME's argument list."
(when-let ((entry (tp--recipe-entry name tp-layer-groups)))
(when-let* ((entry (tp--recipe-entry name tp-layer-groups)))
(copy-sequence (car entry))))
(defun tp--is-layer-name-p (symbol)
@ -185,7 +185,7 @@ Each entry has the form (NAME ARGLIST BODY-FORM).")
(defun tp--layer-properties (name args)
"Expand layer recipe NAME using ARGS."
(when-let ((entry (tp--recipe-entry name tp-layer-alist)))
(when-let* ((entry (tp--recipe-entry name tp-layer-alist)))
(pcase-let ((`(,arglist ,body) entry))
(tp--check-layer-cycle name)
(let* ((tp--layer-expansion-stack
@ -239,7 +239,7 @@ PROVENANCE is accepted for source compatibility and has no effect."
(defun tp--group-properties (name args)
"Return the ordered direct property groups produced by NAME with ARGS."
(when-let ((entry (tp--recipe-entry name tp-layer-groups)))
(when-let* ((entry (tp--recipe-entry name tp-layer-groups)))
(pcase-let ((`(,arglist ,body) entry))
(tp--check-layer-cycle name)
(let* ((tp--layer-expansion-stack
@ -324,7 +324,7 @@ Signal `tp-unresolved-layer' when a symbol does not name a recipe."
(defun tp--candidate-layer-parameterized-p (name layers)
"Return non-nil when NAME accepts arguments in candidate LAYERS."
(when-let ((entry (tp--recipe-entry name layers)))
(when-let* ((entry (tp--recipe-entry name layers)))
(and (car entry) t)))
(defun tp--candidate-layer-properties (name args layers groups)
@ -526,7 +526,7 @@ Each BODY form evaluates to one layer name, recipe call, native property
(defun tp--describe-layer-data (name)
"Return declarative registry data for layer recipe NAME."
(when-let ((entry (tp--recipe-entry name tp-layer-alist)))
(when-let* ((entry (tp--recipe-entry name tp-layer-alist)))
(list :name name
:kind 'direct-declaration-recipe
:arglist (copy-sequence (car entry))

2
tp-ops.el
View File

@ -310,7 +310,7 @@ target string/buffer itself."
;;;###autoload
(defun tp-member (position property &optional object)
"Return (PROPERTY VALUE) when PROPERTY is present at POSITION in OBJECT."
(when-let ((member (plist-member
(when-let* ((member (plist-member
(text-properties-at position object) property)))
(list (car member) (cadr member))))

2
tp-query.el
View File

@ -67,7 +67,7 @@ MODE is recorded in the returned `tp-lookup-result'."
"Return the first non-nil alias value for PROPERTY at POSITION."
(catch 'found
(dolist (alias (cdr (assq property char-property-alias-alist)))
(when-let ((value (get-text-property position alias object)))
(when-let* ((value (get-text-property position alias object)))
(throw 'found (list alias value))))))
(defun tp--lookup-source-cell (position property object)

14
tp-reactive.el
View File

@ -190,7 +190,7 @@
(defun tp--unregister-binding (binding)
"Remove BINDING from owner and global registries."
(when-let ((table (tp--owner-binding-table (tp-binding-owner binding))))
(when-let* ((table (tp--owner-binding-table (tp-binding-owner binding))))
(remhash (tp-binding-key binding) table)
(when (zerop (hash-table-count table))
(remhash (tp-binding-owner binding) tp--owner-bindings)))
@ -347,7 +347,7 @@ dirty target has recomputed."
(when (eq (tp-binding-state binding) 'computing)
(tp--signal-binding-cycle (tp--stack-cycle-path binding)))
(unless computing-only
(when-let ((path (tp--binding-dependency-path
(when-let* ((path (tp--binding-dependency-path
binding tp--current-binding nil)))
(tp--signal-binding-cycle (cons tp--current-binding path))))))
@ -567,7 +567,7 @@ and graph edges already produced by a compiler or pure projection pass."
(defun tp-binding-dispose-owner (owner)
"Dispose every binding installed on OWNER and return the count."
(let ((bindings (when-let ((table (tp--owner-binding-table owner)))
(let ((bindings (when-let* ((table (tp--owner-binding-table owner)))
(let (items)
(maphash (lambda (_key binding) (push binding items)) table)
(sort items (lambda (left right)
@ -581,7 +581,7 @@ and graph edges already produced by a compiler or pure projection pass."
(defun tp-binding-owner-bindings (owner)
"Return OWNER's live bindings ordered by stable binding id."
(when-let ((table (tp--owner-binding-table owner)))
(when-let* ((table (tp--owner-binding-table owner)))
(let (bindings)
(maphash (lambda (_key binding) (push binding bindings)) table)
(sort bindings (lambda (left right)
@ -998,7 +998,7 @@ the primary condition data."
"Forward SYMBOL's NEW-VALUE write into its exact signal adapter.
OPERATION and WHERE follow the standard variable watcher protocol."
(when (eq operation 'set)
(when-let ((signal (gethash (tp--variable-signal-key
(when-let* ((signal (gethash (tp--variable-signal-key
symbol (or where 'global))
tp--variable-signals)))
(when (tp-signal-live-p signal)
@ -1046,14 +1046,14 @@ OPERATION and WHERE follow the standard variable watcher protocol."
(delq signal (tp-binding-dependencies binding))
(tp-binding-dirty binding) t))
(clrhash (tp-signal-subscribers signal))
(when-let ((key (tp-signal-adapter-key signal)))
(when-let* ((key (tp-signal-adapter-key signal)))
(remhash key tp--variable-signals)
(let ((symbol (car key)))
(unless (tp--symbol-has-variable-signal-p symbol)
(remove-variable-watcher symbol #'tp--variable-signal-watcher)
(setq tp--variable-signal-watched
(delq symbol tp--variable-signal-watched)))))
(when-let ((scope (and (bufferp (tp-signal-scope signal))
(when-let* ((scope (and (bufferp (tp-signal-scope signal))
(tp-signal-scope signal))))
(when (buffer-live-p scope)
(with-current-buffer scope

4
tp-search.el
View File

@ -631,7 +631,7 @@ Returns the number of matches found (at most TIMES)."
(save-excursion
(goto-char search-start)
(dotimes (i count)
(when-let ((match (tp--property-search-forward
(when-let* ((match (tp--property-search-forward
property value predicate not-current)))
(when (<= (prop-match-end match) search-end)
(when (= i (1- count))
@ -812,7 +812,7 @@ Returns the number of matches found (at most TIMES)."
(dotimes (i count)
;; `equal' matching by default, same as tp--forward-do's
;; predicate t.
(when-let ((match (tp--property-search-backward
(when-let* ((match (tp--property-search-backward
property value predicate not-current)))
(when (>= (prop-match-beginning match) search-start)
(when (= i (1- count))

6
tp-style.el
View File

@ -123,7 +123,7 @@ Return a rollback journal containing the previous buffer map and slot specs."
(defun tp-paint-slot-rollback-updates (journal)
"Restore paint slots from reverse-safe JOURNAL."
(when-let ((buffer (plist-get journal :buffer)))
(when-let* ((buffer (plist-get journal :buffer)))
(when (buffer-live-p buffer)
(with-current-buffer buffer
(setq-local face-remapping-alist
@ -283,7 +283,7 @@ explicit nil remains present and is distinct from an absent declaration."
(defun tp-style-declarations (name)
"Return a defensive copy of named direct style NAME declarations."
(when-let ((declarations (gethash name tp--named-styles)))
(when-let* ((declarations (gethash name tp--named-styles)))
(tp--copy-property-value declarations)))
(defun tp-undefine-style (name)
@ -304,7 +304,7 @@ explicit nil remains present and is distinct from an absent declaration."
(defun tp--project-policy-value (policy value)
"Project VALUE through POLICY into direct Emacs text properties."
(when-let ((projector (tp-property-policy-projector policy)))
(when-let* ((projector (tp-property-policy-projector policy)))
(let ((projected (funcall projector value)))
(unless (tp--declaration-list-p projected)
(signal 'tp-invalid-declaration

50
tp-surface.el
View File

@ -187,7 +187,7 @@ producer result to the active prepare transaction."
"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-let* ((key (tp-surface-plan-key child)))
(when (gethash key seen)
(signal 'tp-duplicate-object-key (list key)))
(puthash key t seen)))))
@ -1923,9 +1923,9 @@ MOUNT-SPECS and SURFACE provide ranges for PROPERTIES."
(dolist (property properties)
(let ((result (tp--property-segment-result
surface mount-specs start end property)))
(when-let ((entry (plist-get result :ledger)))
(when-let* ((entry (plist-get result :ledger)))
(push entry ledger))
(when-let ((operation (plist-get result :operation)))
(when-let* ((operation (plist-get result :operation)))
(push operation operations)))))
(cons (nreverse ledger) (nreverse operations))))
@ -2325,7 +2325,7 @@ caller reads the scalar summary from the surface instead."
(pcase-let ((`(,start . ,finish) (tp--surface-range surface)))
(push (list surface start finish) content))
(dolist (mount (tp--surface-mounts surface))
(when-let ((anchor (tp--surface-mount-anchor mount)))
(when-let* ((anchor (tp--surface-mount-anchor mount)))
(unless (gethash anchor anchors)
(puthash anchor t anchors)
(push (list anchor
@ -2388,7 +2388,7 @@ caller reads the scalar summary from the surface instead."
(defun tp--surface-scope-table (&optional create)
"Return the transaction-local scope table, creating it when CREATE is non-nil."
(when-let ((state (tp--transaction-extension
(when-let* ((state (tp--transaction-extension
tp--surface-extension-key create)))
(or (gethash 'scopes state)
(when create
@ -2398,13 +2398,13 @@ caller reads the scalar summary from the surface instead."
(defun tp--surface-scope-request (surface)
"Return SURFACE's one-shot scope request in the active transaction."
(when-let ((table (tp--surface-scope-table)))
(when-let* ((table (tp--surface-scope-table)))
(gethash surface table)))
(defun tp--clear-surface-scope-request (surface)
"Clear SURFACE's pending one-shot scope request when one exists."
(when tp--transaction-active
(when-let ((table (tp--surface-scope-table)))
(when-let* ((table (tp--surface-scope-table)))
(remhash surface table))))
(defun tp--set-surface-scope-request (surface objects options)
@ -2785,7 +2785,7 @@ When SCOPED is non-nil, inspect only RANGES, including an empty set."
(fallback (tp--prepared-surface-scope-fallback prepared))
(patches (tp--prepared-surface-scope-patches prepared))
(touched
(if-let ((batch (tp--prepared-surface-commit-batch prepared)))
(if-let* ((batch (tp--prepared-surface-commit-batch prepared)))
(cl-loop for patch in (tp-commit-batch-patches batch)
sum (length (plist-get patch :replacement)))
(if (and scoped (not fallback))
@ -2894,7 +2894,7 @@ the generic property-operation ledger."
(defun tp--publish-buffer-content (prepared)
"Publish PREPARED's text and properties, returning operation counts."
(cl-block publish
(when-let ((batch (tp--prepared-surface-commit-batch prepared)))
(when-let* ((batch (tp--prepared-surface-commit-batch prepared)))
(let ((surface (tp--prepared-surface-surface prepared)))
(tp--commit-batch-apply-patches surface batch)
(tp--publication-step 'text surface)
@ -3000,7 +3000,7 @@ the generic property-operation ledger."
(if (tp--prepared-surface-retained-mount-state-p prepared)
(tp--retain-candidate-mount-state prepared)
(tp--create-candidate-mount-state prepared))
(when-let ((batch (and (not (tp--prepared-surface-retained-mount-state-p
(when-let* ((batch (and (not (tp--prepared-surface-retained-mount-state-p
prepared))
(tp--prepared-surface-commit-batch prepared))))
(tp--commit-batch-validate-mounts
@ -3138,12 +3138,12 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(pcase-let ((`(,buffer ,point-marker ,modified ,windows) state))
(when (buffer-live-p buffer)
(with-current-buffer buffer
(when-let ((position (marker-position point-marker)))
(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))))
(when-let* ((position (marker-position (cdr entry))))
(set-window-start (car entry) position t)))))
(unless retain-markers
(tp--dispose-marker point-marker)
@ -3436,14 +3436,14 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(defun tp--surface-final-accept ()
"Accept the active surface transaction's prepared change group."
(when-let ((state (tp--transaction-extension tp--surface-extension-key)))
(when-let ((group (gethash 'change-group state)))
(when-let* ((state (tp--transaction-extension tp--surface-extension-key)))
(when-let* ((group (gethash 'change-group state)))
(accept-change-group group))))
(defun tp--surface-precommit-transaction ()
"Prepare every fallible surface transition before signal commit."
(when-let ((state (tp--transaction-extension tp--surface-extension-key)))
(when-let ((table (gethash 'prepared state)))
(when-let* ((state (tp--transaction-extension tp--surface-extension-key)))
(when-let* ((table (gethash 'prepared state)))
(let ((all-prepared (tp--all-prepared-surfaces table))
(changed (gethash 'changed state)))
(when changed
@ -3462,7 +3462,7 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(list (tp--surface-snapshot-mounts snapshot)
(tp--surface-mounts surface)))
(dolist (mount mounts)
(when-let ((anchor (tp--surface-mount-anchor mount)))
(when-let* ((anchor (tp--surface-mount-anchor mount)))
(push anchor anchors)))))))
(puthash 'anchor-undo
(tp--capture-anchor-ownership-undo (nreverse anchors))
@ -3509,7 +3509,7 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(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)))
(when-let* ((state (tp--transaction-extension tp--surface-extension-key)))
(let (failures)
(cl-labels
((attempt (owner function)
@ -3550,9 +3550,9 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(defun tp--surface-finalize-killed-rollback ()
"Dispose candidate contexts and reapply killed-buffer teardown."
(when-let ((state (tp--transaction-extension tp--surface-extension-key)))
(when-let* ((state (tp--transaction-extension tp--surface-extension-key)))
(let (failures)
(when-let ((table (gethash 'prepared state)))
(when-let* ((table (gethash 'prepared state)))
(dolist (prepared (tp--all-prepared-surfaces table))
(let ((surface (tp--prepared-surface-surface prepared)))
(condition-case failure
@ -3572,7 +3572,7 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
"Return distinct range anchors referenced by MOUNTS."
(let ((seen (make-hash-table :test #'eq)) anchors)
(dolist (mount mounts)
(when-let ((anchor (tp--surface-mount-anchor mount)))
(when-let* ((anchor (tp--surface-mount-anchor mount)))
(unless (gethash anchor seen)
(puthash anchor t seen)
(push anchor anchors))))
@ -3652,7 +3652,7 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(defun tp--enqueue-surface-observers (surface)
"Schedule SURFACE observers outside the publishing transaction."
(when-let ((observers (tp--surface-observers surface)))
(when-let* ((observers (tp--surface-observers surface)))
(let ((observers (copy-sequence observers))
(report (tp-surface-report surface)))
(tp--enqueue-after-commit
@ -3660,7 +3660,7 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(defun tp--surface-commit-transaction ()
"Run contained postaccept cleanup for every transaction surface."
(when-let ((state (tp--transaction-extension tp--surface-extension-key)))
(when-let* ((state (tp--transaction-extension tp--surface-extension-key)))
(let ((changed (gethash 'changed state))
(snapshots (gethash 'snapshots state)))
(cl-labels
@ -3675,7 +3675,7 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(funcall function))
((error quit)
(tp--record-cleanup-error surface owner failure))))))
(when-let ((prepared (car changed)))
(when-let* ((prepared (car changed)))
(cleanup
(tp--prepared-surface-surface prepared) 'view-markers
(lambda () (tp--dispose-view-state (gethash 'views state)))))
@ -3701,7 +3701,7 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(lambda ()
(tp--dispose-ledger
(tp--surface-snapshot-ledger snapshot)))))))
(when-let ((table (gethash 'prepared state)))
(when-let* ((table (gethash 'prepared state)))
(dolist (prepared (tp--all-prepared-surfaces table))
(let* ((surface (tp--prepared-surface-surface prepared))
(context (tp--prepared-surface-context prepared)))