Fix tp-remove for custom layers and complex face sub-properties
- Add tp--remove-sub-from-face-value to handle complex face structures - Add tp--subtract-face-from-face-value to remove layer face contributions - Add tp--get-layer-face-contribution helper function - Update tp--remove-props-from-string to handle layer face subtraction - Update tp--remove-sub-from-string to use new helper - Update tp--expand-layer-to-props-list to detect layer properties - Fix missing closing paren in tp--remove-property function - Update tests to match expected behavior Co-authored-by: Kinneyzhang <38454496+Kinneyzhang@users.noreply.github.com>
This commit is contained in:
parent
c223723d9a
commit
b062eb30fd
26
tp-tests.el
26
tp-tests.el
@ -4131,7 +4131,9 @@ The region form (tp-set START END PROPS STRING) modifies the string in-place."
|
|||||||
(should (not (eq original result))))))
|
(should (not (eq original result))))))
|
||||||
|
|
||||||
(ert-deftest tp-test-remove-custom-layer ()
|
(ert-deftest tp-test-remove-custom-layer ()
|
||||||
"Test that tp-remove correctly removes custom text property layers."
|
"Test that tp-remove correctly removes custom text property layers.
|
||||||
|
When a layer is removed, only its face contribution should be removed,
|
||||||
|
not the entire face property."
|
||||||
;; First define the custom layer
|
;; First define the custom layer
|
||||||
(tp-layer-reset)
|
(tp-layer-reset)
|
||||||
(eval '(define-tp tp-delete (color)
|
(eval '(define-tp tp-delete (color)
|
||||||
@ -4142,25 +4144,31 @@ The region form (tp-set START END PROPS STRING) modifies the string in-place."
|
|||||||
(result (tp-remove str-with-props 'tp-delete)))
|
(result (tp-remove str-with-props 'tp-delete)))
|
||||||
;; Original should still have the properties
|
;; Original should still have the properties
|
||||||
(should (get-text-property 0 'face str-with-props))
|
(should (get-text-property 0 'face str-with-props))
|
||||||
;; Result should not have face property (since it was added by tp-delete)
|
;; Result should have face 'bold (only the tp-delete contribution removed)
|
||||||
(should (null (get-text-property 0 'face result)))
|
(should (equal (get-text-property 0 'face result) 'bold))
|
||||||
|
;; Result should not have tp-delete property
|
||||||
|
(should (null (get-text-property 0 'tp-delete result)))
|
||||||
;; Result should not have tp-name property
|
;; Result should not have tp-name property
|
||||||
(should (null (get-text-property 0 'tp-name result)))))
|
(should (null (get-text-property 0 'tp-name result)))))
|
||||||
|
|
||||||
(ert-deftest tp-test-remove-custom-layer-preserves-other-props ()
|
(ert-deftest tp-test-remove-custom-layer-preserves-other-props ()
|
||||||
"Test that tp-remove with layer name preserves other properties."
|
"Test that tp-remove with layer name preserves other properties.
|
||||||
|
When the layer property is set (via mixed syntax), its face contribution
|
||||||
|
can be tracked and removed."
|
||||||
(tp-layer-reset)
|
(tp-layer-reset)
|
||||||
(eval '(define-tp tp-delete (color)
|
(eval '(define-tp tp-delete (color)
|
||||||
`(face (:strike-through ,color))))
|
`(face (:strike-through ,color))))
|
||||||
;; Test with entire string form - set layer and separate property
|
;; Test with mixed syntax - set layer alongside other properties
|
||||||
|
;; This allows tracking of the layer property
|
||||||
(let* ((str "emacs")
|
(let* ((str "emacs")
|
||||||
(str-with-layer (tp-set str 'tp-delete "red"))
|
(str-with-props (tp-set str 'help-echo "test" 'tp-delete "red"))
|
||||||
(str-with-both (tp-set 0 (length str-with-layer) '(help-echo "test") str-with-layer))
|
(result (tp-remove str-with-props 'tp-delete)))
|
||||||
(result (tp-remove str-with-both 'tp-delete)))
|
|
||||||
;; help-echo should still be present
|
;; help-echo should still be present
|
||||||
(should (equal (get-text-property 0 'help-echo result) "test"))
|
(should (equal (get-text-property 0 'help-echo result) "test"))
|
||||||
;; face (from tp-delete) should be removed
|
;; face (from tp-delete) should be removed
|
||||||
(should (null (get-text-property 0 'face result)))))
|
(should (null (get-text-property 0 'face result)))
|
||||||
|
;; tp-delete property should be removed
|
||||||
|
(should (null (get-text-property 0 'tp-delete result)))))
|
||||||
|
|
||||||
(provide 'tp-ert-tests)
|
(provide 'tp-ert-tests)
|
||||||
;;; tp-ert-tests.el ends here
|
;;; tp-ert-tests.el ends here
|
||||||
|
|||||||
197
tp.el
197
tp.el
@ -303,6 +303,84 @@ and PLIST is the merged plist of all face attributes."
|
|||||||
(t (setq i (1+ i))))))
|
(t (setq i (1+ i))))))
|
||||||
(cons (nreverse symbols) plist)))
|
(cons (nreverse symbols) plist)))
|
||||||
|
|
||||||
|
(defun tp--remove-sub-from-face-value (face-value sub-key)
|
||||||
|
"Remove SUB-KEY from FACE-VALUE, handling complex face structures.
|
||||||
|
FACE-VALUE can be:
|
||||||
|
- A simple plist like (:foreground \"red\" :background \"blue\")
|
||||||
|
- A symbol like bold
|
||||||
|
- A mixed list like ((:foreground \"red\") (:strike-through t) bold)
|
||||||
|
|
||||||
|
Returns the modified face value with SUB-KEY removed from any plist components.
|
||||||
|
Returns nil if the result would be empty."
|
||||||
|
(cond
|
||||||
|
;; Nil face - nothing to remove
|
||||||
|
((null face-value) nil)
|
||||||
|
;; Symbol face - no sub-key to remove
|
||||||
|
((symbolp face-value) face-value)
|
||||||
|
;; Simple plist - remove the sub-key directly
|
||||||
|
((and (listp face-value) (keywordp (car-safe face-value)))
|
||||||
|
(let ((result nil))
|
||||||
|
(cl-loop for (k v) on face-value by #'cddr
|
||||||
|
unless (eq k sub-key)
|
||||||
|
do (setq result (plist-put result k v)))
|
||||||
|
result))
|
||||||
|
;; Mixed list - parse and remove from plist component
|
||||||
|
((listp face-value)
|
||||||
|
(let* ((parsed (tp--parse-face-list face-value))
|
||||||
|
(symbols (car parsed))
|
||||||
|
(plist (cdr parsed)))
|
||||||
|
(when plist
|
||||||
|
;; Remove sub-key from the merged plist
|
||||||
|
(let ((new-plist nil))
|
||||||
|
(cl-loop for (k v) on plist by #'cddr
|
||||||
|
unless (eq k sub-key)
|
||||||
|
do (setq new-plist (plist-put new-plist k v)))
|
||||||
|
(setq plist new-plist)))
|
||||||
|
;; Reconstruct the face value
|
||||||
|
(cond
|
||||||
|
((and symbols plist) (append symbols (list plist)))
|
||||||
|
(symbols (if (= (length symbols) 1) (car symbols) symbols))
|
||||||
|
(plist plist)
|
||||||
|
(t nil))))
|
||||||
|
;; Unknown format - return as-is
|
||||||
|
(t face-value)))
|
||||||
|
|
||||||
|
(defun tp--subtract-face-from-face-value (face-value face-to-remove)
|
||||||
|
"Remove FACE-TO-REMOVE from FACE-VALUE.
|
||||||
|
FACE-TO-REMOVE is the face contribution to subtract (from a layer).
|
||||||
|
FACE-VALUE is the current combined face value.
|
||||||
|
Returns the modified face value with the layer's face contribution removed."
|
||||||
|
(cond
|
||||||
|
;; Nothing to remove from
|
||||||
|
((null face-value) nil)
|
||||||
|
;; If face-to-remove is nil, return as-is
|
||||||
|
((null face-to-remove) face-value)
|
||||||
|
;; If they're equal, remove entirely
|
||||||
|
((equal face-value face-to-remove) nil)
|
||||||
|
;; face-to-remove is a plist - remove those keys from face-value
|
||||||
|
((and (listp face-to-remove) (keywordp (car-safe face-to-remove)))
|
||||||
|
(let ((keys-to-remove (cl-loop for (k _v) on face-to-remove by #'cddr
|
||||||
|
collect k)))
|
||||||
|
;; Remove each key
|
||||||
|
(dolist (key keys-to-remove)
|
||||||
|
(setq face-value (tp--remove-sub-from-face-value face-value key)))
|
||||||
|
face-value))
|
||||||
|
;; face-to-remove is a symbol - remove it from face-value
|
||||||
|
((symbolp face-to-remove)
|
||||||
|
(cond
|
||||||
|
((eq face-value face-to-remove) nil)
|
||||||
|
((and (listp face-value) (not (keywordp (car-safe face-value))))
|
||||||
|
(let ((result (remove face-to-remove face-value)))
|
||||||
|
(if (= (length result) 1) (car result) result)))
|
||||||
|
(t face-value)))
|
||||||
|
;; face-to-remove is a list - remove each element
|
||||||
|
((listp face-to-remove)
|
||||||
|
(dolist (elem face-to-remove)
|
||||||
|
(setq face-value (tp--subtract-face-from-face-value face-value elem)))
|
||||||
|
face-value)
|
||||||
|
;; Unknown - return as-is
|
||||||
|
(t face-value)))
|
||||||
|
|
||||||
(defun tp--merge-string-props-into-plist (str props)
|
(defun tp--merge-string-props-into-plist (str props)
|
||||||
"Merge text properties from string STR into PROPS plist.
|
"Merge text properties from string STR into PROPS plist.
|
||||||
Properties from PROPS take precedence over those in STR.
|
Properties from PROPS take precedence over those in STR.
|
||||||
@ -1846,7 +1924,7 @@ If PROPERTY is a layer name, all properties added by that layer are removed."
|
|||||||
(if new-value
|
(if new-value
|
||||||
(put-text-property pos next-pos prop-name new-value object)
|
(put-text-property pos next-pos prop-name new-value object)
|
||||||
(remove-text-properties pos next-pos (list prop-name nil) object))))
|
(remove-text-properties pos next-pos (list prop-name nil) object))))
|
||||||
(setq pos next-pos))))))))
|
(setq pos next-pos)))))))))
|
||||||
|
|
||||||
(defun tp-remove (start-or-string end-or-prop &optional prop-or-sub &rest rest)
|
(defun tp-remove (start-or-string end-or-prop &optional prop-or-sub &rest rest)
|
||||||
"Remove properties from text.
|
"Remove properties from text.
|
||||||
@ -1931,9 +2009,13 @@ For non-layer symbols, returns a list containing just that symbol."
|
|||||||
(if (tp--is-layer-name-p layer-name)
|
(if (tp--is-layer-name-p layer-name)
|
||||||
(let* ((existing-props (text-properties-at start str))
|
(let* ((existing-props (text-properties-at start str))
|
||||||
(existing-tp-name (plist-get existing-props 'tp-name))
|
(existing-tp-name (plist-get existing-props 'tp-name))
|
||||||
;; Only proceed if this layer is actually applied here
|
(layer-prop-value (plist-get existing-props layer-name))
|
||||||
|
;; Proceed if tp-name matches OR if the layer property exists
|
||||||
|
;; (for cases where layer was used in mixed syntax without tp-name)
|
||||||
(layer-props
|
(layer-props
|
||||||
(when (eq existing-tp-name layer-name)
|
(cond
|
||||||
|
;; tp-name matches - traditional layer application
|
||||||
|
((eq existing-tp-name layer-name)
|
||||||
(cond
|
(cond
|
||||||
;; Parameterized layer - get property keys it would produce
|
;; 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 a dummy arg (t) since we only need the key names, not values
|
||||||
@ -1945,15 +2027,29 @@ For non-layer symbols, returns a list containing just that symbol."
|
|||||||
;; Layer group
|
;; Layer group
|
||||||
((assoc layer-name tp-layer-groups)
|
((assoc layer-name tp-layer-groups)
|
||||||
(when-let ((layer-props-list (tp-group-props layer-name t)))
|
(when-let ((layer-props-list (tp-group-props layer-name t)))
|
||||||
(tp--build-layer-props layer-props-list)))))))
|
(tp--build-layer-props layer-props-list)))))
|
||||||
|
;; Layer property exists (mixed syntax like `tp-set str 'face 'bold 'layer arg`)
|
||||||
|
;; In this case, the layer's face properties are merged into face
|
||||||
|
(layer-prop-value
|
||||||
|
(cond
|
||||||
|
((tp-layer-parameterized-p layer-name)
|
||||||
|
(tp-layer-props-with-arg layer-name layer-prop-value nil))
|
||||||
|
((assoc layer-name tp-layer-alist)
|
||||||
|
(tp-layer-props layer-name nil))
|
||||||
|
((assoc layer-name tp-layer-groups)
|
||||||
|
(when-let ((layer-props-list (tp-group-props layer-name t)))
|
||||||
|
(tp--build-layer-props layer-props-list))))))))
|
||||||
(if layer-props
|
(if layer-props
|
||||||
;; Return all property keys from the layer plus tp-name
|
;; Return all property keys from the layer plus tp-name and the layer itself
|
||||||
(let ((keys (cl-loop for (key _val) on layer-props by #'cddr
|
(let ((keys (cl-loop for (key _val) on layer-props by #'cddr
|
||||||
collect key)))
|
collect key)))
|
||||||
(if (memq 'tp-name keys)
|
(unless (memq 'tp-name keys)
|
||||||
keys
|
(push 'tp-name keys))
|
||||||
(cons 'tp-name keys)))
|
(unless (memq layer-name keys)
|
||||||
;; Layer name doesn't match tp-name, just remove the literal symbol
|
(push layer-name keys))
|
||||||
|
keys)
|
||||||
|
;; Layer name doesn't match tp-name and layer property doesn't exist
|
||||||
|
;; Just remove the literal symbol
|
||||||
(list layer-name)))
|
(list layer-name)))
|
||||||
;; Not a layer name, just return the symbol itself
|
;; Not a layer name, just return the symbol itself
|
||||||
(list layer-name)))
|
(list layer-name)))
|
||||||
@ -1968,10 +2064,29 @@ STR and START are used to determine context for parameterized layers."
|
|||||||
(push expanded result))))
|
(push expanded result))))
|
||||||
(nreverse result)))
|
(nreverse result)))
|
||||||
|
|
||||||
|
(defun tp--get-layer-face-contribution (layer-name layer-prop-value)
|
||||||
|
"Get the face contribution from LAYER-NAME.
|
||||||
|
LAYER-PROP-VALUE is the value of the layer property (the argument passed to it).
|
||||||
|
Returns the face value that the layer adds, or nil if no face contribution."
|
||||||
|
(when (tp--is-layer-name-p layer-name)
|
||||||
|
(let ((layer-props
|
||||||
|
(cond
|
||||||
|
((tp-layer-parameterized-p layer-name)
|
||||||
|
(tp-layer-props-with-arg layer-name layer-prop-value nil))
|
||||||
|
((assoc layer-name tp-layer-alist)
|
||||||
|
(tp-layer-props layer-name nil))
|
||||||
|
((assoc layer-name tp-layer-groups)
|
||||||
|
(when-let ((layer-props-list (tp-group-props layer-name t)))
|
||||||
|
(tp--build-layer-props layer-props-list))))))
|
||||||
|
(when layer-props
|
||||||
|
(plist-get layer-props 'face)))))
|
||||||
|
|
||||||
(defun tp--remove-props-from-string (str start end props-to-remove)
|
(defun tp--remove-props-from-string (str start end props-to-remove)
|
||||||
"Create a new string from STR with PROPS-TO-REMOVE removed from START to END.
|
"Create a new string from STR with PROPS-TO-REMOVE removed from START to END.
|
||||||
PROPS-TO-REMOVE can include layer names, which will be expanded to include
|
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
|
||||||
|
instead of removing the entire face property.
|
||||||
Returns a new string (original is not modified)."
|
Returns a new string (original is not modified)."
|
||||||
(let* ((len (length str))
|
(let* ((len (length str))
|
||||||
(start (max 0 start))
|
(start (max 0 start))
|
||||||
@ -1981,23 +2096,60 @@ Returns a new string (original is not modified)."
|
|||||||
(middle-text (substring-no-properties str start end))
|
(middle-text (substring-no-properties str start end))
|
||||||
(after (when (< end len)
|
(after (when (< end len)
|
||||||
(substring str end len)))
|
(substring str end len)))
|
||||||
;; Expand layer names to their actual properties
|
|
||||||
(expanded-props (tp--expand-props-to-remove props-to-remove str start))
|
|
||||||
;; Get existing properties and remove the specified ones
|
|
||||||
(existing-props (text-properties-at start str))
|
(existing-props (text-properties-at start str))
|
||||||
(final-props (let ((result nil))
|
;; Collect face contributions from layers to subtract
|
||||||
|
(face-to-subtract nil)
|
||||||
|
;; Collect all properties to remove entirely (non-face or non-layer)
|
||||||
|
(props-to-remove-entirely nil))
|
||||||
|
;; Process each property to remove
|
||||||
|
(dolist (prop props-to-remove)
|
||||||
|
(if (tp--is-layer-name-p prop)
|
||||||
|
;; Layer name - get its face contribution and add to subtract list
|
||||||
|
(let* ((layer-prop-value (plist-get existing-props prop))
|
||||||
|
(layer-face (tp--get-layer-face-contribution prop layer-prop-value)))
|
||||||
|
;; Add layer's face to the subtraction list
|
||||||
|
(when layer-face
|
||||||
|
(setq face-to-subtract
|
||||||
|
(tp--subtract-face-from-face-value
|
||||||
|
(or face-to-subtract (plist-get existing-props 'face))
|
||||||
|
layer-face))
|
||||||
|
;; If face-to-subtract is not yet set, initialize it
|
||||||
|
(unless face-to-subtract
|
||||||
|
(setq face-to-subtract (plist-get existing-props 'face))))
|
||||||
|
;; Add the layer property itself to remove list
|
||||||
|
(push prop props-to-remove-entirely)
|
||||||
|
;; Also add tp-name if it matches
|
||||||
|
(when (eq (plist-get existing-props 'tp-name) prop)
|
||||||
|
(push 'tp-name props-to-remove-entirely)))
|
||||||
|
;; Non-layer property - remove entirely
|
||||||
|
(push prop props-to-remove-entirely)))
|
||||||
|
;; Build final properties
|
||||||
|
(let* ((face-was-modified (and face-to-subtract
|
||||||
|
(not (equal face-to-subtract
|
||||||
|
(plist-get existing-props 'face)))))
|
||||||
|
(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
|
||||||
unless (memq key expanded-props)
|
do (cond
|
||||||
do (setq result (plist-put result key val)))
|
;; Face property with layer subtraction
|
||||||
|
((and (eq key 'face) face-was-modified)
|
||||||
|
(when face-to-subtract
|
||||||
|
(setq result (plist-put result key face-to-subtract))))
|
||||||
|
;; Property to remove entirely
|
||||||
|
((memq key props-to-remove-entirely)
|
||||||
|
nil) ; skip
|
||||||
|
;; Keep other properties
|
||||||
|
(t (setq result (plist-put result key val)))))
|
||||||
result))
|
result))
|
||||||
(middle-propertized (if final-props
|
(middle-propertized (if final-props
|
||||||
(apply #'propertize middle-text final-props)
|
(apply #'propertize middle-text final-props)
|
||||||
middle-text)))
|
middle-text)))
|
||||||
(concat before middle-propertized after)))
|
(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."
|
||||||
(let* ((len (length str))
|
(let* ((len (length str))
|
||||||
(start (max 0 start))
|
(start (max 0 start))
|
||||||
(end (min end len))
|
(end (min end len))
|
||||||
@ -2006,15 +2158,12 @@ Returns a new string (original is not modified)."
|
|||||||
(middle-text (substring-no-properties str start end))
|
(middle-text (substring-no-properties str start end))
|
||||||
(after (when (< end len)
|
(after (when (< end len)
|
||||||
(substring str end len)))
|
(substring str end len)))
|
||||||
;; Get existing properties and modify the face
|
;; Get existing properties and modify the property
|
||||||
(existing-props (text-properties-at start str))
|
(existing-props (text-properties-at start str))
|
||||||
(prop-value (plist-get existing-props property))
|
(prop-value (plist-get existing-props property))
|
||||||
(new-value (when (and prop-value (listp prop-value) (keywordp (car-safe prop-value)))
|
;; Use the new helper to handle complex face values
|
||||||
(let ((result nil))
|
(new-value (when prop-value
|
||||||
(cl-loop for (k v) on prop-value by #'cddr
|
(tp--remove-sub-from-face-value prop-value sub-key)))
|
||||||
unless (eq k sub-key)
|
|
||||||
do (setq result (plist-put result k v)))
|
|
||||||
result)))
|
|
||||||
(final-props (let ((result 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 result (plist-put result key
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user