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

Fix confirmed bugs in core ops and builtins/palette modules

Browse Source 
ops/core (B1-B8): tp-remove no longer drops 3rd+ properties; string
removal is per-interval via tp--map-intervals instead of smearing
position-0 props; tp-clear defaults bounds from OBJECT; (tp-get STR N N)
works like the buffer region form; no bogus (:key nil) from trailing
bare keywords; region form signals immediately on flat PROP/VAL args;
face-family prepend semantics extended to font-lock-face/mouse-face.

builtins/palette (B45-B51): Emacs 28.1 compat for plistp/subr-x;
display-buffer macros use a minor-mode keymap instead of mutating the
major-mode map; tp-link resolves palette colors lazily (theme-correct);
tp-palette-alist is the single source of truth (stale defvars dropped);
tp-headline handles integer heights; tp-space matches its documented
pixel spec; tp-parse-color accepts one-sided cons colors.

Test infra: fixture gains unwind-protect teardown via tp-layer-reset
(incl. transforms); file header/provide renamed to tp-tests; suite is
order-independent (verified with shuffled runs). Adds Makefile with
test/compile/clean targets.

334 tests green (280 legacy + 54 new regression tests).

Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
This commit is contained in:
Kinneyzhang 2026-07-26 18:31:59 +08:00
parent 5e5017a726
commit 49cb8d8062
9 changed files with 840 additions and 198 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -14,3 +14,6 @@ dash.el
# Syncthing conflict files # Syncthing conflict files
*.sync-conflict-* *.sync-conflict-*
.syncthing.* .syncthing.*
# Claude worktrees
.claude/

29
Makefile Normal file
View File

@ -0,0 +1,29 @@
# Makefile for the tp library.
#
# Usage:
# make test # run all ERT test suites
# make compile # byte-compile all modules
# make clean # remove compiled files
#
# If dash.el is not on the default load-path, point LOAD_EXTRA at it:
# make test LOAD_EXTRA="-L ~/.emacs.d/elpa/dash-20240510.1327"
EMACS ?= emacs
LOAD_EXTRA ?=
LOADPATH = -L . $(LOAD_EXTRA)
SRC = tp-core.el tp-reactive.el tp-layer.el tp-ops.el tp-search.el \
tp-render.el tp-stack.el tp-palette.el tp-builtins.el tp.el
TESTS = $(wildcard *-tests.el)
.PHONY: test compile clean
test:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
-f ert-run-tests-batch-and-exit
compile: clean
$(EMACS) -Q --batch $(LOADPATH) -f batch-byte-compile $(SRC)
clean:
rm -f *.elc

238
tp-builtins-tests.el Normal file
View File

