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

Integrate 0.3.0 feature tracks: reactive perf, stack visibility, search/API

Browse Source 
Reactive performance (tp-reactive/tp-render/tp-ops): layer->buffer
registry replaces full buffer-list scans on reactive updates, with a
conservative unknown->learning-scan fallback, kill-buffer pruning,
and tp-reactive-track-buffer to close the propertized-string-insert
gap; minimal-diff tp-text replacement preserves point and markers and
makes identical-text updates true no-ops; tp-gc-anonymous-layers
collects interned anonymous layers no registered buffer still shows.

Stack capabilities (tp-stack): tp-hide-layer/tp-show-layer visibility
(hidden layers stay in the stack but do not render; hiding the top
reveals the next visible layer), tp-lower-layer, tp-rotate-layer
DIRECTION/COUNT, tp-layer-stack-at, and modified-run-count returns
with NOERROR options.

Search and layer APIs (tp-search/tp-layer): SUBEXP capture groups and
START/END bounds for tp-regexp-*/tp-match-*, PREDICATE/NOT-CURRENT
exposure on tp-forward/tp-backward/-do (defaults keep 0.2.0 semantics),
multi-argument parameterized layers (define-tp/define-tps arglists of
any arity, tp-layer-props-with-args, tp-layer-arglist), and the
interactive tp-describe-layer.

79 new regression tests; combined suite 522/522 green, shuffled run
green, doctests 63/63, byte-compile clean with warnings-as-errors.

Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
This commit is contained in:
Kinneyzhang 2026-07-27 00:32:47 +08:00
parent 7f0da36ada
commit 507ccf798c
10 changed files with 2375 additions and 289 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

235
tp-layer-tests.el
View File

