363045ac7c
DOC-STR-01: tp-set's docstring claimed "four calling conventions" and listed three; tp--parse-args actually implements five. The block now enumerates all of them - (START END PROPS), (START END PROPS OBJECT), (STRING PROP VAL ...), (STRING LAYER-NAME [ARG]) and (STRING LAYER-NAME ARG PROP VAL ...) - and the same enumeration is repeated in tp-reset and tp-add, which previously inherited the conventions only implicitly via "Like tp-set". Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
1167 lines
56 KiB
EmacsLisp
1167 lines
56 KiB
EmacsLisp
;;; tp-ops.el --- Core text property operations for tp -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2024-2026 Geekinney
|
|
|
|
;; Author: Geekinney (kinneyzhang666@gmail.com)
|
|
|
|
;; This program is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU General Public License as
|
|
;; published by the Free Software Foundation; either version 3 of
|
|
;; the License, or (at your option) any later version.
|
|
|
|
;;; Commentary:
|
|
|
|
;; The public property primitives: `tp-set', `tp-reset', `tp-add',
|
|
;; `tp-get', `tp-at', `tp-remove', `tp-clear', built on the shared
|
|
;; argument parser. Layer names in property specs are resolved through
|
|
;; tp-layer.el. The reactive `tp-text' property is handled here by
|
|
;; `tp--handle-tp-text-property' and its helper chain; re-rendering on
|
|
;; later variable changes lives in tp-render.el, which calls back down
|
|
;; into these helpers.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'dash)
|
|
(require 'tp-core)
|
|
(require 'tp-reactive)
|
|
(require 'tp-layer)
|
|
|
|
(defun tp--find-tp-text-reactive-var (layer-name)
|
|
"Find the reactive variable symbol used for tp-text in LAYER-NAME.
|
|
Returns the variable symbol (e.g., tp-test-counter) if tp-text uses a
|
|
reactive variable (e.g., $tp-test-counter), or nil if not found.
|
|
Searches through `tp-reactive-deps' to find the original reactive props."
|
|
(catch 'found
|
|
(dolist (dep tp-reactive-deps)
|
|
(let* ((var-sym (car dep))
|
|
(layer-entry (assoc layer-name (cdr dep))))
|
|
(when layer-entry
|
|
(let ((reactive-props (cdr layer-entry)))
|
|
;; Check if tp-text in reactive-props uses this variable
|
|
(when (plist-member reactive-props 'tp-text)
|
|
(let ((tp-text-val (plist-get reactive-props 'tp-text)))
|
|
;; Check if tp-text-val is a reactive symbol for this variable
|
|
(when (and (tp--reactive-symbol-p tp-text-val)
|
|
(eq (tp--reactive-var-symbol tp-text-val) var-sym))
|
|
(throw 'found var-sym))))))))
|
|
nil))
|
|
|
|
(defun tp--tp-text-transform (layer-name text)
|
|
"Return TEXT transformed by LAYER-NAME's `:transform', or TEXT.
|
|
Transform errors are reported and TEXT is returned unchanged; a
|
|
non-string transform result is ignored as well."
|
|
(let ((transform-fn (when layer-name
|
|
(cdr (assoc layer-name tp-layer-transforms)))))
|
|
(if (not transform-fn)
|
|
text
|
|
(condition-case err
|
|
(let ((result (funcall transform-fn text)))
|
|
(tp-debug-log " Transform %s: %S -> %S" layer-name text result)
|
|
(if (stringp result) result text))
|
|
(error
|
|
(message "tp: transform error for %s: %s" layer-name err)
|
|
text)))))
|
|
|
|
(defun tp--merge-embedded-props (embedded props)
|
|
"Merge the EMBEDDED string props plist under PROPS; PROPS win.
|
|
Like `tp--merge-string-props-into-plist' but takes the embedded plist
|
|
directly instead of sampling position 0 of a string, so callers can
|
|
merge per property interval. Face-family values (see
|
|
`tp-face-properties') are merged with PROPS taking precedence; other
|
|
conflicting keys keep the PROPS value; keys only in EMBEDDED are
|
|
added."
|
|
(let ((result (copy-sequence props)))
|
|
(cl-loop for (key val) on embedded by #'cddr
|
|
do (let ((existing (plist-get result key)))
|
|
(setq result
|
|
(plist-put result key
|
|
(if existing
|
|
(if (memq key tp-face-properties)
|
|
(tp--merge-face-values val existing)
|
|
existing)
|
|
val)))))
|
|
result))
|
|
|
|
(defun tp--put-text-property-unless-equal (start end key val object)
|
|
"Apply KEY -> VAL over [START, END) of OBJECT unless already there.
|
|
Like `put-text-property', but when every position of the span already
|
|
holds a value `equal' to VAL for KEY the call is skipped, so an
|
|
update that changes nothing does not flip the buffer-modified flag.
|
|
OBJECT is a string, a buffer, or nil for the current buffer."
|
|
(when (< start end)
|
|
(unless (and (equal (get-text-property start key object) val)
|
|
(>= (or (next-single-property-change start key object end)
|
|
end)
|
|
end))
|
|
(put-text-property start end key val object))))
|
|
|
|
(defun tp--apply-reactive-text-props (source props offset &optional target)
|
|
"Apply PROPS merged with SOURCE's embedded props to TARGET at OFFSET.
|
|
SOURCE is the (possibly propertized) replacement string; TARGET is a
|
|
string, or nil for the current buffer. For every embedded-property
|
|
interval of SOURCE the interval's props are merged under PROPS (see
|
|
`tp--merge-embedded-props') and the result is applied to the
|
|
corresponding span of TARGET shifted by OFFSET. This keeps
|
|
per-interval styling of propertized reactive strings intact instead
|
|
of smearing position-0 props across the whole region. Spans that
|
|
already carry an `equal' value are left untouched, so an update that
|
|
changes nothing does not mark the buffer as modified."
|
|
(tp--map-intervals
|
|
source nil nil
|
|
(lambda (istart iend str-props)
|
|
(let ((merged (if str-props
|
|
(tp--merge-embedded-props str-props props)
|
|
props)))
|
|
(cl-loop for (key val) on merged by #'cddr
|
|
do (tp--put-text-property-unless-equal
|
|
(+ offset istart) (+ offset iend) key val target))))))
|
|
|
|
(defun tp--tp-text-replace (start end final-text result-props object preserve-props)
|
|
"Replace [START, END) of OBJECT with FINAL-TEXT, handling props.
|
|
Implements the text replacement of `tp--handle-tp-text-property' and
|
|
returns its (PROPS NEW-END NEW-OBJECT) result.
|
|
|
|
For a string OBJECT a NEW string is built as prefix + FINAL-TEXT +
|
|
suffix, so text outside the region survives. RESULT-PROPS (merged
|
|
per embedded interval of FINAL-TEXT) are applied to the replaced span
|
|
here, because callers can only apply props from index 0, which would
|
|
smear them over the preserved prefix; the returned NEW-END is 0 so
|
|
the caller's own application over [0, NEW-END) is a no-op.
|
|
|
|
For buffers the region text is replaced in place and the returned
|
|
NEW-END is the end of the inserted text; the caller applies
|
|
RESULT-PROPS itself.
|
|
|
|
When PRESERVE-PROPS is non-nil, properties present at START whose
|
|
keys RESULT-PROPS does not set are re-applied over the replacement."
|
|
(if (stringp object)
|
|
(let* ((plain (substring-no-properties final-text))
|
|
;; Splice: keep the string outside [start, end) intact.
|
|
(new-string (concat (substring object 0 start)
|
|
plain
|
|
(substring object end)))
|
|
(new-end (+ start (length plain)))
|
|
(existing-props (when preserve-props
|
|
(text-properties-at start object))))
|
|
;; Preserve non-conflicting existing props of the replaced region
|
|
(cl-loop for (key val) on existing-props by #'cddr
|
|
do (unless (plist-member result-props key)
|
|
(put-text-property start new-end key val new-string)))
|
|
;; Apply the merged props per embedded interval of FINAL-TEXT
|
|
(tp--apply-reactive-text-props final-text result-props start new-string)
|
|
(list result-props 0 new-string))
|
|
;; Buffer object
|
|
(with-current-buffer (or object (current-buffer))
|
|
(let ((old-text (buffer-substring-no-properties start end)))
|
|
(if (equal old-text (substring-no-properties final-text))
|
|
;; Same text content, no replacement needed
|
|
(list result-props end object)
|
|
;; Need to replace text
|
|
(let ((existing-props (when preserve-props
|
|
(text-properties-at start)))
|
|
(inhibit-read-only t))
|
|
(save-excursion
|
|
(delete-region start end)
|
|
(goto-char start)
|
|
;; Insert without properties - the caller applies RESULT-PROPS
|
|
(insert (substring-no-properties final-text)))
|
|
(let ((new-end (+ start (length final-text))))
|
|
;; Re-apply existing properties to new text region if preserving
|
|
(cl-loop for (key val) on existing-props by #'cddr
|
|
do (unless (plist-member result-props key)
|
|
(put-text-property start new-end key val object)))
|
|
(list result-props new-end object))))))))
|
|
|
|
(defun tp--handle-tp-text-property (start end props object &optional preserve-props merge-mode)
|
|
"Handle tp-text property in PROPS for region from START to END in OBJECT.
|
|
If tp-text is nil, initialize it to the current text in the region;
|
|
when the layer has a `:transform', the displayed text is the
|
|
transformed value (matching later reactive updates) while the model -
|
|
the reactive variable and the `tp-text' property - keeps the raw text.
|
|
If tp-text is a string different from current text, replace the text.
|
|
When PRESERVE-PROPS is non-nil, existing text properties are preserved
|
|
on the replaced text (used by tp-set and tp-add).
|
|
MERGE-MODE is retained for backward compatibility but no longer
|
|
affects behavior.
|
|
All modes now preserve embedded text properties from tp-text, with props taking
|
|
precedence over embedded props when there's a conflict.
|
|
Returns (PROPS NEW-END NEW-OBJECT) where PROPS is the updated props,
|
|
NEW-END is the new end position after any text replacement, and
|
|
NEW-OBJECT is the new string object (only different for strings whose
|
|
text was replaced; see `tp--tp-text-replace' for the string-object
|
|
convention of a 0 NEW-END with pre-applied properties)."
|
|
(ignore merge-mode)
|
|
(if (not (plist-member props 'tp-text))
|
|
;; tp-text not in props - return unchanged
|
|
(list props end object)
|
|
(let ((tp-text-val (plist-get props 'tp-text))
|
|
(layer-name (plist-get props 'tp-name)))
|
|
(cond
|
|
;; tp-text is nil - initialize it to the current text
|
|
((null tp-text-val)
|
|
(let ((current-text
|
|
(if (stringp object)
|
|
(substring-no-properties object start end)
|
|
(with-current-buffer (or object (current-buffer))
|
|
(buffer-substring-no-properties start end)))))
|
|
;; If tp-text uses a reactive variable, update that variable to match
|
|
;; This ensures the reactive variable and buffer text stay in sync
|
|
(when layer-name
|
|
(when-let ((reactive-var (tp--find-tp-text-reactive-var layer-name)))
|
|
;; Update the reactive variable with the current text
|
|
;; Note: Using global `set` here because the layer definition is global.
|
|
;; When the variable is changed, the reactive watcher will update all
|
|
;; buffers that have this layer applied.
|
|
(set reactive-var current-text)
|
|
;; Also update the layer definition so future accesses see the new value
|
|
(let ((layer-props (cdr (assoc layer-name tp-layer-alist))))
|
|
(when layer-props
|
|
(tp--set-layer-props layer-name
|
|
(plist-put layer-props 'tp-text current-text))))))
|
|
(setq props (plist-put props 'tp-text current-text))
|
|
;; Apply the layer's :transform to the DISPLAYED text on this first
|
|
;; render too, so the initial rendering matches later reactive
|
|
;; updates. The model value stays the raw text.
|
|
(let ((display-text (tp--tp-text-transform layer-name current-text)))
|
|
(if (equal display-text current-text)
|
|
(list props end object)
|
|
(tp--tp-text-replace
|
|
start end display-text
|
|
(tp--merge-string-props-into-plist display-text props)
|
|
object preserve-props)))))
|
|
;; tp-text has a string value - replace the text in the region
|
|
((stringp tp-text-val)
|
|
;; Apply transform if layer has one registered
|
|
(let* ((final-text (tp--tp-text-transform layer-name tp-text-val))
|
|
;; Embedded text properties from tp-text are preserved in all
|
|
;; cases. The props passed to this function take precedence
|
|
;; over embedded props when there's a conflict (e.g. both have
|
|
;; a `face' property).
|
|
(result-props
|
|
(tp--merge-string-props-into-plist final-text props)))
|
|
(tp--tp-text-replace start end final-text result-props
|
|
object preserve-props)))
|
|
;; Other types - return unchanged
|
|
(t (list props end object))))))
|
|
|
|
(defun tp--parse-args (start-or-string end-or-prop props-or-val rest)
|
|
"Parse flexible function arguments and return (OBJECT START END PROPS).
|
|
Supports multiple calling conventions:
|
|
1. Buffer region: (START END PROPS)
|
|
2. Buffer region with object: (START END PROPS OBJECT)
|
|
3. String region: (START END PROPS STRING)
|
|
4. Entire string with plist: (STRING PROP VAL ...)
|
|
5. Entire string with layer: (STRING LAYER-NAME ARG)
|
|
6. Entire string with layer and extra props:
|
|
(STRING LAYER-NAME ARG PROP VAL ...)"
|
|
(let (object start finish props)
|
|
(cond
|
|
;; First arg is a string - apply to entire string
|
|
((stringp start-or-string)
|
|
(setq object start-or-string
|
|
start 0
|
|
finish (length start-or-string))
|
|
;; Check if second arg is a layer/group name or parameterized layer
|
|
(cond
|
|
;; (tp-set "str" 'layer-name arg ...) - layer with argument and optional extra props
|
|
((and (symbolp end-or-prop)
|
|
(or (assoc end-or-prop tp-layer-alist)
|
|
(assoc end-or-prop tp-layer-groups))
|
|
props-or-val)
|
|
;; Build props: (layer-name arg extra-prop1 val1 ...)
|
|
(setq props (cons end-or-prop (cons props-or-val rest))))
|
|
;; (tp-set "str" 'layer-name) - layer without argument (legacy)
|
|
((and (symbolp end-or-prop)
|
|
(or (assoc end-or-prop tp-layer-alist)
|
|
(assoc end-or-prop tp-layer-groups))
|
|
(null props-or-val)
|
|
(null rest))
|
|
(setq props (list end-or-prop)))
|
|
;; Standard flat plist: (tp-set "str" 'prop1 val1 'prop2 val2 ...)
|
|
;; Always include props-or-val even if it's nil, to handle (tp-set "str" 'prop nil)
|
|
(t
|
|
(setq props (if end-or-prop
|
|
(cons end-or-prop (cons props-or-val rest))
|
|
nil)))))
|
|
;; First arg is a number - region convention
|
|
((numberp start-or-string)
|
|
(setq start start-or-string
|
|
finish end-or-prop
|
|
props props-or-val)
|
|
;; Check if 4th arg (first of rest) is a buffer or string
|
|
(let ((extra rest))
|
|
(when (and extra (or (bufferp (car extra))
|
|
(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)))
|
|
;; Unwrap double-wrapped properties
|
|
(when (and (listp props) (listp (car-safe props)))
|
|
(setq props (car props)))
|
|
;; Merge duplicate keys in the plist (for single-call property setting)
|
|
;; This must happen before tp--resolve-props to properly handle face merging
|
|
;; Use (cdddr props) for O(1) check - need at least 4 elements (2 key-value pairs) for possible duplicates
|
|
(when (and (listp props) (cdddr props))
|
|
(setq props (tp--merge-duplicate-keys props)))
|
|
;; Resolve props: handles layer/group names and anonymous reactive plists
|
|
(when props
|
|
(setq props (or (tp--resolve-props props) props)))
|
|
(list object start finish props)))
|
|
|
|
(defun tp--ops-register-layer-buffer (props object)
|
|
"Record OBJECT in the reactive buffer registry for PROPS's layer.
|
|
When PROPS carries a `tp-name' (a resolved layer application) and
|
|
OBJECT is a buffer or nil (the current buffer), register that buffer
|
|
under the layer's name so reactive updates can walk only registered
|
|
buffers instead of scanning `buffer-list'. String OBJECTs are not
|
|
registered; see `tp-reactive-layer-buffers' for that gap."
|
|
(when-let ((layer-name (plist-get props 'tp-name)))
|
|
(when (or (null object) (bufferp object))
|
|
(tp-reactive--register-layer-buffer
|
|
layer-name (or object (current-buffer))))))
|
|
|
|
(defun tp--apply-props-to-string (str start end props &optional merge-mode)
|
|
"Apply PROPS to string STR from START to END, returning a NEW string.
|
|
This function does not modify the original string.
|
|
Preserves the original text property intervals.
|
|
|
|
MERGE-MODE controls how properties are applied:
|
|
nil or :set - Set properties, preserving existing unspecified ones
|
|
:reset - Completely replace all properties
|
|
:add - Merge properties deeply (for face, prepend symbols)
|
|
|
|
Returns a new propertized string."
|
|
(let* ((len (length str))
|
|
;; Ensure bounds are valid
|
|
(start (max 0 start))
|
|
(end (min end len)))
|
|
(cond
|
|
;; :reset - completely replace properties in the range
|
|
((eq merge-mode :reset)
|
|
(let ((result (copy-sequence str)))
|
|
(set-text-properties start end props result)
|
|
result))
|
|
;; :add - deep merge with face prepending
|
|
((eq merge-mode :add)
|
|
(let ((result (copy-sequence str)))
|
|
(cl-loop
|
|
for (key val) on props by #'cddr
|
|
do (let ((pos start))
|
|
(while (< pos end)
|
|
(let* ((current-val (get-text-property pos key result))
|
|
(new-val (cond
|
|
((memq key tp-face-properties)
|
|
(tp--prepend-face val current-val))
|
|
((and (listp val) (keywordp (car-safe val))
|
|
(listp current-val) (keywordp (car-safe current-val)))
|
|
(tp--deep-merge-plist current-val val))
|
|
(t val)))
|
|
(next-change (or (next-single-property-change pos key result end) end)))
|
|
(put-text-property pos next-change key new-val result)
|
|
(setq pos next-change)))))
|
|
result))
|
|
;; nil/:set - set properties while preserving existing ones
|
|
;; If applying to the entire string, use propertize for efficiency
|
|
;; Otherwise, use copy-sequence + put-text-property to apply to specific range
|
|
(t
|
|
(if (and (= start 0) (= end len))
|
|
;; Entire string: use propertize which creates a new copy and preserves existing properties
|
|
(apply #'propertize str props)
|
|
;; Partial range: copy string and apply properties to the range
|
|
(let ((result (copy-sequence str)))
|
|
(cl-loop for (key val) on props by #'cddr
|
|
do (put-text-property start end key val result))
|
|
result))))))
|
|
|
|
(defun tp-set (start-or-string &optional end-or-prop props-or-val &rest rest)
|
|
"Set text properties on string or buffer region.
|
|
|
|
Supports five calling conventions:
|
|
1. (tp-set START END PROPS) - region of the current buffer
|
|
2. (tp-set START END PROPS OBJECT) - region of a buffer or string
|
|
3. (tp-set STRING PROP VAL ...) - entire string, flat prop/value pairs
|
|
4. (tp-set STRING LAYER-NAME [ARG]) - entire string, a defined
|
|
layer/group, optionally with its argument
|
|
5. (tp-set STRING LAYER-NAME ARG PROP VAL ...) - entire string, a
|
|
parameterized layer/group plus extra flat properties
|
|
|
|
PROPS can be a plist or a layer/group name symbol.
|
|
Preserves existing properties not specified in PROPS.
|
|
For tp-text, props override embedded text properties.
|
|
|
|
**String Modification Behavior:**
|
|
- Entire string form (tp-set STRING ...): Returns a NEW propertized string
|
|
(original is not modified). Uses `propertize' internally.
|
|
- Region form with string (tp-set START END PROPS STRING): Modifies the
|
|
original string in-place using `put-text-property'.
|
|
- Buffer forms: Always modify in-place.
|
|
|
|
Returns: For buffers, (START . END) cons. For strings, the result string."
|
|
;; Determine if this is the "entire string" form (first arg is a string)
|
|
(let ((entire-string-form (stringp start-or-string)))
|
|
(pcase-let ((`(,object ,start ,finish ,props)
|
|
(tp--parse-args start-or-string end-or-prop props-or-val rest)))
|
|
;; Handle tp-text property specially - :override means props override embedded props
|
|
(pcase-let ((`(,new-props ,new-finish ,new-object)
|
|
(tp--handle-tp-text-property start finish props object t :override)))
|
|
(setq props new-props finish new-finish object new-object)
|
|
(when (and (stringp object) (plist-member props 'tp-text))
|
|
(setq start 0)))
|
|
(cond
|
|
;; Entire string form: create a new propertized string (non-destructive)
|
|
((and (stringp object) entire-string-form)
|
|
(tp--apply-props-to-string object start finish props nil))
|
|
;; Region form with string object: modify in-place
|
|
((stringp object)
|
|
(let ((has-existing-props (text-properties-at start object)))
|
|
(if (and (not has-existing-props)
|
|
(= start (or (next-single-property-change start nil object finish) finish)))
|
|
(set-text-properties start finish props object)
|
|
(cl-loop for (key val) on props by #'cddr
|
|
do (put-text-property start finish key val object))))
|
|
object)
|
|
;; Buffer: modify in place
|
|
(t
|
|
(let ((has-existing-props (text-properties-at start object)))
|
|
(if (and (not has-existing-props)
|
|
(= start (or (next-single-property-change start nil object finish) finish)))
|
|
(set-text-properties start finish props object)
|
|
(cl-loop for (key val) on props by #'cddr
|
|
do (put-text-property start finish key val object))))
|
|
(tp--ops-register-layer-buffer props object)
|
|
(cons start finish))))))
|
|
|
|
(defun tp-reset (start-or-string &optional end-or-prop props-or-val &rest rest)
|
|
"Completely replace all text properties with PROPS.
|
|
Like `tp-set' but replaces ALL existing properties.
|
|
|
|
Supports the same five calling conventions as `tp-set':
|
|
1. (tp-reset START END PROPS) - region of the current buffer
|
|
2. (tp-reset START END PROPS OBJECT) - region of a buffer or string
|
|
3. (tp-reset STRING PROP VAL ...) - entire string, flat pairs
|
|
4. (tp-reset STRING LAYER-NAME [ARG]) - entire string, defined
|
|
layer/group
|
|
5. (tp-reset STRING LAYER-NAME ARG PROP VAL ...) - layer plus extra
|
|
flat properties
|
|
|
|
For tp-text, embedded text properties are preserved (props override
|
|
if there's a conflict).
|
|
|
|
**String Modification Behavior:**
|
|
- Entire string form (tp-reset STRING ...): Returns a NEW propertized string
|
|
(original is not modified). Uses `propertize' internally.
|
|
- Region form with string (tp-reset START END PROPS STRING): Modifies the
|
|
original string in-place using `set-text-properties'.
|
|
- Buffer forms: Always modify in-place.
|
|
|
|
Returns: For buffers, (START . END) cons. For strings, the result string."
|
|
;; Determine if this is the "entire string" form (first arg is a string)
|
|
(let ((entire-string-form (stringp start-or-string)))
|
|
(pcase-let ((`(,object ,start ,finish ,props)
|
|
(tp--parse-args start-or-string end-or-prop props-or-val rest)))
|
|
;; Handle tp-text property - :reset means only use props, ignore embedded props
|
|
(pcase-let ((`(,new-props ,new-finish ,new-object)
|
|
(tp--handle-tp-text-property start finish props object nil :reset)))
|
|
(setq props new-props finish new-finish object new-object)
|
|
(when (and (stringp object) (plist-member props 'tp-text))
|
|
(setq start 0)))
|
|
(cond
|
|
;; Entire string form: create a new propertized string (non-destructive)
|
|
((and (stringp object) entire-string-form)
|
|
(tp--apply-props-to-string object start finish props :reset))
|
|
;; Region form with string object: modify in-place
|
|
((stringp object)
|
|
(set-text-properties start finish props object)
|
|
object)
|
|
;; Buffer: modify in place
|
|
(t
|
|
(set-text-properties start finish props object)
|
|
(tp--ops-register-layer-buffer props object)
|
|
(cons start finish))))))
|
|
|
|
(defun tp-add (start-or-string &optional end-or-prop props-or-val &rest rest)
|
|
"Add or update text properties with deep merging.
|
|
Unlike `tp-set', deeply merges nested properties.
|
|
|
|
Supports the same five calling conventions as `tp-set':
|
|
1. (tp-add START END PROPS) - region of the current buffer
|
|
2. (tp-add START END PROPS OBJECT) - region of a buffer or string
|
|
3. (tp-add STRING PROP VAL ...) - entire string, flat pairs
|
|
4. (tp-add STRING LAYER-NAME [ARG]) - entire string, defined
|
|
layer/group
|
|
5. (tp-add STRING LAYER-NAME ARG PROP VAL ...) - layer plus extra
|
|
flat properties
|
|
|
|
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.
|
|
|
|
**String Modification Behavior:**
|
|
- Entire string form (tp-add STRING ...): Returns a NEW propertized string
|
|
(original is not modified). Uses `propertize' internally.
|
|
- Region form with string (tp-add START END PROPS STRING): Modifies the
|
|
original string in-place using `put-text-property'.
|
|
- Buffer forms: Always modify in-place.
|
|
|
|
Returns: For buffers, (START . END) cons. For strings, the result string."
|
|
;; Determine if this is the "entire string" form (first arg is a string)
|
|
(let ((entire-string-form (stringp start-or-string)))
|
|
(pcase-let ((`(,object ,start ,finish ,props)
|
|
(tp--parse-args start-or-string end-or-prop props-or-val rest)))
|
|
;; Handle tp-text property - :merge means embedded props are merged with props
|
|
(let ((has-tp-text (plist-member props 'tp-text)))
|
|
(pcase-let ((`(,new-props ,new-finish ,new-object)
|
|
(tp--handle-tp-text-property start finish props object t :merge)))
|
|
(setq props new-props finish new-finish object new-object)
|
|
(when (and (stringp object) has-tp-text)
|
|
(setq start 0))))
|
|
(cond
|
|
;; Entire string form: create a new propertized string (non-destructive)
|
|
((and (stringp object) entire-string-form)
|
|
(if (plist-member props 'tp-text)
|
|
;; For tp-text: tp--handle-tp-text-property has already merged embedded
|
|
;; properties with props (in :merge mode above). The new-object is a
|
|
;; fresh string with tp-text content, and new-props contains all merged
|
|
;; properties. We use :reset mode here to simply apply these final
|
|
;; merged properties to the new string, without re-merging with any
|
|
;; (non-existent) existing properties on the new string.
|
|
(tp--apply-props-to-string object start finish props :reset)
|
|
;; Otherwise use :add mode for deep merging with any existing properties
|
|
(tp--apply-props-to-string object start finish props :add)))
|
|
;; Region form with string object: modify in-place with deep merging
|
|
((stringp object)
|
|
(let ((pos start))
|
|
(while (< pos finish)
|
|
(let* ((current-props (text-properties-at pos object))
|
|
(next-pos (or (next-property-change pos object finish) finish)))
|
|
(cl-loop
|
|
for (key val) on props by #'cddr
|
|
do (let* ((current-val (plist-get current-props key))
|
|
(new-val (cond
|
|
((memq key tp-face-properties)
|
|
(tp--prepend-face val current-val))
|
|
((and (listp val) (keywordp (car-safe val))
|
|
(listp current-val) (keywordp (car-safe current-val)))
|
|
(tp--deep-merge-plist current-val val))
|
|
(t val))))
|
|
(put-text-property pos next-pos key new-val object)))
|
|
(setq pos next-pos))))
|
|
object)
|
|
;; Buffer: modify in place with deep merging
|
|
(t
|
|
(let ((pos start))
|
|
(while (< pos finish)
|
|
(let* ((current-props (text-properties-at pos object))
|
|
(next-pos (or (next-property-change pos object finish) finish)))
|
|
(cl-loop
|
|
for (key val) on props by #'cddr
|
|
do (let* ((current-val (plist-get current-props key))
|
|
(new-val (cond
|
|
((memq key tp-face-properties)
|
|
(tp--prepend-face val current-val))
|
|
((and (listp val) (keywordp (car-safe val))
|
|
(listp current-val) (keywordp (car-safe current-val)))
|
|
(tp--deep-merge-plist current-val val))
|
|
(t val))))
|
|
(put-text-property pos next-pos key new-val object)))
|
|
(setq pos next-pos))))
|
|
(tp--ops-register-layer-buffer props object)
|
|
(cons start finish))))))
|
|
|
|
(defun tp-get (start-or-string &optional end-or-property &rest args)
|
|
"Get text property value(s) with support for nested sub-properties.
|
|
Returns list of (START END VALUE) intervals.
|
|
Use `tp-at' for single position queries.
|
|
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
|
|
;; (tp-get STRING ...) - entire string
|
|
;; Returns list of (START END VALUE) intervals for all property values
|
|
((stringp start-or-string)
|
|
(let* ((str start-or-string)
|
|
(len (length str))
|
|
(property nil)
|
|
(sub-path nil))
|
|
(cond
|
|
;; (tp-get str) - return all property intervals
|
|
((null end-or-property)
|
|
(let ((intervals nil)
|
|
(pos 0))
|
|
(while (< pos len)
|
|
(let* ((current-props (text-properties-at pos str))
|
|
(next-pos (or (next-property-change pos str len) len)))
|
|
(when current-props
|
|
(push (list pos next-pos current-props) intervals))
|
|
(setq pos next-pos)))
|
|
(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
|
|
((listp end-or-property)
|
|
(setq property (car end-or-property))
|
|
(setq sub-path (cdr end-or-property))
|
|
(let ((intervals nil)
|
|
(pos 0))
|
|
(while (< pos len)
|
|
(let* ((prop-value (get-text-property pos property str))
|
|
(next-pos (or (next-single-property-change
|
|
pos property str len)
|
|
len))
|
|
(value (if sub-path
|
|
(tp--get-nested prop-value sub-path)
|
|
prop-value)))
|
|
(when value
|
|
(push (list pos next-pos value) intervals))
|
|
(setq pos next-pos)))
|
|
(nreverse intervals)))
|
|
;; (tp-get str 'face ...) - property as symbol with optional sub-path
|
|
((symbolp end-or-property)
|
|
(setq property end-or-property)
|
|
(setq sub-path args)
|
|
(let ((intervals nil)
|
|
(pos 0))
|
|
(while (< pos len)
|
|
(let* ((prop-value (get-text-property pos property str))
|
|
(next-pos (or (next-single-property-change
|
|
pos property str len)
|
|
len))
|
|
(value (if sub-path
|
|
(tp--get-nested prop-value sub-path)
|
|
prop-value)))
|
|
(when value
|
|
(push (list pos next-pos value) intervals))
|
|
(setq pos next-pos)))
|
|
(nreverse intervals))))))
|
|
;; (tp-get START END ...) - range form
|
|
((and (numberp start-or-string)
|
|
(numberp end-or-property))
|
|
(let* ((start start-or-string)
|
|
(end end-or-property)
|
|
(rest-args args)
|
|
(property nil)
|
|
(sub-path nil)
|
|
(object nil))
|
|
;; Parse remaining args
|
|
(when 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 list of (START END VALUE) for all intervals
|
|
(let ((pos start)
|
|
(intervals nil))
|
|
(while (< pos end)
|
|
(let* ((prop-value (get-text-property pos property object))
|
|
(next-pos (or (next-single-property-change
|
|
pos property object end)
|
|
end))
|
|
(value (if sub-path
|
|
(tp--get-nested prop-value sub-path)
|
|
prop-value)))
|
|
(when value
|
|
(push (list pos next-pos value) intervals))
|
|
(setq pos next-pos)))
|
|
(nreverse intervals))
|
|
;; Get all properties from range - return list of (START END PLIST) intervals
|
|
(let ((intervals nil)
|
|
(pos start)
|
|
(obj (or object (current-buffer))))
|
|
(while (< pos end)
|
|
(let* ((current-props (text-properties-at pos obj))
|
|
(next-pos (or (next-property-change pos obj end) end)))
|
|
(when current-props
|
|
(push (list pos next-pos current-props) intervals))
|
|
(setq pos next-pos)))
|
|
(nreverse intervals)))))
|
|
(t (error "Invalid arguments to tp-get"))))
|
|
|
|
(defun tp-at (pos &optional property-or-object object)
|
|
"Get text properties at POS in OBJECT, optionally filtered by PROPERTY.
|
|
|
|
This function supports multiple calling conventions:
|
|
|
|
1. Get all properties at position:
|
|
(tp-at POS)
|
|
(tp-at POS OBJECT)
|
|
|
|
2. Get specific property at position:
|
|
(tp-at POS PROPERTY)
|
|
(tp-at POS PROPERTY OBJECT)
|
|
|
|
3. Get nested sub-property at position:
|
|
(tp-at POS \\='(PROPERTY SUB-KEY ...))
|
|
(tp-at POS \\='(PROPERTY SUB-KEY ...) OBJECT)
|
|
|
|
POS is the position to query.
|
|
PROPERTY-OR-OBJECT can be a property symbol/list, or an object (buffer/string).
|
|
OBJECT is the buffer or string to query; nil defaults to current buffer.
|
|
|
|
For strings, positions are 0-indexed.
|
|
For buffers, positions are 1-indexed.
|
|
|
|
Examples:
|
|
;; Get all properties at position 5 in current buffer
|
|
(tp-at 5)
|
|
;; Get all properties at position 0 in string
|
|
(tp-at 0 my-string)
|
|
;; Get face property at position 5
|
|
(tp-at 5 \\='face)
|
|
;; Get face property at position 0 in string
|
|
(tp-at 0 \\='face my-string)
|
|
;; Get nested sub-property
|
|
(tp-at 5 \\='(face :foreground))
|
|
(tp-at 5 \\='(face :box :color))
|
|
(tp-at 5 \\='(display :width))"
|
|
(let ((property nil)
|
|
(sub-path nil)
|
|
(obj nil))
|
|
;; Parse arguments
|
|
(cond
|
|
;; property-or-object is nil - just get all props
|
|
((null property-or-object)
|
|
(setq obj nil))
|
|
;; property-or-object is a buffer/string - it's the object
|
|
((or (bufferp property-or-object) (stringp property-or-object))
|
|
(setq obj property-or-object))
|
|
;; property-or-object is a symbol - it's a property
|
|
((symbolp property-or-object)
|
|
(setq property property-or-object
|
|
obj object))
|
|
;; property-or-object is a list - it's a property path
|
|
((listp property-or-object)
|
|
(setq property (car property-or-object)
|
|
sub-path (cdr property-or-object)
|
|
obj object))
|
|
(t (error "Invalid PROPERTY-OR-OBJECT argument: %S" property-or-object)))
|
|
;; Get the value
|
|
(if property
|
|
(let ((prop-value (get-text-property pos property obj)))
|
|
(if sub-path
|
|
(tp--get-nested prop-value sub-path)
|
|
prop-value))
|
|
(text-properties-at pos obj))))
|
|
|
|
(defun tp-member (pos property &optional object)
|
|
"Return (PROPERTY VALUE) if PROPERTY is present at POS in OBJECT.
|
|
Return nil when the property is absent. Unlike `tp-at' (which
|
|
returns nil both for an absent property and for a property whose
|
|
value is nil), this distinguishes \"present with value nil\" from
|
|
\"not present\", like `plist-member' does for plists.
|
|
|
|
OBJECT is a string or buffer; nil means the current buffer.
|
|
|
|
Examples:
|
|
(tp-member 1 \\='face) ;; => (face bold) when face is bold
|
|
(tp-member 1 \\='face) ;; => (face nil) when face is present but nil
|
|
(tp-member 1 \\='face) ;; => nil when face is absent"
|
|
(let ((plist (text-properties-at pos object)))
|
|
(when-let ((cell (plist-member plist property)))
|
|
(list (car cell) (cadr cell)))))
|
|
|
|
(defun tp--remove-sub (start end property sub-property &optional object)
|
|
"Remove SUB-PROPERTY from PROPERTY between START and END in OBJECT."
|
|
(let* ((pos start))
|
|
(while (< pos end)
|
|
(let* ((current-value (get-text-property pos property object))
|
|
(next-pos (or (next-single-property-change pos property object end) end))
|
|
(new-value
|
|
(cond
|
|
;; Plist - remove the sub-property
|
|
((and (listp current-value) (keywordp (car current-value)))
|
|
(let ((result (copy-sequence current-value)))
|
|
(cl-remf result sub-property)
|
|
(if result result nil)))
|
|
;; Other types - leave unchanged
|
|
(t current-value))))
|
|
(if new-value
|
|
(put-text-property pos next-pos property new-value object)
|
|
(remove-text-properties pos next-pos (list property nil) object))
|
|
(setq pos next-pos))))
|
|
nil)
|
|
|
|
(defun tp--remove-nested-keys (plist keys-to-remove)
|
|
"Remove KEYS-TO-REMOVE from PLIST.
|
|
Returns the modified plist, or nil if empty after removal."
|
|
(let ((result (copy-sequence plist)))
|
|
(dolist (key keys-to-remove)
|
|
(cl-remf result key))
|
|
(if (null result) nil result)))
|
|
|
|
(defun tp--remove-property (start end property object)
|
|
"Internal function to remove PROPERTY from START to END in OBJECT.
|
|
PROPERTY can be a symbol (including layer names) or a list for nested removal.
|
|
If PROPERTY is a layer name, all properties added by that layer are removed."
|
|
(cond
|
|
;; Simple property removal (or layer name)
|
|
((symbolp property)
|
|
;; Check if this is a layer name
|
|
(if (tp--is-layer-name-p property)
|
|
;; Layer name - need to remove all properties added by the layer
|
|
(let ((pos start))
|
|
(while (< pos end)
|
|
(let* ((tp-name-at-pos (get-text-property pos 'tp-name object))
|
|
(next-pos (or (next-single-property-change pos 'tp-name object end) end)))
|
|
(when (eq tp-name-at-pos property)
|
|
;; This region has the layer applied - get the layer's property keys
|
|
;; For parameterized layers, we pass dummy args (t per
|
|
;; parameter) since we only need key names
|
|
(let* ((layer-props
|
|
(cond
|
|
((tp-layer-parameterized-p property)
|
|
(tp-layer-props-with-args
|
|
property
|
|
(make-list (length (tp-layer-arglist property)) t)
|
|
nil))
|
|
((assoc property tp-layer-alist)
|
|
(tp-layer-props property nil)) ; include-tp-name=nil
|
|
((assoc property tp-layer-groups)
|
|
(when-let ((layer-props-list (tp-group-props property t)))
|
|
(tp--build-layer-props layer-props-list)))))
|
|
(props-to-remove
|
|
(when layer-props
|
|
(cl-loop for (key _val) on layer-props by #'cddr
|
|
collect key into keys
|
|
finally return (if (memq 'tp-name keys)
|
|
keys
|
|
(cons 'tp-name keys))))))
|
|
(dolist (prop-key (or props-to-remove (list property 'tp-name)))
|
|
(remove-text-properties pos next-pos (list prop-key nil) object))))
|
|
(setq pos next-pos))))
|
|
;; Regular property removal
|
|
(remove-text-properties start end (list property nil) object)))
|
|
;; Nested property removal
|
|
((listp property)
|
|
(let* ((prop-name (car property))
|
|
(sub-key (cadr property))
|
|
(nested-keys (caddr property)))
|
|
(if (null nested-keys)
|
|
;; Remove sub-key from property
|
|
(tp--remove-sub start end prop-name sub-key object)
|
|
;; Remove nested keys from sub-key
|
|
(let ((pos start))
|
|
(while (< pos end)
|
|
(let* ((current-value (get-text-property pos prop-name object))
|
|
(next-pos (or (next-single-property-change
|
|
pos prop-name object end)
|
|
end)))
|
|
(when current-value
|
|
(let* ((sub-value
|
|
(if (and (listp current-value) (keywordp (car current-value)))
|
|
(plist-get current-value sub-key)
|
|
nil))
|
|
(new-sub-value
|
|
(when (and (listp sub-value) (keywordp (car sub-value)))
|
|
(tp--remove-nested-keys sub-value nested-keys)))
|
|
(new-value
|
|
(cond
|
|
((and (listp current-value) (keywordp (car current-value)))
|
|
(let ((result (copy-sequence current-value)))
|
|
(if new-sub-value
|
|
(plist-put result sub-key new-sub-value)
|
|
;; Remove sub-key entirely if no keys remain
|
|
(cl-remf result sub-key))
|
|
(if (null result) nil result)))
|
|
(t current-value))))
|
|
(if new-value
|
|
(put-text-property pos next-pos prop-name new-value object)
|
|
(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))
|
|
|
|
**String Modification Behavior:**
|
|
- Entire string form (tp-remove STRING ...): Returns a NEW string with
|
|
properties removed (original is not modified). Uses `propertize' internally.
|
|
- Region form with string (tp-remove START END PROP STRING): Modifies the
|
|
original string in-place using `remove-text-properties'.
|
|
- Buffer forms: Always modify in-place.
|
|
|
|
Returns: For buffers, nil. For entire string forms, a new string."
|
|
(cond
|
|
;; First arg is a string - apply to entire string, non-destructively
|
|
((stringp start-or-string)
|
|
(let* ((str start-or-string)
|
|
(start 0)
|
|
(end (length str)))
|
|
(cond
|
|
;; (tp-remove str 'face :underline '(:style :position)) - nested sub-property removal with list
|
|
((and (symbolp end-or-prop)
|
|
(keywordp prop-or-sub)
|
|
rest
|
|
(listp (car rest)))
|
|
(tp--remove-property-from-string str start end (list end-or-prop prop-or-sub (car rest))))
|
|
;; (tp-remove str 'face :underline :position :style ...) - nested sub-property removal with keywords
|
|
((and (symbolp end-or-prop)
|
|
(keywordp prop-or-sub)
|
|
rest
|
|
(keywordp (car rest)))
|
|
(tp--remove-property-from-string str start end (list end-or-prop prop-or-sub rest)))
|
|
;; (tp-remove str 'face :underline) - sub-property removal
|
|
((and (symbolp end-or-prop) (keywordp 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
|
|
((symbolp end-or-prop)
|
|
;; Splice REST so the 3rd and later properties are kept, and
|
|
;; 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 str '(face :underline)) - nested property spec
|
|
((listp end-or-prop)
|
|
(tp--remove-property-from-string str start end end-or-prop))
|
|
(t 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-props-from-string (str start end props-to-remove)
|
|
"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
|
|
all properties that the layer adds.
|
|
For face properties from layers, subtracts the layer's face contribution
|
|
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)."
|
|
(let ((result (copy-sequence str)))
|
|
(tp--map-intervals
|
|
str start end
|
|
(lambda (istart iend existing-props)
|
|
(let (;; Remaining face after layer subtractions (this interval)
|
|
(remaining-face nil)
|
|
;; Track if face was modified by layer subtraction
|
|
(face-was-modified nil)
|
|
;; Collect all properties to remove entirely (non-face or non-layer)
|
|
(props-to-remove-entirely nil))
|
|
;; Process each property to remove against this interval's props
|
|
(dolist (prop props-to-remove)
|
|
(if (tp--is-layer-name-p prop)
|
|
;; Layer name - get its face contribution and subtract from face
|
|
(let* ((layer-prop-value (plist-get existing-props prop))
|
|
(layer-face (tp--get-layer-face-contribution prop layer-prop-value)))
|
|
;; Subtract layer's face from the current face
|
|
(when layer-face
|
|
(let ((current-face (or remaining-face
|
|
(plist-get existing-props 'face))))
|
|
(setq remaining-face
|
|
(tp--subtract-face-from-face-value current-face layer-face))
|
|
;; Mark that we processed the face (even if result is nil)
|
|
(setq face-was-modified t)))
|
|
;; 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 this interval's final properties
|
|
(let ((final-props
|
|
(let ((res nil))
|
|
(cl-loop for (key val) on existing-props by #'cddr
|
|
do (cond
|
|
;; Face property with layer subtraction
|
|
((and (eq key 'face) face-was-modified)
|
|
(when remaining-face
|
|
(setq res (plist-put res key remaining-face))))
|
|
;; Property to remove entirely
|
|
((memq key props-to-remove-entirely)
|
|
nil) ; skip
|
|
;; Keep other properties
|
|
(t (setq res (plist-put res key val)))))
|
|
res)))
|
|
(set-text-properties istart iend final-props result)))))
|
|
result))
|
|
|
|
(defun tp--remove-sub-from-string (str start end property sub-key)
|
|
"Create a new string from STR with SUB-KEY removed from PROPERTY.
|
|
Returns a new string (original is not modified).
|
|
Handles complex face values that contain a mix of symbols and plists.
|
|
Operates per property interval, so every interval keeps its own
|
|
remaining properties."
|
|
(let ((result (copy-sequence str)))
|
|
(tp--map-intervals
|
|
str start end
|
|
(lambda (istart iend existing-props)
|
|
(let* ((prop-value (plist-get existing-props property))
|
|
;; Use the helper to handle complex face values
|
|
(new-value (when prop-value
|
|
(tp--remove-sub-from-face-value prop-value sub-key)))
|
|
(final-props (let ((res nil))
|
|
(cl-loop for (key val) on existing-props by #'cddr
|
|
do (setq res (plist-put res key
|
|
(if (eq key property)
|
|
new-value
|
|
val))))
|
|
res)))
|
|
(set-text-properties istart iend final-props result))))
|
|
result))
|
|
|
|
(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.
|
|
PROPERTY-SPEC can be a symbol or a nested spec like (PROPERTY SUB-KEY ...).
|
|
Returns a new string (original is not modified)."
|
|
(cond
|
|
((symbolp property-spec)
|
|
(tp--remove-props-from-string str start end (list property-spec)))
|
|
((listp property-spec)
|
|
(let ((property (car property-spec))
|
|
(sub-key (cadr property-spec))
|
|
(nested-keys (caddr property-spec)))
|
|
(cond
|
|
;; Nested sub-property removal - per interval so every interval
|
|
;; keeps its own remaining properties
|
|
((and sub-key nested-keys)
|
|
(let ((result (copy-sequence str)))
|
|
(tp--map-intervals
|
|
str start end
|
|
(lambda (istart iend existing-props)
|
|
(let* ((prop-value (plist-get existing-props property))
|
|
(new-value (if (and prop-value (listp prop-value))
|
|
(tp--remove-nested-sub-keys
|
|
prop-value sub-key nested-keys)
|
|
;; Not a plist-shaped value (e.g. a bare
|
|
;; face symbol) - the nested spec does
|
|
;; not apply; keep the value unchanged.
|
|
prop-value))
|
|
(final-props (let ((res nil))
|
|
(cl-loop for (key val) on existing-props by #'cddr
|
|
do (setq res (plist-put res key
|
|
(if (eq key property)
|
|
new-value
|
|
val))))
|
|
res)))
|
|
(set-text-properties istart iend final-props result))))
|
|
result))
|
|
;; Simple sub-property removal
|
|
(sub-key
|
|
(tp--remove-sub-from-string str start end property sub-key))
|
|
;; Just a property name
|
|
(t
|
|
(tp--remove-props-from-string str start end (list property))))))
|
|
(t str)))
|
|
|
|
(defun tp--remove-nested-sub-keys (plist sub-key nested-keys)
|
|
"Remove NESTED-KEYS from the SUB-KEY value within PLIST.
|
|
Returns a new plist (does not modify the original)."
|
|
(let* ((sub-value (plist-get plist sub-key))
|
|
(keys-to-remove (if (listp nested-keys) nested-keys (list nested-keys)))
|
|
(new-sub-value (when (and sub-value (listp sub-value))
|
|
(let ((result nil))
|
|
(cl-loop for (k v) on sub-value by #'cddr
|
|
unless (memq k keys-to-remove)
|
|
do (setq result (plist-put result k v)))
|
|
result))))
|
|
(if new-sub-value
|
|
;; Build a new plist with the updated sub-value
|
|
(let ((result nil))
|
|
(cl-loop for (k v) on plist by #'cddr
|
|
do (setq result (plist-put result k
|
|
(if (eq k sub-key)
|
|
new-sub-value
|
|
v))))
|
|
result)
|
|
;; Remove the sub-key entirely if no value left
|
|
(let ((result nil))
|
|
(cl-loop for (k v) on plist by #'cddr
|
|
unless (eq k sub-key)
|
|
do (setq result (plist-put result k v)))
|
|
result))))
|
|
|
|
;;;###autoload
|
|
(defun tp-clear (&optional start end object)
|
|
"Clear all text properties from START to END in OBJECT.
|
|
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)
|
|
(let ((beg (or start
|
|
(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)))
|
|
|
|
(provide 'tp-ops)
|
|
;;; tp-ops.el ends here
|