From 507ccf798ccc098fd44ab6a793e85f1abae8fbf9 Mon Sep 17 00:00:00 2001 From: Kinneyzhang Date: Mon, 27 Jul 2026 00:32:47 +0800 Subject: [PATCH] Integrate 0.3.0 feature tracks: reactive perf, stack visibility, search/API 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 --- tp-layer-tests.el | 235 ++++++++++++++++++++++++ tp-layer.el | 402 +++++++++++++++++++++++++++++++--------- tp-ops.el | 16 ++ tp-reactive.el | 102 ++++++++++- tp-render-tests.el | 281 ++++++++++++++++++++++++++++ tp-render.el | 186 +++++++++++++++---- tp-search-tests.el | 238 ++++++++++++++++++++++++ tp-search.el | 349 +++++++++++++++++++++++++++-------- tp-stack-tests.el | 412 +++++++++++++++++++++++++++++++++++++++++ tp-stack.el | 443 ++++++++++++++++++++++++++++++++++++--------- 10 files changed, 2375 insertions(+), 289 deletions(-) diff --git a/tp-layer-tests.el b/tp-layer-tests.el index 56b2278..1b4ca2a 100644 --- a/tp-layer-tests.el +++ b/tp-layer-tests.el @@ -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 diff --git a/tp-layer.el b/tp-layer.el index 7f0bc2e..69efa07 100644 --- a/tp-layer.el +++ b/tp-layer.el @@ -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." diff --git a/tp-ops.el b/tp-ops.el index 4a0d3d0..1c624ef 100644 --- a/tp-ops.el +++ b/tp-ops.el @@ -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) diff --git a/tp-reactive.el b/tp-reactive.el index 10c40de..e81402e 100644 --- a/tp-reactive.el +++ b/tp-reactive.el @@ -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 diff --git a/tp-render-tests.el b/tp-render-tests.el index 21add29..0889d7c 100644 --- a/tp-render-tests.el +++ b/tp-render-tests.el @@ -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 diff --git a/tp-render.el b/tp-render.el index bf5659d..ddd9d49 100644 --- a/tp-render.el +++ b/tp-render.el @@ -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) diff --git a/tp-search-tests.el b/tp-search-tests.el index c51c2ad..14855a7 100644 --- a/tp-search-tests.el +++ b/tp-search-tests.el @@ -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 diff --git a/tp-search.el b/tp-search.el index f83b2cc..4c8a29e 100644 --- a/tp-search.el +++ b/tp-search.el @@ -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) diff --git a/tp-stack-tests.el b/tp-stack-tests.el index 33da75f..1d5054e 100644 --- a/tp-stack-tests.el +++ b/tp-stack-tests.el @@ -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 diff --git a/tp-stack.el b/tp-stack.el index 6e32bf6..e047f04 100644 --- a/tp-stack.el +++ b/tp-stack.el @@ -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)