@ -338,5 +338,240 @@
(tp-layer-reset)
(should-not tp--anonymous-layer-registry)))
;;; 0.3.0 A4: multi-argument parameterized layers
(ert-deftest tp-layer-test-multi-arg-define-and-props-with-args ()
"define-tp accepts multi-symbol arglists; props-with-args expands them."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fgbg (fg bg)
`(face (:foreground ,fg :background ,bg)))
(should (tp-layer-parameterized-p 'tp-layer-test-fgbg))
(should (equal (tp-layer-arglist 'tp-layer-test-fgbg) '(fg bg)))
(should (equal (tp-layer-props-with-args 'tp-layer-test-fgbg
'("red" "blue"))
'(face (:foreground "red" :background "blue"))))
(should (equal (tp-layer-props-with-args 'tp-layer-test-fgbg
'("red" "blue") t)
'(face (:foreground "red" :background "blue")
tp-name tp-layer-test-fgbg)))))
(ert-deftest tp-layer-test-props-with-arg-is-thin-wrapper ()
"tp-layer-props-with-arg keeps its single-argument contract."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fg1 (c) `(face (:foreground ,c)))
(should (equal (tp-layer-props-with-arg 'tp-layer-test-fg1 "red")
'(face (:foreground "red"))))
(should (equal (tp-layer-props-with-arg 'tp-layer-test-fg1 "red")
(tp-layer-props-with-args 'tp-layer-test-fg1 '("red"))))))
(ert-deftest tp-layer-test-props-with-args-non-parameterized-nil ()
"props-with-args and tp-layer-arglist return nil for other layers."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-np () '(face bold))
(should-not (tp-layer-props-with-args 'tp-layer-test-np '(1)))
(should-not (tp-layer-arglist 'tp-layer-test-np))
(should-not (tp-layer-props-with-args 'tp-layer-test-missing '(1)))))
(ert-deftest tp-layer-test-multi-arg-tp-set-flat-string-form ()
"The flat (tp-set STRING \\='LAYER ARG1 ARG2) form binds all params."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fgbg (fg bg)
`(face (:foreground ,fg :background ,bg)))
(let ((s (tp-set "hello" 'tp-layer-test-fgbg "red" "blue")))
(should (equal (get-text-property 0 'face s)
'(:foreground "red" :background "blue"))))))
(ert-deftest tp-layer-test-multi-arg-tp-set-flat-with-extra-props ()
"Extra props after multi args survive, with no stray nil pair."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fgbg (fg bg)
`(face (:foreground ,fg :background ,bg)))
(let ((s (tp-set "hello" 'tp-layer-test-fgbg "red" "blue"
'help-echo "tip")))
(should (equal (plist-get (get-text-property 0 'face s) :foreground)
"red"))
(should (equal (get-text-property 0 'help-echo s) "tip"))
;; The odd-length flat spec is padded with nil by key merging;
;; resolution must strip it instead of setting a nil property.
(should (equal (text-properties-at 0 s)
'(face (:foreground "red" :background "blue")
help-echo "tip"))))))
(ert-deftest tp-layer-test-multi-arg-tp-set-region-list-form ()
"The region form (tp-set START END \\='(LAYER ARG1 ARG2)) works (1-based)."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fgbg (fg bg)
`(face (:foreground ,fg :background ,bg)))
(with-temp-buffer
(insert "hello")
(tp-set 1 4 '(tp-layer-test-fgbg "red" "blue"))
(should (equal (get-text-property 1 'face)
'(:foreground "red" :background "blue")))
(should-not (get-text-property 4 'face)))))
(ert-deftest tp-layer-test-multi-arg-tp-set-wrapped-args-plist-form ()
"The plist spec (LAYER (ARG1 ARG2) EXTRA...) passes args as one list."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fgbg (fg bg)
`(face (:foreground ,fg :background ,bg)))
;; Layer at the head of the plist.
(let ((s (copy-sequence "hello")))
(tp-set 0 5 '(tp-layer-test-fgbg ("red" "blue") help-echo "tip") s)
(should (equal (get-text-property 0 'face s)
'(:foreground "red" :background "blue")))
(should (equal (get-text-property 0 'help-echo s) "tip")))
;; Layer at a non-head plist position.
(let ((s (copy-sequence "hello")))
(tp-set 0 5 '(help-echo "tip" tp-layer-test-fgbg ("red" "blue")) s)
(should (equal (plist-get (get-text-property 0 'face s) :background)
"blue"))
(should (equal (get-text-property 0 'help-echo s) "tip")))))
(ert-deftest tp-layer-test-multi-arg-normalize-layer-spec ()
"tp--normalize-layer-spec accepts (LAYER ARG1 ARG2) specs."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fgbg (fg bg)
`(face (:foreground ,fg :background ,bg)))
(should (equal (tp--normalize-layer-spec
'(tp-layer-test-fgbg "red" "blue"))
'(face (:foreground "red" :background "blue")
tp-name tp-layer-test-fgbg)))))
(ert-deftest tp-layer-test-multi-arg-tp-put-layer ()
"tp-put-layer accepts multi-argument parameterized layer specs."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-fgbg (fg bg)
`(face (:foreground ,fg :background ,bg)))
(let ((s (copy-sequence "hi")))
(tp-put-layer s '(tp-layer-test-fgbg "red" "blue") 0)
(should (equal (get-text-property 0 'face s)
'(:foreground "red" :background "blue")))
(should (eq (get-text-property 0 'tp-name s) 'tp-layer-test-fgbg)))))
(ert-deftest tp-layer-test-multi-arg-cycle-detection ()
"Cycle detection still fires through the multi-argument path."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-mcyc (a b)
`(tp-layer-test-mcyc (,a ,b)))
(let ((err (should-error
(tp-layer-props-with-args 'tp-layer-test-mcyc '(1 2)))))
(should (string-match-p "cyclic layer reference"
(error-message-string err))))))
(ert-deftest tp-layer-test-multi-arg-props-are-copies ()
"props-with-args returns fresh copies; mutation cannot corrupt storage."
(tp-layer-tests--with-clean
;; The (:weight bold) subform is a shared constant in the
;; backquoted body; without copy-on-return, mutating the returned
;; plist would corrupt every later expansion.
(define-tp tp-layer-test-mcopy (a b)
`(face (:weight bold) help-echo ,(format "%s-%s" a b)))
(let ((props (tp-layer-props-with-args 'tp-layer-test-mcopy '("x" "y"))))
(setcar (plist-get props 'face) 'MUTATED))
(should (equal (tp-layer-props-with-args 'tp-layer-test-mcopy '("x" "y"))
'(face (:weight bold) help-echo "x-y")))))
(ert-deftest tp-layer-test-multi-arg-group ()
"define-tps accepts multi-symbol arglists usable through tp-set specs."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-mgrp (fg w)
`((face (:foreground ,fg)))
`((face (:weight ,w))))
(should (tp-group-parameterized-p 'tp-layer-test-mgrp))
(should (equal (tp--group-arglist 'tp-layer-test-mgrp) '(fg w)))
(should (equal (tp--group-props-with-args 'tp-layer-test-mgrp
'("red" bold))
'((face (:foreground "red")) (face (:weight bold)))))
;; Flat (GROUP ARG1 ARG2) spec through the tp-set pipeline.
(let ((props (tp--resolve-props '(tp-layer-test-mgrp "red" bold))))
(should (equal (plist-get props 'face) '(:foreground "red")))
(should (equal (plist-get props 'tp-layers)
'((face (:weight bold))))))
;; Single-argument groups keep working through the wrapper.
(define-tps tp-layer-test-sgrp (color)
`((face (:foreground ,color))))
(should (equal (tp-group-props-with-arg 'tp-layer-test-sgrp "red")
'((face (:foreground "red")))))))
;;; 0.3.0 A5: tp-describe-layer and its data collector
(ert-deftest tp-layer-test-describe-data-unified ()
"Describe data for a define-tp layer reports the unified format."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-du () '(face bold))
(let ((data (tp--describe-layer-data 'tp-layer-test-du)))
(should (eq (plist-get data :name) 'tp-layer-test-du))
(should (eq (plist-get data :format) 'unified))
(should (equal (plist-get data :body) '(quote (face bold))))
(should (equal (plist-get data :props)
'(face bold tp-name tp-layer-test-du)))
(should-not (plist-get data :arglist))
(should-not (plist-get data :reactive-deps))
(should-not (plist-get data :transform))
(should-not (plist-get data :group)))))
(ert-deftest tp-layer-test-describe-data-flat ()
"Describe data for an old-format layer reports the flat format."
(tp-layer-tests--with-clean
(tp--set-layer-props 'tp-layer-test-df '(face italic))
(let ((data (tp--describe-layer-data 'tp-layer-test-df)))
(should (eq (plist-get data :format) 'flat))
(should (equal (plist-get data :body) '(face italic)))
(should (equal (plist-get data :props)
'(face italic tp-name tp-layer-test-df))))))
(ert-deftest tp-layer-test-describe-data-parameterized ()
"Describe data for a parameterized layer reports arglist and a note."
(tp-layer-tests--with-clean
(define-tp tp-layer-test-dp (a b)
`(face (:foreground ,a :background ,b)))
(let ((data (tp--describe-layer-data 'tp-layer-test-dp)))
(should (eq (plist-get data :format) 'parameterized))
(should (equal (plist-get data :arglist) '(a b)))
;; Expanded props need arguments, so a placeholder note is used.
(should (stringp (plist-get data :props)))
(should (string-match-p "tp-layer-props-with-args"
(plist-get data :props))))))
(ert-deftest tp-layer-test-describe-data-reactive ()
"Describe data for a reactive layer reports format and dependencies."
(tp-layer-tests--with-clean
(setq tp-layer-test-b15-color "red")
(define-tp tp-layer-test-dr ()
'(face (:foreground $tp-layer-test-b15-color)))
(let ((data (tp--describe-layer-data 'tp-layer-test-dr)))
(should (eq (plist-get data :format) 'reactive))
(should (equal (plist-get data :reactive-deps)
'(tp-layer-test-b15-color))))))
(ert-deftest tp-layer-test-describe-data-group-and-transform ()
"Describe data reports the owning group and transform presence."
(tp-layer-tests--with-clean
(define-tps tp-layer-test-dg ()
'("a" :props (face bold) :transform upcase))
(let ((data (tp--describe-layer-data 'tp-layer-test-dg-a)))
(should (eq (plist-get data :group) 'tp-layer-test-dg))
(should (plist-get data :transform)))))
(ert-deftest tp-layer-test-describe-data-unknown-layer-nil ()
"Describe data returns nil for names not in tp-layer-alist."
(tp-layer-tests--with-clean
(should-not (tp--describe-layer-data 'tp-layer-test-nonexistent))))
(ert-deftest tp-layer-test-describe-layer-command ()
"tp-describe-layer is a command and renders a help buffer."
(should (commandp 'tp-describe-layer))
(tp-layer-tests--with-clean
(define-tp tp-layer-test-dc () '(face bold))
(save-window-excursion
(tp-describe-layer 'tp-layer-test-dc)
(with-current-buffer (help-buffer)
(should (string-match-p "tp-layer-test-dc is a tp layer"
(buffer-string)))
(should (string-match-p "Storage format: unified"
(buffer-string)))))
(should-error (tp-describe-layer 'tp-layer-test-missing)
:type 'user-error)))
(provide 'tp-layer-tests)
;;; tp-layer-tests.el ends here

402
tp-layer.el
View File

@ -101,9 +101,13 @@ For non-layer symbols, returns a list containing just that symbol."
((eq existing-tp-name layer-name)
(cond
;; Parameterized layer - get property keys it would produce
;; We pass a dummy arg (t) since we only need the key names, not values
;; We pass dummy args (t) since we only need the key
;; names, not values
((tp-layer-parameterized-p layer-name)
(tp-layer-props-with-arg layer-name t nil)) ; arg=t, include-tp-name=nil
(tp-layer-props-with-args
layer-name
(make-list (length (tp-layer-arglist layer-name)) t)
nil)) ; include-tp-name=nil
;; Non-parameterized layer
((assoc layer-name tp-layer-alist)
(tp-layer-props layer-name nil)) ; include-tp-name=nil
@ -116,7 +120,7 @@ For non-layer symbols, returns a list containing just that symbol."
(layer-prop-value
(cond
((tp-layer-parameterized-p layer-name)
(tp-layer-props-with-arg layer-name layer-prop-value nil))
(tp--layer-props-for-arg-value layer-name layer-prop-value nil))
((assoc layer-name tp-layer-alist)
(tp-layer-props layer-name nil))
((assoc layer-name tp-layer-groups)
@ -155,7 +159,7 @@ Returns the face value that the layer adds, or nil if no face contribution."
(let ((layer-props
(cond
((tp-layer-parameterized-p layer-name)
(tp-layer-props-with-arg layer-name layer-prop-value nil))
(tp--layer-props-for-arg-value layer-name layer-prop-value nil))
((assoc layer-name tp-layer-alist)
(tp-layer-props layer-name nil))
((assoc layer-name tp-layer-groups)
@ -320,9 +324,11 @@ Format 1 - Non-parameterized simple (empty arglist, simple body):
(define-tp tp-bold ()
\\='(face bold))
Format 2 - Parameterized simple (single argument, simple body):
Format 2 - Parameterized simple (one or more arguments, simple body):
(define-tp tp-space (pixel)
\\=`(display (space :width (,pixel))))
(define-tp tp-colors (fg bg)
\\=`(face (:foreground ,fg :background ,bg)))
Format 3 - Non-parameterized with reactive features
\(requires $-prefixed variables):
@ -340,7 +346,7 @@ Usage:
ARGLIST must be either:
- An empty list () for non-parameterized layers
- A list containing exactly one symbol for parameterized layers
- A list of one or more parameter symbols for parameterized layers
BODY is either:
- A single property list expression (simple format)
@ -356,7 +362,7 @@ $-prefixed reactive symbols appearing in a PARAMETERIZED body do not
create reactive dependencies (parameterized layers cannot be
reactive); they are resolved to the current value of the corresponding
variable each time the layer is evaluated via
`tp-layer-props-with-arg'.
`tp-layer-props-with-arg' or `tp-layer-props-with-args'.
Note: NAME cannot be a built-in Emacs text property name like `face',
`display', `invisible', etc. See `tp--builtin-text-properties' for the
@ -386,18 +392,18 @@ complete list of reserved names."
;; Non-parameterized: empty arglist - store as (LAYER-NAME nil BODY-FORM)
((null arglist)
`(tp--define-layer-unified ',name nil ,simple-body))
;; Parameterized: single argument - store as (LAYER-NAME ARGLIST BODY-FORM)
((and (= (length arglist) 1)
(symbolp (car arglist)))
;; Parameterized: one or more argument symbols - store as
;; (LAYER-NAME ARGLIST BODY-FORM)
((cl-every #'symbolp arglist)
`(tp--define-layer-unified ',name ',arglist ',simple-body))
(t
(error "define-tp ARGLIST must be empty or contain exactly one symbol"))))))))
(error "define-tp ARGLIST must be empty or a list of symbols"))))))))
(defun tp--define-layer-unified (name arglist body)
"Define a layer NAME with ARGLIST and BODY using unified structure.
For non-parameterized layers, ARGLIST is nil and BODY is the evaluated plist.
For parameterized layers, ARGLIST contains one symbol and BODY is the
unevaluated form.
For parameterized layers, ARGLIST is a list of one or more parameter
symbols and BODY is the unevaluated form.
Stores the layer in `tp-layer-alist' with format:
\(LAYER-NAME ARGLIST BODY-FORM).
@ -670,7 +676,7 @@ It follows the same format as `define-tp' for consistency.
ARGLIST must be either:
- An empty list () for non-parameterized groups
- A list containing exactly one symbol for parameterized groups
- A list of one or more parameter symbols for parameterized groups
BODY contains the layer definitions, which should be quoted lists.
@ -679,7 +685,7 @@ Format 1 - Non-parameterized (empty arglist):
\\='(display \"🌑\")
\\='(display \"🌕\"))
Format 2 - Parameterized (with argument):
Format 2 - Parameterized (with one or more arguments):
(define-tps my-status (color)
\\=`((face (:foreground ,color)))
\\='(face (:weight bold)))
@ -717,12 +723,11 @@ complete list of reserved names."
;; Non-parameterized: empty arglist
((null arglist)
`(tp--define-layer-group-internal ',name nil (list ,@body)))
;; Parameterized: single argument
((and (= (length arglist) 1)
(symbolp (car arglist)))
;; Parameterized: one or more argument symbols
((cl-every #'symbolp arglist)
`(tp--define-layer-group-unified ',name ',arglist '(list ,@body)))
(t
(error "define-tps ARGLIST must be empty or contain exactly one symbol"))))
(error "define-tps ARGLIST must be empty or a list of symbols"))))
;; For backward compatibility, keep define-tp-group as an alias
(defalias 'define-tp-group 'define-tps
@ -812,9 +817,60 @@ where ARGLIST is a non-nil list of argument symbols."
(not (null (car entry)))
(cl-every #'symbolp (car entry)))))
(defun tp-layer-arglist (layer-name)
"Return the parameter list of parameterized layer LAYER-NAME.
Returns nil when LAYER-NAME is not a parameterized layer (including
non-parameterized and undefined layers). The returned list is a copy
of the ARGLIST given to `define-tp', e.g. (fg bg) for a
two-parameter layer."
(when (tp-layer-parameterized-p layer-name)
(copy-sequence (car (cdr (assoc layer-name tp-layer-alist))))))
(defun tp-layer-props-with-args (layer-name args &optional include-tp-name)
"Return properties for parameterized layer LAYER-NAME with ARGS.
ARGS is a list of argument values bound positionally (via `cl-progv',
so dynamically) to the layer's parameters while the stored body form
is evaluated. Extra values are ignored; missing ones leave their
parameter unbound, which signals an error if the body refers to it.
If INCLUDE-TP-NAME is non-nil, appends `tp-name' property to identify
the layer.
Recursively expands any nested layer names in the returned plist.
$-prefixed reactive symbols in the body are resolved to the current
values of their variables at evaluation time; they do not create
reactive dependencies (parameterized layers cannot be reactive).
Signals an error naming the cycle if layer references are cyclic.
The returned plist is a fresh copy: mutating it does not affect the
stored layer definition.
Returns nil when LAYER-NAME is not a parameterized layer."
(when (tp-layer-parameterized-p layer-name)
(let* ((entry (cdr (assoc layer-name tp-layer-alist)))
(arglist (car entry))
(body (cadr entry)))
(tp--check-layer-cycle layer-name)
(let* ((tp--layer-expansion-stack
(cons layer-name tp--layer-expansion-stack))
;; Evaluate the body with all parameters bound. `eval'
;; without a lexical environment sees the dynamic
;; bindings established by `cl-progv'.
(plist (cl-progv arglist args (eval body))))
(when plist
;; Recursively expand nested layer names
(when (tp--plist-has-layer-key-p plist)
(setq plist (tp--expand-layer-in-plist plist)))
;; Resolve $-prefixed reactive symbols to their current values
;; so they never leak literally into the returned props.
(when (tp--collect-reactive-symbols plist)
(setq plist (tp--resolve-reactive-symbols plist)))
(copy-tree
(if include-tp-name
(append plist (list 'tp-name layer-name))
plist)))))))
(defun tp-layer-props-with-arg (layer-name arg &optional include-tp-name)
"Return properties for parameterized layer LAYER-NAME with ARG.
Evaluates the body form with the argument bound to the parameter.
This is the single-argument convenience over
`tp-layer-props-with-args', equivalent to calling it with (list ARG).
If INCLUDE-TP-NAME is non-nil, appends `tp-name' property to identify
the layer.
Recursively expands any nested layer names in the returned plist.
@ -824,29 +880,19 @@ reactive dependencies (parameterized layers cannot be reactive).
Signals an error naming the cycle if layer references are cyclic.
The returned plist is a fresh copy: mutating it does not affect the
stored layer definition."
(when-let ((entry (cdr (assoc layer-name tp-layer-alist))))
;; entry is (ARGLIST BODY-FORM)
(let ((arglist (car entry))
(body (cadr entry)))
(when arglist ; Only for parameterized layers
(tp--check-layer-cycle layer-name)
(let* ((tp--layer-expansion-stack
(cons layer-name tp--layer-expansion-stack))
(arg-sym (car arglist))
;; Evaluate the body with the argument bound
(plist (eval `(let ((,arg-sym ',arg)) ,body))))
(when plist
;; Recursively expand nested layer names
(when (tp--plist-has-layer-key-p plist)
(setq plist (tp--expand-layer-in-plist plist)))
;; Resolve $-prefixed reactive symbols to their current values
;; so they never leak literally into the returned props.
(when (tp--collect-reactive-symbols plist)
(setq plist (tp--resolve-reactive-symbols plist)))
(copy-tree
(if include-tp-name
(append plist (list 'tp-name layer-name))
plist))))))))
(tp-layer-props-with-args layer-name (list arg) include-tp-name))
(defun tp--layer-props-for-arg-value (layer-name value &optional include-tp-name)
"Return props for parameterized LAYER-NAME given a stored VALUE.
When LAYER-NAME takes more than one parameter and VALUE is a proper
list, VALUE is treated as the full argument list (as stored by the
plist-style spec (LAYER-NAME (ARG1 ARG2 ...))); otherwise VALUE is
the single argument (the single-parameter behavior).
INCLUDE-TP-NAME is passed through."
(if (and (proper-list-p value)
(> (length (tp-layer-arglist layer-name)) 1))
(tp-layer-props-with-args layer-name value include-tp-name)
(tp-layer-props-with-arg layer-name value include-tp-name)))
(defun tp-group-props (group-name &optional include-tp-name)
"Return list of properties for all layers in GROUP-NAME.
@ -882,6 +928,13 @@ where ARGLIST is a non-nil list of argument symbols."
(not (null (car entry)))
(cl-every #'symbolp (car entry)))))
(defun tp--group-arglist (group-name)
"Return the parameter list of parameterized group GROUP-NAME.
Returns nil when GROUP-NAME is not a parameterized group. The
returned list is a copy of the ARGLIST given to `define-tps'."
(when (tp-group-parameterized-p group-name)
(copy-sequence (car (cdr (assoc group-name tp-layer-groups))))))
(defun tp--group-anonymous-props (plist)
"Normalize anonymous-layer PLIST from a parameterized group element.
Expands nested layer names, resolves $-prefixed reactive symbols to
@ -913,10 +966,13 @@ Returns nil if SPEC cannot be interpreted."
((not (consp spec)) nil)
;; (LAYER-NAME ARG ...) - defined layer at the head
((and (symbolp (car spec)) (tp--is-layer-name-p (car spec)))
(let ((layer-name (car spec))
(layer-arg (cadr spec)))
(let ((layer-name (car spec)))
(if (tp-layer-parameterized-p layer-name)
(tp-layer-props-with-arg layer-name layer-arg include-tp-name)
;; Bind as many arguments as the layer has parameters.
(tp-layer-props-with-args
layer-name
(-take (length (tp-layer-arglist layer-name)) (cdr spec))
include-tp-name)
;; Non-parameterized layer - arg should be t or ignored
(tp-layer-props layer-name include-tp-name))))
;; ("NAME" :props PLIST) or ("NAME" . PLIST) - use the props part
@ -933,26 +989,49 @@ Returns nil if SPEC cannot be interpreted."
(tp--group-anonymous-props spec))
(t nil)))
(defun tp--group-props-with-args (group-name args &optional include-tp-name)
"Return list of properties for parameterized group GROUP-NAME with ARGS.
ARGS is a list of argument values bound positionally (via `cl-progv',
so dynamically) to the group's parameters while the stored body form
is evaluated. Each evaluated element is converted like
`tp-group-props-with-arg' documents. If INCLUDE-TP-NAME is non-nil,
named layer references include tp-name.
Returns nil when GROUP-NAME is not a parameterized group."
(when (tp-group-parameterized-p group-name)
(let* ((entry (cdr (assoc group-name tp-layer-groups)))
(arglist (car entry))
(body-form (cadr entry))
;; Evaluate the body with all parameters bound - returns
;; list of layer specs.
(layer-specs (cl-progv arglist args (eval body-form))))
;; Convert layer specs to property lists
(mapcar (lambda (spec)
(tp--group-spec-to-props spec include-tp-name))
layer-specs))))
(defun tp-group-props-with-arg (group-name arg &optional include-tp-name)
"Return list of properties for parameterized group GROUP-NAME with ARG.
Evaluates the body form with the argument bound to the parameter.
This is the single-argument convenience over the multi-argument path
\(`tp--group-props-with-args'), equivalent to passing (list ARG).
Each evaluated element may be a layer name symbol, a (LAYER-NAME ARG)
reference, a named element (\"NAME\" . PLIST) / (\"NAME\" :props PLIST),
or a raw property list (anonymous layer) as documented in `define-tps'.
If INCLUDE-TP-NAME is non-nil, named layer references include tp-name.
Returns a list of property lists for each layer in the group."
(when-let ((entry (cdr (assoc group-name tp-layer-groups))))
;; entry is (ARGLIST BODY-FORM)
(let ((arglist (car entry))
(body-form (cadr entry)))
(when arglist ; Only for parameterized groups
(let* ((arg-sym (car arglist))
;; Evaluate the body with the argument bound - returns list of layer specs
(layer-specs (eval `(let ((,arg-sym ',arg)) ,body-form))))
;; Convert layer specs to property lists
(mapcar (lambda (spec)
(tp--group-spec-to-props spec include-tp-name))
layer-specs))))))
(tp--group-props-with-args group-name (list arg) include-tp-name))
(defun tp--group-props-for-arg-value (group-name value &optional include-tp-name)
"Return props list for parameterized GROUP-NAME given a stored VALUE.
When GROUP-NAME takes more than one parameter and VALUE is a proper
list, VALUE is treated as the full argument list (as stored by the
plist-style spec (GROUP-NAME (ARG1 ARG2 ...))); otherwise VALUE is
the single argument (the single-parameter behavior).
INCLUDE-TP-NAME is passed through."
(if (and (proper-list-p value)
(> (length (tp--group-arglist group-name)) 1))
(tp--group-props-with-args group-name value include-tp-name)
(tp-group-props-with-arg group-name value include-tp-name)))
(defun tp--is-layer-name-p (sym)
"Return non-nil if SYM is a defined layer, parameterized layer, or group name."
@ -982,15 +1061,18 @@ Returns the expanded plist."
((tp--is-layer-name-p key)
(let ((layer-props
(cond
;; Parameterized layer - evaluate with the argument (val)
;; Parameterized layer - evaluate with the argument (val);
;; for multi-parameter layers a list VAL carries all args
((tp-layer-parameterized-p key)
(tp-layer-props-with-arg key val nil)) ; no tp-name
(tp--layer-props-for-arg-value key val nil)) ; no tp-name
;; Non-parameterized layer - val should be t
((assoc key tp-layer-alist)
(tp-layer-props key nil)) ; no tp-name
;; Parameterized layer group - evaluate with the argument (val)
;; Parameterized layer group - evaluate with the argument (val);
;; for multi-parameter groups a list VAL carries all args
((tp-group-parameterized-p key)
(when-let ((layer-props-list (tp-group-props-with-arg key val t)))
(when-let ((layer-props-list
(tp--group-props-for-arg-value key val t)))
;; Build layered structure: first layer at top, rest in tp-layers
(tp--build-layer-props layer-props-list)))
;; Non-parameterized layer group - build layered structure
@ -1013,6 +1095,18 @@ Returns the expanded plist."
(tp--merge-duplicate-keys result)
result)))
(defun tp--strip-trailing-plist-nil (plist)
"Remove a lone trailing nil from odd-length PLIST.
`tp--merge-duplicate-keys' pads an odd-length property spec (a flat
\(LAYER ARG1 ARG2 EXTRA-PROP VAL) call for a multi-parameter layer)
with a trailing nil value; strip it so the extra properties form a
proper plist again."
(if (and plist
(cl-oddp (length plist))
(null (car (last plist))))
(butlast plist)
plist))
(defun tp--resolve-props (props)
"Resolve PROPS to a property list with layer metadata.
PROPS can be:
@ -1023,6 +1117,12 @@ PROPS can be:
for parameterized layers
- A list starting with (LAYER-NAME ARG EXTRA-PROPS...) where extra properties
are merged with the layer properties
- For multi-parameter layers/groups, (LAYER-NAME ARG1 ARG2 ...
EXTRA-PROPS...) binds as many leading elements as the layer has
parameters; alternatively (LAYER-NAME (ARG1 ARG2 ...) EXTRA-PROPS...)
passes all arguments as one list (recognized when the list's length
equals the layer's parameter count and the remaining elements form
an even-length plist)
- A plist with layer names at any position - they will be expanded inline
- A plist (handles anonymous layers with reactive variables)
@ -1032,8 +1132,10 @@ If PROPS is a symbol:
If PROPS is (LAYER-NAME ARG) or (LAYER-NAME ARG EXTRA-PROPS...):
- For non-parameterized layers: if ARG is t, returns the layer properties
- For parameterized layers: evaluates the body with ARG and returns the result
- Extra properties after ARG are appended to the layer properties
- For parameterized layers: evaluates the body with the argument(s)
and returns the result
- Extra properties after the argument(s) are appended to the layer
properties
If PROPS is a plist with layer names at any position:
- Layer names are expanded inline with their properties
@ -1055,32 +1157,54 @@ For group names, includes `tp-layers' property with the full layer stack."
;; Already a plist - check for reactive variables and add tp-name
((listp props)
(let ((first-elem (car-safe props))
(second-elem (cadr props))
(extra-props (cddr props)))
(second-elem (cadr props)))
(cond
;; Handle (layer-name arg ...) format for defined layers at the START
;; This includes both (layer-name arg) and (layer-name arg extra-prop val ...)
((and (>= (length props) 2)
(tp--is-layer-name-p first-elem))
(let ((layer-props
(cond
;; Parameterized layer - evaluate with the argument
((tp-layer-parameterized-p first-elem)
(tp-layer-props-with-arg first-elem second-elem nil)) ; no tp-name
;; Non-parameterized layer - arg should be t, return the layer props
;; (silently ignore non-t values for flexibility)
((assoc first-elem tp-layer-alist)
(tp-layer-props first-elem nil)) ; no tp-name
;; Parameterized layer group - evaluate with the argument
((tp-group-parameterized-p first-elem)
(when-let ((layer-props-list (tp-group-props-with-arg first-elem second-elem t)))
;; Build layered structure: first layer at top, rest in tp-layers
(tp--build-layer-props layer-props-list)))
;; Non-parameterized layer group - build layered structure
((assoc first-elem tp-layer-groups)
(when-let ((layer-props-list (tp-group-props first-elem t)))
;; Build layered structure: first layer at top, rest in tp-layers
(tp--build-layer-props layer-props-list))))))
(let* ((arity (cond ((tp-layer-parameterized-p first-elem)
(length (tp-layer-arglist first-elem)))
((tp-group-parameterized-p first-elem)
(length (tp--group-arglist first-elem)))
;; Non-parameterized: one slot is consumed
;; by the conventional `t' argument.
(t 1)))
;; Plist-style multi-arg spec (LAYER (ARG1 ... ARGN)
;; EXTRA...): the element after the name carries all
;; arguments when it is a list of exactly ARITY values
;; and the remaining elements form an even-length plist.
(wrapped-args (and (> arity 1)
(proper-list-p second-elem)
(= (length second-elem) arity)
(cl-evenp (length (cddr props)))))
(args (if wrapped-args
second-elem
(-take arity (cdr props))))
(extra-props (if wrapped-args
(cddr props)
(tp--strip-trailing-plist-nil
(-drop arity (cdr props)))))
(layer-props
(cond
;; Parameterized layer - evaluate with the argument(s)
((tp-layer-parameterized-p first-elem)
(tp-layer-props-with-args first-elem args nil)) ; no tp-name
;; Non-parameterized layer - arg should be t, return the layer props
;; (silently ignore non-t values for flexibility)
((assoc first-elem tp-layer-alist)
(tp-layer-props first-elem nil)) ; no tp-name
;; Parameterized layer group - evaluate with the argument(s)
((tp-group-parameterized-p first-elem)
(when-let ((layer-props-list
(tp--group-props-with-args first-elem args t)))
;; Build layered structure: first layer at top, rest in tp-layers
(tp--build-layer-props layer-props-list)))
;; Non-parameterized layer group - build layered structure
((assoc first-elem tp-layer-groups)
(when-let ((layer-props-list (tp-group-props first-elem t)))
;; Build layered structure: first layer at top, rest in tp-layers
(tp--build-layer-props layer-props-list))))))
;; Recursively resolve extra properties (they may also contain layer names)
(let ((expanded-props
(if (and layer-props extra-props)
@ -1233,7 +1357,9 @@ Used by layer stack functions that need tp-name for identification.
LAYER-SPEC can be:
- A symbol (non-parameterized layer name from define-tp or
tp--define-layer-internal)
- A list (LAYER-NAME ARG) for parameterized layers from define-tp
- A list (LAYER-NAME ARG ...) for parameterized layers from
define-tp, with exactly as many arguments as the layer has
parameters
- A plist for inline layer definition
- A list (NAME &rest PLIST) for named inline layer"
(cond
@ -1257,12 +1383,13 @@ LAYER-SPEC can be:
(let ((name (car layer-spec))
(rest (cdr layer-spec)))
(cond
;; Parameterized layer: (LAYER-NAME ARG)
;; Parameterized layer: (LAYER-NAME ARG ...) with exactly as
;; many arguments as the layer has parameters
((and (tp-layer-parameterized-p name)
(= (length rest) 1))
(or (tp-layer-props-with-arg name (car rest) t) ; include tp-name
(error "Failed to resolve parameterized layer %S with arg %S"
name (car rest))))
(= (length rest) (length (tp-layer-arglist name))))
(or (tp-layer-props-with-args name rest t) ; include tp-name
(error "Failed to resolve parameterized layer %S with args %S"
name rest)))
;; Named inline layer: (NAME &rest PLIST)
(rest
(append rest (list 'tp-name name)))
@ -1302,6 +1429,101 @@ First element is top layer, rest are in tp-layers."
(cons top belows)
belows))
(defun tp--describe-layer-data (name)
"Collect description data for layer NAME as a plist.
Returns nil when NAME is not registered in `tp-layer-alist'.
The returned plist has these keys:
:name NAME itself.
:format Storage format: `parameterized' (unified storage with
a non-empty arglist), `reactive' (flat storage with
reactive dependencies registered), `unified' (from
`define-tp' with an empty arglist) or `flat' (old
direct plist storage).
:arglist The parameter list for parameterized layers, else nil.
:body The raw stored body: the unevaluated BODY-FORM for
unified/parameterized layers, the stored plist for
flat/reactive layers.
:props The expanded properties from `tp-layer-props' (with
tp-name), or a placeholder string for parameterized
layers, which need arguments
\(see `tp-layer-props-with-args').
:reactive-deps List of reactive variable symbols NAME depends on,
from tp-reactive's `tp-reactive-deps' registry.
:transform Non-nil when a transform is registered for NAME in
`tp-layer-transforms'.
:group The group that generated NAME (from
`tp--group-generated-layers'), or nil."
(when-let ((entry (cdr (assoc name tp-layer-alist))))
(let* ((parameterized (tp-layer-parameterized-p name))
(reactive (tp--layer-has-reactive-deps-p name))
(unified (and (= (length entry) 2)
(or (null (car entry))
(and (listp (car entry))
(cl-every #'symbolp (car entry))))))
(format (cond (parameterized 'parameterized)
(reactive 'reactive)
(unified 'unified)
(t 'flat)))
(arglist (when parameterized (tp-layer-arglist name)))
(body (if unified (cadr entry) entry))
(props (if parameterized
"parameterized layer: expand with `tp-layer-props-with-args'"
(tp-layer-props name t)))
(deps (cl-loop for dep in tp-reactive-deps
when (assoc name (cdr dep))
collect (car dep)))
(transform (and (assoc name tp-layer-transforms) t))
(group (cl-loop for (group-name . layers)
in tp--group-generated-layers
when (memq name layers)
return group-name)))
(list :name name
:format format
:arglist arglist
:body body
:props props
:reactive-deps deps
:transform transform
:group group))))
;;;###autoload
(defun tp-describe-layer (name)
"Display a help buffer describing the tp layer NAME.
NAME is a layer registered in `tp-layer-alist'. Interactively,
prompt with completion over the registered layers.
The buffer shows the storage format (flat, unified, parameterized or
reactive), the raw stored body, the expanded properties (or a
placeholder for parameterized layers, which need arguments), the
parameter list, the reactive variables the layer depends on, whether
a transform is registered, and the group that generated the layer,
if any."
(interactive
(list (intern (completing-read "Describe tp layer: "
(mapcar #'car tp-layer-alist)
nil t))))
(let ((data (tp--describe-layer-data name)))
(unless data
(user-error "No tp layer named `%s'" name))
(with-help-window (help-buffer)
(princ (format "%s is a tp layer.\n\n" name))
(princ (format "Storage format: %s\n" (plist-get data :format)))
(when (plist-get data :arglist)
(princ (format "Arguments: %S\n" (plist-get data :arglist))))
(princ (format "Stored body: %S\n" (plist-get data :body)))
(let ((props (plist-get data :props)))
(princ (format "Expanded props: %s\n"
(if (stringp props) props (format "%S" props)))))
(princ (format "Reactive deps: %s\n"
(if (plist-get data :reactive-deps)
(mapconcat #'symbol-name
(plist-get data :reactive-deps) ", ")
"none")))
(princ (format "Transform: %s\n"
(if (plist-get data :transform) "yes" "no")))
(when (plist-get data :group)
(princ (format "Generated by: group %s\n"
(plist-get data :group)))))))
(defun tp--get-layer-by-idx-or-name (layers idx-or-name)
"Find layer in LAYERS by IDX-OR-NAME.
Returns (index . layer-props) or nil."

16
tp-ops.el
View File

@ -22,6 +22,7 @@
(require 'cl-lib)
(require 'dash)
(require 'tp-core)
(require 'tp-reactive)
(require 'tp-layer)
(defvar tp--tp-text-handler-function nil
@ -111,6 +112,18 @@ Supports multiple calling conventions:
(setq props (or (tp--resolve-props props) props)))
(list object start finish props)))
(defun tp--ops-register-layer-buffer (props object)
"Record OBJECT in the reactive buffer registry for PROPS's layer.
When PROPS carries a `tp-name' (a resolved layer application) and
OBJECT is a buffer or nil (the current buffer), register that buffer
under the layer's name so reactive updates can walk only registered
buffers instead of scanning `buffer-list'. String OBJECTs are not
registered; see `tp-reactive-layer-buffers' for that gap."
(when-let ((layer-name (plist-get props 'tp-name)))
(when (or (null object) (bufferp object))
(tp-reactive--register-layer-buffer
layer-name (or object (current-buffer))))))
(defun tp--apply-props-to-string (str start end props &optional merge-mode)
"Apply PROPS to string STR from START to END, returning a NEW string.
This function does not modify the original string.
@ -215,6 +228,7 @@ Returns: For buffers, (START . END) cons. For strings, the result string."
(set-text-properties start finish props object)
(cl-loop for (key val) on props by #'cddr
do (put-text-property start finish key val object))))
(tp--ops-register-layer-buffer props object)
(cons start finish))))))
(defun tp-reset (start-or-string &optional end-or-prop props-or-val &rest rest)
@ -252,6 +266,7 @@ Returns: For buffers, (START . END) cons. For strings, the result string."
;; Buffer: modify in place
(t
(set-text-properties start finish props object)
(tp--ops-register-layer-buffer props object)
(cons start finish))))))
(defun tp-add (start-or-string &optional end-or-prop props-or-val &rest rest)
@ -331,6 +346,7 @@ Returns: For buffers, (START . END) cons. For strings, the result string."
(t val))))
(put-text-property pos next-pos key new-val object)))
(setq pos next-pos))))
(tp--ops-register-layer-buffer props object)
(cons start finish))))))
(defun tp-get (start-or-string &optional end-or-property &rest args)

102
tp-reactive.el
View File

@ -40,6 +40,99 @@ Each element: (VAR-SYMBOL . ((LAYER-NAME . REACTIVE-PROPS) ...)).")
Each entry is a list (LAYER-NAME CHANGED-SYMBOLS WHERE TP-TEXT-AFFECTED).
Entries are created and widened by `tp--queue-batch-update'.")
(defvar tp--layer-buffers (make-hash-table :test 'equal)
"Hash table mapping layer names to buffers showing their regions.
Keys are layer names; values are lists of buffers registered via
`tp-reactive--register-layer-buffer'. Reactive updates walk only
these buffers instead of scanning `buffer-list' (see
`tp-reactive-layer-buffers'). A key holding an empty list means
\"known: no buffer shows this layer\", which is distinct from an
absent key (`unknown').")
(defvar tp--layer-buffers-hook-installed nil
"Non-nil once the registry's `kill-buffer-hook' pruner is installed.")
(defun tp-reactive--install-kill-buffer-hook ()
"Install the global `kill-buffer-hook' pruning the buffer registry.
Idempotent; guarded by `tp--layer-buffers-hook-installed'."
(unless tp--layer-buffers-hook-installed
(add-hook 'kill-buffer-hook #'tp-reactive--prune-killed-buffer)
(setq tp--layer-buffers-hook-installed t)))
(defun tp-reactive--prune-killed-buffer ()
"Drop the buffer being killed from `tp--layer-buffers'.
Runs on `kill-buffer-hook' with the dying buffer current. The layer
entries themselves are kept: an entry left with an empty list means
\"known: no buffer shows this layer\", not `unknown'."
(let ((buf (current-buffer)))
(maphash (lambda (layer bufs)
(when (memq buf bufs)
(puthash layer (delq buf bufs) tp--layer-buffers)))
tp--layer-buffers)))
(defun tp-reactive--register-layer-buffer (layer-name buffer)
"Register BUFFER as showing regions of layer LAYER-NAME.
Idempotent: registering the same live BUFFER again keeps a single
entry. Dead buffers and a nil LAYER-NAME are ignored. Installs the
`kill-buffer-hook' pruner on first use. See
`tp-reactive-layer-buffers' for the consumer side of the registry."
(when (and layer-name (buffer-live-p buffer))
(tp-reactive--install-kill-buffer-hook)
(let ((bufs (gethash layer-name tp--layer-buffers)))
(unless (memq buffer bufs)
(puthash layer-name (cons buffer bufs) tp--layer-buffers)))))
(defun tp-reactive-layer-buffers (layer-name)
"Return the live buffers registered as showing layer LAYER-NAME.
Return a list of live buffers - possibly empty, meaning \"known: no
buffer shows this layer\" - or the symbol `unknown' when LAYER-NAME
has no registry entry at all. Killed buffers still recorded in the
registry are dropped lazily by this accessor.
KNOWN GAP: inserting an already-propertized STRING into a buffer
bypasses the buffer operations that register buffers, so such a
buffer is missing here until a reactive update's full-scan fallback
finds it or `tp-reactive-track-buffer' is called on it."
(let ((bufs (gethash layer-name tp--layer-buffers 'unknown)))
(if (eq bufs 'unknown)
'unknown
(let ((live (cl-remove-if-not #'buffer-live-p bufs)))
(unless (= (length live) (length bufs))
(puthash layer-name live tp--layer-buffers))
live))))
;;;###autoload
(defun tp-reactive-track-buffer (&optional buffer)
"Scan BUFFER for layer regions and register it in the buffer registry.
BUFFER defaults to the current buffer. Walk BUFFER's `tp-name' text
property intervals and register BUFFER for every layer name found, so
reactive updates visit it without a full `buffer-list' scan.
Call this after inserting an already-propertized string into a
buffer: string application bypasses the buffer operations that
register buffers (see `tp-reactive-layer-buffers'), and this command
closes that gap. Return the list of layer names registered, in
buffer order."
(interactive)
(let ((buf (or buffer (current-buffer)))
(found nil))
(with-current-buffer buf
(save-excursion
(let ((pos (point-min))
(max (point-max)))
(while (< pos max)
(let ((name (get-text-property pos 'tp-name))
(next (or (next-single-property-change pos 'tp-name nil max)
max)))
(when (and name (not (member name found)))
(tp-reactive--register-layer-buffer name buf)
(push name found))
(setq pos next))))))
(when (called-interactively-p 'interactive)
(message "tp: tracking %d layer(s) in %s"
(length found) (buffer-name buf)))
(nreverse found)))
(defvar tp--batch-update-active nil
"When non-nil, we are inside a `tp-with-batch-updates' form.")
@ -122,7 +215,11 @@ Only the reactive portions of the properties are stored for each variable."
;; Also clean up layer watchers, computed properties, and data
(tp--unregister-layer-watchers layer-name)
(tp--unregister-layer-computed layer-name)
(tp--unregister-layer-data layer-name))
(tp--unregister-layer-data layer-name)
;; Drop the layer's buffer-registry entry: an undefined (or about to
;; be redefined) layer must not linger as stale "known" state; the
;; next update or refresh falls back to a learning full scan.
(remhash layer-name tp--layer-buffers))
(defun tp--layer-has-reactive-deps-p (layer-name)
"Return non-nil if LAYER-NAME has reactive dependencies registered.
@ -366,7 +463,8 @@ it to allow re-definition to change initial values."
(setq tp-reactive-deps nil)
(setq tp-layer-watchers nil)
(setq tp-layer-computed nil)
(setq tp-layer-data nil))
(setq tp-layer-data nil)
(clrhash tp--layer-buffers))
(provide 'tp-reactive)
;;; tp-reactive.el ends here

281
tp-render-tests.el
View File

@ -34,6 +34,16 @@
(defvar tp-rt-b18-text nil)
(defvar tp-rt-b19-amount nil)
(defvar tp-rt-b19s-amount nil)
(defvar tp-rt-r1-color nil)
(defvar tp-rt-r1b-color nil)
(defvar tp-rt-r1c-color nil)
(defvar tp-rt-r1d-color nil)
(defvar tp-rt-r2-text nil)
(defvar tp-rt-r2m-text nil)
(defvar tp-rt-r2n-text nil)
(defvar tp-rt-r3a-color nil)
(defvar tp-rt-r3b-color nil)
(defvar tp-rt-r3c-color nil)
(defmacro tp-rt-with-cleanup (layers vars &rest body)
"Run BODY, then undefine LAYERS and reset VARS to nil (teardown)."
@ -360,5 +370,276 @@
(should (equal (get-text-property 0 'tp-text result) "5.00"))
(should (eq (get-text-property 0 'face result) 'bold)))))
;;; R1 (0.3.0): reactive buffer registry replaces the buffer-list scan
(ert-deftest tp-render-test-registry-update-visits-only-registered ()
"A reactive update walks only registered buffers, not `buffer-list'."
(tp-rt-with-cleanup (tp-rt-r1-layer) (tp-rt-r1-color)
(setq tp-rt-r1-color "red")
(define-tp tp-rt-r1-layer () '(face (:foreground $tp-rt-r1-color)))
(let ((buf-a (generate-new-buffer " tp-rt-r1-a"))
(buf-b (generate-new-buffer " tp-rt-r1-b"))
(visited nil))
(unwind-protect
(progn
(with-current-buffer buf-a
(insert "Hello")
(tp-set 1 6 'tp-rt-r1-layer))
(with-current-buffer buf-b (insert "Hello"))
;; Applying through tp-ops registered the buffer
(should (equal (tp-reactive-layer-buffers 'tp-rt-r1-layer)
(list buf-a)))
;; Count per-buffer visits of the update walk
(let ((orig (symbol-function 'tp--render-visit-buffer)))
(cl-letf (((symbol-function 'tp--render-visit-buffer)
(lambda (buf fn)
(push buf visited)
(funcall orig buf fn))))
(setq tp-rt-r1-color "blue")))
;; Only the registered buffer was visited
(should (equal visited (list buf-a)))
(with-current-buffer buf-a
(should (equal (plist-get (get-text-property 1 'face)
:foreground)
"blue"))))
(kill-buffer buf-a)
(kill-buffer buf-b)))))
(ert-deftest tp-render-test-registry-prunes-on-kill-buffer ()
"Killing a buffer removes it from the layer-buffer registry."
(tp-rt-with-cleanup (tp-rt-r1b-layer) (tp-rt-r1b-color)
(setq tp-rt-r1b-color "red")
(define-tp tp-rt-r1b-layer () '(face (:foreground $tp-rt-r1b-color)))
(let ((buf (generate-new-buffer " tp-rt-r1b")))
(unwind-protect
(progn
(with-current-buffer buf
(insert "Hello")
(tp-set 1 6 'tp-rt-r1b-layer))
(should (equal (tp-reactive-layer-buffers 'tp-rt-r1b-layer)
(list buf)))
(kill-buffer buf)
;; The kill-buffer hook pruned the raw registry entry ...
(should-not (memq buf (gethash 'tp-rt-r1b-layer
tp--layer-buffers)))
;; ... and the accessor answers "known: none", NOT `unknown'.
(should (null (tp-reactive-layer-buffers 'tp-rt-r1b-layer)))
(should-not (eq (tp-reactive-layer-buffers 'tp-rt-r1b-layer)
'unknown)))
(when (buffer-live-p buf) (kill-buffer buf))))))
(ert-deftest tp-render-test-registry-unknown-full-scan-learns ()
"An `unknown' layer falls back to a full scan and learns its buffers."
(tp-rt-with-cleanup (tp-rt-r1c-layer) (tp-rt-r1c-color)
(setq tp-rt-r1c-color "red")
(define-tp tp-rt-r1c-layer () '(face (:foreground $tp-rt-r1c-color)))
(let ((buf (generate-new-buffer " tp-rt-r1c")))
(unwind-protect
(progn
(with-current-buffer buf
(insert "Hello")
(tp-set 1 6 'tp-rt-r1c-layer))
;; Simulate a buffer that got the layer outside the
;; registering paths: erase the registry knowledge.
(remhash 'tp-rt-r1c-layer tp--layer-buffers)
(should (eq (tp-reactive-layer-buffers 'tp-rt-r1c-layer)
'unknown))
;; The update still reaches the buffer (conservative fallback)
(setq tp-rt-r1c-color "blue")
(with-current-buffer buf
(should (equal (plist-get (get-text-property 1 'face)
:foreground)
"blue")))
;; ... and the scan registered the buffer it found (learning)
(should (equal (tp-reactive-layer-buffers 'tp-rt-r1c-layer)
(list buf))))
(kill-buffer buf)))))
(ert-deftest tp-render-test-track-buffer-closes-string-insert-gap ()
"`tp-reactive-track-buffer' registers a buffer filled by string insert."
(tp-rt-with-cleanup (tp-rt-r1d-layer) (tp-rt-r1d-color)
(setq tp-rt-r1d-color "red")
(define-tp tp-rt-r1d-layer () '(face (:foreground $tp-rt-r1d-color)))
(let ((buf-a (generate-new-buffer " tp-rt-r1d-a"))
(buf-b (generate-new-buffer " tp-rt-r1d-b")))
(unwind-protect
(progn
(with-current-buffer buf-a
(insert "Hello")
(tp-set 1 6 'tp-rt-r1d-layer))
;; Inserting an already-propertized STRING bypasses the
;; registering buffer operations.
(let ((s (tp-set "Hi" 'tp-rt-r1d-layer)))
(with-current-buffer buf-b (insert s)))
(should-not (memq buf-b
(tp-reactive-layer-buffers 'tp-rt-r1d-layer)))
;; The layer is known, so buf-b is NOT updated (the gap) ...
(setq tp-rt-r1d-color "blue")
(with-current-buffer buf-b
(should (equal (plist-get (get-text-property 1 'face)
:foreground)
"red")))
;; ... until tp-reactive-track-buffer closes it.
(should (equal (with-current-buffer buf-b
(tp-reactive-track-buffer))
'(tp-rt-r1d-layer)))
(should (memq buf-b
(tp-reactive-layer-buffers 'tp-rt-r1d-layer)))
(setq tp-rt-r1d-color "green")
(with-current-buffer buf-b
(should (equal (plist-get (get-text-property 1 'face)
:foreground)
"green")))
(with-current-buffer buf-a
(should (equal (plist-get (get-text-property 1 'face)
:foreground)
"green"))))
(kill-buffer buf-a)
(kill-buffer buf-b)))))
;;; R2 (0.3.0): minimal-diff tp-text replacement
(ert-deftest tp-render-test-minimal-diff-point-in-prefix-stays ()
"Point in the common prefix survives a reactive text edit unmoved."
(tp-rt-with-cleanup (tp-rt-r2-layer) (tp-rt-r2-text)
(setq tp-rt-r2-text "abcdef")
(define-tp tp-rt-r2-layer () '(tp-text $tp-rt-r2-text))
(with-temp-buffer
(insert "abcdef")
(tp-set 1 7 'tp-rt-r2-layer)
(goto-char 2) ; inside the common prefix "ab"
(setq tp-rt-r2-text "abXYef")
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"abXYef"))
(should (= (point) 2)))))
(ert-deftest tp-render-test-minimal-diff-point-in-suffix-stays ()
"Point in the common suffix stays glued to its character."
(tp-rt-with-cleanup (tp-rt-r2-layer) (tp-rt-r2-text)
(setq tp-rt-r2-text "abcdef")
(define-tp tp-rt-r2-layer () '(tp-text $tp-rt-r2-text))
(with-temp-buffer
(insert "abcdef")
(tp-set 1 7 'tp-rt-r2-layer)
(goto-char 6) ; on the "f" of the suffix "ef"
;; Same-length edit: point must not move at all
(setq tp-rt-r2-text "abXYef")
(should (= (point) 6))
(should (eq (char-after) ?f))
;; Length-changing edit: point stays glued to its character
(setq tp-rt-r2-text "abXYZWef")
(should (= (point) 8))
(should (eq (char-after) ?f)))))
(ert-deftest tp-render-test-minimal-diff-point-inside-diff-clamps ()
"Point inside the differing span ends up at the edit start."
(tp-rt-with-cleanup (tp-rt-r2-layer) (tp-rt-r2-text)
(setq tp-rt-r2-text "abcdef")
(define-tp tp-rt-r2-layer () '(tp-text $tp-rt-r2-text))
(with-temp-buffer
(insert "abcdef")
(tp-set 1 7 'tp-rt-r2-layer)
(goto-char 4) ; on "d", inside the "cd" -> "XY" span
(setq tp-rt-r2-text "abXYef")
(should (= (point) 3)))))
(ert-deftest tp-render-test-minimal-diff-markers-survive ()
"Markers in the unchanged prefix and suffix survive a text update."
(tp-rt-with-cleanup (tp-rt-r2m-layer) (tp-rt-r2m-text)
(setq tp-rt-r2m-text "abcdef")
(define-tp tp-rt-r2m-layer () '(tp-text $tp-rt-r2m-text))
(with-temp-buffer
(insert "abcdef")
(tp-set 1 7 'tp-rt-r2m-layer)
(let ((m-prefix (copy-marker 2)) ; on "b"
(m-suffix (copy-marker 6))) ; on "f"
(setq tp-rt-r2m-text "abXYZef") ; "cd" -> "XYZ", one char longer
(should (equal (buffer-substring-no-properties (point-min)
(point-max))
"abXYZef"))
(should (= (marker-position m-prefix) 2))
(should (eq (char-after m-prefix) ?b))
(should (= (marker-position m-suffix) 7))
(should (eq (char-after m-suffix) ?f))
(set-marker m-prefix nil)
(set-marker m-suffix nil)))))
(ert-deftest tp-render-test-minimal-diff-identical-update-is-noop ()
"An identical-text reactive replacement leaves the buffer unmodified."
(tp-rt-with-cleanup (tp-rt-r2n-layer) (tp-rt-r2n-text)
(setq tp-rt-r2n-text "emacs")
(define-tp tp-rt-r2n-layer () '(face bold tp-text $tp-rt-r2n-text))
(with-temp-buffer
(insert "emacs")
(tp-set 1 6 'tp-rt-r2n-layer)
(set-buffer-modified-p nil)
(save-excursion
(tp--replace-reactive-text-in-buffer
'tp-rt-r2n-layer "emacs" (tp-layer-props 'tp-rt-r2n-layer t)))
;; No text edit and no property churn: the flag must stay clear
(should-not (buffer-modified-p))
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"emacs"))
(should (eq (get-text-property 1 'face) 'bold)))))
;;; R3 (0.3.0): anonymous-layer garbage collection
(ert-deftest tp-render-test-gc-collects-unreferenced-anonymous-layer ()
"GC collects an anonymous layer whose only buffer was killed."
(setq tp-rt-r3a-color "red")
(let ((buf (generate-new-buffer " tp-rt-r3a"))
(name nil))
(unwind-protect
(progn
(with-current-buffer buf
(insert "Hello")
(tp-set 1 6 '(face (:foreground $tp-rt-r3a-color)))
(setq name (get-text-property 1 'tp-name)))
(should name)
(should (assoc name tp-layer-alist))
(kill-buffer buf)
(should (memq name (tp-gc-anonymous-layers)))
(should-not (assoc name tp-layer-alist))
(should-not (rassq name tp--anonymous-layer-registry)))
(when (buffer-live-p buf) (kill-buffer buf))
(when (and name (assoc name tp-layer-alist))
(tp-undefine-layer name))
(setq tp-rt-r3a-color nil))))
(ert-deftest tp-render-test-gc-keeps-layer-still-displayed ()
"GC keeps an anonymous layer that a live buffer still shows."
(setq tp-rt-r3b-color "red")
(let ((buf (generate-new-buffer " tp-rt-r3b"))
(name nil))
(unwind-protect
(progn
(with-current-buffer buf
(insert "Hello")
(tp-set 1 6 '(face (:foreground $tp-rt-r3b-color)))
(setq name (get-text-property 1 'tp-name)))
(should name)
(should-not (memq name (tp-gc-anonymous-layers)))
(should (assoc name tp-layer-alist)))
(kill-buffer buf)
(when (and name (assoc name tp-layer-alist))
(tp-undefine-layer name))
(setq tp-rt-r3b-color nil))))
(ert-deftest tp-render-test-gc-keeps-unknown-registry-layer ()
"GC keeps an anonymous layer whose registry state is `unknown'."
(setq tp-rt-r3c-color "red")
(let* ((s (tp-set "Hello" '(face (:foreground $tp-rt-r3c-color))))
(name (get-text-property 0 'tp-name s)))
(unwind-protect
(progn
(should name)
;; Applied to a string only: the registry knows nothing
(should (eq (tp-reactive-layer-buffers name) 'unknown))
(should-not (memq name (tp-gc-anonymous-layers)))
(should (assoc name tp-layer-alist)))
(when (and name (assoc name tp-layer-alist))
(tp-undefine-layer name))
(setq tp-rt-r3c-color nil))))
(provide 'tp-render-tests)
;;; tp-render-tests.el ends here

186
tp-render.el
View File

@ -102,6 +102,51 @@ Returns an updated override-alist with the new computed values."
(tp--deep-merge-plist current-props resolved-props)))))))))))
override-alist)
(defun tp--buffer-has-layer-region-p (layer-name &optional buffer)
"Return non-nil when BUFFER has a region tagged with LAYER-NAME.
BUFFER defaults to the current buffer; a dead BUFFER yields nil.
Checks the `tp-name' text property."
(let ((buf (or buffer (current-buffer))))
(when (buffer-live-p buf)
(with-current-buffer buf
(save-excursion
(goto-char (point-min))
(and (text-property-search-forward 'tp-name layer-name t) t))))))
(defun tp--render-visit-buffer (buffer fn)
"Call FN with BUFFER current and `inhibit-read-only' bound to t.
Dead buffers are skipped. This is the per-buffer seam of the
reactive update walk; tests may advise it to count buffer visits."
(when (buffer-live-p buffer)
(tp-with-current-buffer buffer
(funcall fn))))
(defun tp--map-layer-buffers (layer-name where fn)
"Run FN in each buffer that may show LAYER-NAME's regions.
A non-nil WHERE (a live buffer, the `setq-local' case) restricts the
walk to that buffer. Otherwise the walk consults the buffer registry
via `tp-reactive-layer-buffers' and visits only registered live
buffers. When the registry answers `unknown', the walk falls back to
a full `buffer-list' scan, registering every buffer that actually
contains a region of LAYER-NAME; once at least one buffer is
registered the layer is known and later updates skip the full scan.
A layer found in no buffer at all deliberately stays `unknown', so a
later application through a path that does not register buffers is
still picked up by the next update's full scan."
(if (and where (bufferp where) (buffer-live-p where))
(tp--render-visit-buffer where fn)
(let ((registered (tp-reactive-layer-buffers layer-name)))
(if (not (eq registered 'unknown))
(dolist (buf registered)
(tp--render-visit-buffer buf fn))
;; Learning fallback: behave exactly like the historical full
;; scan, but record which buffers actually carry the layer.
(dolist (buf (buffer-list))
(when (buffer-live-p buf)
(when (tp--buffer-has-layer-region-p layer-name buf)
(tp-reactive--register-layer-buffer layer-name buf))
(tp--render-visit-buffer buf fn)))))))
(defun tp--update-layer-regions (layer-name &optional where override-alist)
"Update text regions that have LAYER-NAME applied.
Re-applies the layer's current properties to every region tagged with
@ -112,7 +157,10 @@ properties contributed by other sources are left untouched.
WHERE specifies which buffers to update:
- If WHERE is a buffer, only update that buffer (setq-local case).
- If WHERE is nil, update all buffers that have the text property.
- If WHERE is nil, update the buffers registered for the layer in
the reactive buffer registry, falling back to one full
`buffer-list' scan when the registry has no knowledge of the
layer (see `tp--map-layer-buffers').
OVERRIDE-ALIST maps reactive variables to their new values when the
watcher fires before the variables are set; layer props are
@ -132,15 +180,7 @@ variable values are honored."
do (put-text-property start end key val))
nil)
'tp-name layer-name)))))))
(if (and where (bufferp where) (buffer-live-p where))
;; setq-local case: only update the specific buffer
(tp-with-current-buffer where
(funcall update-buffer))
;; setq case: update all buffers that have the text property
(dolist (buf (buffer-list))
(when (buffer-live-p buf)
(tp-with-current-buffer buf
(funcall update-buffer)))))))
(tp--map-layer-buffers layer-name where update-buffer)))
(defun tp--find-tp-text-reactive-var (layer-name)
"Find the reactive variable symbol used for tp-text in LAYER-NAME.
@ -198,6 +238,19 @@ added."
val)))))
result))
(defun tp--put-text-property-unless-equal (start end key val object)
"Apply KEY -> VAL over [START, END) of OBJECT unless already there.
Like `put-text-property', but when every position of the span already
holds a value `equal' to VAL for KEY the call is skipped, so an
update that changes nothing does not flip the buffer-modified flag.
OBJECT is a string, a buffer, or nil for the current buffer."
(when (< start end)
(unless (and (equal (get-text-property start key object) val)
(>= (or (next-single-property-change start key object end)
end)
end))
(put-text-property start end key val object))))
(defun tp--apply-reactive-text-props (source props offset &optional target)
"Apply PROPS merged with SOURCE's embedded props to TARGET at OFFSET.
SOURCE is the (possibly propertized) replacement string; TARGET is a
@ -206,7 +259,9 @@ interval of SOURCE the interval's props are merged under PROPS (see
`tp--merge-embedded-props') and the result is applied to the
corresponding span of TARGET shifted by OFFSET. This keeps
per-interval styling of propertized reactive strings intact instead
of smearing position-0 props across the whole region."
of smearing position-0 props across the whole region. Spans that
already carry an `equal' value are left untouched, so an update that
changes nothing does not mark the buffer as modified."
(tp--map-intervals
source nil nil
(lambda (istart iend str-props)
@ -214,8 +269,8 @@ of smearing position-0 props across the whole region."
(tp--merge-embedded-props str-props props)
props)))
(cl-loop for (key val) on merged by #'cddr
do (put-text-property (+ offset istart) (+ offset iend)
key val target))))))
do (tp--put-text-property-unless-equal
(+ offset istart) (+ offset iend) key val target))))))
(defun tp--update-reactive-text (layer-name &optional where override-alist)
"Update text regions that have tp-text property with LAYER-NAME applied.
@ -223,7 +278,10 @@ This is called when a reactive variable bound to tp-text changes.
WHERE specifies which buffers to update:
- If WHERE is a buffer, only update that buffer (setq-local case).
- If WHERE is nil, update all buffers that have the text property (setq case).
- If WHERE is nil, update the buffers registered for the layer in
the reactive buffer registry, falling back to one full
`buffer-list' scan when the registry has no knowledge of the
layer (see `tp--map-layer-buffers').
OVERRIDE-ALIST maps reactive variables to their new values when the
watcher fires before the variables are set; the layer's props are
@ -244,20 +302,18 @@ it will be applied to the text before updating."
(save-excursion
(tp--replace-reactive-text-in-buffer
layer-name new-text props)))))))))
(if (and where (bufferp where) (buffer-live-p where))
;; setq-local case: only update the specific buffer
(tp-with-current-buffer where
(funcall update-buffer))
;; setq case: update all buffers that have the text property
(dolist (buf (buffer-list))
(when (buffer-live-p buf)
(tp-with-current-buffer buf
(funcall update-buffer)))))))
(tp--map-layer-buffers layer-name where update-buffer)))
(defun tp--replace-reactive-text-in-buffer (layer-name new-text props)
"Replace text in current buffer for reactive text with LAYER-NAME.
NEW-TEXT is the new text to replace with.
PROPS are the properties to apply to the new text.
Only the differing span of each region is edited: the common prefix
and suffix of the old and new text are left untouched, so point and
markers sitting in unchanged text keep their positions (point inside
the edited span ends up at the start of the edit). An identical-text
update touches no buffer text at all and does not mark the buffer as
modified.
Text properties embedded in NEW-TEXT are merged with PROPS per
embedded interval, so a multi-interval propertized reactive string
keeps its per-character styling. Existing text properties whose keys
@ -272,20 +328,44 @@ contributions on the same region."
(m-end (prop-match-end match))
(old-text (buffer-substring-no-properties m-start m-end)))
(unless (equal old-text plain-text)
;; Text content differs: replace it, carrying over the existing
;; properties whose keys this layer does not set.
(let ((existing-props (text-properties-at m-start)))
(delete-region m-start m-end)
(goto-char m-start)
(insert plain-text)
(let ((new-end (+ m-start (length plain-text))))
(cl-loop for (key val) on existing-props by #'cddr
do (unless (plist-member props key)
(put-text-property m-start new-end key val))))))
;; Text content differs: trim the common prefix and suffix and
;; edit only the span that actually differs, so point and
;; markers in the unchanged parts survive the update.
(let* ((old-len (length old-text))
(new-len (length plain-text))
(min-len (min old-len new-len))
(prefix 0)
(suffix 0))
(while (and (< prefix min-len)
(eq (aref old-text prefix) (aref plain-text prefix)))
(setq prefix (1+ prefix)))
(while (and (< suffix (- min-len prefix))
(eq (aref old-text (- old-len suffix 1))
(aref plain-text (- new-len suffix 1))))
(setq suffix (1+ suffix)))
(let ((edit-start (+ m-start prefix))
(edit-end (- m-end suffix))
(insert-text (substring plain-text prefix (- new-len suffix)))
(existing-props (text-properties-at m-start)))
(when (< edit-start edit-end)
(delete-region edit-start edit-end))
(when (> (length insert-text) 0)
(goto-char edit-start)
(insert insert-text))
;; Carry over existing properties whose keys this layer does
;; not set onto the newly inserted span; the untouched
;; prefix and suffix keep their own properties as is.
(let ((mid-end (+ edit-start (length insert-text))))
(cl-loop for (key val) on existing-props by #'cddr
do (unless (plist-member props key)
(put-text-property edit-start mid-end key val)))))))
;; Apply the layer's props, merged per embedded interval of NEW-TEXT.
;; Keys are replaced (not accumulated); unrelated keys are untouched.
(tp--apply-reactive-text-props new-text props m-start))
;; Search for next match
(tp--apply-reactive-text-props new-text props m-start)
;; Continue searching after the fully updated region: a preserved
;; suffix still carries the layer's `tp-name', and restarting the
;; search inside it would re-match this region.
(goto-char (+ m-start (length plain-text))))
(setq match (text-property-search-forward 'tp-name layer-name t)))))
(defun tp--tp-text-replace (start end final-text result-props object preserve-props)
@ -492,6 +572,42 @@ actually been set, so layer props re-resolve against current
(tp--update-reactive-text layer-name where)
(tp--update-layer-regions layer-name where)))
;;;###autoload
(defun tp-gc-anonymous-layers ()
"Collect anonymous layers that no live buffer displays anymore.
Walk `tp--anonymous-layer-registry' and, for every interned anonymous
layer whose buffer registry has real knowledge (see
`tp-reactive-layer-buffers'), check whether any registered live
buffer still contains a region tagged with the layer's `tp-name'.
Layers displayed nowhere are undefined via `tp-undefine-layer', which
also drops their reactive dependencies, transforms and registry
entries.
Layers whose registry state is `unknown' are conservatively kept:
they were never seen in any buffer through the registering paths,
and detached strings may still reference them. A layer becomes
collectable only after it was registered for at least one buffer and
none of the registered buffers still shows it (for example after the
buffers were killed); call `tp-reactive-track-buffer' after
inserting propertized strings so their buffers are registered too.
Return the list of collected layer names."
(interactive)
(let ((collected nil))
;; Snapshot the names first: `tp-undefine-layer' mutates the
;; anonymous-layer registry while we iterate.
(dolist (name (mapcar #'cdr tp--anonymous-layer-registry))
(let ((bufs (tp-reactive-layer-buffers name)))
(when (and (not (eq bufs 'unknown))
(not (cl-some (lambda (buf)
(tp--buffer-has-layer-region-p name buf))
bufs)))
(tp-undefine-layer name)
(push name collected))))
(when (called-interactively-p 'interactive)
(message "tp: collected %d anonymous layer(s)" (length collected)))
(nreverse collected)))
;; Install the engine into the lower modules.
(setq tp--reactive-update-function #'tp--reactive-apply-update)
(setq tp--reactive-flush-function #'tp--reactive-flush-entry)

238
tp-search-tests.el
View File

@ -372,5 +372,243 @@ with predicate t, where VALUE nil matches property-absent runs."
(should (equal (substring-no-properties str) "hello world"))
(should (eq (get-text-property 0 'face str) 'bold)))))
;;; 0.3.0 A1: capture-group targeting via SUBEXP in tp-regexp-*
(ert-deftest tp-search-test-regexp-subexp-string ()
"SUBEXP applies properties to the capture group only (string path)."
(let ((s (tp-regexp-set "\\(foo\\)-bar" '(face bold)
"foo-bar foo-bar" nil nil 1)))
(should (eq (get-text-property 0 'face s) 'bold))
(should (eq (get-text-property 2 'face s) 'bold))
(should-not (get-text-property 3 'face s))
(should-not (get-text-property 6 'face s))
(should (eq (get-text-property 8 'face s) 'bold))
(should-not (get-text-property 11 'face s))))
(ert-deftest tp-search-test-regexp-subexp-buffer ()
"SUBEXP applies properties and reports regions for the group (buffer path)."
(with-temp-buffer
(insert "foo-bar")
(let ((regions (tp-regexp-set "\\(foo\\)-\\(bar\\)" '(face bold)
(current-buffer) nil nil 2)))
(should (equal regions '((5 . 8))))
(should (eq (get-text-property 5 'face) 'bold))
(should-not (get-text-property 1 'face))
(should-not (get-text-property 4 'face)))))
(ert-deftest tp-search-test-regexp-subexp-group-not-participating ()
"A match where the SUBEXP group does not participate contributes nothing."
(with-temp-buffer
(insert "b a b")
(let ((regions (tp-regexp-set "\\(a\\)\\|b" '(face bold)
(current-buffer) nil nil 1)))
;; Only the "a" match has group 1; the "b" matches contribute
;; neither properties nor regions.
(should (equal regions '((3 . 4))))
(should (eq (get-text-property 3 'face) 'bold))
(should-not (get-text-property 1 'face))
(should-not (get-text-property 5 'face))))
;; String path mirror.
(let ((s (tp-regexp-set "\\(a\\)\\|b" '(face bold) "b a b" nil nil 1)))
(should (eq (get-text-property 2 'face s) 'bold))
(should-not (get-text-property 0 'face s))
(should-not (get-text-property 4 'face s))))
(ert-deftest tp-search-test-regexp-subexp-zero-width-guard ()
"The zero-width guard still terminates when SUBEXP is given."
;; "\\(x\\)*" matches the empty string everywhere in "ab" with
;; group 1 never participating; both paths must terminate cleanly.
(let ((s (tp-regexp-set "\\(x\\)*" '(face bold) "ab" nil nil 1)))
(should (equal (substring-no-properties s) "ab"))
(should-not (text-properties-at 0 s))
(should-not (text-properties-at 1 s)))
(with-temp-buffer
(insert "ab")
(should-not (tp-regexp-set "\\(x\\)*" '(face bold)
(current-buffer) nil nil 1))
(should-not (get-text-property 1 'face))))
;;; 0.3.0 A2: START/END bounds in tp-match-* / tp-regexp-*
(ert-deftest tp-search-test-match-bounds-string ()
"START/END restrict tp-match-set to [START, END) in a string (0-based)."
(let ((s (tp-match-set "foo" '(face bold) "foo foo foo" 4 11)))
(should-not (get-text-property 0 'face s))
(should (eq (get-text-property 4 'face s) 'bold))
(should (eq (get-text-property 8 'face s) 'bold))))
(ert-deftest tp-search-test-match-bounds-buffer ()
"START/END restrict tp-match-set to [START, END) in a buffer (1-based)."
(with-temp-buffer
(insert "foo foo foo")
(let ((regions (tp-match-set "foo" '(face bold) (current-buffer) 5 12)))
(should (equal regions '((5 . 8) (9 . 12))))
(should-not (get-text-property 1 'face))
(should (eq (get-text-property 5 'face) 'bold))
(should (eq (get-text-property 9 'face) 'bold)))))
(ert-deftest tp-search-test-regexp-bounds-do-not-cross-boundary ()
"Bounded regexp matching behaves as if only [START, END) existed."
;; A greedy "a+" would match the whole object; with bounds it must
;; match exactly the bounded portion instead of being discarded.
(let ((s (tp-regexp-set "a+" '(face bold) "aaaa" 1 3)))
(should-not (get-text-property 0 'face s))
(should (eq (get-text-property 1 'face s) 'bold))
(should (eq (get-text-property 2 'face s) 'bold))
(should-not (get-text-property 3 'face s)))
(with-temp-buffer
(insert "aaaa")
(should (equal (tp-regexp-set "a+" '(face bold) (current-buffer) 2 4)
'((2 . 4))))
(should-not (get-text-property 1 'face))
(should (eq (get-text-property 2 'face) 'bold))
(should-not (get-text-property 4 'face))))
(ert-deftest tp-search-test-match-reset-and-add-accept-bounds ()
"tp-match-reset/add accept the same START/END bounds."
(let* ((base (tp-set "foo foo" 'face 'italic))
(s (tp-match-reset "foo" '(face bold) base 4 7)))
(should (eq (get-text-property 0 'face s) 'italic))
(should (eq (get-text-property 4 'face s) 'bold)))
(let ((s (tp-match-add "foo" '(face bold) "foo foo" 4 7)))
(should-not (get-text-property 0 'face s))
(should (eq (get-text-property 4 'face s) 'bold))))
;;; 0.3.0 A3: PREDICATE / NOT-CURRENT exposure in tp-forward/tp-backward
(defmacro tp-search-tests--with-lvl-buffer (&rest body)
"Run BODY in a temp buffer with `lvl' runs 1/2/3 over \"aaabbbccc\"."
(declare (indent 0))
`(with-temp-buffer
(insert "aaabbbccc")
(put-text-property 1 4 'lvl 1)
(put-text-property 4 7 'lvl 2)
(put-text-property 7 10 'lvl 3)
,@body))
(ert-deftest tp-search-test-forward-predicate-buffer ()
"A function PREDICATE selects buffer matches by property value."
(tp-search-tests--with-lvl-buffer
(goto-char (point-min))
(let ((m (tp-forward 'lvl nil nil 1
(lambda (_ v) (and (numberp v) (> v 1))))))
(should m)
(should (equal (list (prop-match-beginning m)
(prop-match-end m)
(prop-match-value m))
'(4 7 2))))))
(ert-deftest tp-search-test-forward-predicate-string ()
"A function PREDICATE selects string matches by property value."
(let ((s (copy-sequence "aaabbbccc")))
(tp-set 0 3 '(lvl 1) s)
(tp-set 3 6 '(lvl 2) s)
(tp-set 6 9 '(lvl 3) s)
(should (equal (tp-forward 'lvl nil s 2
(lambda (_ v) (and (numberp v) (> v 1))))
'((3 6 2) (6 9 3))))))
(ert-deftest tp-search-test-backward-predicate-buffer ()
"tp-backward accepts the same function PREDICATE as tp-forward."
(tp-search-tests--with-lvl-buffer
(goto-char (point-max))
(let ((m (tp-backward 'lvl nil nil 1
(lambda (_ v) (and (numberp v) (< v 3))))))
(should m)
(should (equal (list (prop-match-beginning m)
(prop-match-end m)
(prop-match-value m))
'(4 7 2))))))
(ert-deftest tp-search-test-backward-predicate-string ()
"tp-backward with a PREDICATE returns string matches innermost first."
(let ((s (copy-sequence "aaabbbccc")))
(tp-set 0 3 '(lvl 1) s)
(tp-set 3 6 '(lvl 2) s)
(tp-set 6 9 '(lvl 3) s)
(should (equal (tp-backward 'lvl nil s 2
(lambda (_ v) (and (numberp v) (> v 1))))
'((6 9 3) (3 6 2))))))
(ert-deftest tp-search-test-forward-not-current-skips-point-region ()
"NOT-CURRENT makes tp-forward skip the matching region around point."
(with-temp-buffer
(insert "aabbaa")
(put-text-property 1 3 'k 'x)
(put-text-property 3 5 'k 'y)
(put-text-property 5 7 'k 'x)
(goto-char (point-min))
(let ((m (tp-forward 'k 'x)))
(should (= (prop-match-beginning m) 1)))
(goto-char (point-min))
(let ((m (tp-forward 'k 'x nil 1 nil t)))
(should (= (prop-match-beginning m) 5))
(should (= (prop-match-end m) 7)))))
(ert-deftest tp-search-test-backward-not-current-skips-point-region ()
"NOT-CURRENT makes tp-backward skip the matching region at point."
(with-temp-buffer
(insert "aa bb")
(put-text-property 1 3 'k 'x)
(put-text-property 4 6 'k 'x)
(goto-char (point-max))
;; Default keeps the 0.2.0 behavior: the run ending at point wins.
(let ((m (save-excursion (tp-backward 'k 'x))))
(should (equal (list (prop-match-beginning m) (prop-match-end m))
'(4 6))))
;; NOT-CURRENT skips it and finds the previous matching run.
(let ((m (save-excursion (tp-backward 'k 'x nil 1 nil t))))
(should (equal (list (prop-match-beginning m) (prop-match-end m))
'(1 3))))))
(ert-deftest tp-search-test-predicate-t-equals-default ()
"An explicit PREDICATE of t keeps the default `equal' matching."
(tp-search-tests--with-lvl-buffer
(goto-char (point-min))
(let ((default-m (save-excursion (tp-forward 'lvl 2)))
(t-m (save-excursion (tp-forward 'lvl 2 nil 1 t))))
(should (= (prop-match-beginning default-m) (prop-match-beginning t-m)))
(should (= (prop-match-end default-m) (prop-match-end t-m))))))
(ert-deftest tp-search-test-predicate-adjacent-runs-stay-separate ()
"Adjacent matching runs with different values are separate matches.
Mirrors `text-property-search-forward', which ends a match where the
value changes when a non-nil predicate is given."
(let ((s (copy-sequence "abcdef")))
(tp-set 0 3 '(lvl 1) s)
(tp-set 3 6 '(lvl 2) s)
(should (equal (tp-forward 'lvl nil s 5 (lambda (_ v) (numberp v)))
'((0 3 1) (3 6 2))))))
(ert-deftest tp-search-test-forward-do-predicate ()
"tp-forward-do passes PREDICATE through to select the target match."
(let ((s (copy-sequence "abc def")))
(tp-set 0 3 '(lvl 1) s)
(tp-set 4 7 '(lvl 2) s)
(should (= (tp-forward-do #'upcase 'lvl nil s 1 nil nil
(lambda (_ v) (eq v 2)))
1))
(should (equal (substring-no-properties s) "abc DEF"))))
(ert-deftest tp-search-test-backward-do-predicate ()
"tp-backward-do passes PREDICATE through to select the target match."
(with-temp-buffer
(insert "abc def")
(put-text-property 1 4 'lvl 1)
(put-text-property 5 8 'lvl 2)
(should (= (tp-backward-do #'upcase 'lvl nil (current-buffer) 1 nil nil
(lambda (_ v) (eq v 1)))
1))
(should (equal (buffer-substring-no-properties (point-min) (point-max))
"ABC def"))))
(ert-deftest tp-search-test-forward-do-defaults-unchanged ()
"tp-forward-do without PREDICATE keeps the 0.2.0 `equal' matching."
(let ((s (copy-sequence "abc def")))
(tp-set 0 3 '(lvl 1) s)
(tp-set 4 7 '(lvl 2) s)
(should (= (tp-forward-do #'upcase 'lvl 2 s) 1))
(should (equal (substring-no-properties s) "abc DEF"))))
(provide 'tp-search-tests)
;;; tp-search-tests.el ends here

349
tp-search.el
View File

@ -23,11 +23,23 @@
(require 'tp-layer)
(require 'tp-ops)
(defun tp--pattern-apply-single (pattern properties apply-fn object literal)
(defun tp--pattern-apply-single (pattern properties apply-fn object literal
&optional start end subexp)
"Apply APPLY-FN to matches of single PATTERN in OBJECT.
When LITERAL is non-nil, PATTERN is matched literally; otherwise it
is a regexp. APPLY-FN is called with (START END PROPS OBJECT) for
each match.
START and END restrict matching to the [START, END) portion of
OBJECT, in native coordinates (0-based for strings, 1-based for
buffers); nil means the object's bounds. Matching behaves as if
OBJECT consisted only of that portion (the buffer path narrows, the
string path matches against the substring), so no match crosses the
boundaries.
When SUBEXP is non-nil, it names a capture group of PATTERN: the
properties and returned regions cover (match-beginning SUBEXP) to
\(match-end SUBEXP) of each match, and a match in which that group
does not participate contributes nothing. The scan still advances
past the whole match.
For strings, returns a NEW string with properties applied
\(non-destructive).
For buffers, modifies in-place and returns list of regions.
@ -39,14 +51,26 @@ position past them, so the search always terminates."
(cond
;; String object
((stringp object)
;; First, collect all match positions from the original string
(let ((matches nil)
(pos 0)
(limit (length object)))
(while (and (<= pos limit) (string-match regexp object pos))
;; First, collect all match positions from the original string.
;; Bounded searches run against the substring so matches cannot
;; cross the [START, END) boundaries; positions are shifted back
;; into whole-string coordinates afterwards.
(let* ((from (max (or start 0) 0))
(to (min (or end (length object)) (length object)))
(searchable (if (and (= from 0) (= to (length object)))
object
(substring object from to)))
(matches nil)
(pos 0)
(limit (- to from)))
(while (and (<= pos limit) (string-match regexp searchable pos))
(let ((beg (match-beginning 0))
(end (match-end 0)))
(push (cons beg end) matches)
(end (match-end 0))
(sub-beg (match-beginning (or subexp 0)))
(sub-end (match-end (or subexp 0))))
;; A group that does not participate contributes nothing.
(when sub-beg
(push (cons (+ from sub-beg) (+ from sub-end)) matches))
(setq pos (if (= beg end) (1+ beg) end))))
;; Apply function to each match in order (reverse to get correct order)
;; Make a copy to ensure original string is not modified
@ -62,26 +86,38 @@ position past them, so the search always terminates."
(let ((buf (or object (current-buffer))))
(tp-with-current-buffer buf
(save-excursion
(goto-char (point-min))
(let (regions (keep-going t))
(while (and keep-going (re-search-forward regexp nil t))
(let ((beg (match-beginning 0))
(end (match-end 0)))
(when properties
(funcall apply-fn beg end properties buf))
(push (cons beg end) regions)
;; Guard against zero-width matches looping forever
(when (= beg end)
(if (eobp)
(setq keep-going nil)
(forward-char 1)))))
(nreverse regions)))))))))
(save-restriction
(when (or start end)
(narrow-to-region (max (or start (point-min)) (point-min))
(min (or end (point-max)) (point-max))))
(goto-char (point-min))
(let (regions (keep-going t))
(while (and keep-going (re-search-forward regexp nil t))
(let ((beg (match-beginning 0))
(end (match-end 0))
(sub-beg (match-beginning (or subexp 0)))
(sub-end (match-end (or subexp 0))))
;; A group that does not participate contributes nothing.
(when sub-beg
(when properties
(funcall apply-fn sub-beg sub-end properties buf))
(push (cons sub-beg sub-end) regions))
;; Guard against zero-width matches looping forever
(when (= beg end)
(if (eobp)
(setq keep-going nil)
(forward-char 1)))))
(nreverse regions))))))))))
(defun tp--pattern-apply (pattern properties apply-fn object literal)
(defun tp--pattern-apply (pattern properties apply-fn object literal
&optional start end subexp)
"Apply APPLY-FN to matches of PATTERN (one pattern or a list).
When LITERAL is non-nil, patterns are matched literally; otherwise
they are regexps. APPLY-FN is called with (START END PROPS OBJECT)
for each match.
START and END restrict matching to [START, END) in native
coordinates; SUBEXP names a capture group to target (see
`tp--pattern-apply-single').
For strings, returns a NEW string with properties applied
\(non-destructive).
For buffers, returns list of regions."
@ -92,47 +128,59 @@ For buffers, returns list of regions."
(let ((result object))
(dolist (p patterns)
(setq result (tp--pattern-apply-single p properties apply-fn
result literal)))
result literal
start end subexp)))
result))
;; Buffer or nil (current buffer)
(t
(let ((all-regions nil))
(dolist (p patterns)
(let ((regions (tp--pattern-apply-single p properties apply-fn
object literal)))
object literal
start end subexp)))
(setq all-regions (append all-regions regions))))
all-regions)))))
(defun tp--match-apply-single (pattern properties apply-fn object)
(defun tp--match-apply-single (pattern properties apply-fn object
&optional start end)
"Apply APPLY-FN to literal matches of single PATTERN in OBJECT.
START and END restrict matching to [START, END) in native coordinates.
For strings, returns a new string with properties applied (non-destructive).
For buffers, modifies in-place and returns list of regions."
(tp--pattern-apply-single pattern properties apply-fn object t))
(tp--pattern-apply-single pattern properties apply-fn object t start end))
(defun tp--match-apply (pattern properties apply-fn &optional object)
(defun tp--match-apply (pattern properties apply-fn &optional object start end)
"Internal function to apply APPLY-FN to matches of PATTERN.
PATTERN can be a string or a list of strings (multiple patterns).
When PATTERN is a list, each element is a pattern to match.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
START and END restrict matching to [START, END) in native coordinates.
For strings, returns a NEW string with properties applied (non-destructive).
For buffers, returns list of regions."
(tp--pattern-apply pattern properties apply-fn object t))
(tp--pattern-apply pattern properties apply-fn object t start end))
(defun tp--regexp-apply-single (pattern properties apply-fn object)
(defun tp--regexp-apply-single (pattern properties apply-fn object
&optional start end subexp)
"Apply APPLY-FN to regexp matches of single PATTERN in OBJECT.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
START and END restrict matching to [START, END) in native
coordinates; SUBEXP names a capture group to target.
For strings, returns a NEW string with properties applied (non-destructive).
For buffers, modifies in-place and returns list of regions."
(tp--pattern-apply-single pattern properties apply-fn object nil))
(tp--pattern-apply-single pattern properties apply-fn object nil
start end subexp))
(defun tp--regexp-apply (pattern properties apply-fn &optional object)
(defun tp--regexp-apply (pattern properties apply-fn
&optional object start end subexp)
"Internal function to apply APPLY-FN to regexp matches of PATTERN.
PATTERN can be a string (single regexp) or a list of strings (multiple regexps).
When PATTERN is a list, each element is a regexp to match.
APPLY-FN is called with (START END PROPS OBJECT) for each match.
START and END restrict matching to [START, END) in native
coordinates; SUBEXP names a capture group to target.
For strings, returns a NEW string with properties applied (non-destructive).
For buffers, returns list of regions."
(tp--pattern-apply pattern properties apply-fn object nil))
(tp--pattern-apply pattern properties apply-fn object nil start end subexp))
(defun tp--deep-merge-apply (start end props obj)
"Apply PROPS to OBJ from START to END with deep merge.
@ -165,10 +213,10 @@ For buffers, modifies in-place."
(setq pos next-pos))))
obj))
(defun tp-match-set (pattern plist &optional object)
(defun tp-match-set (pattern plist &optional object start end)
"Set properties on all occurrences of PATTERN.
(tp-match-set PATTERN PLIST &optional OBJECT)
(tp-match-set PATTERN PLIST &optional OBJECT START END)
PATTERN is a string (single pattern) or list of strings (multiple patterns).
Each pattern will be matched and have properties applied.
@ -176,22 +224,31 @@ PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
START and END restrict matching to the [START, END) portion of
OBJECT, in native coordinates (0-based for strings, 1-based for
buffers); nil means the object's bounds. Matching behaves as if
OBJECT consisted only of that portion, so no match crosses the
boundaries.
Returns:
- For strings: the modified string
- For buffers: list of (START . END) pairs for all matches."
(tp--match-apply pattern (tp--ensure-props plist) #'tp-set object))
(tp--match-apply pattern (tp--ensure-props plist) #'tp-set object
start end))
(defun tp-match-reset (pattern plist &optional object)
(defun tp-match-reset (pattern plist &optional object start end)
"Reset (completely replace) properties on all occurrences of PATTERN.
(tp-match-reset PATTERN PLIST &optional OBJECT)
(tp-match-reset PATTERN PLIST &optional OBJECT START END)
PATTERN is a string (single pattern) or list of strings (multiple patterns).
PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
START and END restrict matching to the [START, END) portion of
OBJECT, in native coordinates (0-based for strings, 1-based for
buffers); nil means the object's bounds.
Unlike `tp-match-set', this completely replaces all existing properties.
@ -199,7 +256,7 @@ For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of regions."
(tp--match-apply pattern (tp--ensure-props plist)
#'tp--reset-apply
object))
object start end))
(defun tp--reset-apply (start end props obj)
"Apply PROPS to OBJ from START to END, completely replacing existing properties.
@ -210,24 +267,28 @@ For buffers, modifies in-place."
(set-text-properties start end props obj)
obj))
(defun tp-match-add (pattern plist &optional object)
(defun tp-match-add (pattern plist &optional object start end)
"Add/update properties on all occurrences of PATTERN.
(tp-match-add PATTERN PLIST &optional OBJECT)
(tp-match-add PATTERN PLIST &optional OBJECT START END)
PATTERN is a string (single pattern) or list of strings (multiple patterns).
PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
START and END restrict matching to the [START, END) portion of
OBJECT, in native coordinates (0-based for strings, 1-based for
buffers); nil means the object's bounds.
Unlike `tp-match-set', this deeply merges nested properties."
(tp--match-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply object))
(tp--match-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply
object start end))
(defun tp-regexp-set (pattern plist &optional object)
(defun tp-regexp-set (pattern plist &optional object start end subexp)
"Set properties on all matches of PATTERN (regexp).
(tp-regexp-set PATTERN PLIST &optional OBJECT)
(tp-regexp-set PATTERN PLIST &optional OBJECT START END SUBEXP)
PATTERN is a string (single regexp) or list of strings (multiple regexps).
Each pattern will be matched and have properties applied.
@ -235,22 +296,38 @@ PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
START and END restrict matching to the [START, END) portion of
OBJECT, in native coordinates (0-based for strings, 1-based for
buffers); nil means the object's bounds. Matching behaves as if
OBJECT consisted only of that portion, so no match crosses the
boundaries.
When SUBEXP is non-nil, it names a capture group of PATTERN (1 for
the first group, like font-lock highlights): properties apply to that
group of each match instead of the whole match, and a match in which
the group does not participate contributes nothing.
Returns:
- For strings: the modified string
- For buffers: list of (START . END) pairs for all matches."
(tp--regexp-apply pattern (tp--ensure-props plist) #'tp-set object))
(tp--regexp-apply pattern (tp--ensure-props plist) #'tp-set object
start end subexp))
(defun tp-regexp-reset (pattern plist &optional object)
(defun tp-regexp-reset (pattern plist &optional object start end subexp)
"Reset (completely replace) properties on all regexp matches of PATTERN.
(tp-regexp-reset PATTERN PLIST &optional OBJECT)
(tp-regexp-reset PATTERN PLIST &optional OBJECT START END SUBEXP)
PATTERN is a string (single regexp) or list of strings (multiple regexps).
PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
START and END restrict matching to the [START, END) portion of
OBJECT, in native coordinates (0-based for strings, 1-based for
buffers); nil means the object's bounds.
When SUBEXP is non-nil, properties apply to that capture group of
each match instead of the whole match; a match in which the group
does not participate contributes nothing.
Unlike `tp-regexp-set', this completely replaces all existing properties.
@ -258,21 +335,28 @@ For strings, returns a NEW string (original is not modified).
For buffers, modifies in-place and returns list of regions."
(tp--regexp-apply pattern (tp--ensure-props plist)
#'tp--reset-apply
object))
object start end subexp))
(defun tp-regexp-add (pattern plist &optional object)
(defun tp-regexp-add (pattern plist &optional object start end subexp)
"Add/update properties on all regexp matches of PATTERN.
(tp-regexp-add PATTERN PLIST &optional OBJECT)
(tp-regexp-add PATTERN PLIST &optional OBJECT START END SUBEXP)
PATTERN is a string (single regexp) or list of strings (multiple regexps).
PLIST is a property list like \\='(face bold help-echo \"tip\"),
or a symbol representing a layer/group name defined by `define-tp'
or `define-tp-group'.
OBJECT is a buffer or string; nil means current buffer.
START and END restrict matching to the [START, END) portion of
OBJECT, in native coordinates (0-based for strings, 1-based for
buffers); nil means the object's bounds.
When SUBEXP is non-nil, properties apply to that capture group of
each match instead of the whole match; a match in which the group
does not participate contributes nothing.
Unlike `tp-regexp-set', this deeply merges nested properties."
(tp--regexp-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply object))
(tp--regexp-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply
object start end subexp))
(defun tp-search-forward (property &optional value predicate not-current)
"Search forward for text with PROPERTY.
@ -284,17 +368,53 @@ Wraps `text-property-search-forward'."
Wraps `text-property-search-backward'."
(text-property-search-backward property value predicate not-current))
(defun tp--property-search-backward (property value)
"Search backward for the previous region where PROPERTY `equal's VALUE.
(defun tp--property-match-p (value prop-value predicate)
"Return non-nil when PROP-VALUE matches VALUE under PREDICATE.
PREDICATE follows the convention tp uses for
`text-property-search-forward': nil and t both mean the values must
be `equal' (tp's 0.2.0 symmetric matching contract); a function is
called with VALUE and PROP-VALUE and matches when it returns
non-nil."
(if (functionp predicate)
(funcall predicate value prop-value)
(equal value prop-value)))
(defun tp--string-property-matches (string property value predicate)
"Collect PROPERTY runs of STRING matching VALUE under PREDICATE.
Returns a list of (START END VALUE) lists with 0-based positions. A
run is a maximal stretch with one `eq' PROPERTY value, and it matches
when `tp--property-match-p' accepts that value. Adjacent matching
runs with different values stay separate entries, mirroring how
`text-property-search-forward' ends a match where the property value
changes when a non-nil predicate is given."
(let ((results nil))
(tp--map-intervals
string 0 (length string)
(lambda (beg end val)
(when (tp--property-match-p value val predicate)
(push (list beg end val) results))
nil)
property)
(nreverse results)))
(defun tp--property-search-backward (property value
&optional predicate not-current)
"Search backward for the previous region where PROPERTY matches VALUE.
This is the backward mirror of (text-property-search-forward PROPERTY
VALUE t): a region matches when its PROPERTY value is `equal' to
VALUE. It deliberately does not call
VALUE t): by default a region matches when its PROPERTY value is
`equal' to VALUE. It deliberately does not call
`text-property-search-backward' with predicate t, because that
primitive's non-default-predicate branch skips every other property
run when non-matching runs intervene (observed through Emacs 30.2),
silently missing valid matches.
PREDICATE follows `tp--property-match-p': nil and t both mean `equal'
matching (the 0.2.0 contract); a function is called with VALUE and
the region's PROPERTY value. When NOT-CURRENT is non-nil, the
matching region containing point (or ending exactly at point) is
skipped, mirroring the primitive's NOT-CURRENT argument.
If a matching region is found, move point to its beginning and
return a `prop-match' object whose end is clipped to the starting
point (matching the primitive's behavior when point starts inside a
@ -308,7 +428,10 @@ matching region). Otherwise return nil and leave point alone."
(tp--map-intervals
(current-buffer) (point-min) origin
(lambda (ibeg iend val)
(when (equal value val)
(when (and (tp--property-match-p value val predicate)
;; With NOT-CURRENT, the run point is inside (or
;; just after) is not a candidate.
(not (and not-current (= iend origin))))
(setq found (list ibeg iend val)))
nil)
property)
@ -318,14 +441,30 @@ matching region). Otherwise return nil and leave point alone."
:end (cadr found)
:value (caddr found))))))
(defun tp-forward (property &optional value object n)
(defun tp-forward (property &optional value object n predicate not-current)
"Search forward N times for text with PROPERTY.
Returns prop-match for buffers or list of (START END VALUE) for strings."
Returns prop-match for buffers or list of (START END VALUE) for strings.
VALUE is the optional value to match; N is the number of searches,
defaulting to 1.
OBJECT can be a buffer or string; nil defaults to current buffer.
PREDICATE customizes matching: nil (the default) and t both keep the
0.2.0 contract where a region matches when its PROPERTY value is
`equal' to VALUE; a function is called with VALUE and the region's
PROPERTY value and matches when it returns non-nil. For buffers it
is passed to `text-property-search-forward'.
NOT-CURRENT is passed to `text-property-search-forward' and, when
non-nil, makes the search skip a matching region containing point.
It only applies to the buffer path; strings have no point, so it is
ignored there."
(let ((count (or n 1)))
(cond
;; String object - use tp-search
;; String object - use tp-search (or the predicate-aware matcher)
((stringp object)
(let ((matches (tp-search object property value)))
(let ((matches (if (functionp predicate)
(tp--string-property-matches object property
value predicate)
(tp-search object property value))))
(seq-take matches count)))
;; Buffer or nil
(t
@ -333,26 +472,41 @@ Returns prop-match for buffers or list of (START END VALUE) for strings."
(buf (or object (current-buffer))))
(tp-with-current-buffer buf
(dotimes (_ count)
(setq result (tp-search-forward property value t))))
(setq result (tp-search-forward
property value
(if (functionp predicate) predicate t)
not-current))))
result)))))
(defun tp-backward (property &optional value object n)
(defun tp-backward (property &optional value object n predicate not-current)
"Search backward N times for text with PROPERTY.
N is the number of searches, defaulting to 1.
VALUE is the optional value to match.
OBJECT can be a buffer or string; nil defaults to current buffer.
PREDICATE customizes matching: nil (the default) and t both keep the
0.2.0 contract where a region matches when its PROPERTY value is
`equal' to VALUE; a function is called with VALUE and the region's
PROPERTY value and matches when it returns non-nil.
NOT-CURRENT, when non-nil, skips a matching region containing point
\(or ending exactly at point), mirroring
`text-property-search-backward'. It only applies to the buffer
path; strings have no point, so it is ignored there.
For buffers, returns the prop-match object from the last successful search.
For strings, returns a list of (START END VALUE) for the last N matches
in reverse order (from end to start).
Uses `tp-search-backward' for buffers and `tp-search' for strings."
Uses `tp--property-search-backward' for buffers and `tp-search' (or
the predicate-aware matcher) for strings."
(let ((count (or n 1)))
(cond
;; String object - use tp-search and reverse
((stringp object)
(let ((matches (nreverse (tp-search object property value))))
(let ((matches (nreverse (if (functionp predicate)
(tp--string-property-matches
object property value predicate)
(tp-search object property value)))))
(seq-take matches count)))
;; Buffer or nil
(t
@ -360,14 +514,17 @@ Uses `tp-search-backward' for buffers and `tp-search' for strings."
(buf (or object (current-buffer))))
(tp-with-current-buffer buf
(dotimes (_ count)
;; `equal' matching, mirroring the predicate t that
;; `tp-forward' passes. The previous code used the default
;; nil predicate, which matches values NOT `equal' to VALUE
;; and so inverted the match when VALUE was non-nil.
(setq result (tp--property-search-backward property value))))
;; `equal' matching by default, mirroring the predicate t
;; that `tp-forward' passes. The previous code used the
;; default nil predicate, which matches values NOT `equal'
;; to VALUE and so inverted the match when VALUE was
;; non-nil.
(setq result (tp--property-search-backward
property value predicate not-current))))
result)))))
(defun tp--forward-do (function property &optional value object times start end)
(defun tp--forward-do (function property &optional value object times
start end predicate not-current)
"Internal: search forward TIMES for PROPERTY, call FUNCTION on last match.
FUNCTION receives two arguments: the prop-match object (or list for strings)
@ -376,6 +533,8 @@ TIMES is the number of searches, defaulting to 1.
VALUE is the optional value to match.
OBJECT can be a buffer or string; nil defaults to current buffer.
START and END define the search range; defaults are object start and end.
PREDICATE and NOT-CURRENT are passed to each underlying search (see
`tp-forward'); nil PREDICATE keeps the 0.2.0 `equal' matching.
FUNCTION is called only when the TIMES-th match exists; if fewer
matches are available, nothing is applied.
@ -386,7 +545,10 @@ Returns the number of matches found (at most TIMES)."
((stringp object)
(let* ((start-pos (or start 0))
(end-pos (or end (length object)))
(all-matches (tp-search object property value))
(all-matches (if (functionp predicate)
(tp--string-property-matches object property
value predicate)
(tp-search object property value)))
(filtered-matches (seq-filter (lambda (m)
(and (>= (car m) start-pos)
(<= (cadr m) end-pos)))
@ -408,7 +570,10 @@ Returns the number of matches found (at most TIMES)."
(save-excursion
(goto-char search-start)
(dotimes (i count)
(when-let ((match (tp-search-forward property value t)))
(when-let ((match (tp-search-forward
property value
(if (functionp predicate) predicate t)
not-current)))
(when (<= (prop-match-end match) search-end)
(when (= i (1- count))
(funcall function match buf))
@ -483,7 +648,8 @@ length-changing replacements" new-text (length new-text) len))
(goto-char m-start)
(insert new-text)))))))
(defun tp-forward-do (function property &optional value object times start end)
(defun tp-forward-do (function property &optional value object times
start end predicate not-current)
"Search forward for text with PROPERTY and apply FUNCTION to the last match.
FUNCTION receives (TEXT &optional START END) where TEXT is the matched text,
@ -497,6 +663,13 @@ OBJECT can be a buffer or string; nil defaults to current buffer.
TIMES is the number of searches, defaulting to 1. The function searches
TIMES times but only applies FUNCTION to the last (Nth) match found.
START and END define the search range; defaults are object start and end.
PREDICATE customizes matching: nil (the default) and t both keep the
0.2.0 contract where a region matches when its PROPERTY value is
`equal' to VALUE; a function is called with VALUE and the region's
PROPERTY value and matches when it returns non-nil.
NOT-CURRENT is passed to each underlying
`text-property-search-forward' call; it only applies to the buffer
path (strings have no point).
Returns the number of successful matches.
@ -523,9 +696,10 @@ Example:
(tp--forward-do
(lambda (match obj)
(tp--replace-match-text function arity match obj))
property value object times start end)))
property value object times start end predicate not-current)))
(defun tp--backward-do (function property &optional value object times start end)
(defun tp--backward-do (function property &optional value object times
start end predicate not-current)
"Internal: search backward TIMES for PROPERTY, call FUNCTION on last match.
FUNCTION receives two arguments: the prop-match object (or list for strings)
@ -534,6 +708,8 @@ TIMES is the number of searches, defaulting to 1.
VALUE is the optional value to match.
OBJECT can be a buffer or string; nil defaults to current buffer.
START and END define the search range; defaults are object start and end.
PREDICATE and NOT-CURRENT are passed to each underlying search (see
`tp-backward'); nil PREDICATE keeps the 0.2.0 `equal' matching.
FUNCTION is called only when the TIMES-th match exists; if fewer
matches are available, nothing is applied.
@ -544,7 +720,10 @@ Returns the number of matches found (at most TIMES)."
((stringp object)
(let* ((start-pos (or start 0))
(end-pos (or end (length object)))
(all-matches (tp-search object property value))
(all-matches (if (functionp predicate)
(tp--string-property-matches object property
value predicate)
(tp-search object property value)))
(filtered-matches
(seq-filter (lambda (m)
(and (>= (car m) start-pos)
@ -565,15 +744,18 @@ Returns the number of matches found (at most TIMES)."
(save-excursion
(goto-char search-end)
(dotimes (i count)
;; `equal' matching, same as tp--forward-do's predicate t.
(when-let ((match (tp--property-search-backward property value)))
;; `equal' matching by default, same as tp--forward-do's
;; predicate t.
(when-let ((match (tp--property-search-backward
property value predicate not-current)))
(when (>= (prop-match-beginning match) search-start)
(when (= i (1- count))
(funcall function match buf))
(cl-incf matches)))))))
matches)))))
(defun tp-backward-do (function property &optional value object times start end)
(defun tp-backward-do (function property &optional value object times
start end predicate not-current)
"Search backward for text with PROPERTY and apply FUNCTION to the last match.
FUNCTION receives (TEXT &optional START END) where TEXT is the matched text,
@ -587,6 +769,13 @@ OBJECT can be a buffer or string; nil defaults to current buffer.
TIMES is the number of searches, defaulting to 1. The function searches
TIMES times but only applies FUNCTION to the last (Nth) match found.
START and END define the search range; defaults are object start and end.
PREDICATE customizes matching: nil (the default) and t both keep the
0.2.0 contract where a region matches when its PROPERTY value is
`equal' to VALUE; a function is called with VALUE and the region's
PROPERTY value and matches when it returns non-nil.
NOT-CURRENT, when non-nil, skips a matching region containing point
on each underlying search; it only applies to the buffer path
\(strings have no point).
Returns the number of successful matches.
@ -613,7 +802,7 @@ Example:
(tp--backward-do
(lambda (match obj)
(tp--replace-match-text function arity match obj))
property value object times start end)))
property value object times start end predicate not-current)))
(defun tp-search (start-or-string
&optional end-or-property property-or-value value object)

412
tp-stack-tests.el
View File

@ -379,5 +379,417 @@ definitions cannot leak between tests."
(should-error (tp-push-layer nil 'layer1))
(should-error (tp-delete-layer 'not-a-position 5 'layer1))))
;;; 0.3.0 S1: layer visibility (tp-hide-layer / tp-show-layer)
(ert-deftest tp-stack-test-hide-top-reveals-next-visible ()
"Hiding the top layer renders the next visible layer's properties."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp lower () '(face bold))
(define-tp upper () '(face italic))
(tp-push-layer 1 6 'lower)
(tp-push-layer 1 6 'upper)
(should (= (tp-hide-layer 1 6 'upper) 1))
;; The text now renders the lower layer.
(should (eq (get-text-property 1 'face) 'bold))
(should (eq (get-text-property 1 'tp-name) 'lower))
;; The hidden layer is still in the stack for the queries.
(should (= (tp-layer-count 1 6) 2))
(should (equal (tp-layer-list 1 6) '(upper lower)))
(should (tp-layer-exists-p 1 6 'upper))))
(ert-deftest tp-stack-test-show-restores-hidden-top ()
"Showing a hidden top layer restores its properties onto the text."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp lower () '(face bold))
(define-tp upper () '(face italic))
(tp-push-layer 1 6 'lower)
(tp-push-layer 1 6 'upper)
(tp-hide-layer 1 6 'upper)
(should (= (tp-show-layer 1 6 'upper) 1))
(should (eq (get-text-property 1 'face) 'italic))
(should (eq (get-text-property 1 'tp-name) 'upper))
;; No bookkeeping flag leaks into the rendered properties.
(should-not (tp-stack-tests--has-prop-p 1 'tp-hidden))))
(ert-deftest tp-stack-test-hide-all-layers-contract ()
"With every layer hidden only the tp-layers bookkeeping remains."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp lower () '(face bold))
(define-tp upper () '(face italic))
(tp-push-layer 1 6 'lower)
(tp-push-layer 1 6 'upper)
(should (= (tp-hide-layer 1 6 'upper) 1))
(should (= (tp-hide-layer 1 6 'lower) 1))
;; No layer props render, not even tp-name.
(should (null (get-text-property 1 'face)))
(should (null (get-text-property 1 'tp-name)))
(should (tp-stack-tests--has-prop-p 1 'tp-layers))
;; The whole stack stays queryable.
(should (= (tp-layer-count 1 6) 2))
(should (equal (tp-layer-list 1 6) '(upper lower)))
;; Showing one layer again renders it.
(should (= (tp-show-layer 1 6 'lower) 1))
(should (eq (get-text-property 1 'face) 'bold))
(should (eq (get-text-property 1 'tp-name) 'lower))))
(ert-deftest tp-stack-test-hide-missing-name-is-silent-noop ()
"Hiding or showing a non-existent layer returns 0 without signaling."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp layer1 () '(face bold))
(tp-push-layer 1 6 'layer1)
(let ((before (text-properties-at 1)))
(should (= (tp-hide-layer 1 6 'nope) 0))
(should (= (tp-show-layer 1 6 'nope) 0))
(should (equal (text-properties-at 1) before)))))
(ert-deftest tp-stack-test-hide-already-hidden-returns-zero ()
"Hiding an already-hidden layer (or showing a visible one) counts 0."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp lower () '(face bold))
(define-tp upper () '(face italic))
(tp-push-layer 1 6 'lower)
(tp-push-layer 1 6 'upper)
(should (= (tp-show-layer 1 6 'upper) 0)) ; visible already
(should (= (tp-hide-layer 1 6 'upper) 1))
(should (= (tp-hide-layer 1 6 'upper) 0)) ; hidden already
(should (eq (get-text-property 1 'face) 'bold))))
(ert-deftest tp-stack-test-hide-string-forms ()
"Whole-string and region-on-string forms of hide/show work 0-based."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp lower () '(face bold))
(define-tp upper () '(face italic))
(tp-push-layer str 'lower)
(tp-push-layer str 'upper)
(should (= (tp-hide-layer str 'upper) 1))
(should (eq (get-text-property 0 'tp-name str) 'lower))
(should (= (tp-show-layer 0 6 'upper str) 1))
(should (eq (get-text-property 0 'tp-name str) 'upper))
;; Region form only touches [2, 5).
(should (= (tp-hide-layer 2 5 'upper str) 1))
(should (eq (get-text-property 0 'tp-name str) 'upper))
(should (eq (get-text-property 2 'tp-name str) 'lower))
(should (eq (get-text-property 5 'tp-name str) 'upper)))))
(ert-deftest tp-stack-test-show-layer-above-visible-top ()
"Showing a hidden layer above the visible top makes it render again."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(define-tp lc () '(face underline))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-push-layer 1 6 'lc)
(tp-hide-layer 1 6 'lc)
(tp-hide-layer 1 6 'lb)
(should (eq (get-text-property 1 'tp-name) 'la))
;; lc sits above the visible top (la); showing it wins again.
(should (= (tp-show-layer 1 6 'lc) 1))
(should (eq (get-text-property 1 'tp-name) 'lc))
(should (eq (get-text-property 1 'face) 'underline))))
(ert-deftest tp-stack-test-hidden-layer-can-be-raised ()
"A hidden layer can be moved in the stack and shown later."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-hide-layer 1 6 'la) ; hide the bottom layer
(should (= (tp-raise-layer 1 6 'la 1) 1))
;; la is now on top but hidden, so lb still renders.
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(la lb)))
(should (eq (get-text-property 1 'tp-name) 'lb))
(should (= (tp-show-layer 1 6 'la) 1))
(should (eq (get-text-property 1 'tp-name) 'la))
(should (eq (get-text-property 1 'face) 'bold))))
(ert-deftest tp-stack-test-hide-show-roundtrip-restores-storage ()
"A hide/show roundtrip restores the exact original properties."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp layer1 () '(face bold))
(tp-push-layer 1 6 'layer1)
(let ((before (text-properties-at 1)))
(tp-hide-layer 1 6 'layer1)
;; All layers hidden: only bookkeeping remains.
(should (null (get-text-property 1 'tp-name)))
(tp-show-layer 1 6 'layer1)
(should (equal (text-properties-at 1) before))
(should-not (tp-stack-tests--has-prop-p 1 'tp-layers)))))
(ert-deftest tp-stack-test-flatten-drops-tp-hidden-flag ()
"Flattening a stack with a hidden layer never leaks the tp-hidden flag."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp lower () '(face bold))
(define-tp upper () '(face italic))
(tp-push-layer 1 6 'lower)
(tp-push-layer 1 6 'upper)
(tp-hide-layer 1 6 'upper)
(tp-flatten-layers 1 6 'flat)
(should (eq (get-text-property 1 'tp-name) 'flat))
(should-not (tp-stack-tests--has-prop-p 1 'tp-hidden))
(should-not (tp-stack-tests--has-prop-p 1 'tp-layers))))
;;; 0.3.0 S2: tp-lower-layer and extended tp-rotate-layer
(ert-deftest tp-stack-test-lower-layer-moves-down ()
"Lowering by 1 swaps the layer with the one below it."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(define-tp lc () '(face underline))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-push-layer 1 6 'lc) ; top->bottom: lc lb la
(should (= (tp-lower-layer 1 6 'lc 1) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lb lc la)))
(should (eq (get-text-property 1 'tp-name) 'lb))))
(ert-deftest tp-stack-test-lower-layer-mirrors-raise ()
"Lowering then raising by the same N restores the stack order."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(define-tp lc () '(face underline))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-push-layer 1 6 'lc)
(let ((before (mapcar #'car (tp-layer-stack-at 1))))
(tp-lower-layer 1 6 'lc 2)
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lb la lc)))
(tp-raise-layer 1 6 'lc 2)
(should (equal (mapcar #'car (tp-layer-stack-at 1)) before)))))
(ert-deftest tp-stack-test-lower-layer-clamps-and-negates ()
"Lowering clamps at the bottom; a negative N raises instead."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(define-tp lc () '(face underline))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-push-layer 1 6 'lc)
(should (= (tp-lower-layer 1 6 'lc 99) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lb la lc)))
(should (= (tp-lower-layer 1 6 'lc -2) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lc lb la)))))
(ert-deftest tp-stack-test-lower-layer-defaults-and-index ()
"N defaults to 1 and integer indexes address the stack (0 = top)."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(tp-push-layer str 'la)
(tp-push-layer str 'lb) ; top->bottom: lb la
(should (= (tp-lower-layer str 0) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 0 str)) '(la lb)))
(should (eq (get-text-property 0 'tp-name str) 'la)))))
(ert-deftest tp-stack-test-lower-layer-missing-returns-zero ()
"Lowering a non-existent layer is a silent no-op returning 0."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(tp-push-layer 1 6 'la)
(let ((before (text-properties-at 1)))
(should (= (tp-lower-layer 1 6 'nope 1) 0))
(should (equal (text-properties-at 1) before)))))
(ert-deftest tp-stack-test-rotate-layer-default-unchanged ()
"With no new arguments rotate still moves the top layer to bottom."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(define-tp lc () '(face underline))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-push-layer 1 6 'lc) ; top->bottom: lc lb la
(should (= (tp-rotate-layer 1 6) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lb la lc)))
(should (eq (get-text-property 1 'tp-name) 'lb))))
(ert-deftest tp-stack-test-rotate-layer-up-inverts-down ()
"Rotating up moves the bottom layer to the top; up undoes down."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(define-tp lc () '(face underline))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-push-layer 1 6 'lc)
(should (= (tp-rotate-layer 1 6 nil 'up) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(la lc lb)))
(should (= (tp-rotate-layer 1 6 nil 'down) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lc lb la)))))
(ert-deftest tp-stack-test-rotate-layer-count-and-wraparound ()
"COUNT rotates several steps; a full cycle restores the order."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(define-tp lc () '(face underline))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-push-layer 1 6 'lc)
(should (= (tp-rotate-layer 1 6 nil 'down 2) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(la lc lb)))
(should (= (tp-rotate-layer 1 6 nil 'up 2) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lc lb la)))
(should (= (tp-rotate-layer 1 6 nil 'down 3) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 1)) '(lc lb la)))))
(ert-deftest tp-stack-test-rotate-layer-string-form-direction ()
"String form accepts DIRECTION and COUNT right after the string."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(tp-push-layer str 'la)
(tp-push-layer str 'lb) ; top->bottom: lb la
(should (= (tp-rotate-layer str 'up) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 0 str)) '(la lb)))
(should (= (tp-rotate-layer str 'down 1) 1))
(should (equal (mapcar #'car (tp-layer-stack-at 0 str)) '(lb la))))))
(ert-deftest tp-stack-test-rotate-layer-edge-arguments ()
"Invalid DIRECTION signals; COUNT below 1 and bare text return 0."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(tp-push-layer 1 4 'la)
(should-error (tp-rotate-layer 1 4 nil 'sideways))
(should (= (tp-rotate-layer 1 4 nil 'down 0) 0))
(should (= (tp-rotate-layer 4 6) 0))
(should (eq (get-text-property 1 'tp-name) 'la))))
;;; 0.3.0 S3: tp-layer-stack-at
(ert-deftest tp-stack-test-layer-stack-at-shape ()
"The stack at a position is (NAME . PROPS) conses, top first."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(should (equal (tp-layer-stack-at 1)
'((lb . (face italic))
(la . (face bold)))))))
(ert-deftest tp-stack-test-layer-stack-at-hidden-marker ()
"Hidden layers carry a tp-hidden t entry in their PROPS."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(tp-hide-layer 1 6 'lb)
(let ((stack (tp-layer-stack-at 1)))
(should (equal (mapcar #'car stack) '(lb la)))
(should (eq (plist-get (cdr (nth 0 stack)) 'tp-hidden) t))
(should-not (plist-member (cdr (nth 1 stack)) 'tp-hidden)))))
(ert-deftest tp-stack-test-layer-stack-at-string-positions ()
"String positions are 0-based; outside the layer the stack is nil."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp la () '(face bold))
(tp-put-layer 2 5 'la 0 str)
(should (null (tp-layer-stack-at 0 str)))
(should (equal (tp-layer-stack-at 2 str) '((la . (face bold)))))
(should (null (tp-layer-stack-at 5 str))))))
(ert-deftest tp-stack-test-layer-stack-at-unnamed-and-bare ()
"Unnamed layers report a nil NAME; bare text reports nil."
(tp-stack-tests--with-env
(insert "abcdef")
(tp-push-layer 1 4 '(face bold))
(should (equal (tp-layer-stack-at 1) '((nil . (face bold)))))
(should (null (tp-layer-stack-at 5)))))
;;; 0.3.0 S4: modified-interval counts and NOERROR
(ert-deftest tp-stack-test-delete-layer-returns-run-count ()
"Delete returns how many property runs matched; 0 when none did."
(tp-stack-tests--with-env
(insert "abcdefghij")
(define-tp la () '(face bold))
(tp-push-layer 1 4 'la)
(tp-push-layer 6 9 'la)
(should (= (tp-delete-layer 1 9 'nope) 0))
(should (= (tp-delete-layer 1 9 'la) 2))
(should-not (tp-layer-exists-p 1 9 'la))))
(ert-deftest tp-stack-test-pop-layer-returns-run-count ()
"Pop returns the number of runs that had a layer to pop."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp la () '(face bold))
(tp-put-layer 0 3 'la 0 str)
(should (= (tp-pop-layer 0 6 str) 1))
(should (= (tp-pop-layer 0 6 str) 0)))))
(ert-deftest tp-stack-test-movement-ops-return-run-counts ()
"Move, raise, pin and switch return matched-run counts."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(define-tp lb () '(face italic))
(tp-push-layer 1 6 'la)
(tp-push-layer 1 6 'lb)
(should (= (tp-raise-layer 1 6 'nope 1) 0))
(should (= (tp-raise-layer 1 6 'la 1) 1))
(should (= (tp-pin-layer 1 6 'lb) 1))
(should (= (tp-move-layer 1 6 'la 0) 1))
(should (= (tp-move-layer 1 6 'nope 0) 0))
(should (= (tp-switch-layer 1 6 'la 'lb) 1))
(should (= (tp-switch-layer 1 6 'la 'nope) 0))))
(ert-deftest tp-stack-test-put-layer-noerror ()
"With NOERROR an unresolvable LAYER returns nil and writes nothing."
(tp-stack-tests--with-env
(insert "abcdef")
(define-tp la () '(face bold))
(should-error (tp-put-layer 1 6 'undefined-x 0))
(should (null (tp-put-layer 1 6 'undefined-x 0 nil t)))
(should (null (text-properties-at 1)))
;; A resolvable layer with NOERROR still applies normally.
(should (tp-put-layer 1 6 'la 0 nil t))
(should (eq (get-text-property 1 'tp-name) 'la))))
(ert-deftest tp-stack-test-push-layer-noerror-both-forms ()
"NOERROR works for push in region and string forms."
(tp-stack-tests--with-env
(let ((str (copy-sequence "abcdef")))
(define-tp la () '(face bold))
(should-error (tp-push-layer str 'undefined-x))
(should (null (tp-push-layer str 'undefined-x t)))
(should (null (tp-put-layer str 'undefined-x 0 t)))
(should (null (text-properties-at 0 str)))
;; The string form still returns the string on success.
(should (eq (tp-push-layer str 'la t) str))
(should (eq (get-text-property 0 'tp-name str) 'la)))
(insert "abcdef")
(should (null (tp-push-layer 1 6 'undefined-x nil t)))
(should (null (text-properties-at 1)))))
(provide 'tp-stack-tests)
;;; tp-stack-tests.el ends here

443
tp-stack.el
View File

@ -12,8 +12,8 @@
;;; Commentary:
;; Photoshop-style layer stack operations on text regions: put/push/
;; delete/pop/move/raise/rotate/pin/switch/merge/flatten, stack queries,
;; and bulk layer property manipulation.
;; delete/pop/move/raise/lower/rotate/pin/switch/hide/show/merge/
;; flatten, stack queries, and bulk layer property manipulation.
;;; Code:
@ -50,6 +50,41 @@ buffers)."
(seq-take (cdr rest) n)))
(t (error "Invalid layer arguments: %S" (cons start-or-string rest)))))
(defun tp--stack-hidden-p (layer)
"Return non-nil when the layer plist LAYER is flagged hidden.
A layer is hidden when its plist carries a non-nil `tp-hidden' entry;
see `tp-hide-layer'."
(and (plist-get layer 'tp-hidden) t))
(defun tp--plist-remove (plist key)
"Return a copy of PLIST without KEY and its value.
Comparison uses `eq'. PLIST itself is not modified."
(cl-loop for (k v) on plist by #'cddr
unless (eq k key) append (list k v)))
(defun tp--stack-props-to-list (props)
"Return the ordered layer stack stored in raw text properties PROPS.
The result is a list of layer plists, top layer first, including
hidden layers (flagged with a non-nil `tp-hidden' entry) at their
stack position. Returns nil for bare text.
This is the inverse of `tp--stack-build-props': when any entry of the
`tp-layers' bookkeeping property is hidden, that property holds the
whole ordered stack and the direct properties are only a render cache
of the topmost non-hidden layer; otherwise the direct properties are
the top layer and `tp-layers' holds the layers below it. Direct
property edits made outside the stack API (for example `tp-set') are
therefore discarded by the next stack operation while any layer is
hidden."
(let* ((idx (-elem-index 'tp-layers props))
(top (if idx
(-remove-at-indices (list idx (1+ idx)) props)
props))
(belows (plist-get props 'tp-layers)))
(if (seq-some #'tp--stack-hidden-p belows)
belows
(tp--layer-stack-to-list top belows))))
(defun tp--stack-map-region (start end object function)
"Call FUNCTION over each property run of [START, END) in OBJECT.
@ -57,7 +92,8 @@ OBJECT is a string, a buffer, or nil for the current buffer.
FUNCTION receives (ABS-START ABS-END STACK): the run's bounds, clipped
to [START, END) and expressed in OBJECT's native coordinates (0-based
for strings, 1-based for buffers), and the run's layer stack as a list
of layer plists, top layer first (empty for bare text).
of layer plists, top layer first (empty for bare text). Hidden layers
\(see `tp-hide-layer') are included at their stack position.
Returns the list of FUNCTION's non-nil results, in order.
@ -69,13 +105,8 @@ previously property-less text."
(tp--map-intervals
object start end
(lambda (i-start i-end props)
(let* ((idx (-elem-index 'tp-layers props))
(top (if idx
(-remove-at-indices (list idx (1+ idx)) props)
props))
(belows (plist-get props 'tp-layers)))
(funcall function i-start i-end
(tp--layer-stack-to-list top belows)))))))
(funcall function i-start i-end
(tp--stack-props-to-list props))))))
(defun tp--stack-build-props (layer-list)
"Build text properties from LAYER-LIST (top layer first).
@ -83,9 +114,21 @@ Like `tp--build-layer-props', but the `tp-layers' entry is only added
when there are below-layers, so single-layer stacks do not carry a
garbage (tp-layers nil) property. Consumers must therefore tolerate
an absent `tp-layers' property (both `plist-get' and
`tp--stack-map-region' do)."
`tp--stack-map-region' do).
When any layer in LAYER-LIST is hidden (non-nil `tp-hidden' entry,
see `tp-hide-layer'), the storage switches to full-stack mode: the
direct properties are those of the topmost non-hidden layer (or no
layer properties at all when every layer is hidden) and the
`tp-layers' property holds the complete ordered LAYER-LIST.
`tp--stack-props-to-list' reverses either representation."
(cond
((null layer-list) nil)
((seq-some #'tp--stack-hidden-p layer-list)
(append (seq-find (lambda (layer)
(not (tp--stack-hidden-p layer)))
layer-list)
(list 'tp-layers layer-list)))
((null (cdr layer-list)) (copy-sequence (car layer-list)))
(t (append (car layer-list)
(list 'tp-layers (cdr layer-list))))))
@ -140,12 +183,36 @@ Scans the region's property runs in order and returns the `tp-name'
of the first top layer that has one, so bare or unnamed runs (for
example before a layer that starts mid-region) do not hide layers
later in the region. Returns nil when no run in the region has a
named top layer. OBJECT defaults to current buffer."
named top layer. OBJECT defaults to current buffer.
The topmost layer is reported in stack order even when it is hidden
\(see `tp-hide-layer'); use `tp-layer-stack-at' to distinguish hidden
layers from visible ones."
(car (tp--stack-map-region
start end object
(lambda (_abs-start _abs-end stack)
(plist-get (car stack) 'tp-name)))))
(defun tp-layer-stack-at (pos &optional object)
"Return the full ordered layer stack at POS in OBJECT.
The result is a list with one element per layer, topmost layer first
and bottommost last, where each element is a cons (NAME . PROPS):
- NAME is the layer's `tp-name' symbol, or nil for an unnamed layer.
- PROPS is the layer's property plist without its `tp-name' entry.
A hidden layer (see `tp-hide-layer') is distinguishable by the
entry `tp-hidden' with value t in PROPS; visible layers never
carry a `tp-hidden' entry.
Hidden layers are included at their stack position. Returns nil for
bare text. POS is in OBJECT's native coordinates (0-based for
strings, 1-based for buffers). OBJECT is a string, a buffer, or nil
for the current buffer."
(mapcar (lambda (layer)
(cons (plist-get layer 'tp-name)
(tp--plist-remove layer 'tp-name)))
(tp--stack-props-to-list (text-properties-at pos object))))
;;; Layer spec normalization for tp-put-layer
(defun tp--put-layer-specs (layer-spec)
@ -212,15 +279,15 @@ defined layer or group name); a named inline layer has odd length
;;; Mutators
(defun tp-put-layer (start-or-string &optional end-or-layer layer-or-idx idx-or-object object)
(defun tp-put-layer (start-or-string &optional end-or-layer layer-or-idx idx-or-object object noerror)
"Set layer(s) at a specific index position.
Calling conventions:
1. Buffer/string region:
(tp-put-layer START END LAYER IDX OBJECT)
(tp-put-layer START END LAYER IDX OBJECT NOERROR)
2. Entire string:
(tp-put-layer STRING LAYER IDX)
(tp-put-layer STRING LAYER IDX NOERROR)
LAYER can be:
- A symbol (layer name from `tp-layer-alist' or `tp-layer-groups')
@ -236,43 +303,65 @@ IDX specifies where to insert:
- Other values insert at that position
OBJECT defaults to current buffer for region form. Only text inside
\[START, END) is modified."
\[START, END) is modified.
A LAYER naming an undefined layer or group normally signals an
error. If NOERROR is non-nil, return nil instead of signaling when
LAYER cannot be resolved; nothing is modified in that case.
Returns OBJECT when one was given (in particular the string in
string forms), otherwise the cons (START . END)."
(pcase-let ((`(,start ,end ,obj ,layer-spec ,idx)
(tp--parse-layer-args
start-or-string
(list end-or-layer layer-or-idx idx-or-object object) 2)))
(setq idx (or idx 0))
(let ((layers-to-add (tp--put-layer-specs layer-spec)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(let* ((actual-idx (if (< idx 0)
(max 0 (+ (length stack) 1 idx))
(min idx (length stack))))
(new-stack (append (seq-take stack actual-idx)
layers-to-add
(seq-drop stack actual-idx))))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)))))
(or obj (cons start end))))
(let* ((noerr (if (stringp start-or-string) idx-or-object noerror))
(layers-to-add
(if noerr
(condition-case nil
(tp--put-layer-specs layer-spec)
(error 'tp--unresolved))
(tp--put-layer-specs layer-spec))))
(unless (eq layers-to-add 'tp--unresolved)
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(let* ((actual-idx (if (< idx 0)
(max 0 (+ (length stack) 1 idx))
(min idx (length stack))))
(new-stack (append (seq-take stack actual-idx)
layers-to-add
(seq-drop stack actual-idx))))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj))))
(or obj (cons start end))))))
(defun tp-push-layer (start-or-string &optional end-or-layer layer-or-object object)
(defun tp-push-layer (start-or-string &optional end-or-layer layer-or-object object noerror)
"Push layer(s) to the top of the layer stack.
This is equivalent to (tp-put-layer ... LAYER 0 ...).
Calling conventions:
1. Buffer/string region:
(tp-push-layer START END LAYER OBJECT)
(tp-push-layer START END LAYER OBJECT NOERROR)
2. Entire string:
(tp-push-layer STRING LAYER)"
(tp-push-layer STRING LAYER NOERROR)
A LAYER naming an undefined layer or group normally signals an
error. If NOERROR is non-nil, return nil instead of signaling when
LAYER cannot be resolved; nothing is modified in that case.
Returns what `tp-put-layer' returns: OBJECT when one was given (in
particular the string in string forms), otherwise (START . END)."
(pcase-let ((`(,start ,end ,obj ,layer)
(tp--parse-layer-args
start-or-string
(list end-or-layer layer-or-object object) 1)))
(tp-put-layer start end layer 0 obj)))
(let ((noerr (if (stringp start-or-string) layer-or-object noerror)))
(tp-put-layer start end layer 0 obj noerr))))
(defun tp-delete-layer (start-or-string &optional end-or-idx idx-or-object object)
"Delete layer by name or index.
@ -288,20 +377,26 @@ LAYER-NAME/IDX can be:
- A symbol (layer name)
- An integer (layer index, 0=top, -1=bottom)
Only text inside [START, END) is modified."
Only text inside [START, END) is modified.
Returns the number of property runs modified. A LAYER-NAME/IDX
matching no layer never signals: unmatched runs are silently left
alone and a return value of 0 means nothing matched at all."
(pcase-let ((`(,start ,end ,obj ,layer-id)
(tp--parse-layer-args
start-or-string
(list end-or-idx idx-or-object object) 1)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((found (tp--get-layer-by-idx-or-name stack layer-id)))
(set-text-properties
abs-start abs-end
(tp--stack-build-props (-remove-at (car found) stack))
obj))))
nil))
(let ((count 0))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((found (tp--get-layer-by-idx-or-name stack layer-id)))
(set-text-properties
abs-start abs-end
(tp--stack-build-props (-remove-at (car found) stack))
obj)
(setq count (1+ count)))))
count)))
(defun tp-pop-layer (start-or-string &optional end-or-object object)
"Pop the top layer from the layer stack.
@ -313,7 +408,10 @@ Calling conventions:
(tp-pop-layer START END OBJECT)
2. Entire string:
(tp-pop-layer STRING)"
(tp-pop-layer STRING)
Returns the number of property runs modified; 0 means no run in the
region had a layer to pop."
(pcase-let ((`(,start ,end ,obj)
(tp--parse-layer-args
start-or-string (list end-or-object object) 0)))
@ -398,19 +496,25 @@ TO-IDX is the target position (integer index):
Both indices refer to positions before the move.
The layer at FROM-ID is removed and inserted at TO-IDX position.
OBJECT defaults to current buffer for region form."
OBJECT defaults to current buffer for region form.
Returns the number of property runs modified. A FROM-ID matching no
layer never signals: unmatched runs are silently left alone and a
return value of 0 means nothing matched at all."
(pcase-let ((`(,start ,end ,obj ,from-id ,to-idx)
(tp--parse-layer-args
start-or-string
(list end-or-from from-or-to to-or-object object) 2)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--move-layer-in-stack stack from-id to-idx)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj))))
nil))
(let ((count 0))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--move-layer-in-stack stack from-id to-idx)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)
(setq count (1+ count)))))
count)))
(defun tp-raise-layer (start-or-string &optional end-or-idx idx-or-n n-or-object object)
"Raise a layer by N positions in the stack.
@ -424,38 +528,108 @@ Calling conventions:
Positive N moves the layer up (toward top/visible).
Negative N moves the layer down (toward bottom).
N defaults to 1. The resulting position is clamped to the stack.
Uses `tp--raise-layer-in-stack' internally, which is built on
`tp--move-layer-in-stack'."
`tp--move-layer-in-stack'.
Returns the number of property runs modified. An IDX/LAYER-NAME
matching no layer never signals: unmatched runs are silently left
alone and a return value of 0 means nothing matched at all."
(pcase-let ((`(,start ,end ,obj ,layer-id ,n)
(tp--parse-layer-args
start-or-string
(list end-or-idx idx-or-n n-or-object object) 2)))
(setq n (or n 1))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--raise-layer-in-stack stack layer-id n)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj))))
nil))
(let ((count 0))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--raise-layer-in-stack stack layer-id n)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)
(setq count (1+ count)))))
count)))
(defun tp-rotate-layer (start-or-string &optional end-or-object object)
"Rotate layers, moving top layer to bottom.
(defun tp-lower-layer (start-or-string &optional end-or-idx idx-or-n n-or-object object)
"Lower a layer by N positions in the stack.
This is the mirror image of `tp-raise-layer': lowering by N is
raising by -N.
Calling conventions:
1. Buffer/string region:
(tp-rotate-layer START END OBJECT)
(tp-lower-layer START END IDX/LAYER-NAME N OBJECT)
2. Entire string:
(tp-rotate-layer STRING)
(tp-lower-layer STRING IDX/LAYER-NAME N)
Uses `tp-move-layer' internally to move layer at index 0 to index -1."
IDX/LAYER-NAME identifies the layer: a layer name symbol or an
integer index (0 = top, negative indices count from the bottom, so
-1 = bottom).
Positive N moves the layer down (toward bottom).
Negative N moves the layer up (toward top/visible).
N defaults to 1. The resulting position is clamped to the stack.
OBJECT defaults to current buffer for region form.
Returns the number of property runs modified. An IDX/LAYER-NAME
matching no layer never signals: unmatched runs are silently left
alone and a return value of 0 means nothing matched at all."
(pcase-let ((`(,start ,end ,obj ,layer-id ,n)
(tp--parse-layer-args
start-or-string
(list end-or-idx idx-or-n n-or-object object) 2)))
(setq n (or n 1))
(tp-raise-layer start end layer-id (- n) obj)))
(defun tp-rotate-layer (start-or-string &optional end-or-direction object-or-count direction count)
"Rotate layers, by default moving the top layer to the bottom.
Calling conventions:
1. Buffer/string region:
(tp-rotate-layer START END OBJECT DIRECTION COUNT)
2. Entire string:
(tp-rotate-layer STRING DIRECTION COUNT)
DIRECTION is `down' or nil to move the top layer to the bottom (the
historical behavior), or `up' to move the bottom layer to the top;
any other value signals an error. COUNT is the number of rotation
steps and defaults to 1; a COUNT below 1 rotates nothing. Layers
keep their relative order; hidden layers rotate with the rest of the
stack.
OBJECT defaults to current buffer for region form.
Returns the number of property runs modified; 0 means no run in the
region had layers to rotate (or COUNT was below 1)."
(pcase-let ((`(,start ,end ,obj)
(tp--parse-layer-args
start-or-string (list end-or-object object) 0)))
(tp-move-layer start end 0 -1 obj)))
start-or-string
(list end-or-direction object-or-count) 0)))
(let* ((string-form (stringp start-or-string))
(dir (or (if string-form end-or-direction direction) 'down))
(cnt (or (if string-form object-or-count count) 1))
(applied 0))
(unless (memq dir '(up down))
(error "Invalid rotate direction: %S" dir))
(when (>= cnt 1)
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when stack
(let* ((len (length stack))
(k (mod (if (eq dir 'up) (- cnt) cnt) len))
(new-stack (append (seq-drop stack k)
(seq-take stack k))))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)
(setq applied (1+ applied)))))))
applied)))
(defun tp-pin-layer (start-or-string &optional end-or-idx idx-or-object object)
"Pin a layer to the top (make it visible).
@ -467,7 +641,11 @@ Calling conventions:
2. Entire string:
(tp-pin-layer STRING IDX/LAYER-NAME)
Uses `tp-move-layer' internally to move the specified layer to index 0 (top)."
Uses `tp-move-layer' internally to move the specified layer to index 0 (top).
Returns the number of property runs modified. An IDX/LAYER-NAME
matching no layer never signals: unmatched runs are silently left
alone and a return value of 0 means nothing matched at all."
(pcase-let ((`(,start ,end ,obj ,layer-id)
(tp--parse-layer-args
start-or-string
@ -484,19 +662,119 @@ Calling conventions:
2. Entire string:
(tp-switch-layer STRING IDX1/NAME1 IDX2/NAME2)
Uses `tp--switch-layers-in-stack' internally."
Uses `tp--switch-layers-in-stack' internally.
Returns the number of property runs modified. When either layer is
missing from a run's stack nothing signals: such runs are silently
left alone and a return value of 0 means nothing matched at all."
(pcase-let ((`(,start ,end ,obj ,id1 ,id2)
(tp--parse-layer-args
start-or-string
(list end-or-id1 id1-or-id2 id2-or-object object) 2)))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--switch-layers-in-stack stack id1 id2)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj))))
nil))
(let ((count 0))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((new-stack (tp--switch-layers-in-stack stack id1 id2)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)
(setq count (1+ count)))))
count)))
(defun tp-hide-layer (start-or-string &optional end-or-name name-or-object object)
"Hide layer NAME in region from START to END without removing it.
Calling conventions:
1. Buffer/string region:
(tp-hide-layer START END NAME OBJECT)
2. Entire string:
(tp-hide-layer STRING NAME)
NAME identifies the layer: a layer name symbol or an integer index
into the full stack, hidden layers included (0 = top, -1 = bottom).
A hidden layer stays in the stack -- it still counts for
`tp-layer-count', appears in `tp-layer-list' and `tp-layer-stack-at'
and can be moved, raised or lowered -- but it no longer renders: the
text shows the properties of the topmost non-hidden layer instead.
Hiding the currently visible top layer therefore reveals the next
visible layer below it. When every layer of a run is hidden the text
keeps only the `tp-layers' bookkeeping property (so not even
`tp-name' renders) while all layers stay queryable. Use
`tp-show-layer' to make a hidden layer render again.
Hiddenness is stored as a `tp-hidden' flag entry inside the layer's
plist in the `tp-layers' stack storage, so `tp-hidden' is a reserved
property name inside layers, like `tp-name'.
OBJECT defaults to current buffer for region form.
Returns the number of property runs modified. A NAME matching no
layer never signals; runs whose match is already hidden are left
alone as well, so a return value of 0 means nothing changed."
(pcase-let ((`(,start ,end ,obj ,name)
(tp--parse-layer-args
start-or-string
(list end-or-name name-or-object object) 1)))
(let ((count 0))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((found (tp--get-layer-by-idx-or-name stack name)))
(unless (tp--stack-hidden-p (cdr found))
(let ((new-stack (-replace-at (car found)
(append (list 'tp-hidden t)
(cdr found))
stack)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)
(setq count (1+ count)))))))
count)))
(defun tp-show-layer (start-or-string &optional end-or-name name-or-object object)
"Show layer NAME in region from START to END, undoing `tp-hide-layer'.
Calling conventions:
1. Buffer/string region:
(tp-show-layer START END NAME OBJECT)
2. Entire string:
(tp-show-layer STRING NAME)
NAME identifies the layer: a layer name symbol or an integer index
into the full stack, hidden layers included (0 = top, -1 = bottom).
The layer's `tp-hidden' flag is removed. When the shown layer sits
above the currently visible top layer it becomes the rendered layer
again, restoring its properties onto the text.
OBJECT defaults to current buffer for region form.
Returns the number of property runs modified. A NAME matching no
layer never signals; runs whose match is not hidden are left alone
as well, so a return value of 0 means nothing changed."
(pcase-let ((`(,start ,end ,obj ,name)
(tp--parse-layer-args
start-or-string
(list end-or-name name-or-object object) 1)))
(let ((count 0))
(tp--stack-map-region
start end obj
(lambda (abs-start abs-end stack)
(when-let ((found (tp--get-layer-by-idx-or-name stack name)))
(when (tp--stack-hidden-p (cdr found))
(let ((new-stack (-replace-at (car found)
(tp--plist-remove (cdr found)
'tp-hidden)
stack)))
(set-text-properties abs-start abs-end
(tp--stack-build-props new-stack)
obj)
(setq count (1+ count)))))))
count)))
(defun tp--merge-layer-props (layers initial)
"Merge the plists of LAYERS into the INITIAL plist and return it.
@ -505,10 +783,11 @@ LAYERS is a list of (INDEX . PROPS) conses as returned by
already present in the accumulator is never overwritten, and presence
is tested with `plist-member' so an explicit nil value in a higher
layer shadows lower layers' values. `tp-name' keys of the merged
layers are dropped (INITIAL may seed its own)."
layers are dropped (INITIAL may seed its own), as are `tp-hidden'
bookkeeping flags (see `tp-hide-layer')."
(cl-reduce (lambda (acc layer)
(cl-loop for (key val) on (cdr layer) by #'cddr
unless (eq key 'tp-name)
unless (memq key '(tp-name tp-hidden))
do (unless (plist-member acc key)
(setq acc (plist-put acc key val))))
acc)