diff --git a/README.md b/README.md index ea1a361..f961084 100644 --- a/README.md +++ b/README.md @@ -244,6 +244,11 @@ Add or update properties with deep merge support for nested plists. (tp-set 1 10 '(face (:foreground "red"))) (tp-add 1 10 '(face (:background "blue"))) ;; Result: face is (:foreground "red" :background "blue") + +;; Face prepending - symbol faces are prepended to face list +(tp-set "Hello" 'face 'bold) +(tp-add "Hello" 'face 'shadow) +;; Result: face is (shadow bold) ``` --- @@ -301,9 +306,18 @@ Get property value(s) from position or range, with support for nested sub-proper (tp-get START END PROPERTY) (tp-get START END PROPERTY OBJECT) +;; Range with property path as list +(tp-get START END '(PROPERTY) OBJECT) +(tp-get START END '(PROPERTY SUB-KEY ...) OBJECT) + ;; Range - all properties (tp-get START END) (tp-get START END OBJECT) + +;; Entire string +(tp-get STRING) +(tp-get STRING PROPERTY) +(tp-get STRING PROPERTY SUB-KEY ...) ``` **Examples:** @@ -323,8 +337,16 @@ Get property value(s) from position or range, with support for nested sub-proper ;; Get from range (tp-get 1 10 'face) ; => bold +;; Get with property path as list +(tp-get 5 20 '(face :underline :style) my-string) + ;; Get all properties from range (tp-get 1 10) ; => (face bold help-echo "test") + +;; Get from entire string +(tp-get "Hello World") ; => all properties +(tp-get "Hello World" 'face) ; => face value +(tp-get "Hello World" 'face :foreground) ; => foreground color ``` --- @@ -378,17 +400,22 @@ Get all text properties at POINT as a plist. #### `tp-remove` - Remove Property -Remove a property or nested sub-property from a region. +Remove a property or nested sub-property from a region or entire string. ```elisp -;; Remove entire property +;; Remove entire property (buffer) (tp-remove START END PROPERTY &optional OBJECT) -;; Remove sub-property +;; Remove sub-property (buffer) (tp-remove START END '(PROPERTY SUB-KEY) &optional OBJECT) -;; Remove nested sub-properties +;; Remove nested sub-properties (buffer) (tp-remove START END '(PROPERTY SUB-KEY (NESTED-KEYS...)) &optional OBJECT) + +;; Remove from entire string +(tp-remove STRING PROP1 PROP2 ...) +(tp-remove STRING PROPERTY SUB-KEY) +(tp-remove STRING PROPERTY SUB-KEY '(NESTED-KEYS...)) ``` **Examples:** @@ -404,6 +431,11 @@ Remove a property or nested sub-property from a region. (tp-remove 1 10 '(face :underline (:style :position))) ;; Removes :style and :position from :underline ;; If :color exists in :underline, it's preserved + +;; Remove from entire string +(tp-remove "Hello World" 'face 'help-echo) ; Remove multiple properties +(tp-remove "Hello World" 'face :underline) ; Remove sub-property +(tp-remove "Hello World" 'face :underline '(:style :position)) ; Remove nested ``` --- diff --git a/README_CN.md b/README_CN.md index 1586407..ae204df 100644 --- a/README_CN.md +++ b/README_CN.md @@ -243,6 +243,11 @@ tp.el 提供三个主要的属性设置函数,每个有不同的语义: (tp-set 1 10 '(face (:foreground "red"))) (tp-add 1 10 '(face (:background "blue"))) ;; 结果: face 是 (:foreground "red" :background "blue") + +;; Face 前置 - 符号 face 会被添加到 face 列表的开头 +(tp-set "Hello" 'face 'bold) +(tp-add "Hello" 'face 'shadow) +;; 结果: face 是 (shadow bold) ``` --- @@ -300,9 +305,18 @@ tp.el 提供三个主要的属性设置函数,每个有不同的语义: (tp-get START END PROPERTY) (tp-get START END PROPERTY OBJECT) +;; 范围 - 属性路径作为列表 +(tp-get START END '(PROPERTY) OBJECT) +(tp-get START END '(PROPERTY SUB-KEY ...) OBJECT) + ;; 范围 - 所有属性 (tp-get START END) (tp-get START END OBJECT) + +;; 整个字符串 +(tp-get STRING) +(tp-get STRING PROPERTY) +(tp-get STRING PROPERTY SUB-KEY ...) ``` **示例:** @@ -322,8 +336,16 @@ tp.el 提供三个主要的属性设置函数,每个有不同的语义: ;; 从范围获取 (tp-get 1 10 'face) ; => bold +;; 使用列表形式的属性路径 +(tp-get 5 20 '(face :underline :style) my-string) + ;; 获取范围内的所有属性 (tp-get 1 10) ; => (face bold help-echo "test") + +;; 从整个字符串获取 +(tp-get "Hello World") ; => 所有属性 +(tp-get "Hello World" 'face) ; => face 值 +(tp-get "Hello World" 'face :foreground) ; => 前景色 ``` --- @@ -377,17 +399,22 @@ tp.el 提供三个主要的属性设置函数,每个有不同的语义: #### `tp-remove` - 移除属性 -从区域中移除属性或嵌套子属性。 +从区域或整个字符串中移除属性或嵌套子属性。 ```elisp -;; 移除整个属性 +;; 移除整个属性(缓冲区) (tp-remove START END PROPERTY &optional OBJECT) -;; 移除子属性 +;; 移除子属性(缓冲区) (tp-remove START END '(PROPERTY SUB-KEY) &optional OBJECT) -;; 移除嵌套子属性 +;; 移除嵌套子属性(缓冲区) (tp-remove START END '(PROPERTY SUB-KEY (NESTED-KEYS...)) &optional OBJECT) + +;; 从整个字符串移除 +(tp-remove STRING PROP1 PROP2 ...) +(tp-remove STRING PROPERTY SUB-KEY) +(tp-remove STRING PROPERTY SUB-KEY '(NESTED-KEYS...)) ``` **示例:** @@ -403,6 +430,11 @@ tp.el 提供三个主要的属性设置函数,每个有不同的语义: (tp-remove 1 10 '(face :underline (:style :position))) ;; 从 :underline 移除 :style 和 :position ;; 如果 :underline 中存在 :color,则保留 + +;; 从整个字符串移除 +(tp-remove "Hello World" 'face 'help-echo) ; 移除多个属性 +(tp-remove "Hello World" 'face :underline) ; 移除子属性 +(tp-remove "Hello World" 'face :underline '(:style :position)) ; 移除嵌套 ``` --- diff --git a/tp-tests.el b/tp-tests.el index 1d4b9c5..3c4c7ae 100644 --- a/tp-tests.el +++ b/tp-tests.el @@ -1048,5 +1048,128 @@ (should (eq (get-text-property 4 'face str) 'bold)) (should (equal (get-text-property 4 'help-echo str) "original")))) +;;; ============================================================ +;;; New API Tests - Issue 1: tp-add face prepending +;;; ============================================================ + +(ert-deftest tp-test-add-face-prepend-symbol () + "Test tp-add prepends face symbol to existing face." + (let ((str (copy-sequence "Hello"))) + (tp-set 0 5 '(face bold) str) + (tp-add 0 5 '(face shadow) str) + (let ((face (get-text-property 0 'face str))) + ;; New face should be prepended, creating a list + (should (equal face '(shadow bold)))))) + +(ert-deftest tp-test-add-face-prepend-to-list () + "Test tp-add prepends face to existing face list." + (let ((str (copy-sequence "Hello"))) + (tp-set 0 5 '(face (bold italic)) str) + (tp-add 0 5 '(face shadow) str) + (let ((face (get-text-property 0 'face str))) + ;; New face should be prepended + (should (equal face '(shadow bold italic)))))) + +(ert-deftest tp-test-add-face-plist-merge () + "Test tp-add merges face plist with existing face." + (let ((str (copy-sequence "Hello"))) + (tp-set 0 5 '(face (:foreground "red")) str) + (tp-add 0 5 '(face (:background "blue")) str) + (let ((face (get-text-property 0 'face str))) + (should (equal (plist-get face :foreground) "red")) + (should (equal (plist-get face :background) "blue"))))) + +(ert-deftest tp-test-add-face-symbol-no-dup () + "Test tp-add doesn't duplicate faces." + (let ((str (copy-sequence "Hello"))) + (tp-set 0 5 '(face bold) str) + (tp-add 0 5 '(face bold) str) + (let ((face (get-text-property 0 'face str))) + ;; Should not duplicate + (should (eq face 'bold))))) + +;;; ============================================================ +;;; New API Tests - Issue 2: tp-remove for strings +;;; ============================================================ + +(ert-deftest tp-test-remove-entire-string-single-prop () + "Test tp-remove removes single property from entire string." + (let ((str (tp-set "Hello" 'face 'bold 'help-echo "test"))) + (tp-remove str 'face) + (should (null (get-text-property 0 'face str))) + (should (equal (get-text-property 0 'help-echo str) "test")))) + +(ert-deftest tp-test-remove-entire-string-multiple-props () + "Test tp-remove removes multiple properties from entire string." + (let ((str (tp-set "Hello" 'face 'bold 'help-echo "test" 'mouse-face 'highlight))) + (tp-remove str 'face 'help-echo) + (should (null (get-text-property 0 'face str))) + (should (null (get-text-property 0 'help-echo str))) + (should (eq (get-text-property 0 'mouse-face str) 'highlight)))) + +(ert-deftest tp-test-remove-entire-string-sub-prop () + "Test tp-remove removes sub-property from entire string." + (let ((str (copy-sequence "Hello"))) + (put-text-property 0 5 'face '(:foreground "red" :underline t) str) + (tp-remove str 'face :underline) + (let ((face (get-text-property 0 'face str))) + (should (equal (plist-get face :foreground) "red")) + (should (null (plist-get face :underline)))))) + +(ert-deftest tp-test-remove-entire-string-nested-sub-prop () + "Test tp-remove removes nested sub-properties from entire string." + (let ((str (copy-sequence "Hello"))) + (put-text-property 0 5 'face '(:foreground "red" :underline (:style wave :color "blue")) str) + (tp-remove str 'face :underline '(:style)) + (let* ((face (get-text-property 0 'face str)) + (underline (plist-get face :underline))) + (should (equal (plist-get face :foreground) "red")) + (should (equal (plist-get underline :color) "blue")) + (should (null (plist-get underline :style)))))) + +;;; ============================================================ +;;; New API Tests - Issue 3 & 4: tp-get for strings and new API +;;; ============================================================ + +(ert-deftest tp-test-get-entire-string-all-props () + "Test tp-get returns all properties from entire string." + (let ((str (tp-set "Hello" 'face 'bold 'help-echo "test"))) + (let ((props (tp-get str))) + (should (eq (plist-get props 'face) 'bold)) + (should (equal (plist-get props 'help-echo) "test"))))) + +(ert-deftest tp-test-get-entire-string-single-prop () + "Test tp-get returns single property from entire string." + (let ((str (tp-set "Hello" 'face 'bold 'help-echo "test"))) + (should (eq (tp-get str 'face) 'bold)) + (should (equal (tp-get str 'help-echo) "test")))) + +(ert-deftest tp-test-get-entire-string-nested-prop () + "Test tp-get returns nested property from entire string." + (let ((str (copy-sequence "Hello"))) + (put-text-property 0 5 'face '(:foreground "red" :box (:color "blue" :line-width 2)) str) + (should (equal (tp-get str 'face :foreground) "red")) + (should (equal (tp-get str 'face :box :color) "blue")) + (should (equal (tp-get str 'face :box :line-width) 2)))) + +(ert-deftest tp-test-get-range-with-list-prop-path () + "Test tp-get with property path as list." + (tp-test-with-temp-buffer + (insert "Hello World") + (put-text-property 1 6 'face '(:foreground "red" :underline (:style wave)) nil) + ;; Get with list path + (should (equal (tp-get 1 6 '(face)) '(:foreground "red" :underline (:style wave)))) + (should (equal (tp-get 1 6 '(face :foreground)) "red")) + (should (eq (tp-get 1 6 '(face :underline :style)) 'wave)))) + +(ert-deftest tp-test-get-range-with-list-prop-path-on-string () + "Test tp-get with property path as list on string." + (let ((str (copy-sequence "Hello World"))) + (put-text-property 0 5 'face '(:foreground "red" :underline (:style wave)) str) + ;; Get with list path and object + (should (equal (tp-get 0 5 '(face) str) '(:foreground "red" :underline (:style wave)))) + (should (equal (tp-get 0 5 '(face :foreground) str) "red")) + (should (eq (tp-get 0 5 '(face :underline :style) str) 'wave)))) + (provide 'tp-ert-tests) ;;; tp-ert-tests.el ends here diff --git a/tp.el b/tp.el index 6c1d1a7..eccc6db 100644 --- a/tp.el +++ b/tp.el @@ -289,6 +289,50 @@ NEW values override BASE values." (t val)))))) result)) +(defun tp--prepend-face (new-face existing-face) + "Prepend NEW-FACE to EXISTING-FACE for the face property. +Returns a face value where NEW-FACE takes precedence. +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." + (cond + ;; No existing face - just use new face + ((null existing-face) new-face) + ;; New face is a plist - deep merge with existing + ((and (listp new-face) (keywordp (car-safe new-face))) + (cond + ((and (listp existing-face) (keywordp (car-safe existing-face))) + (tp--deep-merge-plist existing-face new-face)) + ;; Existing is a symbol or list of faces - wrap new plist and prepend + ((symbolp existing-face) + (list new-face existing-face)) + ((listp existing-face) + (cons new-face existing-face)) + (t new-face))) + ;; New face is a symbol - prepend to existing + ((symbolp new-face) + (cond + ((symbolp existing-face) + (if (eq new-face existing-face) + new-face + (list new-face existing-face))) + ((listp existing-face) + (if (member new-face existing-face) + existing-face + (cons new-face existing-face))) + (t new-face))) + ;; New face is a list of faces - prepend to existing + ((listp new-face) + (cond + ((symbolp existing-face) + (if (member existing-face new-face) + new-face + (append new-face (list existing-face)))) + ((listp existing-face) + (append new-face + (cl-remove-if (lambda (f) (member f new-face)) existing-face))) + (t new-face))) + (t new-face))) + (defun tp-add (start-or-string &optional end-or-prop props-or-val &rest rest) "Add or update text properties, preserving existing properties. @@ -310,6 +354,11 @@ Unlike `tp-set', this deeply merges nested properties. For example, \\='(face (:underline (:style wave))) will merge with existing face properties rather than replacing them entirely. +For the `face' property specifically, symbol faces are prepended to +the existing face list rather than replacing. For example: + (tp-add str \\='face \\='shadow) with existing face \\='bold + results in face value \\='(shadow bold). + Return the modified object (string) or region (START . END) for buffer." (pcase-let ((`(,object ,start ,finish ,props) (tp--parse-args start-or-string end-or-prop props-or-val rest))) @@ -323,6 +372,9 @@ Return the modified object (string) or region (START . END) for buffer." do (let* ((current-val (plist-get current-props key)) (new-val (cond + ;; Handle face property specially - prepend faces + ((eq key 'face) + (tp--prepend-face val current-val)) ;; Both are plists - deep merge ((and (listp val) (keywordp (car-safe val)) (listp current-val) (keywordp (car-safe current-val))) @@ -368,7 +420,7 @@ Supports plists, alists, and special display property formats." (t nil)))) (tp--get-nested next-value rest)))) -(defun tp-get (pos-or-start &optional property-or-end &rest args) +(defun tp-get (pos-or-start-or-string &optional property-or-end &rest args) "Get text property value(s) with support for nested sub-properties. This function supports multiple calling conventions: @@ -383,25 +435,56 @@ This function supports multiple calling conventions: (tp-get 5 \\='face :box :color) (tp-get 5 \\='display \\='space :width) -3. Range, single property: +3. Range with property path as list: + (tp-get START END \\='(PROPERTY) OBJECT) + (tp-get START END \\='(PROPERTY SUB-KEY ...) OBJECT) + (tp-get 5 20 \\='(face) str-or-buffer-or-nil) + (tp-get 5 20 \\='(face :underline) str-or-buffer-or-nil) + (tp-get 5 20 \\='(face :underline :style) str-or-buffer-or-nil) + +4. Range, single property: (tp-get START END PROPERTY) (tp-get START END PROPERTY OBJECT) -4. Range, nested sub-property: +5. Range, nested sub-property: (tp-get START END PROPERTY SUB-KEY ...) -5. Range, all properties (returns plist): +6. Range, all properties (returns plist): (tp-get START END) (tp-get START END OBJECT) +7. Entire string, all properties: + (tp-get STRING) + +8. Entire string, single property: + (tp-get STRING PROPERTY) + +9. Entire string, nested sub-property: + (tp-get STRING PROPERTY SUB-KEY ...) + (tp-get str \\='face) + (tp-get str \\='face :underline) + (tp-get str \\='face :underline :style) + For buffers, positions are 1-indexed. For strings, positions are 0-indexed. OBJECT defaults to current buffer." (cond - ;; (tp-get POS PROP ...) or (tp-get POS PROP OBJECT) - single position - ((and (numberp pos-or-start) + ;; (tp-get STRING ...) - entire string + ((stringp pos-or-start-or-string) + (let ((str pos-or-start-or-string)) + (if (null property-or-end) + ;; (tp-get str) - return all properties + (text-properties-at 0 str) + ;; (tp-get str 'face ...) - get specific property with optional sub-path + (let* ((prop-value (get-text-property 0 property-or-end str)) + (sub-path args)) + (if sub-path + (tp--get-nested prop-value sub-path) + prop-value))))) + ;; (tp-get POS PROP ...) or (tp-get POS PROP OBJECT) - single position with symbol property + ((and (numberp pos-or-start-or-string) (symbolp property-or-end)) - (let* ((prop-value (get-text-property pos-or-start property-or-end nil)) + (let* ((prop-value (get-text-property pos-or-start-or-string property-or-end nil)) ;; Determine if last arg is object or sub-property path (sub-path args) (object nil)) @@ -411,14 +494,14 @@ OBJECT defaults to current buffer." (or (bufferp last) (stringp last)))) (setq object (car (last args))) (setq sub-path (butlast args)) - (setq prop-value (get-text-property pos-or-start property-or-end object))) + (setq prop-value (get-text-property pos-or-start-or-string property-or-end object))) (if sub-path (tp--get-nested prop-value sub-path) prop-value))) ;; (tp-get START END ...) - range form - ((and (numberp pos-or-start) + ((and (numberp pos-or-start-or-string) (numberp property-or-end)) - (let* ((start pos-or-start) + (let* ((start pos-or-start-or-string) (end property-or-end) (rest-args args) (property nil) @@ -426,21 +509,28 @@ OBJECT defaults to current buffer." (object nil)) ;; Parse remaining args (when rest-args - (if (symbolp (car rest-args)) - (progn - (setq property (car rest-args)) - (setq rest-args (cdr rest-args)) - ;; Remaining args could be sub-path and/or object - (when rest-args - (if (or (bufferp (car (last rest-args))) - (stringp (car (last rest-args)))) - (progn - (setq object (car (last rest-args))) - (setq sub-path (butlast rest-args))) - (setq sub-path rest-args)))) - ;; First arg is object (buffer/string) - (when (or (bufferp (car rest-args)) (stringp (car rest-args))) - (setq object (car rest-args))))) + (cond + ;; Property path as list: (tp-get 5 20 '(face :underline) obj) + ((listp (car rest-args)) + (let ((prop-path (car rest-args))) + (setq property (car prop-path)) + (setq sub-path (cdr prop-path)) + (setq object (cadr rest-args)))) + ;; Property as symbol + ((symbolp (car rest-args)) + (setq property (car rest-args)) + (setq rest-args (cdr rest-args)) + ;; Remaining args could be sub-path and/or object + (when rest-args + (if (or (bufferp (car (last rest-args))) + (stringp (car (last rest-args)))) + (progn + (setq object (car (last rest-args))) + (setq sub-path (butlast rest-args))) + (setq sub-path rest-args)))) + ;; First arg is object (buffer/string) + ((or (bufferp (car rest-args)) (stringp (car rest-args))) + (setq object (car rest-args))))) (if property ;; Get specific property from range - return first non-nil value (let ((pos start) @@ -547,22 +637,9 @@ Returns the modified plist, or nil if empty after removal." (cl-remf result key)) (if (null result) nil result))) -(defun tp-remove (start end property &optional object) - "Remove PROPERTY or sub-properties from text between START and END. - -PROPERTY can be: -- A symbol: Remove entire property - (tp-remove 1 10 \\='face) - -- A list (PROP SUB-KEY): Remove sub-property from PROP - (tp-remove 1 10 \\='(face :underline)) - -- A list (PROP SUB-KEY (NESTED-KEYS...)): Remove nested sub-properties - (tp-remove 1 10 \\='(face :underline (:style :position))) - This removes :style and :position from :underline, keeping other keys like :color. - If no keys remain in :underline after removal, :underline itself is removed. - -OBJECT defaults to current buffer." +(defun tp--remove-property (start end property object) + "Internal function to remove PROPERTY from START to END in OBJECT. +PROPERTY can be a symbol or a list for nested removal." (cond ;; Simple property removal ((symbolp property) @@ -601,6 +678,68 @@ OBJECT defaults to current buffer." (remove-text-properties pos next-pos (list prop-name nil) object)))) (setq pos next-pos))))))))) +(defun tp-remove (start-or-string end-or-prop &optional prop-or-sub &rest rest) + "Remove properties from text. + +This function supports multiple calling conventions: + +1. Buffer region with property: + (tp-remove START END PROPERTY) + (tp-remove START END PROPERTY OBJECT) + +2. Buffer region with nested property: + (tp-remove START END \\='(PROPERTY SUB-KEY)) + (tp-remove START END \\='(PROPERTY SUB-KEY (NESTED-KEYS...))) + +3. Entire string with properties to remove: + (tp-remove STRING PROP1 PROP2 ...) + (tp-remove \"Hello\" \\='face \\='help-echo) + +4. Entire string with sub-property removal: + (tp-remove STRING PROPERTY SUB-KEY) + (tp-remove \"Hello\" \\='face :underline) + +5. Entire string with nested sub-property removal: + (tp-remove STRING PROPERTY SUB-KEY \\='(NESTED-KEYS...)) + (tp-remove \"Hello\" \\='face :underline \\='(:style :position)) + +Returns the modified string for string input, or nil for buffer operations." + (cond + ;; First arg is a string - apply to entire string + ((stringp start-or-string) + (let ((str start-or-string) + (start 0) + (end (length start-or-string))) + (cond + ;; (tp-remove str 'face :underline '(:style :position)) - nested sub-property removal + ((and (symbolp end-or-prop) + (keywordp prop-or-sub) + rest + (listp (car rest))) + (tp--remove-property start end (list end-or-prop prop-or-sub (car rest)) str)) + ;; (tp-remove str 'face :underline) - sub-property removal + ((and (symbolp end-or-prop) (keywordp prop-or-sub)) + (tp-remove-sub start end end-or-prop prop-or-sub str)) + ;; (tp-remove str 'face 'help-echo ...) - multiple properties + ((symbolp end-or-prop) + (let ((props (cons end-or-prop (cons prop-or-sub rest)))) + (dolist (prop props) + (when (symbolp prop) + (remove-text-properties start end (list prop nil) str))))) + ;; (tp-remove str '(face :underline)) - nested property spec + ((listp end-or-prop) + (tp--remove-property start end end-or-prop str))) + str)) + ;; First arg is a number - buffer region + ((numberp start-or-string) + (let* ((start start-or-string) + (end end-or-prop) + (property prop-or-sub) + (object (car rest))) + (tp--remove-property start end property object) + nil)) + (t (error "Invalid arguments to tp-remove")))) + (defun tp-remove-list (start end properties &optional object) "Remove list of PROPERTIES from text between START and END in OBJECT. PROPERTIES should be a list of property names."