@ -0,0 +1,238 @@
;;; tp-builtins-tests.el --- ERT tests for tp-builtins.el and tp-palette.el -*- lexical-binding: t -*-
;;; Commentary:
;; Regression tests for the built-in layers, the display buffer
;; macros, and the palette module (tp-builtins.el / tp-palette.el).
;;
;; Run with:
;; emacs --batch -L . -l tp.el -l tp-builtins-tests.el \
;; -f ert-run-tests-batch-and-exit
;;; Code:
(require 'ert)
(require 'tp)
;;; Test helpers
(defmacro tp-builtins-test--with-builtins (&rest body)
"Run BODY ensuring the shipped built-in layers are registered.
Other test files reset `tp-layer-alist' globally; reloading
tp-builtins restores the shipped layer definitions."
(declare (indent defun))
`(progn
(unless (assoc 'tp-link tp-layer-alist)
(load "tp-builtins" nil t))
,@body))
(defmacro tp-builtins-test--with-background-mode (mode &rest body)
"Run BODY with the frame background-mode set to MODE, restoring it after."
(declare (indent 1))
(let ((old (gensym "old-mode-")))
`(let ((,old (frame-parameter nil 'background-mode)))
(unwind-protect
(progn (set-frame-parameter nil 'background-mode ,mode)
,@body)
(set-frame-parameter nil 'background-mode ,old)))))
;;; B45: plistp / subr-x compatibility with Emacs 28.1
(ert-deftest tp-builtins-test-plistp-compat ()
"The `tp-palette--plistp' compat helper mirrors `plistp' semantics."
(should (tp-palette--plistp nil))
(should (tp-palette--plistp '(:a 1)))
(should (tp-palette--plistp '(:a 1 :b 2)))
(should-not (tp-palette--plistp '(:a 1 :b)))
(should-not (tp-palette--plistp "string"))
(should-not (tp-palette--plistp '(:a . 1))))
(ert-deftest tp-builtins-test-palette-pure-suffix-stripping ()
"`tp-palette-pure' strips variant suffixes (needs subr-x loaded)."
(should (eq (tp-palette-pure 'info) 'info))
(should (eq (tp-palette-pure 'info-fg) 'info))
(should (eq (tp-palette-pure 'info-bg) 'info))
(should (eq (tp-palette-pure 'info-fbg) 'info))
(should (eq (tp-palette-pure 'heading-1-border) 'heading-1))
(should-error (tp-palette-pure 'no-such-palette)))
;;; B46: display buffer macros must not mutate shared keymaps
(ert-deftest tp-builtins-test-display-buffer-no-shared-keymap-pollution ()
"Using the display macros must leave the major-mode keymap untouched."
(unwind-protect
(progn
(tp-switch-to-buffer "*tp-builtins-test-display*"
(text-mode)
(insert "hello"))
;; The shared text-mode keymap must NOT have gained a q binding.
(should-not (lookup-key text-mode-map "q"))
(with-current-buffer "*tp-builtins-test-display*"
;; q still quits, via the buffer-local minor mode.
(should (eq (key-binding "q") #'quit-window))
(should tp-display-buffer-mode)
(should buffer-read-only)
(should (equal (buffer-string) "hello"))))
(when (get-buffer "*tp-builtins-test-display*")
(kill-buffer "*tp-builtins-test-display*"))))
(ert-deftest tp-builtins-test-display-buffer-hygienic-binding ()
"BODY must see the user's own `buffer' variable, not a macro capture."
(unwind-protect
(let ((buffer "user-value"))
(tp-switch-to-buffer "*tp-builtins-test-hygiene*"
(insert buffer))
(with-current-buffer "*tp-builtins-test-hygiene*"
(should (equal (buffer-string) "user-value"))))
(when (get-buffer "*tp-builtins-test-hygiene*")
(kill-buffer "*tp-builtins-test-hygiene*"))))
(ert-deftest tp-builtins-test-pop-to-buffer-expansion-hygiene ()
"`tp-pop-to-buffer' expands to a gensym binding, never literal `buffer'."
(let* ((expansion (macroexpand-1 '(tp-pop-to-buffer "b" (ignore))))
(binding-var (caar (nth 1 expansion))))
(should (eq (car expansion) 'let))
(should (symbolp binding-var))
(should-not (eq binding-var 'buffer))))
(ert-deftest tp-builtins-test-display-buffer-reusable ()
"A second invocation erases and refills the (read-only) buffer."
(unwind-protect
(progn
(tp-switch-to-buffer "*tp-builtins-test-reuse*"
(insert "first"))
(tp-switch-to-buffer "*tp-builtins-test-reuse*"
(insert "second"))
(with-current-buffer "*tp-builtins-test-reuse*"
(should (equal (buffer-string) "second"))
(should buffer-read-only)))
(when (get-buffer "*tp-builtins-test-reuse*")
(kill-buffer "*tp-builtins-test-reuse*"))))
(ert-deftest tp-builtins-test-palette-show-smoke ()
"`tp-palette-show' renders the gallery without error."
(tp-builtins-test--with-builtins
(unwind-protect
(progn
(tp-palette-show)
(with-current-buffer "*tp-palette-gallery*"
(should (> (buffer-size) 0))
(should buffer-read-only)))
(when (get-buffer "*tp-palette-gallery*")
(kill-buffer "*tp-palette-gallery*")))))
;;; B47: tp-link resolves its palette color lazily
(ert-deftest tp-builtins-test-link-no-frozen-color ()
"The registered tp-link layer must not contain a baked-in hex color."
(tp-builtins-test--with-builtins
(let ((entry (assoc 'tp-link tp-layer-alist)))
(should entry)
(should-not (string-match-p "#[0-9a-fA-F]" (format "%S" entry))))))
(ert-deftest tp-builtins-test-link-lazy-theme-resolution ()
"tp-link resolves the info color at application time per theme."
(tp-builtins-test--with-builtins
(tp-builtins-test--with-background-mode 'light
(let ((face (get-text-property 0 'face (tp-set "x" 'tp-link t))))
(should (equal (plist-get face :foreground) "#0969da"))
(should (plist-get face :underline))))
(tp-builtins-test--with-background-mode 'dark
(let* ((s (tp-set "x" 'tp-link t))
(face (get-text-property 0 'face s)))
(should (equal (plist-get face :foreground) "#58a6ff"))
(should (plist-get face :underline))
(should (eq (get-text-property 0 'mouse-face s) 'highlight))
(should (eq (get-text-property 0 'pointer s) 'hand))))))
;;; B48: palette redefinition must not go stale
(ert-deftest tp-builtins-test-palette-redefinition-updates-colors ()
"Redefining a palette updates what the color lookups return."
(unwind-protect
(tp-builtins-test--with-background-mode 'light
(define-tp-palette tp-builtins-test-pal
:fg ("#111111" . "#aaaaaa") :bg ("#222222" . "#bbbbbb"))
(should (tp-palette-p 'tp-builtins-test-pal))
(should (equal (tp-palette-fg-color 'tp-builtins-test-pal) "#111111"))
(define-tp-palette tp-builtins-test-pal
:fg ("#333333" . "#cccccc") :bg ("#444444" . "#dddddd"))
(should (equal (tp-palette-fg-color 'tp-builtins-test-pal) "#333333"))
(should (equal (tp-palette-bg-color 'tp-builtins-test-pal) "#444444")))
(setq tp-palette-alist
(assq-delete-all 'tp-builtins-test-pal tp-palette-alist))))
;;; B49: tp-headline accepts integer heights, never emits :height nil
(ert-deftest tp-builtins-test-headline-integer-height ()
"An integer height (absolute, 1/10 pt units) produces a valid face."
(tp-builtins-test--with-builtins
(let ((face (get-text-property 0 'face (tp-set "h" 'tp-headline 120))))
(should (equal (plist-get face :height) 120))
(should (eq (plist-get face :weight) 'bold)))))
(ert-deftest tp-builtins-test-headline-float-height ()
"A float height (scaling factor) keeps its documented behavior."
(tp-builtins-test--with-builtins
(let ((face (get-text-property 0 'face (tp-set "h" 'tp-headline 1.5))))
(should (equal (plist-get face :height) 1.5))
(should (eq (plist-get face :weight) 'bold)))))
(ert-deftest tp-builtins-test-headline-plist-height ()
"A (:height H :bold B) plist is honored."
(tp-builtins-test--with-builtins
(let ((face (get-text-property 0 'face
(tp-set "h" 'tp-headline
'(:height 1.2 :bold nil)))))
(should (equal (plist-get face :height) 1.2))
(should-not (plist-get face :weight)))))
(ert-deftest tp-builtins-test-headline-never-emits-nil-height ()
"A plist without :height must not produce (:height nil)."
(tp-builtins-test--with-builtins
(let ((face (get-text-property 0 'face
(tp-set "h" 'tp-headline '(:bold t)))))
(should-not (plist-member face :height))
(should (eq (plist-get face :weight) 'bold)))))
(ert-deftest tp-builtins-test-headline-invalid-spec-errors ()
"Unsupported tp-headline specs signal an error instead of a no-op."
(tp-builtins-test--with-builtins
(should-error (tp-set "h" 'tp-headline "big"))))
;;; B50: tp-space uses the documented pixel spec
(ert-deftest tp-builtins-test-space-pixel-spec ()
"The shipped tp-space emits (space :width (PIXEL)) as documented."
(tp-builtins-test--with-builtins
;; Other test files redefine tp-space; make sure we exercise the
;; shipped definition.
(load "tp-builtins" nil t)
(should (equal (get-text-property 0 'display (tp-set "emacs" 'tp-space 2))
'(space :width (2))))))
;;; B51: tp-parse-color accepts one-sided cons colors
(ert-deftest tp-builtins-test-parse-color-one-sided-cons ()
"A cons with a nil side means no color for that mode."
(tp-builtins-test--with-background-mode 'light
(should (equal (tp-parse-color '("red" . nil)) "red"))
(should-not (tp-parse-color '(nil . "green"))))
(tp-builtins-test--with-background-mode 'dark
(should-not (tp-parse-color '("red" . nil)))
(should (equal (tp-parse-color '(nil . "green")) "green"))))
(ert-deftest tp-builtins-test-parse-color-existing-forms ()
"Strings, two-sided conses and plists keep their behavior."
(tp-builtins-test--with-background-mode 'light
(should (equal (tp-parse-color "red") "red"))
(should (equal (tp-parse-color '("red" . "green")) "red"))
(should (equal (tp-parse-color '(:light "red" :dark "green")) "red")))
(tp-builtins-test--with-background-mode 'dark
(should (equal (tp-parse-color '("red" . "green")) "green"))
(should (equal (tp-parse-color '(:light "red" :dark "green")) "green")))
(should-not (tp-parse-color nil))
(should-error (tp-parse-color 42)))
(provide 'tp-builtins-tests)
;;; tp-builtins-tests.el ends here

86
tp-builtins.el
View File

@ -23,31 +23,51 @@
(require 'tp-ops) (require 'tp-ops)
(require 'tp-palette) (require 'tp-palette)
(defmacro tp-pop-to-buffer (buffer-or-name &rest body) (defvar tp-display-buffer-mode-map
(declare (indent defun)) (let ((map (make-sparse-keymap)))
`(let ((buffer (get-buffer-create ,buffer-or-name))) (define-key map "q" #'quit-window)
(tp-with-current-buffer buffer map)
"Keymap for `tp-display-buffer-mode'.")
(define-minor-mode tp-display-buffer-mode
"Minor mode enabled in tp read-only display buffers.
It binds \\`q' to `quit-window' in its own buffer-local minor-mode
keymap, leaving the major-mode keymap (which is shared by every
buffer of that major mode) untouched."
:lighter nil
:keymap tp-display-buffer-mode-map)
(eval-and-compile
(defun tp--display-buffer-form (buffer-or-name body display-fn)
"Build the shared expansion of the display-buffer macros.
BUFFER-OR-NAME and BODY are the macro arguments; DISPLAY-FN is
the symbol of the function used to display the populated buffer."
(let ((buffer (gensym "tp-buffer-")))
`(let ((,buffer (get-buffer-create ,buffer-or-name)))
(tp-with-current-buffer ,buffer
(erase-buffer) (erase-buffer)
,@body ,@body
(local-set-key "q" (lambda () (tp-display-buffer-mode 1)
(interactive)
(local-unset-key "q")
(quit-window)))
(read-only-mode 1)) (read-only-mode 1))
(pop-to-buffer buffer))) (,display-fn ,buffer)))))
(defmacro tp-pop-to-buffer (buffer-or-name &rest body)
"Show BUFFER-OR-NAME with `pop-to-buffer' after filling it by BODY.
The buffer is created if needed and erased, then BODY runs inside
it with `inhibit-read-only' non-nil. The buffer is finally made
read-only with `tp-display-buffer-mode' enabled, so \\`q' quits
its window."
(declare (indent defun))
(tp--display-buffer-form buffer-or-name body 'pop-to-buffer))
(defmacro tp-switch-to-buffer (buffer-or-name &rest body) (defmacro tp-switch-to-buffer (buffer-or-name &rest body)
"Show BUFFER-OR-NAME with `switch-to-buffer' after filling it by BODY.
The buffer is created if needed and erased, then BODY runs inside
it with `inhibit-read-only' non-nil. The buffer is finally made
read-only with `tp-display-buffer-mode' enabled, so \\`q' quits
its window."
(declare (indent defun)) (declare (indent defun))
`(let ((buffer (get-buffer-create ,buffer-or-name))) (tp--display-buffer-form buffer-or-name body 'switch-to-buffer))
(tp-with-current-buffer buffer
(erase-buffer)
,@body
(local-set-key "q" (lambda ()
(interactive)
(local-unset-key "q")
(quit-window)))
(read-only-mode 1))
(switch-to-buffer buffer)))
(define-tp tp-palette (palette) (define-tp tp-palette (palette)
(let* ((pure-palette (tp-palette-pure palette)) (let* ((pure-palette (tp-palette-pure palette))
@ -124,23 +144,33 @@
`(face (:strike-through ,color))) `(face (:strike-through ,color)))
(define-tp tp-link () (define-tp tp-link ()
(let ((color (tp-palette-fg-color 'info))) ;; No color is resolved here: the body of a zero-arg layer is
`( tp-underline ,color ;; evaluated once, when this file is loaded, so any color computed
;; here would be frozen forever (wrong after a theme switch, or in a
;; daemon session started before any frame exists). Instead the
;; nested parameterized layer `tp-palette' resolves the info
;; foreground lazily at application time, and `:underline t'
;; underlines with that same foreground color.
'( face (:underline t)
tp-palette info-fg tp-palette info-fg
mouse-face highlight mouse-face highlight
pointer hand))) pointer hand))
(define-tp tp-space (width) (define-tp tp-space (pixel)
`(display (space :width ,width))) `(display (space :width (,pixel))))
(define-tp tp-headline (props) (define-tp tp-headline (props)
;; PROPS is either a number - a float scaling factor or an integer
;; absolute height in units of 1/10 pt, both valid face :height
;; values - implying bold, or a (:height H :bold B) plist.
(let (height boldp) (let (height boldp)
(cond ((floatp props) (cond ((numberp props)
(setq height props boldp t)) (setq height props boldp t))
((plistp props) ((tp-palette--plistp props)
(setq height (plist-get props :height) (setq height (plist-get props :height)
boldp (plist-get props :bold)))) boldp (plist-get props :bold)))
`(face (:height ,height (t (error "Invalid tp-headline spec: %S" props)))
`(face (,@(when height (list :height height))
,@(when boldp '(:weight bold)))))) ,@(when boldp '(:weight bold))))))
(define-tp tp-action (sexp) (define-tp tp-action (sexp)

51
tp-core.el
View File

@ -78,6 +78,11 @@ being created.")
NAME should be a symbol." NAME should be a symbol."
(memq name tp--builtin-text-properties)) (memq name tp--builtin-text-properties))
(defconst tp-face-properties '(face font-lock-face mouse-face)
"Text properties whose values follow face merging semantics.
These properties hold face specs (symbols, plists or lists thereof)
and are merged with face-aware logic instead of plain replacement.")
(defun tp-debug-log (format-string &rest args) (defun tp-debug-log (format-string &rest args)
"Log a debug message if `tp-debug-mode' is enabled. "Log a debug message if `tp-debug-mode' is enabled.
FORMAT-STRING and ARGS are passed to `format'." FORMAT-STRING and ARGS are passed to `format'."
@ -218,12 +223,16 @@ and PLIST is the merged plist of all face attributes."
(setq i (1+ i))) (setq i (1+ i)))
;; Inline keyword - consume key and value ;; Inline keyword - consume key and value
((keywordp elem) ((keywordp elem)
(if (< (1+ i) len)
(let ((key elem) (let ((key elem)
(val (nth (1+ i) face-list))) (val (nth (1+ i) face-list)))
(setq plist (if plist (setq plist (if plist
(plist-put plist key val) (plist-put plist key val)
(list key val))) (list key val)))
(setq i (+ i 2)))) (setq i (+ i 2)))
;; Trailing bare keyword with no value: malformed input.
;; Ignore it rather than inventing a bogus (KEY nil) pair.
(setq i (1+ i))))
;; Face symbol ;; Face symbol
((symbolp elem) ((symbolp elem)
(push elem symbols) (push elem symbols)
@ -330,7 +339,7 @@ For simplicity, only considers properties at position 0 of STR."
(cond (cond
;; Face properties need special merging ;; Face properties need special merging
;; Pass embedded val as face1 (base), existing as face2 (override) ;; Pass embedded val as face1 (base), existing as face2 (override)
((memq key '(face font-lock-face mouse-face)) ((memq key tp-face-properties)
(tp--merge-face-values val existing)) (tp--merge-face-values val existing))
;; Other properties - props value takes precedence ;; Other properties - props value takes precedence
(t existing)))) (t existing))))
@ -343,7 +352,21 @@ For simplicity, only considers properties at position 0 of STR."
FACE1 is the earlier value, FACE2 is the later value. FACE1 is the earlier value, FACE2 is the later value.
For face plists (like (:foreground \"red\")), merge with later overriding. For face plists (like (:foreground \"red\")), merge with later overriding.
For symbol faces, create a list with FACE2 taking precedence. For symbol faces, create a list with FACE2 taking precedence.
Returns the merged face value." Returns the merged face value.
Role: this is the merge engine for face values that arrive together in
a SINGLE call's property spec - `tp--merge-duplicate-keys' reduces
repeated face/font-lock-face/mouse-face keys through it, and
`tp--merge-string-props-into-plist' uses it to fold a string's embedded
face into caller props. Argument order is (EARLIER LATER); LATER wins.
Note: `tp--prepend-face' is a sibling engine used by `tp-add' to merge
an INCOMING face value into one already present on the text. Its
argument order is swapped ((NEW EXISTING)), and the two engines have
drifted for mixed lists: `tp--prepend-face' parses a mixed
symbol/plist list and merges plist components, whereas this function
conses a plist override onto a non-plist list without parsing. Do not
substitute one for the other without checking those cases."
(cond (cond
;; No earlier face - just use later face ;; No earlier face - just use later face
((null face1) face2) ((null face1) face2)
@ -460,7 +483,7 @@ Example:
(let ((merged-val (let ((merged-val
(cond (cond
;; Face properties - use special face merging ;; Face properties - use special face merging
((memq key '(face font-lock-face mouse-face)) ((memq key tp-face-properties)
(cl-reduce #'tp--merge-face-values values)) (cl-reduce #'tp--merge-face-values values))
;; Other properties - later overrides earlier ;; Other properties - later overrides earlier
(t (car (last values)))))) (t (car (last values))))))
@ -595,7 +618,20 @@ Examples:
If NEW-FACE is a plist (like (:foreground \"red\")), deeply merge it. If NEW-FACE is a plist (like (:foreground \"red\")), deeply merge it.
If NEW-FACE is a symbol or list of faces, prepend it to create a face list. If NEW-FACE is a symbol or list of faces, prepend it to create a face list.
For mixed lists containing both symbols and plists, plists are merged correctly. For mixed lists containing both symbols and plists, plists are merged correctly.
Duplicate faces are not added." Duplicate faces are not added.
Role: this is the merge engine `tp-add' uses to fold an INCOMING face
value into the face value already present on the text, for every
property in `tp-face-properties'. Argument order is (NEW EXISTING);
NEW wins.
Note: `tp--merge-face-values' is a sibling engine (argument order
swapped: (EARLIER LATER)) used when duplicate face keys appear within
a single call's property spec. The two have drifted for mixed
symbol/plist lists - this function parses such lists and merges their
plist components, `tp--merge-face-values' conses a plist override onto
a non-plist list without parsing. Do not substitute one for the other
without checking those cases."
(cond (cond
;; No existing face - just use new face ;; No existing face - just use new face
((null existing-face) new-face) ((null existing-face) new-face)
@ -665,11 +701,6 @@ Duplicate faces are not added."
(t new-face))) (t new-face)))
(t new-face))) (t new-face)))
(defconst tp-face-properties '(face font-lock-face mouse-face)
"Text properties whose values follow face merging semantics.
These properties hold face specs (symbols, plists or lists thereof)
and are merged with face-aware logic instead of plain replacement.")
(defun tp--map-intervals (object start end function &optional property) (defun tp--map-intervals (object start end function &optional property)
"Iterate property intervals of OBJECT between START and END, clipped. "Iterate property intervals of OBJECT between START and END, clipped.

254
tp-ops-tests.el Normal file
View File

@ -0,0 +1,254 @@
;;; tp-ops-tests.el --- ERT regression tests for tp-ops.el -*- lexical-binding: t -*-
;;; Commentary:
;; Regression tests for confirmed bugs fixed in the ops-core module
;; (tp-ops.el, with supporting fixes in tp-core.el). Each section is
;; tagged with the canonical bug id it guards against.
;;; Code:
(require 'ert)
(require 'tp)
;;; B1: tp-remove string form must not drop the 3rd+ properties
(ert-deftest tp-ops-test-remove-string-three-props ()
"Removing three properties from a string removes all three."
(let* ((str (propertize "hi" 'face 'bold 'help-echo "x" 'mouse-face 'highlight))
(result (tp-remove str 'face 'help-echo 'mouse-face)))
(should (null (get-text-property 0 'face result)))
(should (null (get-text-property 0 'help-echo result)))
(should (null (get-text-property 0 'mouse-face result)))))
(ert-deftest tp-ops-test-remove-string-four-props ()
"Removing four properties removes all four; nothing rides along."
(let* ((str (propertize "hi" 'face 'bold 'help-echo "x"
'mouse-face 'highlight 'keymap 'km))
(result (tp-remove str 'face 'help-echo 'mouse-face 'keymap)))
(should (null (text-properties-at 0 result)))))
(ert-deftest tp-ops-test-remove-string-third-prop-kept-elsewhere ()
"Properties not listed stay when 3+ properties are removed."
(let* ((str (propertize "hi" 'face 'bold 'help-echo "x"
'mouse-face 'highlight 'keymap 'km))
(result (tp-remove str 'face 'help-echo 'mouse-face)))
(should (eq (get-text-property 0 'keymap result) 'km))))
;;; B2: string-form removal operates per interval
(ert-deftest tp-ops-test-remove-string-prop-preserves-other-intervals ()
"Removing a property keeps each interval's own remaining props."
(let* ((s (concat (propertize "ab" 'face 'bold)
(propertize "cd" 'face 'italic 'help-echo "x")))
(result (tp-remove s 'help-echo)))
(should (eq (get-text-property 0 'face result) 'bold))
(should (eq (get-text-property 2 'face result) 'italic))
(should (null (get-text-property 2 'help-echo result)))))
(ert-deftest tp-ops-test-remove-string-sub-key-per-interval ()
"Sub-key removal does not smear one interval's face over another."
(let* ((s (concat (propertize "ab" 'face '(:weight bold :underline t))
(propertize "cd" 'face 'italic)))
(result (tp-remove s 'face :underline)))
(let ((face0 (get-text-property 0 'face result)))
(should (eq (plist-get face0 :weight) 'bold))
(should (null (plist-get face0 :underline))))
(should (eq (get-text-property 2 'face result) 'italic))))
(ert-deftest tp-ops-test-remove-string-nested-sub-key-per-interval ()
"Nested sub-key removal keeps other intervals' face values intact."
(let* ((s (concat (propertize "ab" 'face '(:underline (:style wave :position t)))
(propertize "cd" 'face 'italic)))
(result (tp-remove s 'face :underline '(:style))))
(let* ((face0 (get-text-property 0 'face result))
(underline (plist-get face0 :underline)))
(should (plist-get underline :position))
(should (null (plist-get underline :style))))
(should (eq (get-text-property 2 'face result) 'italic))))
(ert-deftest tp-ops-test-remove-string-prop-interval-boundaries-kept ()
"Interval boundaries survive removal of an unrelated property."
(let* ((s (concat (propertize "ab" 'face 'bold)
"cd"
(propertize "ef" 'face 'underline 'help-echo "z")))
(result (tp-remove s 'help-echo)))
(should (eq (get-text-property 0 'face result) 'bold))
(should (null (get-text-property 2 'face result)))
(should (eq (get-text-property 4 'face result) 'underline))
(should (null (get-text-property 4 'help-echo result)))))
;;; B3: tp-clear defaults bounds from OBJECT
(ert-deftest tp-ops-test-clear-string-defaults ()
"tp-clear with a string OBJECT clears the whole string by default."
(with-temp-buffer ; empty buffer: old code no-oped
(let ((s (propertize "hey" 'face 'bold 'help-echo "x")))
(tp-clear nil nil s)
(should (null (text-properties-at 0 s)))
(should (tp-empty-p s)))))
(ert-deftest tp-ops-test-clear-string-defaults-in-longer-buffer ()
"tp-clear on a short string works even when current buffer is longer."
(with-temp-buffer
(insert (make-string 100 ?x))
(let ((s (propertize "ab" 'face 'bold)))
(tp-clear nil nil s) ; old code: args-out-of-range
(should (tp-empty-p s)))))
(ert-deftest tp-ops-test-clear-buffer-defaults-still-work ()
"tp-clear with no args still clears the whole current buffer."
(with-temp-buffer
(insert "Hello")
(put-text-property 1 6 'face 'bold)
(tp-clear)
(should (null (text-properties-at 1)))))
(ert-deftest tp-ops-test-clear-buffer-object-defaults ()
"tp-clear defaults bounds from a buffer OBJECT, not the current buffer."
(let ((buf (generate-new-buffer " tp-ops-test-clear")))
(unwind-protect
(progn
(with-current-buffer buf
(insert "Hello")
(put-text-property 1 6 'face 'bold))
(with-temp-buffer ; empty current buffer
(tp-clear nil nil buf))
(with-current-buffer buf
(should (null (text-properties-at 1)))))
(kill-buffer buf))))
;;; B4: (tp-get STRING START END ...) range form
(ert-deftest tp-ops-test-get-string-numeric-range ()
"String object with a numeric range returns the intervals in range."
(let ((str (propertize "hey" 'face 'bold)))
(should (equal (tp-get str 0 2) '((0 2 (face bold)))))))
(ert-deftest tp-ops-test-get-string-numeric-range-with-property ()
"String range form accepts a property like the buffer region form."
(let ((str (concat (propertize "ab" 'face 'bold)
(propertize "cd" 'face 'italic))))
(should (equal (tp-get str 0 4 'face)
'((0 2 bold) (2 4 italic))))
(should (equal (tp-get str 2 4 'face) '((2 4 italic))))))
(ert-deftest tp-ops-test-get-string-numeric-range-with-sub-path ()
"String range form supports nested sub-paths."
(let ((str (propertize "hey" 'face '(:foreground "red" :weight bold))))
(should (equal (tp-get str 0 3 'face :foreground)
'((0 3 "red"))))))
(ert-deftest tp-ops-test-get-string-numeric-start-without-end-errors ()
"A numeric START without a numeric END signals a clear error."
(should-error (tp-get (propertize "hey" 'face 'bold) 0)))
;;; B5: tp--parse-face-list trailing bare keyword
(ert-deftest tp-ops-test-parse-face-list-trailing-keyword ()
"A trailing bare keyword does not produce a bogus (KEY nil) pair."
(should (equal (tp--parse-face-list '(bold :foreground))
'((bold)))))
(ert-deftest tp-ops-test-parse-face-list-inline-keyword-still-works ()
"Inline keyword-value pairs are still consumed normally."
(should (equal (tp--parse-face-list '(bold :foreground "green"))
'((bold) :foreground "green"))))
;;; B6: region form with flat prop/val signals immediately
(ert-deftest tp-ops-test-set-region-flat-args-error ()
"Region form with flat PROP/VAL args signals an immediate error."
(with-temp-buffer
(insert "hello")
(should-error (tp-set 1 4 'face 'bold))
;; Nothing was applied
(should (null (get-text-property 1 'face)))))
(ert-deftest tp-ops-test-add-and-reset-region-flat-args-error ()
"tp-add and tp-reset region forms reject flat PROP/VAL args too."
(with-temp-buffer
(insert "hello")
(should-error (tp-add 1 4 'face 'bold))
(should-error (tp-reset 1 4 'face 'bold))))
(ert-deftest tp-ops-test-set-region-with-object-still-works ()
"Region form with a plist and trailing OBJECT is unaffected."
(let ((s (copy-sequence "hello")))
(tp-set 0 3 '(face bold) s)
(should (eq (get-text-property 0 'face s) 'bold)))
(with-temp-buffer
(insert "hello")
(tp-set 1 4 '(face bold))
(should (eq (get-text-property 1 'face) 'bold))))
;;; B7: tp-add face-family prepend semantics for all tp-face-properties
(ert-deftest tp-ops-test-add-font-lock-face-prepends-string ()
"tp-add prepends font-lock-face like face (string form)."
(let* ((s (propertize "hey" 'font-lock-face 'bold))
(result (tp-add s 'font-lock-face 'italic)))
(should (equal (get-text-property 0 'font-lock-face result)
'(italic bold)))))
(ert-deftest tp-ops-test-add-mouse-face-prepends-string ()
"tp-add prepends mouse-face like face (string form)."
(let* ((s (propertize "hey" 'mouse-face 'highlight))
(result (tp-add s 'mouse-face 'region)))
(should (equal (get-text-property 0 'mouse-face result)
'(region highlight)))))
(ert-deftest tp-ops-test-add-font-lock-face-prepends-buffer ()
"tp-add prepends font-lock-face like face (buffer region form)."
(with-temp-buffer
(insert "hey")
(put-text-property 1 4 'font-lock-face 'bold)
(tp-add 1 4 '(font-lock-face italic))
(should (equal (get-text-property 1 'font-lock-face) '(italic bold)))))
(ert-deftest tp-ops-test-add-font-lock-face-prepends-string-region ()
"tp-add prepends font-lock-face in the string region form."
(let ((s (propertize "hey" 'font-lock-face 'bold)))
(tp-add 0 3 '(font-lock-face italic) s)
(should (equal (get-text-property 0 'font-lock-face s) '(italic bold)))))
(ert-deftest tp-ops-test-add-font-lock-face-plist-merge ()
"tp-add deep-merges font-lock-face plists like face plists."
(let* ((s (propertize "hey" 'font-lock-face '(:foreground "red")))
(result (tp-add s 'font-lock-face '(:background "blue"))))
(let ((flf (get-text-property 0 'font-lock-face result)))
(should (equal (plist-get flf :foreground) "red"))
(should (equal (plist-get flf :background) "blue")))))
(ert-deftest tp-ops-test-add-non-face-property-still-replaces ()
"Non-face properties keep plain replacement semantics in tp-add."
(let* ((s (propertize "hey" 'help-echo "old"))
(result (tp-add s 'help-echo "new")))
(should (equal (get-text-property 0 'help-echo result) "new"))))
;;; B8: tp-intervals clips to the requested range
(ert-deftest tp-ops-test-intervals-clipped-buffer ()
"Buffer intervals are clipped: offsets stay within [0, END-START)."
(with-temp-buffer
(insert "abcdef")
(put-text-property 1 5 'face 'bold)
(let ((intervals (tp-intervals 3 6)))
(dolist (iv intervals)
(should (>= (nth 0 iv) 0))
(should (<= (nth 1 iv) 3))
(should (< (nth 0 iv) (nth 1 iv))))
(should (equal intervals '((0 2 (face bold)) (2 3 nil)))))))
(ert-deftest tp-ops-test-intervals-clipped-string ()
"String intervals are clipped to [START, END)."
(let ((s (copy-sequence "abcdef")))
(put-text-property 0 6 'face 'bold s)
(let ((intervals (tp-intervals 2 4 s)))
(dolist (iv intervals)
(should (>= (nth 0 iv) 2))
(should (<= (nth 1 iv) 4)))
(should (equal intervals '((2 4 (face bold))))))))
(provide 'tp-ops-tests)
;;; tp-ops-tests.el ends here

182
tp-ops.el
View File

@ -84,9 +84,18 @@ Supports multiple calling conventions:
finish end-or-prop finish end-or-prop
props props-or-val) props props-or-val)
;; Check if 4th arg (first of rest) is a buffer or string ;; Check if 4th arg (first of rest) is a buffer or string
(when (and rest (or (bufferp (car rest)) (let ((extra rest))
(stringp (car rest)))) (when (and extra (or (bufferp (car extra))
(setq object (car rest)))) (stringp (car extra))))
(setq object (car extra)
extra (cdr extra)))
;; Anything left over is not a valid region-form argument.
;; In particular, flat PROP/VAL pairs like (tp-set 1 4 'face 'bold)
;; are only supported in the whole-string form; region form takes
;; a plist. Signal immediately instead of silently discarding.
(when extra
(error "Region form takes a properties plist: (tp-set START END '(PROP VAL ...) &optional OBJECT); flat PROP/VAL arguments like %S are only supported in the whole-string form"
(car extra)))))
(t (error "Invalid first argument: %S" start-or-string))) (t (error "Invalid first argument: %S" start-or-string)))
;; Unwrap double-wrapped properties ;; Unwrap double-wrapped properties
(when (and (listp props) (listp (car-safe props))) (when (and (listp props) (listp (car-safe props)))
@ -131,7 +140,8 @@ Returns a new propertized string."
(while (< pos end) (while (< pos end)
(let* ((current-val (get-text-property pos key result)) (let* ((current-val (get-text-property pos key result))
(new-val (cond (new-val (cond
((eq key 'face) (tp--prepend-face val current-val)) ((memq key tp-face-properties)
(tp--prepend-face val current-val))
((and (listp val) (keywordp (car-safe val)) ((and (listp val) (keywordp (car-safe val))
(listp current-val) (keywordp (car-safe current-val))) (listp current-val) (keywordp (car-safe current-val)))
(tp--deep-merge-plist current-val val)) (tp--deep-merge-plist current-val val))
@ -245,7 +255,9 @@ Returns: For buffers, (START . END) cons. For strings, the result string."
(defun tp-add (start-or-string &optional end-or-prop props-or-val &rest rest) (defun tp-add (start-or-string &optional end-or-prop props-or-val &rest rest)
"Add or update text properties with deep merging. "Add or update text properties with deep merging.
Unlike `tp-set', deeply merges nested properties. Unlike `tp-set', deeply merges nested properties.
For `face' property, symbol faces are prepended to existing face list. For face-family properties (see `tp-face-properties': face,
font-lock-face, mouse-face), symbol faces are prepended to the
existing face list and face plists are deep-merged.
For tp-text, embedded text properties are merged with props. For tp-text, embedded text properties are merged with props.
**String Modification Behavior:** **String Modification Behavior:**
@ -290,7 +302,8 @@ Returns: For buffers, (START . END) cons. For strings, the result string."
for (key val) on props by #'cddr for (key val) on props by #'cddr
do (let* ((current-val (plist-get current-props key)) do (let* ((current-val (plist-get current-props key))
(new-val (cond (new-val (cond
((eq key 'face) (tp--prepend-face val current-val)) ((memq key tp-face-properties)
(tp--prepend-face val current-val))
((and (listp val) (keywordp (car-safe val)) ((and (listp val) (keywordp (car-safe val))
(listp current-val) (keywordp (car-safe current-val))) (listp current-val) (keywordp (car-safe current-val)))
(tp--deep-merge-plist current-val val)) (tp--deep-merge-plist current-val val))
@ -308,7 +321,8 @@ Returns: For buffers, (START . END) cons. For strings, the result string."
for (key val) on props by #'cddr for (key val) on props by #'cddr
do (let* ((current-val (plist-get current-props key)) do (let* ((current-val (plist-get current-props key))
(new-val (cond (new-val (cond
((eq key 'face) (tp--prepend-face val current-val)) ((memq key tp-face-properties)
(tp--prepend-face val current-val))
((and (listp val) (keywordp (car-safe val)) ((and (listp val) (keywordp (car-safe val))
(listp current-val) (keywordp (car-safe current-val))) (listp current-val) (keywordp (car-safe current-val)))
(tp--deep-merge-plist current-val val)) (tp--deep-merge-plist current-val val))
@ -321,7 +335,13 @@ Returns: For buffers, (START . END) cons. For strings, the result string."
"Get text property value(s) with support for nested sub-properties. "Get text property value(s) with support for nested sub-properties.
Returns list of (START END VALUE) intervals. Returns list of (START END VALUE) intervals.
Use `tp-at' for single position queries. Use `tp-at' for single position queries.
OBJECT defaults to current buffer." OBJECT defaults to current buffer.
Calling conventions:
(tp-get STRING [PROPERTY [SUB-KEYS...]]) - entire string
(tp-get STRING START END [PROPERTY ...]) - range within STRING
(tp-get START END [PROPERTY ...] [OBJECT]) - region form
String positions are 0-based; buffer positions are 1-based."
(cond (cond
;; (tp-get STRING ...) - entire string ;; (tp-get STRING ...) - entire string
;; Returns list of (START END VALUE) intervals for all property values ;; Returns list of (START END VALUE) intervals for all property values
@ -342,6 +362,18 @@ OBJECT defaults to current buffer."
(push (list pos next-pos current-props) intervals)) (push (list pos next-pos current-props) intervals))
(setq pos next-pos))) (setq pos next-pos)))
(nreverse intervals))) (nreverse intervals)))
;; (tp-get str START END [PROPERTY [SUB-KEYS...]]) - range within
;; the string, consistent with the buffer region form. Positions
;; are 0-based as everywhere else for strings.
((numberp end-or-property)
(let ((range-start end-or-property)
(range-end (car args)))
(unless (numberp range-end)
(error "tp-get: string range form requires a numeric END after START, got %S"
range-end))
;; Delegate to the region form with the string as OBJECT.
(apply #'tp-get range-start range-end
(append (cdr args) (list str)))))
;; (tp-get str '(face :foreground)) - property path as list ;; (tp-get str '(face :foreground)) - property path as list
((listp end-or-property) ((listp end-or-property)
(setq property (car end-or-property)) (setq property (car end-or-property))
@ -668,8 +700,12 @@ Returns: For buffers, nil. For entire string forms, a new string."
(tp--remove-sub-from-string str start end end-or-prop prop-or-sub)) (tp--remove-sub-from-string str start end end-or-prop prop-or-sub))
;; (tp-remove str 'face 'help-echo ...) - multiple properties ;; (tp-remove str 'face 'help-echo ...) - multiple properties
((symbolp end-or-prop) ((symbolp end-or-prop)
(let ((props-to-remove (cl-remove-if-not #'symbolp ;; Splice REST so the 3rd and later properties are kept, and
(list end-or-prop prop-or-sub rest)))) ;; drop nils (nil is a symbol and would otherwise ride along
;; when PROP-OR-SUB is not given).
(let ((props-to-remove (cl-remove-if-not
(lambda (p) (and p (symbolp p)))
(cons end-or-prop (cons prop-or-sub rest)))))
(tp--remove-props-from-string str start end props-to-remove))) (tp--remove-props-from-string str start end props-to-remove)))
;; (tp-remove str '(face :underline)) - nested property spec ;; (tp-remove str '(face :underline)) - nested property spec
((listp end-or-prop) ((listp end-or-prop)
@ -691,23 +727,21 @@ PROPS-TO-REMOVE can include layer names, which will be expanded to include
all properties that the layer adds. all properties that the layer adds.
For face properties from layers, subtracts the layer's face contribution For face properties from layers, subtracts the layer's face contribution
instead of removing the entire face property. instead of removing the entire face property.
Operates per property interval, so every interval keeps its own
remaining properties (intervals are never overwritten with properties
sampled at START).
Returns a new string (original is not modified)." Returns a new string (original is not modified)."
(let* ((len (length str)) (let ((result (copy-sequence str)))
(start (max 0 start)) (tp--map-intervals
(end (min end len)) str start end
(before (when (> start 0) (lambda (istart iend existing-props)
(substring str 0 start))) (let (;; Remaining face after layer subtractions (this interval)
(middle-text (substring-no-properties str start end))
(after (when (< end len)
(substring str end len)))
(existing-props (text-properties-at start str))
;; Remaining face after layer subtractions
(remaining-face nil) (remaining-face nil)
;; Track if face was modified by layer subtraction ;; Track if face was modified by layer subtraction
(face-was-modified nil) (face-was-modified nil)
;; Collect all properties to remove entirely (non-face or non-layer) ;; Collect all properties to remove entirely (non-face or non-layer)
(props-to-remove-entirely nil)) (props-to-remove-entirely nil))
;; Process each property to remove ;; Process each property to remove against this interval's props
(dolist (prop props-to-remove) (dolist (prop props-to-remove)
(if (tp--is-layer-name-p prop) (if (tp--is-layer-name-p prop)
;; Layer name - get its face contribution and subtract from face ;; Layer name - get its face contribution and subtract from face
@ -715,7 +749,8 @@ Returns a new string (original is not modified)."
(layer-face (tp--get-layer-face-contribution prop layer-prop-value))) (layer-face (tp--get-layer-face-contribution prop layer-prop-value)))
;; Subtract layer's face from the current face ;; Subtract layer's face from the current face
(when layer-face (when layer-face
(let ((current-face (or remaining-face (plist-get existing-props 'face)))) (let ((current-face (or remaining-face
(plist-get existing-props 'face))))
(setq remaining-face (setq remaining-face
(tp--subtract-face-from-face-value current-face layer-face)) (tp--subtract-face-from-face-value current-face layer-face))
;; Mark that we processed the face (even if result is nil) ;; Mark that we processed the face (even if result is nil)
@ -727,55 +762,47 @@ Returns a new string (original is not modified)."
(push 'tp-name props-to-remove-entirely))) (push 'tp-name props-to-remove-entirely)))
;; Non-layer property - remove entirely ;; Non-layer property - remove entirely
(push prop props-to-remove-entirely))) (push prop props-to-remove-entirely)))
;; Build final properties ;; Build this interval's final properties
(let* ((final-props (let ((final-props
(let ((result nil)) (let ((res nil))
(cl-loop for (key val) on existing-props by #'cddr (cl-loop for (key val) on existing-props by #'cddr
do (cond do (cond
;; Face property with layer subtraction ;; Face property with layer subtraction
((and (eq key 'face) face-was-modified) ((and (eq key 'face) face-was-modified)
(when remaining-face (when remaining-face
(setq result (plist-put result key remaining-face)))) (setq res (plist-put res key remaining-face))))
;; Property to remove entirely ;; Property to remove entirely
((memq key props-to-remove-entirely) ((memq key props-to-remove-entirely)
nil) ; skip nil) ; skip
;; Keep other properties ;; Keep other properties
(t (setq result (plist-put result key val))))) (t (setq res (plist-put res key val)))))
res)))
(set-text-properties istart iend final-props result)))))
result)) result))
(middle-propertized (if final-props
(apply #'propertize middle-text final-props)
middle-text)))
(concat before middle-propertized after))))
(defun tp--remove-sub-from-string (str start end property sub-key) (defun tp--remove-sub-from-string (str start end property sub-key)
"Create a new string from STR with SUB-KEY removed from PROPERTY. "Create a new string from STR with SUB-KEY removed from PROPERTY.
Returns a new string (original is not modified). Returns a new string (original is not modified).
Handles complex face values that contain a mix of symbols and plists." Handles complex face values that contain a mix of symbols and plists.
(let* ((len (length str)) Operates per property interval, so every interval keeps its own
(start (max 0 start)) remaining properties."
(end (min end len)) (let ((result (copy-sequence str)))
(before (when (> start 0) (tp--map-intervals
(substring str 0 start))) str start end
(middle-text (substring-no-properties str start end)) (lambda (istart iend existing-props)
(after (when (< end len) (let* ((prop-value (plist-get existing-props property))
(substring str end len))) ;; Use the helper to handle complex face values
;; Get existing properties and modify the property
(existing-props (text-properties-at start str))
(prop-value (plist-get existing-props property))
;; Use the new helper to handle complex face values
(new-value (when prop-value (new-value (when prop-value
(tp--remove-sub-from-face-value prop-value sub-key))) (tp--remove-sub-from-face-value prop-value sub-key)))
(final-props (let ((result nil)) (final-props (let ((res nil))
(cl-loop for (key val) on existing-props by #'cddr (cl-loop for (key val) on existing-props by #'cddr
do (setq result (plist-put result key do (setq res (plist-put res key
(if (eq key property) (if (eq key property)
new-value new-value
val)))) val))))
res)))
(set-text-properties istart iend final-props result))))
result)) result))
(middle-propertized (if final-props
(apply #'propertize middle-text final-props)
middle-text)))
(concat before middle-propertized after)))
(defun tp--remove-property-from-string (str start end property-spec) (defun tp--remove-property-from-string (str start end property-spec)
"Create a new string from STR with PROPERTY-SPEC removed from START to END. "Create a new string from STR with PROPERTY-SPEC removed from START to END.
@ -789,32 +816,30 @@ Returns a new string (original is not modified)."
(sub-key (cadr property-spec)) (sub-key (cadr property-spec))
(nested-keys (caddr property-spec))) (nested-keys (caddr property-spec)))
(cond (cond
;; Nested sub-property removal ;; Nested sub-property removal - per interval so every interval
;; keeps its own remaining properties
((and sub-key nested-keys) ((and sub-key nested-keys)
;; For complex nested removal, we need to handle this specially (let ((result (copy-sequence str)))
(let* ((len (length str)) (tp--map-intervals
(start (max 0 start)) str start end
(end (min end len)) (lambda (istart iend existing-props)
(before (when (> start 0) (let* ((prop-value (plist-get existing-props property))
(substring str 0 start))) (new-value (if (and prop-value (listp prop-value))
(middle-text (substring-no-properties str start end)) (tp--remove-nested-sub-keys
(after (when (< end len) prop-value sub-key nested-keys)
(substring str end len))) ;; Not a plist-shaped value (e.g. a bare
(existing-props (text-properties-at start str)) ;; face symbol) - the nested spec does
(prop-value (plist-get existing-props property)) ;; not apply; keep the value unchanged.
(new-value (when (and prop-value (listp prop-value)) prop-value))
(tp--remove-nested-sub-keys prop-value sub-key nested-keys))) (final-props (let ((res nil))
(final-props (let ((result nil))
(cl-loop for (key val) on existing-props by #'cddr (cl-loop for (key val) on existing-props by #'cddr
do (setq result (plist-put result key do (setq res (plist-put res key
(if (eq key property) (if (eq key property)
new-value new-value
val)))) val))))
res)))
(set-text-properties istart iend final-props result))))
result)) result))
(middle-propertized (if final-props
(apply #'propertize middle-text final-props)
middle-text)))
(concat before middle-propertized after)))
;; Simple sub-property removal ;; Simple sub-property removal
(sub-key (sub-key
(tp--remove-sub-from-string str start end property sub-key)) (tp--remove-sub-from-string str start end property sub-key))
@ -853,10 +878,21 @@ Returns a new plist (does not modify the original)."
;;;###autoload ;;;###autoload
(defun tp-clear (&optional start end object) (defun tp-clear (&optional start end object)
"Clear all text properties from START to END in OBJECT. "Clear all text properties from START to END in OBJECT.
If START and END are not provided, clear the entire buffer." OBJECT is a string or buffer; nil means the current buffer.
If START and END are not provided, they default to the whole of
OBJECT: 0/(length OBJECT) for strings, `point-min'/`point-max' of
OBJECT for buffers (the current buffer when OBJECT is nil)."
(interactive) (interactive)
(let ((beg (or start (point-min))) (let ((beg (or start
(finish (or end (point-max)))) (cond ((stringp object) 0)
((bufferp object)
(with-current-buffer object (point-min)))
(t (point-min)))))
(finish (or end
(cond ((stringp object) (length object))
((bufferp object)
(with-current-buffer object (point-max)))
(t (point-max))))))
(set-text-properties beg finish nil object))) (set-text-properties beg finish nil object)))
(provide 'tp-ops) (provide 'tp-ops)

62
tp-palette.el
View File

@ -17,15 +17,30 @@
;;; Code: ;;; Code:
(defvar tp-palette-alist nil) (require 'subr-x) ; string-trim-right
(defalias 'tp-palette--plistp
(if (fboundp 'plistp)
#'plistp
(lambda (object)
(let ((len (proper-list-p object)))
(and len (zerop (% len 2)) t))))
"Return non-nil if OBJECT is a property list.
Compatibility shim: `plistp' was only added in Emacs 29.1, while
the library supports Emacs 28.1.")
(defvar tp-palette-alist nil
"Alist of (NAME . PLIST) palette definitions.
This is the single source of truth for palette lookups.")
(defmacro define-tp-palette (name &rest plist) (defmacro define-tp-palette (name &rest plist)
"Register a color palette named NAME, defined by PLIST.
PLIST maps the keys :fg, :bg and :border to colors in any format
accepted by `tp-parse-color' (usually a (LIGHT . DARK) cons).
The palette is stored in `tp-palette-alist'; re-evaluating a
definition updates the stored palette in place."
(declare (indent defun)) (declare (indent defun))
(let ((var (intern (concat "tp-palette-" (symbol-name name))))) `(setf (alist-get ',name tp-palette-alist) '(,@plist)))
`(progn
(setf (alist-get ',name tp-palette-alist)
'(,@plist))
(defvar ,var '(,@plist)))))
(define-tp-palette button-primary (define-tp-palette button-primary
:fg ("#ffffff" . "#ffffff") :bg ("#007bff" . "#007bff")) :fg ("#ffffff" . "#ffffff") :bg ("#007bff" . "#007bff"))
@ -236,19 +251,25 @@
(eq (frame-parameter nil 'background-mode) 'light)) (eq (frame-parameter nil 'background-mode) 'light))
(defun tp-parse-color (color) (defun tp-parse-color (color)
"e.g.1 (tp-parse-color \"red\") "Resolve COLOR to a color string for the current theme.
e.g.2 (tp-parse-color '(\"red\" . \"green\")) COLOR may be:
e.g.3 (tp-parse-color '(:light \"red\" :dark \"green\"))" - a color string, returned as is: \"red\"
- a (LIGHT . DARK) cons: (\"red\" . \"green\"); either side may be
nil, meaning no color for that mode
- a (:light LIGHT :dark DARK) plist: (:light \"red\" :dark \"green\")
Return nil when COLOR is nil, or when the side selected by the
current theme is nil. When the theme cannot be determined, fall
back to the light color."
(cond ((stringp color) color) (cond ((stringp color) color)
((and (consp color) ((and (consp color)
(stringp (car color)) (or (stringp (car color)) (null (car color)))
(stringp (cdr color))) (or (stringp (cdr color)) (null (cdr color))))
(cond (cond
((tp-theme-light-p) (car color)) ((tp-theme-light-p) (car color))
((tp-theme-dark-p) (cdr color)) ((tp-theme-dark-p) (cdr color))
;; Default to light color when background-mode is unknown ;; Default to light color when background-mode is unknown
(t (car color)))) (t (car color))))
((and (plistp color) ((and (tp-palette--plistp color)
(or (plist-member color :light) (or (plist-member color :light)
(plist-member color :dark))) (plist-member color :dark)))
(cond (cond
@ -260,16 +281,13 @@ e.g.3 (tp-parse-color '(:light \"red\" :dark \"green\"))"
(t (error "Invalid format of color %S" color)))) (t (error "Invalid format of color %S" color))))
(defun tp-palette--get-color (symbol key) (defun tp-palette--get-color (symbol key)
"Get color value for KEY from palette SYMBOL. "Get color value for KEY from the palette named SYMBOL.
SYMBOL should be a symbol bound to a palette plist. SYMBOL is looked up in `tp-palette-alist'. KEY should be one of
KEY should be one of :fg, :bg, or :border. :fg, :bg, or :border. Return nil if SYMBOL names no registered
Returns nil if SYMBOL is unbound or doesn't contain KEY." palette or its definition doesn't contain KEY."
(setq symbol (intern (concat "tp-palette-" (let ((plist (alist-get symbol tp-palette-alist)))
(symbol-name symbol)))) (when (tp-palette--plistp plist)
(when (and (symbolp symbol) (boundp symbol)) (tp-parse-color (plist-get plist key)))))
(let ((plist (symbol-value symbol)))
(when (plistp plist)
(tp-parse-color (plist-get plist key))))))
(defun tp-palette-fg-color (symbol) (defun tp-palette-fg-color (symbol)
"Get the foreground color from palette SYMBOL. "Get the foreground color from palette SYMBOL.

25
tp-tests.el
View File

@ -1,11 +1,11 @@
;;; tp-ert-tests.el --- ERT tests for tp.el -*- lexical-binding: t -*- ;;; tp-tests.el --- ERT tests for tp.el -*- lexical-binding: t -*-
;; Copyright (C) 2024 ;; Copyright (C) 2024-2026
;;; Commentary: ;;; Commentary:
;; Comprehensive test suite for tp.el using ERT (Emacs Lisp Regression Testing). ;; Comprehensive test suite for tp.el using ERT (Emacs Lisp Regression Testing).
;; Run with: emacs --batch -l tp.el -l tp-ert-tests.el -f ert-run-tests-batch-and-exit ;; Run with: emacs --batch -L . -l tp.el -l tp-tests.el -f ert-run-tests-batch-and-exit
;;; Code: ;;; Code:
@ -23,13 +23,16 @@
;;; ============================================================ ;;; ============================================================
(defmacro tp-test-with-temp-buffer (&rest body) (defmacro tp-test-with-temp-buffer (&rest body)
"Execute BODY in a temporary buffer with tp.el loaded." "Execute BODY in a temporary buffer with a clean tp state.
All layer registries, transforms and reactive watchers are cleared
before BODY runs and again afterwards (teardown), so state cannot
leak between tests regardless of how BODY exits."
(declare (indent 0)) (declare (indent 0))
`(with-temp-buffer `(unwind-protect
(setq tp-layer-alist nil) (with-temp-buffer
(setq tp-layer-groups nil) (tp-layer-reset)
(tp-reactive-reset) ,@body)
,@body)) (tp-layer-reset)))
;;; ============================================================ ;;; ============================================================
;;; Basic Text Property Functions Tests ;;; Basic Text Property Functions Tests
@ -4109,5 +4112,5 @@ can be tracked and removed."
;; tp-delete property should be removed ;; tp-delete property should be removed
(should (null (get-text-property 0 'tp-delete result))))) (should (null (get-text-property 0 'tp-delete result)))))
(provide 'tp-ert-tests) (provide 'tp-tests)
;;; tp-ert-tests.el ends here ;;; tp-tests.el ends here