905d3523ac
Expose one-shot string and buffer styling plus reactive range watches over the same schema, mutation, binding, and retained surface core. Verification: 712 ERT tests; 92 doctests; shuffled seed 20260806; compile-all WERROR=t.
1267 lines
58 KiB
EmacsLisp
1267 lines
58 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-style)
|
|
(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'.
|
|
Signal when the transform fails or returns a non-string value."
|
|
(let ((transform-fn (when layer-name
|
|
(cdr (assoc layer-name tp-layer-transforms)))))
|
|
(if (not transform-fn)
|
|
text
|
|
(let ((result (funcall transform-fn text)))
|
|
(unless (stringp result)
|
|
(error "tp: transform for %s returned non-string %S"
|
|
layer-name result))
|
|
(tp-debug-log " Transform %s: %S -> %S" layer-name text result)
|
|
result))))
|
|
|
|
(defun tp--merge-embedded-props (embedded props)
|
|
"Merge the EMBEDDED string props plist under PROPS; PROPS win.
|
|
Takes one property run's EMBEDDED plist, so callers preserve every
|
|
interval instead of treating position 0 as representative.
|
|
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 ((present (plist-member result key))
|
|
(existing (plist-get result key)))
|
|
(setq result
|
|
(plist-put result key
|
|
(if present
|
|
(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 (plist-member (text-properties-at start object) key)
|
|
(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--value-after-add (key existing incoming)
|
|
"Return EXISTING after adding INCOMING for property KEY."
|
|
(cond
|
|
((memq key tp-face-properties)
|
|
(tp--prepend-face incoming existing))
|
|
((and (listp incoming) (keywordp (car-safe incoming))
|
|
(listp existing) (keywordp (car-safe existing)))
|
|
(tp--deep-merge-plist existing incoming))
|
|
(t incoming)))
|
|
|
|
(defun tp--props-after-add (existing incoming)
|
|
"Return EXISTING with INCOMING applied using `tp-add' semantics."
|
|
(let ((result (copy-sequence existing)))
|
|
(cl-loop
|
|
for (key val) on incoming by #'cddr
|
|
do (setq result
|
|
(plist-put
|
|
result key
|
|
(tp--value-after-add key (plist-get result key) val))))
|
|
result))
|
|
|
|
(defun tp--apply-props-by-operation (start end props target operation)
|
|
"Apply PROPS to TARGET from START to END according to OPERATION."
|
|
(let ((pos start))
|
|
(while (< pos end)
|
|
(let* ((next (or (next-property-change pos target end) end))
|
|
(existing (text-properties-at pos target)))
|
|
(pcase operation
|
|
(:reset
|
|
(set-text-properties pos next props target))
|
|
(:add
|
|
(set-text-properties
|
|
pos next (tp--props-after-add existing props) target))
|
|
(_
|
|
(cl-loop for (key val) on props by #'cddr
|
|
do (tp--put-text-property-unless-equal
|
|
pos next key val target))))
|
|
(setq pos next)))))
|
|
|
|
(defun tp--apply-reactive-text-props
|
|
(source props offset &optional target operation)
|
|
"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.
|
|
|
|
OPERATION is `:reset', `:add', or nil for ordinary set semantics.
|
|
Ordinary set 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)))
|
|
(tp--apply-props-by-operation
|
|
(+ offset istart) (+ offset iend) merged target operation)))))
|
|
|
|
(defun tp--tp-text-replace
|
|
(start end final-text props object preserve-props operation)
|
|
"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 PROPS-APPLIED) result.
|
|
|
|
For a string OBJECT a NEW string is built as prefix + FINAL-TEXT +
|
|
suffix, so text outside the region survives. For strings and buffers,
|
|
PROPS are merged under every embedded property interval of FINAL-TEXT
|
|
and applied here through `tp--apply-reactive-text-props'. The final
|
|
non-nil return element tells callers not to flatten PROPS over the
|
|
whole replacement afterward.
|
|
|
|
For buffers the region text is replaced in place and NEW-END is the
|
|
end of the inserted text.
|
|
|
|
When PRESERVE-PROPS is non-nil, properties present at START whose
|
|
keys PROPS does not set are re-applied over the replacement.
|
|
OPERATION selects ordinary set, `:reset', or `:add' semantics."
|
|
(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
|
|
when (or (eq operation :add)
|
|
(not (plist-member props key)))
|
|
do (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 props start new-string operation)
|
|
(list props new-end new-string t))
|
|
;; 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))
|
|
(progn
|
|
(tp--apply-reactive-text-props
|
|
final-text props start object operation)
|
|
(list props end object t))
|
|
;; 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
|
|
when (or (eq operation :add)
|
|
(not (plist-member props key)))
|
|
do (put-text-property start new-end key val object))
|
|
(tp--apply-reactive-text-props
|
|
final-text props start object operation)
|
|
(list props new-end object t))))))))
|
|
|
|
(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 selects `:reset', `:merge' (`tp-add'), or ordinary
|
|
`tp-set' 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 PROPS-APPLIED), where PROPS is the
|
|
updated props, NEW-END is the new end position after replacement, and
|
|
NEW-OBJECT is the new string object (only different for strings whose
|
|
text was replaced). PROPS-APPLIED is non-nil when replacement props
|
|
were already applied per embedded interval."
|
|
(let ((operation (pcase merge-mode
|
|
(:reset :reset)
|
|
(:merge :add)
|
|
(_ nil))))
|
|
(if (not (plist-member props 'tp-text))
|
|
;; tp-text not in props - return unchanged
|
|
(list props end object nil)
|
|
(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)))
|
|
(tp--tp-text-replace
|
|
start end display-text props object preserve-props
|
|
operation))))
|
|
;; 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)))
|
|
(tp--tp-text-replace start end final-text props
|
|
object preserve-props operation)))
|
|
;; Other types - return unchanged
|
|
(t (list props end object nil)))))))
|
|
|
|
(defun tp--parse-args (start-or-string end-or-prop props-or-val rest
|
|
&optional operation)
|
|
"Parse flexible function arguments and return a canonical request.
|
|
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)))
|
|
(let ((range (tp--native-range-from-object object start finish)))
|
|
(tp--make-request
|
|
:operation operation
|
|
:range range
|
|
:props props
|
|
:mutation (if (and (stringp start-or-string)
|
|
(stringp (tp--native-range-object range)))
|
|
:copy
|
|
:in-place)
|
|
:public-return (if (stringp (tp--native-range-object range))
|
|
:object
|
|
:range)))))
|
|
|
|
(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))))))
|
|
|
|
;;;###autoload
|
|
(defun tp-propertize (string declarations)
|
|
"Return a copy of STRING styled by native DECLARATIONS.
|
|
DECLARATIONS pass through TP's property schemas, cascade, and projector.
|
|
Ordinary function values remain literal text-property values."
|
|
(unless (stringp string)
|
|
(signal 'wrong-type-argument (list 'stringp string)))
|
|
(tp--apply-props-to-string
|
|
string 0 (length string)
|
|
(tp--project-text-declarations declarations)))
|
|
|
|
;;;###autoload
|
|
(defun tp-apply (buffer start end declarations)
|
|
"Apply native DECLARATIONS once to BUFFER from START to END.
|
|
The operation preserves text and direct properties not named by DECLARATIONS.
|
|
Return the committed range as a START . END cons."
|
|
(let* ((target (get-buffer buffer))
|
|
(_range (tp--validate-buffer-range target start end))
|
|
(range (tp--native-range-from-object target start end))
|
|
(properties (tp--project-text-declarations declarations)))
|
|
(tp--apply-props-by-operation
|
|
(tp--native-range-start range) (tp--native-range-end range)
|
|
properties target nil)
|
|
(cons (tp--native-range-start range) (tp--native-range-end range))))
|
|
|
|
(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)))
|
|
(let* ((request (tp--parse-args start-or-string end-or-prop
|
|
props-or-val rest :set))
|
|
(range (tp--request-range request))
|
|
(object (tp--native-range-object range))
|
|
(start (tp--native-range-start range))
|
|
(finish (tp--native-range-end range))
|
|
(props (tp--request-props request)))
|
|
;; Handle tp-text property specially - :override means props override embedded props
|
|
(pcase-let ((`(,new-props ,new-finish ,new-object ,props-applied)
|
|
(tp--handle-tp-text-property start finish props object t :override)))
|
|
(setq props new-props finish new-finish object new-object)
|
|
(cond
|
|
(props-applied
|
|
(if (stringp object)
|
|
object
|
|
(tp--ops-register-layer-buffer props object)
|
|
(cons start finish)))
|
|
;; 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)))
|
|
(let* ((request (tp--parse-args start-or-string end-or-prop
|
|
props-or-val rest :reset))
|
|
(range (tp--request-range request))
|
|
(object (tp--native-range-object range))
|
|
(start (tp--native-range-start range))
|
|
(finish (tp--native-range-end range))
|
|
(props (tp--request-props request)))
|
|
;; Handle tp-text property - :reset means only use props, ignore embedded props
|
|
(pcase-let ((`(,new-props ,new-finish ,new-object ,props-applied)
|
|
(tp--handle-tp-text-property start finish props object nil :reset)))
|
|
(setq props new-props finish new-finish object new-object)
|
|
(cond
|
|
(props-applied
|
|
(if (stringp object)
|
|
object
|
|
(tp--ops-register-layer-buffer props object)
|
|
(cons start finish)))
|
|
;; 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)))
|
|
(let* ((request (tp--parse-args start-or-string end-or-prop
|
|
props-or-val rest :add))
|
|
(range (tp--request-range request))
|
|
(object (tp--native-range-object range))
|
|
(start (tp--native-range-start range))
|
|
(finish (tp--native-range-end range))
|
|
(props (tp--request-props request)))
|
|
;; 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 ,props-applied)
|
|
(tp--handle-tp-text-property start finish props object t :merge)))
|
|
(setq props new-props finish new-finish object new-object)
|
|
(cond
|
|
(props-applied
|
|
(if (stringp object)
|
|
object
|
|
(tp--ops-register-layer-buffer props object)
|
|
(cons start finish)))
|
|
;; Entire string form: create a new propertized string (non-destructive)
|
|
((and (stringp object) entire-string-form)
|
|
(if has-tp-text
|
|
(tp--apply-props-to-string object start finish props :reset)
|
|
(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 (put-text-property
|
|
pos next-pos key
|
|
(tp--value-after-add
|
|
key (plist-get current-props key) 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 (put-text-property
|
|
pos next-pos key
|
|
(tp--value-after-add
|
|
key (plist-get current-props key) 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--value-after-sub-removal (value sub-property)
|
|
"Return VALUE after removing SUB-PROPERTY, or nil when empty."
|
|
(tp--remove-sub-from-face-value value sub-property))
|
|
|
|
(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 (tp--value-after-sub-removal
|
|
current-value sub-property)))
|
|
(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))
|
|
(new-value (tp--value-after-sub-removal prop-value sub-key))
|
|
(final-props (let ((res nil))
|
|
(cl-loop for (key val) on existing-props by #'cddr
|
|
unless (and (eq key property)
|
|
(null new-value))
|
|
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).
|
|
Returns 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)
|
|
nil))
|
|
|
|
(provide 'tp-ops)
|
|
;;; tp-ops.el ends here
|