4921 lines
215 KiB
EmacsLisp
4921 lines
215 KiB
EmacsLisp
;;; tp.el --- Text Properties manipulation library for Emacs Lisp -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2024
|
|
|
|
;; Version: 0.1.0
|
|
;; Keywords: convenience text-properties
|
|
;; Author: Geekinney (kinneyzhang666@gmail.com)
|
|
;; Package-Requires: ((emacs "28.1") (dash "2.19.1"))
|
|
|
|
;; 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 2 of
|
|
;; the License, or (at your option) any later version.
|
|
|
|
;;; Commentary:
|
|
|
|
;; tp.el provides a comprehensive text property manipulation library with:
|
|
;;
|
|
;; Architecture (5 layers, bottom to top):
|
|
;; 1. Basic utilities: argument parsing, plist operations, interval handling
|
|
;; 2. Core property operations: tp-set, tp-get, tp-at, tp-remove, tp-clear
|
|
;; 3. Layer system: multi-layer property stacks with tp-push-layer, tp-pop-layer
|
|
;; 4. Reactive system: automatic updates when variables change
|
|
;; 5. High-level API: pattern matching, search and navigation
|
|
;;
|
|
;; See ARCHITECTURE.md for detailed function call hierarchy.
|
|
;;
|
|
;; Inspired by https://github.com/emacsorphanage/ov
|
|
;; Requires Emacs 28.1+ for `object-intervals' function.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'dash)
|
|
(require 'seq)
|
|
|
|
;;;============================================================================
|
|
;;; Layer 1: Global Variables and Configuration
|
|
;;;============================================================================
|
|
|
|
;;; --- Layer Definition Storage ---
|
|
|
|
(defgroup tp nil
|
|
"Group for tp.el text property manipulation."
|
|
:prefix "tp-"
|
|
:group 'development)
|
|
|
|
(defvar tp-layer-alist nil
|
|
"Alist of layer definitions: (LAYER-NAME . PROPERTIES).")
|
|
|
|
(defvar tp-layer-groups nil
|
|
"Alist of layer groups: (GROUP-NAME . (LAYER-NAME1 LAYER-NAME2 ...)).")
|
|
|
|
;;; --- Reactive System Storage ---
|
|
|
|
(defvar tp-reactive-deps nil
|
|
"Alist mapping reactive variables to dependent layers.
|
|
Each element: (VAR-SYMBOL . ((LAYER-NAME . REACTIVE-PROPS) ...)).")
|
|
|
|
(defvar tp-layer-watchers nil
|
|
"Alist of layer watchers: (LAYER-NAME . ((VAR-SYMBOL . CALLBACK) ...)).")
|
|
|
|
(defvar tp-layer-computed nil
|
|
"Alist of computed properties: (LAYER-NAME . ((VAR-SYMBOL . COMPUTE-FN) ...)).")
|
|
|
|
(defvar tp-layer-data nil
|
|
"Alist of data variables: (LAYER-NAME . (VAR-SYMBOL ...)).")
|
|
|
|
(defvar tp--anonymous-layer-counter 0
|
|
"Counter for generating unique anonymous layer names.")
|
|
|
|
;;; --- Debug Mode ---
|
|
|
|
(defcustom tp-debug-mode nil
|
|
"When non-nil, enable debug logging for reactive updates.
|
|
Debug messages are logged to the *tp-debug* buffer and optionally
|
|
displayed in the minibuffer based on `tp-debug-echo' setting."
|
|
:type 'boolean
|
|
:group 'tp)
|
|
|
|
(defcustom tp-debug-echo nil
|
|
"When non-nil and `tp-debug-mode' is enabled, also echo debug messages.
|
|
If nil, debug messages are only logged to the *tp-debug* buffer."
|
|
:type 'boolean
|
|
:group 'tp)
|
|
|
|
(defvar tp-layer-transforms nil
|
|
"Alist of layer transforms: (LAYER-NAME . TRANSFORM-FN).
|
|
TRANSFORM-FN receives the value and returns the transformed value.
|
|
Used for tp-text transformations like formatting numbers or dates.")
|
|
|
|
;;; --- Batched Updates ---
|
|
|
|
(defvar tp--batch-update-pending nil
|
|
"When non-nil, reactive updates are being batched.
|
|
This is a list of (LAYER-NAME . CHANGED-VARS) pairs pending update.")
|
|
|
|
(defvar tp--batch-update-active nil
|
|
"When non-nil, we are inside a `tp-with-batch-updates' form.")
|
|
|
|
;;; --- Built-in Text Property Names ---
|
|
|
|
(defconst tp--builtin-text-properties
|
|
'(;; Display and appearance
|
|
face font-lock-face mouse-face display invisible intangible
|
|
;; Interaction and help
|
|
help-echo cursor keymap local-map pointer
|
|
;; Stickiness
|
|
front-sticky rear-nonsticky
|
|
;; Text modification
|
|
read-only insert-in-front-hooks insert-behind-hooks
|
|
modification-hooks point-entered point-left
|
|
;; Font and composition
|
|
fontified composition hard cursor-intangible
|
|
;; Line properties
|
|
line-height line-spacing wrap-prefix line-prefix
|
|
;; Field and input
|
|
field inhibit-line-move-field-capture
|
|
;; Button and widget
|
|
button category follow-link action
|
|
;; Syntax and parsing
|
|
syntax-table
|
|
;; Misc
|
|
yank-handler auto-composed evaporate face-alias)
|
|
"List of built-in Emacs text property names.
|
|
These property names are reserved and cannot be used as layer names in `define-tp'.
|
|
An error is signaled at macro expansion time (when the `define-tp' form is
|
|
evaluated) if a reserved name is used, preventing the layer definition from
|
|
being created.")
|
|
|
|
(defun tp--builtin-text-property-p (name)
|
|
"Return non-nil if NAME is a built-in text property name.
|
|
NAME should be a symbol."
|
|
(memq name tp--builtin-text-properties))
|
|
|
|
;;;============================================================================
|
|
;;; Layer 1: Basic Utility Functions
|
|
;;;============================================================================
|
|
|
|
;;; --- Debug Logging ---
|
|
|
|
(defun tp-debug-log (format-string &rest args)
|
|
"Log a debug message if `tp-debug-mode' is enabled.
|
|
FORMAT-STRING and ARGS are passed to `format'."
|
|
(when tp-debug-mode
|
|
(let ((msg (apply #'format format-string args))
|
|
(timestamp (format-time-string "%H:%M:%S.%3N")))
|
|
(with-current-buffer (get-buffer-create "*tp-debug*")
|
|
(goto-char (point-max))
|
|
(insert (format "[%s] %s\n" timestamp msg)))
|
|
(when tp-debug-echo
|
|
(message "[tp] %s" msg)))))
|
|
|
|
(defun tp-debug-clear ()
|
|
"Clear the *tp-debug* buffer."
|
|
(interactive)
|
|
(when-let ((buf (get-buffer "*tp-debug*")))
|
|
(with-current-buffer buf
|
|
(erase-buffer))))
|
|
|
|
(defun tp-debug-show ()
|
|
"Show the *tp-debug* buffer."
|
|
(interactive)
|
|
(pop-to-buffer (get-buffer-create "*tp-debug*")))
|
|
|
|
;;; --- Anonymous Layer Generation ---
|
|
|
|
(defun tp--generate-anonymous-layer-name ()
|
|
"Generate a unique symbol for anonymous reactive layers."
|
|
(setq tp--anonymous-layer-counter (1+ tp--anonymous-layer-counter))
|
|
(intern (format "tp-anon-%d" tp--anonymous-layer-counter)))
|
|
|
|
;;; --- Buffer Utility ---
|
|
|
|
(defmacro tp-with-current-buffer (buffer-or-name &rest body)
|
|
"Execute BODY in BUFFER-OR-NAME with `inhibit-read-only' bound to t."
|
|
(declare (indent defun))
|
|
`(with-current-buffer ,buffer-or-name
|
|
(let ((inhibit-read-only t))
|
|
,@body)))
|
|
|
|
;;;============================================================================
|
|
;;; Layer 1: Interval and Property Inspection
|
|
;;;============================================================================
|
|
|
|
(defun tp-intervals (start end &optional object)
|
|
"Return list of property intervals from START to END in OBJECT.
|
|
Each element is (START END PROPERTIES). OBJECT defaults to current buffer.
|
|
For buffers, returns positions relative to START (0-based offsets).
|
|
For strings, returns absolute positions."
|
|
(let* ((intervals (object-intervals (or object (current-buffer))))
|
|
;; For buffers, object-intervals returns 0-based positions
|
|
;; but buffer positions are 1-based, so we need to adjust
|
|
(offset (if (stringp object) 0 (1- start)))
|
|
;; Filter bounds in 0-based terms for buffers
|
|
(filter-start (if (stringp object) start offset))
|
|
(filter-end (if (stringp object) end (1- end))))
|
|
(mapcar (lambda (tp)
|
|
(let* ((tp-start (- (nth 0 tp) offset))
|
|
(tp-end (- (nth 1 tp) offset))
|
|
(tp-props (nth 2 tp)))
|
|
(list tp-start tp-end tp-props)))
|
|
(seq-filter (lambda (tp)
|
|
(and (< (nth 0 tp) filter-end)
|
|
(> (nth 1 tp) filter-start)))
|
|
intervals))))
|
|
|
|
(defun tp-empty-p (&optional object)
|
|
"Return t if OBJECT has no text properties.
|
|
OBJECT can be string or buffer; nil means current buffer."
|
|
(null (object-intervals (or object (current-buffer)))))
|
|
|
|
(defun tp-plist (start-or-string &optional end object)
|
|
"Return merged plist of all properties from START to END in OBJECT.
|
|
With single STRING argument, return properties of entire string."
|
|
(let (start-pos end-pos obj)
|
|
(if (stringp start-or-string)
|
|
(setq start-pos 0
|
|
end-pos (length start-or-string)
|
|
obj start-or-string)
|
|
(setq start-pos start-or-string
|
|
end-pos end
|
|
obj object))
|
|
(let ((result nil))
|
|
(dolist (interval (tp-intervals start-pos end-pos obj))
|
|
(let ((props (nth 2 interval)))
|
|
(cl-loop for (key val) on props by #'cddr
|
|
do (setq result (plist-put result key val)))))
|
|
result)))
|
|
|
|
;;;============================================================================
|
|
;;; Layer 1: Plist Deep Merge and Nested Access
|
|
;;;============================================================================
|
|
|
|
(defun tp--deep-merge-plist (base new)
|
|
"Deep merge NEW plist into BASE plist.
|
|
For nested plists (starting with keyword), recursively merge.
|
|
NEW values override BASE values."
|
|
(let ((result (copy-sequence base)))
|
|
(cl-loop
|
|
for (key val) on new by #'cddr
|
|
do (let ((base-val (plist-get result key)))
|
|
(setq result
|
|
(plist-put
|
|
result key
|
|
(cond
|
|
;; Both are plists - recursively merge
|
|
((and (listp val) (keywordp (car-safe val))
|
|
(listp base-val) (keywordp (car-safe base-val)))
|
|
(tp--deep-merge-plist base-val val))
|
|
;; Otherwise use new value
|
|
(t val))))))
|
|
result))
|
|
|
|
(defun tp--string-has-properties-p (str)
|
|
"Return non-nil if string STR has any text properties.
|
|
Scans the entire string, not just position 0."
|
|
(and (stringp str)
|
|
(not (null (object-intervals str)))))
|
|
|
|
(defun tp--equal-including-string-properties (a b)
|
|
"Compare A and B for equality, considering string text properties.
|
|
If both A and B are strings, uses `equal-including-properties' to ensure
|
|
text properties are considered in the comparison.
|
|
Otherwise, uses standard `equal'."
|
|
(if (and (stringp a) (stringp b))
|
|
(equal-including-properties a b)
|
|
(equal a b)))
|
|
|
|
(defun tp--parse-face-list (face-list)
|
|
"Parse a mixed face list into symbols and a plist.
|
|
FACE-LIST can be a mix of:
|
|
- Face symbols (like bold, italic)
|
|
- Face plists (like (:foreground \"red\"))
|
|
- Inline plist keys and values (like bold :foreground \"green\")
|
|
|
|
Returns (SYMBOLS . PLIST) where SYMBOLS is a list of face symbols
|
|
and PLIST is the merged plist of all face attributes."
|
|
(let ((symbols nil)
|
|
(plist nil)
|
|
(i 0)
|
|
(len (length face-list)))
|
|
(while (< i len)
|
|
(let ((elem (nth i face-list)))
|
|
(cond
|
|
;; Nested plist like (:foreground "red")
|
|
((and (listp elem) (keywordp (car-safe elem)))
|
|
(setq plist (if plist (tp--deep-merge-plist plist elem) elem))
|
|
(setq i (1+ i)))
|
|
;; Inline keyword - consume key and value
|
|
((keywordp elem)
|
|
(let ((key elem)
|
|
(val (nth (1+ i) face-list)))
|
|
(setq plist (if plist
|
|
(plist-put plist key val)
|
|
(list key val)))
|
|
(setq i (+ i 2))))
|
|
;; Face symbol
|
|
((symbolp elem)
|
|
(push elem symbols)
|
|
(setq i (1+ i)))
|
|
;; Something else - skip
|
|
(t (setq i (1+ i))))))
|
|
(cons (nreverse symbols) plist)))
|
|
|
|
(defun tp--remove-sub-from-face-value (face-value sub-key)
|
|
"Remove SUB-KEY from FACE-VALUE, handling complex face structures.
|
|
FACE-VALUE can be:
|
|
- A simple plist like (:foreground \"red\" :background \"blue\")
|
|
- A symbol like bold
|
|
- A mixed list like ((:foreground \"red\") (:strike-through t) bold)
|
|
|
|
Returns the modified face value with SUB-KEY removed from any plist components.
|
|
Returns nil if the result would be empty."
|
|
(cond
|
|
;; Nil face - nothing to remove
|
|
((null face-value) nil)
|
|
;; Symbol face - no sub-key to remove
|
|
((symbolp face-value) face-value)
|
|
;; Simple plist - remove the sub-key directly
|
|
((and (listp face-value) (keywordp (car-safe face-value)))
|
|
(let ((result nil))
|
|
(cl-loop for (k v) on face-value by #'cddr
|
|
unless (eq k sub-key)
|
|
do (setq result (plist-put result k v)))
|
|
result))
|
|
;; Mixed list - parse and remove from plist component
|
|
((listp face-value)
|
|
(let* ((parsed (tp--parse-face-list face-value))
|
|
(symbols (car parsed))
|
|
(plist (cdr parsed)))
|
|
(when plist
|
|
;; Remove sub-key from the merged plist
|
|
(let ((new-plist nil))
|
|
(cl-loop for (k v) on plist by #'cddr
|
|
unless (eq k sub-key)
|
|
do (setq new-plist (plist-put new-plist k v)))
|
|
(setq plist new-plist)))
|
|
;; Reconstruct the face value
|
|
(cond
|
|
((and symbols plist) (append symbols (list plist)))
|
|
(symbols (if (= (length symbols) 1) (car symbols) symbols))
|
|
(plist plist)
|
|
(t nil))))
|
|
;; Unknown format - return as-is
|
|
(t face-value)))
|
|
|
|
(defun tp--subtract-face-from-face-value (face-value face-to-remove)
|
|
"Remove FACE-TO-REMOVE from FACE-VALUE.
|
|
FACE-TO-REMOVE is the face contribution to subtract (from a layer).
|
|
FACE-VALUE is the current combined face value.
|
|
Returns the modified face value with the layer's face contribution removed."
|
|
(cond
|
|
;; Nothing to remove from
|
|
((null face-value) nil)
|
|
;; If face-to-remove is nil, return as-is
|
|
((null face-to-remove) face-value)
|
|
;; If they're equal, remove entirely
|
|
((equal face-value face-to-remove) nil)
|
|
;; face-to-remove is a plist - remove those keys from face-value
|
|
((and (listp face-to-remove) (keywordp (car-safe face-to-remove)))
|
|
(let ((keys-to-remove (cl-loop for (k _v) on face-to-remove by #'cddr
|
|
collect k)))
|
|
;; Remove each key
|
|
(dolist (key keys-to-remove)
|
|
(setq face-value (tp--remove-sub-from-face-value face-value key)))
|
|
face-value))
|
|
;; face-to-remove is a symbol - remove it from face-value
|
|
((symbolp face-to-remove)
|
|
(cond
|
|
((eq face-value face-to-remove) nil)
|
|
((and (listp face-value) (not (keywordp (car-safe face-value))))
|
|
(let ((result (remove face-to-remove face-value)))
|
|
(if (= (length result) 1) (car result) result)))
|
|
(t face-value)))
|
|
;; face-to-remove is a list - remove each element
|
|
((listp face-to-remove)
|
|
(dolist (elem face-to-remove)
|
|
(setq face-value (tp--subtract-face-from-face-value face-value elem)))
|
|
face-value)
|
|
;; Unknown - return as-is
|
|
(t face-value)))
|
|
|
|
(defun tp--merge-string-props-into-plist (str props)
|
|
"Merge text properties from string STR into PROPS plist.
|
|
Properties from PROPS take precedence over those in STR.
|
|
Returns the merged plist where new props override embedded props.
|
|
For simplicity, only considers properties at position 0 of STR."
|
|
(if (not (tp--string-has-properties-p str))
|
|
props
|
|
(let ((str-props (text-properties-at 0 str))
|
|
(result (copy-sequence props)))
|
|
;; Merge each property from the string into result
|
|
;; Props values take precedence over embedded string values
|
|
(cl-loop for (key val) on str-props by #'cddr
|
|
do (let ((existing (plist-get result key)))
|
|
(if existing
|
|
;; Props already has this key - merge with props taking precedence
|
|
(setq result
|
|
(plist-put result key
|
|
(cond
|
|
;; Face properties need special merging
|
|
;; Pass embedded val as face1 (base), existing as face2 (override)
|
|
((memq key '(face font-lock-face mouse-face))
|
|
(tp--merge-face-values val existing))
|
|
;; Other properties - props value takes precedence
|
|
(t existing))))
|
|
;; Props doesn't have this key - add from string
|
|
(setq result (plist-put result key val)))))
|
|
result)))
|
|
|
|
(defun tp--merge-face-values (face1 face2)
|
|
"Merge two face values into one.
|
|
FACE1 is the earlier value, FACE2 is the later value.
|
|
For face plists (like (:foreground \"red\")), merge with later overriding.
|
|
For symbol faces, create a list with FACE2 taking precedence.
|
|
Returns the merged face value."
|
|
(cond
|
|
;; No earlier face - just use later face
|
|
((null face1) face2)
|
|
;; No later face - just use earlier face
|
|
((null face2) face1)
|
|
;; Both are plists - merge with later overriding earlier
|
|
((and (listp face1) (keywordp (car-safe face1))
|
|
(listp face2) (keywordp (car-safe face2)))
|
|
(tp--deep-merge-plist face1 face2))
|
|
;; Later is a plist, earlier is a symbol or list of faces
|
|
((and (listp face2) (keywordp (car-safe face2)))
|
|
(cond
|
|
((symbolp face1)
|
|
(list face2 face1))
|
|
((listp face1)
|
|
(cons face2 face1))
|
|
(t face2)))
|
|
;; Earlier is a plist, later is a symbol
|
|
((and (listp face1) (keywordp (car-safe face1))
|
|
(symbolp face2))
|
|
(list face2 face1))
|
|
;; Later is a symbol - prepend to earlier
|
|
((symbolp face2)
|
|
(cond
|
|
((symbolp face1)
|
|
(if (eq face1 face2)
|
|
face2
|
|
(list face2 face1)))
|
|
((listp face1)
|
|
(if (member face2 face1)
|
|
(cons face2 (remove face2 face1)) ; Move to front
|
|
(cons face2 face1)))
|
|
(t face2)))
|
|
;; Later is a list of faces - prepend to earlier
|
|
((listp face2)
|
|
(cond
|
|
((symbolp face1)
|
|
(if (member face1 face2)
|
|
face2
|
|
(append face2 (list face1))))
|
|
;; face1 is a plist - need to merge any plist in face2 with face1
|
|
((and (listp face1) (keywordp (car-safe face1)))
|
|
;; Use tp--parse-face-list to handle mixed formats like (bold :foreground "green")
|
|
(let* ((parsed (tp--parse-face-list face2))
|
|
(symbols (car parsed))
|
|
(plist (cdr parsed)))
|
|
;; Merge face2's plist with face1, then prepend symbols
|
|
(let ((merged-plist (if plist (tp--deep-merge-plist face1 plist) face1)))
|
|
(if symbols
|
|
(append symbols (list merged-plist))
|
|
merged-plist))))
|
|
;; Both are lists - parse both, merge plists, combine symbols
|
|
((listp face1)
|
|
(let* ((parsed1 (tp--parse-face-list face1))
|
|
(symbols1 (car parsed1))
|
|
(plist1 (cdr parsed1))
|
|
(parsed2 (tp--parse-face-list face2))
|
|
(symbols2 (car parsed2))
|
|
(plist2 (cdr parsed2))
|
|
;; Merge plists with face2's plist taking precedence
|
|
(merged-plist (cond
|
|
((and plist1 plist2) (tp--deep-merge-plist plist1 plist2))
|
|
(plist2 plist2)
|
|
(plist1 plist1)
|
|
(t nil)))
|
|
;; Combine symbols: face2 symbols first, then face1 symbols not in face2
|
|
(merged-symbols (append symbols2
|
|
(cl-remove-if (lambda (s) (member s symbols2)) symbols1))))
|
|
;; Build result: symbols first, then merged plist if any
|
|
(if merged-plist
|
|
(append merged-symbols (list merged-plist))
|
|
merged-symbols)))
|
|
(t face2)))
|
|
(t face2)))
|
|
|
|
(defun tp--merge-duplicate-keys (plist)
|
|
"Merge duplicate keys in PLIST into a single key-value pair.
|
|
For `face' and `font-lock-face' properties, values are merged so that
|
|
later values take precedence over earlier ones for the same sub-properties.
|
|
For other properties, later values override earlier ones.
|
|
|
|
This function is designed for single-call property setting where multiple
|
|
properties of the same type can be specified and should be merged.
|
|
|
|
Example:
|
|
(tp--merge-duplicate-keys \\='(face bold face (:foreground \"red\")))
|
|
=> (face ((:foreground \"red\") bold))
|
|
|
|
(tp--merge-duplicate-keys \\='(face (:background \"blue\") face (:foreground \"red\")))
|
|
=> (face (:background \"blue\" :foreground \"red\"))
|
|
|
|
(tp--merge-duplicate-keys \\='(prop1 a prop2 b prop1 c))
|
|
=> (prop1 c prop2 b)"
|
|
(let ((key-values (make-hash-table :test 'eq))
|
|
(key-order nil))
|
|
;; Collect all values for each key in order
|
|
(cl-loop for (key val) on plist by #'cddr
|
|
do (progn
|
|
(unless (gethash key key-values)
|
|
(push key key-order))
|
|
(puthash key
|
|
(cons val (gethash key key-values))
|
|
key-values)))
|
|
;; Reverse key-order to get original order
|
|
(setq key-order (nreverse key-order))
|
|
;; Build result plist by merging values for each key
|
|
(let ((result nil))
|
|
(dolist (key key-order)
|
|
(let ((values (nreverse (gethash key key-values)))) ; Reverse to get original order
|
|
(if (= (length values) 1)
|
|
;; Single value - use as-is
|
|
(setq result (append result (list key (car values))))
|
|
;; Multiple values - merge them
|
|
(let ((merged-val
|
|
(cond
|
|
;; Face properties - use special face merging
|
|
((memq key '(face font-lock-face mouse-face))
|
|
(cl-reduce #'tp--merge-face-values values))
|
|
;; Other properties - later overrides earlier
|
|
(t (car (last values))))))
|
|
(setq result (append result (list key merged-val)))))))
|
|
result)))
|
|
|
|
(defun tp--get-nested (value path)
|
|
"Get nested value from VALUE following PATH (list of keys).
|
|
Supports plists, alists, and list-of-keys extraction."
|
|
(if (null path)
|
|
value
|
|
(let* ((key (car path))
|
|
(rest (cdr path))
|
|
(is-plist-like (and (listp value)
|
|
(or (keywordp (car value))
|
|
(and (symbolp (car value))
|
|
(cdr value)
|
|
(keywordp (cadr value))))))
|
|
(next-value
|
|
(cond
|
|
;; Key is a list - extract multiple keys
|
|
((and (listp key) (not (null key)))
|
|
(when is-plist-like
|
|
(let ((result nil)
|
|
(plist-part (if (keywordp (car value)) value (cdr value))))
|
|
(dolist (k key)
|
|
(let ((v (plist-get plist-part k)))
|
|
(when v (setq result (plist-put result k v)))))
|
|
result)))
|
|
;; Value is plist-like
|
|
(is-plist-like
|
|
(plist-get (if (keywordp (car value)) value (cdr value)) key))
|
|
;; Value is alist
|
|
((and (listp value) (consp (car value)))
|
|
(cdr (assoc key value)))
|
|
;; Other list types
|
|
((listp value)
|
|
(or (plist-get value key)
|
|
(cdr (assoc key value))
|
|
(cl-loop for spec in value
|
|
when (and (listp spec) (eq (car spec) key))
|
|
return (if (= (length (cdr spec)) 1) (cadr spec) (cdr spec))
|
|
when (and (listp spec) (keywordp (car spec)))
|
|
thereis (plist-get spec key))))
|
|
(t nil))))
|
|
(tp--get-nested next-value rest))))
|
|
|
|
;;;============================================================================
|
|
;;; Layer 4: Reactive System - Symbol Detection and Resolution
|
|
;;;============================================================================
|
|
|
|
(defun tp--reactive-symbol-p (sym)
|
|
"Return non-nil if SYM is a reactive variable symbol (starts with $)."
|
|
(and (symbolp sym)
|
|
(string-prefix-p "$" (symbol-name sym))))
|
|
|
|
(defun tp--reactive-var-symbol (sym)
|
|
"Convert a reactive symbol SYM (e.g., $foo) to its variable symbol (e.g., foo).
|
|
Returns nil if SYM is not a reactive symbol."
|
|
(when (tp--reactive-symbol-p sym)
|
|
(intern (substring (symbol-name sym) 1))))
|
|
|
|
(defun tp--collect-reactive-symbols (form)
|
|
"Recursively collect all reactive symbols ($-prefixed) from FORM.
|
|
Returns a list of reactive symbols found."
|
|
(cond
|
|
((tp--reactive-symbol-p form)
|
|
(list form))
|
|
((consp form)
|
|
(append (tp--collect-reactive-symbols (car form))
|
|
(tp--collect-reactive-symbols (cdr form))))
|
|
(t nil)))
|
|
|
|
(defun tp--extract-reactive-value (val reactive-var)
|
|
"Extract only the parts of VAL that use REACTIVE-VAR.
|
|
If VAL is a plist, recursively extract only the key-value pairs containing REACTIVE-VAR.
|
|
If VAL directly contains REACTIVE-VAR, return VAL as-is.
|
|
REACTIVE-VAR should be the $-prefixed symbol (e.g., $my-color)."
|
|
(cond
|
|
;; If val is the reactive var itself, return it
|
|
((eq val reactive-var) val)
|
|
;; If val is a plist (starts with a keyword), extract reactive parts recursively
|
|
((and (listp val) (keywordp (car val)))
|
|
(let ((result nil))
|
|
(cl-loop for (key subval) on val by #'cddr
|
|
when (member reactive-var (tp--collect-reactive-symbols subval))
|
|
do (setq result
|
|
(plist-put result key
|
|
(tp--extract-reactive-value subval reactive-var))))
|
|
result))
|
|
;; Otherwise return val as-is if it contains the reactive var
|
|
(t val)))
|
|
|
|
(defun tp--extract-reactive-props (plist reactive-var)
|
|
"Extract only the properties from PLIST that use REACTIVE-VAR.
|
|
Returns a plist containing only the key-value pairs that reference REACTIVE-VAR.
|
|
For nested plists, only the sub-properties containing REACTIVE-VAR are included.
|
|
REACTIVE-VAR should be the $-prefixed symbol (e.g., $my-color)."
|
|
(let ((result nil))
|
|
(cl-loop for (key val) on plist by #'cddr
|
|
when (member reactive-var (tp--collect-reactive-symbols val))
|
|
do (setq result
|
|
(plist-put result key
|
|
(tp--extract-reactive-value val reactive-var))))
|
|
result))
|
|
|
|
(defun tp--resolve-reactive-symbols (form &optional override-alist)
|
|
"Recursively resolve all reactive symbols in FORM to their values.
|
|
Reactive symbols ($foo) are replaced with the value of the variable foo.
|
|
OVERRIDE-ALIST is an optional alist of (SYMBOL . VALUE) pairs that
|
|
override the current variable values (used during watcher callbacks)."
|
|
(cond
|
|
((tp--reactive-symbol-p form)
|
|
(let* ((var-sym (tp--reactive-var-symbol form))
|
|
(override (assoc var-sym override-alist)))
|
|
(if override
|
|
(cdr override)
|
|
(if (boundp var-sym)
|
|
(symbol-value var-sym)
|
|
nil))))
|
|
((consp form)
|
|
(cons (tp--resolve-reactive-symbols (car form) override-alist)
|
|
(tp--resolve-reactive-symbols (cdr form) override-alist)))
|
|
(t form)))
|
|
|
|
(defun tp--register-reactive-deps (layer-name reactive-symbols props)
|
|
"Register REACTIVE-SYMBOLS as dependencies for LAYER-NAME.
|
|
PROPS is the original property specification with reactive symbols.
|
|
Only the reactive portions of the properties are stored for each variable."
|
|
;; Register each reactive symbol's dependency with only its relevant properties
|
|
(dolist (rsym reactive-symbols)
|
|
(let* ((var-sym (tp--reactive-var-symbol rsym))
|
|
;; Extract only the properties that use this specific reactive variable
|
|
(reactive-props (tp--extract-reactive-props props rsym))
|
|
(existing (assoc var-sym tp-reactive-deps)))
|
|
(if existing
|
|
;; Update or add this layer to existing dependencies
|
|
(let ((layer-entry (assoc layer-name (cdr existing))))
|
|
(if layer-entry
|
|
;; Update existing entry with new reactive-props
|
|
(setf (cdr layer-entry) reactive-props)
|
|
;; Add new layer entry
|
|
(push (cons layer-name reactive-props) (cdr existing))))
|
|
;; Create new dependency entry and add watcher
|
|
(push (cons var-sym (list (cons layer-name reactive-props))) tp-reactive-deps)
|
|
;; Add variable watcher for this variable
|
|
(unless (boundp var-sym) (set var-sym nil))
|
|
(add-variable-watcher var-sym #'tp--reactive-variable-watcher)))))
|
|
|
|
(defun tp--unregister-reactive-deps (layer-name)
|
|
"Unregister all reactive dependencies for LAYER-NAME."
|
|
;; Collect variables that need watcher removal
|
|
(let ((vars-to-clean nil))
|
|
;; First pass: remove layer from dependencies and collect empty vars
|
|
(dolist (dep tp-reactive-deps)
|
|
(let ((var-sym (car dep)))
|
|
(setf (cdr dep) (assq-delete-all layer-name (cdr dep)))
|
|
;; If no more dependencies, mark for watcher removal
|
|
(when (null (cdr dep))
|
|
(push var-sym vars-to-clean))))
|
|
;; Remove watchers for variables with no dependencies
|
|
(dolist (var-sym vars-to-clean)
|
|
(remove-variable-watcher var-sym #'tp--reactive-variable-watcher)))
|
|
;; Clean up empty dependency entries
|
|
(setq tp-reactive-deps
|
|
(cl-remove-if (lambda (dep) (null (cdr dep))) tp-reactive-deps))
|
|
;; Also clean up layer watchers, computed properties, and data
|
|
(tp--unregister-layer-watchers layer-name)
|
|
(tp--unregister-layer-computed layer-name)
|
|
(tp--unregister-layer-data layer-name))
|
|
|
|
(defun tp--layer-has-reactive-deps-p (layer-name)
|
|
"Return non-nil if LAYER-NAME has reactive dependencies registered.
|
|
Layers with reactive deps need tp-name for reactive tracking."
|
|
(cl-some (lambda (dep)
|
|
(assoc layer-name (cdr dep)))
|
|
tp-reactive-deps))
|
|
|
|
(defun tp--reactive-variable-watcher (symbol newval operation where)
|
|
"Watcher function called when a reactive variable changes.
|
|
SYMBOL is the variable that changed.
|
|
NEWVAL is the new value being set.
|
|
OPERATION is the type of operation (set, let, unlet, makunbound, defvaralias).
|
|
WHERE indicates where the variable was set:
|
|
- nil for global `setq' or `set'
|
|
- a buffer for `setq-local'
|
|
Updates all layers that depend on this variable.
|
|
|
|
Only 'set' operations trigger updates because:
|
|
- 'let'/'unlet': Temporary bindings that will be restored, no need to update UI
|
|
- 'makunbound': Variable is being undefined, not a value change
|
|
- 'defvaralias': Aliasing, the actual value change will trigger a separate 'set'
|
|
|
|
When `tp--batch-update-active' is non-nil, buffer updates are deferred until
|
|
the batch completes. Layer definitions are still updated immediately.
|
|
|
|
Uses `tp--equal-including-string-properties' for comparison to properly detect
|
|
changes in text properties when the text content is the same."
|
|
(when (and (not (tp--equal-including-string-properties (symbol-value symbol) newval))
|
|
(eq operation 'set))
|
|
(tp-debug-log "Variable %s changed: %S -> %S (where: %s)"
|
|
symbol (symbol-value symbol) newval
|
|
(if where (buffer-name where) "global"))
|
|
(let ((deps (cdr (assoc symbol tp-reactive-deps)))
|
|
(oldval (symbol-value symbol))
|
|
;; Create override alist with the new value
|
|
;; (watcher is called before the variable is actually updated)
|
|
(override-alist (list (cons symbol newval))))
|
|
(dolist (dep deps)
|
|
(let* ((layer-name (car dep))
|
|
;; Get the reactive props stored directly in the dependency
|
|
(reactive-props (cdr dep))
|
|
;; Check if tp-text is affected by this variable
|
|
(tp-text-affected (plist-member reactive-props 'tp-text)))
|
|
;; Call user-defined watch callbacks for this layer
|
|
(tp--invoke-layer-watchers layer-name symbol newval oldval)
|
|
;; Update computed properties for this layer
|
|
(let ((updated-override
|
|
(tp--update-layer-computed layer-name override-alist)))
|
|
(when reactive-props
|
|
;; Resolve the reactive props with the new value override
|
|
(let ((resolved-props (tp--resolve-reactive-symbols
|
|
reactive-props updated-override)))
|
|
;; Update only the reactive properties in the layer definition
|
|
(let ((current-props (cdr (assoc layer-name tp-layer-alist))))
|
|
(when current-props
|
|
;; Deep merge the resolved reactive props into the current layer props
|
|
;; This preserves nested plist values (like face properties)
|
|
(setq current-props (tp--deep-merge-plist current-props resolved-props))
|
|
(tp--set-layer-props layer-name current-props))))))
|
|
;; Update text regions with this layer (or defer if batching)
|
|
(if tp--batch-update-active
|
|
;; Batching: defer the buffer update
|
|
;; Pending format: (layer-name symbols-list where tp-text-affected)
|
|
(let ((existing (assoc layer-name tp--batch-update-pending)))
|
|
(tp-debug-log " Deferring buffer update for %s (batch mode)" layer-name)
|
|
(if existing
|
|
;; Update existing entry: add symbol if not present
|
|
(let ((symbols (nth 1 existing)))
|
|
(unless (memq symbol symbols)
|
|
(setf (nth 1 existing) (cons symbol symbols))))
|
|
;; Create new entry
|
|
(push (list layer-name (list symbol) where tp-text-affected)
|
|
tp--batch-update-pending)))
|
|
;; Normal: update immediately
|
|
(tp-debug-log " Updating layer %s (tp-text affected: %s)"
|
|
layer-name (if tp-text-affected "yes" "no"))
|
|
(if tp-text-affected
|
|
(tp--update-reactive-text layer-name where)
|
|
(tp--update-layer-regions layer-name where))))))))
|
|
|
|
(defun tp--invoke-layer-watchers (layer-name symbol newval oldval)
|
|
"Invoke all registered watcher callbacks for LAYER-NAME watching SYMBOL.
|
|
NEWVAL is the new value, OLDVAL is the old value."
|
|
(when-let ((watchers (cdr (assoc layer-name tp-layer-watchers))))
|
|
(dolist (watcher watchers)
|
|
(let ((watch-sym (car watcher))
|
|
(callback (cdr watcher)))
|
|
(when (eq watch-sym symbol)
|
|
(tp-debug-log " Invoking watcher for %s on %s" watch-sym layer-name)
|
|
(condition-case err
|
|
(funcall callback newval oldval layer-name)
|
|
(error (message "tp: watcher error for %s watching %s: %s"
|
|
layer-name watch-sym err))))))))
|
|
|
|
;;; --- Batched Updates ---
|
|
|
|
(defun tp--flush-batch-updates ()
|
|
"Flush all pending batch updates.
|
|
This processes all updates collected during a `tp-with-batch-updates' form."
|
|
(tp-debug-log "Flushing %d pending batch updates" (length tp--batch-update-pending))
|
|
(let ((processed-layers nil))
|
|
;; Process each pending update, avoiding duplicate layer updates
|
|
(dolist (pending (nreverse tp--batch-update-pending))
|
|
(let ((layer-name (car pending))
|
|
(where (caddr pending))
|
|
(tp-text-affected (cadddr pending)))
|
|
(unless (memq layer-name processed-layers)
|
|
(push layer-name processed-layers)
|
|
(tp-debug-log " Batch updating layer %s (tp-text: %s)"
|
|
layer-name (if tp-text-affected "yes" "no"))
|
|
(if tp-text-affected
|
|
(tp--update-reactive-text layer-name where)
|
|
(tp--update-layer-regions layer-name where))))))
|
|
(setq tp--batch-update-pending nil))
|
|
|
|
(defmacro tp-with-batch-updates (&rest body)
|
|
"Execute BODY with reactive updates batched.
|
|
Multiple variable changes within BODY are collected and applied
|
|
together at the end, avoiding redundant buffer modifications.
|
|
|
|
This is useful when changing multiple reactive variables simultaneously:
|
|
|
|
(tp-with-batch-updates
|
|
(setq my-color \"red\")
|
|
(setq my-size 14)
|
|
(setq my-text \"Hello\"))
|
|
|
|
Without batching, each `setq' would trigger a separate buffer update.
|
|
With batching, all updates are consolidated and applied once at the end."
|
|
(declare (indent 0) (debug t))
|
|
`(let ((tp--batch-update-active t)
|
|
(tp--batch-update-pending nil))
|
|
(tp-debug-log "Starting batch updates")
|
|
(unwind-protect
|
|
(progn ,@body)
|
|
(tp-debug-log "Ending batch updates")
|
|
(tp--flush-batch-updates))))
|
|
|
|
(defun tp--update-layer-computed (layer-name override-alist)
|
|
"Update computed reactive variables for LAYER-NAME with OVERRIDE-ALIST.
|
|
Evaluates compute functions and updates the reactive variable values.
|
|
Returns an updated override-alist with the new computed values."
|
|
(when-let ((computed (cdr (assoc layer-name tp-layer-computed))))
|
|
(dolist (comp computed)
|
|
(let* ((var-sym (car comp))
|
|
(compute-fn (cdr comp))
|
|
;; Temporarily bind variables to their new values from override-alist
|
|
;; before calling the compute function
|
|
(computed-val
|
|
(condition-case err
|
|
(cl-progv
|
|
(mapcar #'car override-alist)
|
|
(mapcar #'cdr override-alist)
|
|
(funcall compute-fn))
|
|
(error
|
|
(message "tp: compute error for %s.%s: %s"
|
|
layer-name var-sym err)
|
|
nil))))
|
|
(when computed-val
|
|
;; Update the global variable
|
|
(set var-sym computed-val)
|
|
;; Add to override-alist for property resolution
|
|
(push (cons var-sym computed-val) override-alist)
|
|
;; Also update the layer properties if the computed var is used in props
|
|
(let ((current-props (cdr (assoc layer-name tp-layer-alist))))
|
|
(when current-props
|
|
;; Collect all reactive props for this layer from tp-reactive-deps
|
|
(let ((all-reactive-props nil))
|
|
(dolist (dep tp-reactive-deps)
|
|
(let ((layer-entry (assoc layer-name (cdr dep))))
|
|
(when (and layer-entry (cdr layer-entry))
|
|
;; Merge the reactive props
|
|
(cl-loop for (key val) on (cdr layer-entry) by #'cddr
|
|
do (setq all-reactive-props
|
|
(plist-put all-reactive-props key val))))))
|
|
(when all-reactive-props
|
|
(let ((resolved-props (tp--resolve-reactive-symbols
|
|
all-reactive-props override-alist)))
|
|
(when resolved-props
|
|
(cl-loop for (key val) on resolved-props by #'cddr
|
|
do (setq current-props (plist-put current-props key val)))
|
|
(tp--set-layer-props layer-name current-props)))))))))))
|
|
override-alist)
|
|
|
|
(defun tp--register-layer-watchers (layer-name watchers)
|
|
"Register WATCHERS for LAYER-NAME.
|
|
WATCHERS is a list of (VAR-SYMBOL CALLBACK) pairs."
|
|
(when watchers
|
|
(let ((watcher-pairs
|
|
(mapcar (lambda (watcher)
|
|
(cons (car watcher) (cadr watcher)))
|
|
watchers)))
|
|
(if (assoc layer-name tp-layer-watchers)
|
|
(setf (cdr (assoc layer-name tp-layer-watchers)) watcher-pairs)
|
|
(push (cons layer-name watcher-pairs) tp-layer-watchers)))))
|
|
|
|
(defun tp--register-layer-computed (layer-name computed)
|
|
"Register COMPUTED variable definitions for LAYER-NAME.
|
|
COMPUTED is a list of (VAR-SYMBOL COMPUTE-FN) pairs."
|
|
(when computed
|
|
(let ((computed-pairs
|
|
(mapcar (lambda (comp)
|
|
(cons (car comp) (cadr comp)))
|
|
computed)))
|
|
(if (assoc layer-name tp-layer-computed)
|
|
(setf (cdr (assoc layer-name tp-layer-computed)) computed-pairs)
|
|
(push (cons layer-name computed-pairs) tp-layer-computed)))))
|
|
|
|
(defun tp--unregister-layer-watchers (layer-name)
|
|
"Unregister all watchers for LAYER-NAME."
|
|
(setq tp-layer-watchers (assq-delete-all layer-name tp-layer-watchers)))
|
|
|
|
(defun tp--unregister-layer-computed (layer-name)
|
|
"Unregister all computed properties for LAYER-NAME."
|
|
(setq tp-layer-computed (assq-delete-all layer-name tp-layer-computed)))
|
|
|
|
(defun tp--apply-initial-computed (compute)
|
|
"Apply initial computed values using COMPUTE definitions.
|
|
COMPUTE is a list of (VAR-SYMBOL COMPUTE-FN) pairs.
|
|
Sets the global variables to their computed values."
|
|
(dolist (comp compute)
|
|
(let* ((var-sym (car comp))
|
|
(compute-fn (cadr comp))
|
|
(val (condition-case err
|
|
(funcall compute-fn)
|
|
(error
|
|
(message "tp: initial compute error for %s: %s" var-sym err)
|
|
nil))))
|
|
(when val
|
|
(set var-sym val)))))
|
|
|
|
(defun tp--data-var-symbol (data-entry)
|
|
"Extract the variable symbol from DATA-ENTRY.
|
|
DATA-ENTRY can be a symbol or a cons cell (SYMBOL . INITIAL-VALUE)."
|
|
(if (consp data-entry)
|
|
(car data-entry)
|
|
data-entry))
|
|
|
|
(defun tp--register-layer-data (layer-name data-vars)
|
|
"Register DATA-VARS for LAYER-NAME.
|
|
DATA-VARS is a list of variable symbols or cons cells (SYMBOL . INITIAL-VALUE).
|
|
Also adds variable watchers so changes to data vars trigger computed updates."
|
|
(when data-vars
|
|
;; Extract just the symbols for storage
|
|
(let ((var-symbols (mapcar #'tp--data-var-symbol data-vars)))
|
|
(if (assoc layer-name tp-layer-data)
|
|
(setf (cdr (assoc layer-name tp-layer-data)) var-symbols)
|
|
(push (cons layer-name var-symbols) tp-layer-data))
|
|
;; Add watchers for data variables
|
|
(dolist (var-sym var-symbols)
|
|
(let ((existing (assoc var-sym tp-reactive-deps)))
|
|
(if existing
|
|
;; Add this layer to existing dependencies
|
|
;; (with nil props since data vars don't have direct props)
|
|
(let ((layer-entry (assoc layer-name (cdr existing))))
|
|
(unless layer-entry
|
|
(push (cons layer-name nil) (cdr existing))))
|
|
;; Create new dependency entry and add watcher
|
|
(push (cons var-sym (list (cons layer-name nil))) tp-reactive-deps)
|
|
(unless (boundp var-sym) (set var-sym nil))
|
|
(add-variable-watcher var-sym #'tp--reactive-variable-watcher)))))))
|
|
|
|
(defun tp--unregister-layer-data (layer-name)
|
|
"Unregister data variables for LAYER-NAME."
|
|
(setq tp-layer-data (assq-delete-all layer-name tp-layer-data)))
|
|
|
|
(defun tp--ensure-reactive-variables (var-symbols)
|
|
"Ensure all VAR-SYMBOLS are defined as global variables.
|
|
VAR-SYMBOLS can be a list of symbols or cons cells (SYMBOL . INITIAL-VALUE).
|
|
If a variable is not bound, define it with the initial value (nil if not specified).
|
|
If a variable has an explicit initial value (cons cell), always update it to allow
|
|
re-definition to change initial values."
|
|
(dolist (sym var-symbols)
|
|
(let* ((is-cons (and (consp sym) (not (tp--reactive-symbol-p sym))))
|
|
(var-sym (cond
|
|
(is-cons (car sym))
|
|
((tp--reactive-symbol-p sym)
|
|
(tp--reactive-var-symbol sym))
|
|
(t sym)))
|
|
(initial-val (if is-cons (cdr sym) nil)))
|
|
(if is-cons
|
|
;; For explicit initial values, always update (allows re-definition)
|
|
(set var-sym initial-val)
|
|
;; For implicit initial values, only set if not already bound
|
|
(unless (boundp var-sym)
|
|
(set var-sym initial-val))))))
|
|
|
|
(defun tp--update-layer-regions (layer-name &optional where)
|
|
"Update text regions that have LAYER-NAME applied.
|
|
Re-applies the layer properties using tp-search-map and tp-add.
|
|
|
|
WHERE specifies which buffers to update:
|
|
- If WHERE is a buffer, only update that buffer (setq-local case).
|
|
- If WHERE is nil, update all buffers that have the text property (setq case)."
|
|
(let ((props (tp-layer-props layer-name t))) ; include tp-name for reactive tracking
|
|
(when props
|
|
;; Callback for tp-search-map: applies props to matched region.
|
|
;; _TEXT is unused (the matched text), START and END are buffer positions.
|
|
;; Returns nil to prevent tp-search-map from replacing the text.
|
|
(let ((apply-props-fn (lambda (_text start end)
|
|
(tp-add start end props)
|
|
nil)))
|
|
(if (and where (bufferp where) (buffer-live-p where))
|
|
;; setq-local case: only update the specific buffer
|
|
(tp-with-current-buffer where
|
|
(save-excursion
|
|
(tp-search-map apply-props-fn 'tp-name layer-name)))
|
|
;; setq case: update all buffers that have the text property
|
|
(dolist (buf (buffer-list))
|
|
(when (buffer-live-p buf)
|
|
(tp-with-current-buffer buf
|
|
(save-excursion
|
|
(tp-search-map apply-props-fn 'tp-name layer-name))))))))))
|
|
|
|
(defun tp-reactive-reset ()
|
|
"Reset all reactive text property watchers and dependencies."
|
|
(interactive)
|
|
;; Remove all variable watchers
|
|
(dolist (dep tp-reactive-deps)
|
|
(let ((var-sym (car dep)))
|
|
(remove-variable-watcher var-sym #'tp--reactive-variable-watcher)))
|
|
;; Clear all registries
|
|
(setq tp-reactive-deps nil)
|
|
(setq tp-layer-watchers nil)
|
|
(setq tp-layer-computed nil)
|
|
(setq tp-layer-data nil))
|
|
|
|
;;;============================================================================
|
|
;;; Layer 4: Reactive Text (tp-text property)
|
|
;;;============================================================================
|
|
|
|
(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--update-reactive-text (layer-name &optional where)
|
|
"Update text regions that have tp-text property with LAYER-NAME applied.
|
|
This is called when a reactive variable bound to tp-text changes.
|
|
|
|
WHERE specifies which buffers to update:
|
|
- If WHERE is a buffer, only update that buffer (setq-local case).
|
|
- If WHERE is nil, update all buffers that have the text property (setq case).
|
|
|
|
If a transform function is registered for LAYER-NAME via `:transform',
|
|
it will be applied to the text before updating."
|
|
(let ((props (tp-layer-props layer-name t))) ; include tp-name for reactive tracking
|
|
(when props
|
|
(let* ((raw-text (plist-get props 'tp-text))
|
|
;; Apply transformation if registered
|
|
(transform-fn (cdr (assoc layer-name tp-layer-transforms)))
|
|
(new-text (if (and transform-fn raw-text (stringp raw-text))
|
|
(condition-case err
|
|
(let ((result (funcall transform-fn raw-text)))
|
|
(tp-debug-log " Transform %s: %S -> %S"
|
|
layer-name raw-text result)
|
|
result)
|
|
(error
|
|
(message "tp: transform error for %s: %s"
|
|
layer-name err)
|
|
raw-text))
|
|
raw-text)))
|
|
(when (and new-text (stringp new-text))
|
|
(if (and where (bufferp where) (buffer-live-p where))
|
|
;; setq-local case: only update the specific buffer
|
|
(tp-with-current-buffer where
|
|
(save-excursion
|
|
(tp--replace-reactive-text-in-buffer layer-name new-text props)))
|
|
;; setq case: update all buffers that have the text property
|
|
(dolist (buf (buffer-list))
|
|
(when (buffer-live-p buf)
|
|
(tp-with-current-buffer buf
|
|
(save-excursion
|
|
(tp--replace-reactive-text-in-buffer layer-name new-text props)))))))))))
|
|
|
|
(defvar tp-preserve-external-properties '(keymap mouse-face cursor pointer help-echo)
|
|
"List of text properties to preserve during reactive text updates.
|
|
These properties are typically set by external libraries (like twidget's event
|
|
system) and should not be overwritten when tp.el updates reactive text.
|
|
Properties in this list will be preserved from the buffer during updates,
|
|
while other properties will be replaced with the new values.")
|
|
|
|
(defun tp--replace-reactive-text-in-buffer (layer-name new-text props)
|
|
"Replace text in current buffer for reactive text with LAYER-NAME.
|
|
NEW-TEXT is the new text to replace with.
|
|
PROPS are the properties to apply to the new text.
|
|
+Text properties embedded in NEW-TEXT are merged with PROPS.
|
|
+Properties listed in `tp-preserve-external-properties' that were applied
|
|
+by other libraries are preserved during the update."
|
|
(goto-char (point-min))
|
|
(let ((match (text-property-search-forward 'tp-name layer-name t))
|
|
;; Merge embedded text properties from new-text into props
|
|
(merged-props (tp--merge-string-props-into-plist new-text props)))
|
|
(while match
|
|
(let* ((m-start (prop-match-beginning match))
|
|
(m-end (prop-match-end match))
|
|
(old-text (buffer-substring-no-properties m-start m-end))
|
|
;; Preserve only specific external properties
|
|
(existing-props (text-properties-at m-start))
|
|
(preserved-props nil))
|
|
;; Extract only the explicitly listed external properties to preserve
|
|
(dolist (prop-name tp-preserve-external-properties)
|
|
(let ((val (plist-get existing-props prop-name)))
|
|
(when (and val (not (plist-member merged-props prop-name)))
|
|
(setq preserved-props
|
|
(plist-put preserved-props prop-name val)))))
|
|
;; Combine merged-props with preserved external props
|
|
(let ((final-props (append merged-props preserved-props)))
|
|
(if (equal old-text (substring-no-properties new-text))
|
|
;; Text content is the same, but properties may differ
|
|
;; Use set-text-properties to replace with final properties
|
|
(set-text-properties m-start m-end final-props)
|
|
;; Text content is different - delete old text and insert new
|
|
(delete-region m-start m-end)
|
|
(goto-char m-start)
|
|
(insert (substring-no-properties new-text))
|
|
;; Apply final properties
|
|
(let ((new-end (+ m-start (length new-text))))
|
|
(set-text-properties m-start new-end final-props)))))
|
|
;; Search for next match
|
|
(setq match (text-property-search-forward 'tp-name layer-name 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.
|
|
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 controls how embedded text properties in tp-text are handled:
|
|
:merge - embedded properties are merged with props (tp-add behavior)
|
|
:override or nil - props override embedded properties (tp-set behavior)
|
|
:reset - embedded properties are ignored, only props used (tp-reset behavior)
|
|
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 with tp-text)."
|
|
(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)))
|
|
(cond
|
|
;; tp-text is nil - initialize it to the current text
|
|
((null tp-text-val)
|
|
(let ((current-text
|
|
(if (stringp object)
|
|
(substring object start end)
|
|
(if object
|
|
(with-current-buffer object
|
|
(buffer-substring-no-properties start end))
|
|
(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-let ((layer-name (plist-get props 'tp-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))))))
|
|
(list (plist-put props 'tp-text current-text) end object)))
|
|
;; tp-text has a string value - replace the text in the region
|
|
((stringp tp-text-val)
|
|
;; Apply transform if layer has one registered
|
|
(let* ((layer-name (plist-get props 'tp-name))
|
|
(transform-fn (when layer-name
|
|
(cdr (assoc layer-name tp-layer-transforms))))
|
|
(final-text
|
|
(if transform-fn
|
|
(condition-case err
|
|
(funcall transform-fn tp-text-val)
|
|
(error
|
|
(message "tp: transform error for %s: %s" layer-name err)
|
|
tp-text-val))
|
|
tp-text-val))
|
|
;; Handle embedded text properties based on merge-mode:
|
|
;; :merge - merge embedded props with props (tp-add)
|
|
;; :override/nil - props take precedence, don't merge (tp-set)
|
|
;; :reset - ignore embedded props entirely (tp-reset)
|
|
(result-props
|
|
(if (eq merge-mode :merge)
|
|
;; tp-add: merge embedded properties with props
|
|
(tp--merge-string-props-into-plist final-text props)
|
|
;; tp-set/:override or tp-reset: just use props as-is
|
|
props)))
|
|
(if (stringp object)
|
|
;; For strings: create a new string with tp-text content
|
|
;; Strip properties - result-props will be applied by the caller
|
|
(let ((new-string (substring-no-properties final-text)))
|
|
(list result-props (length new-string) new-string))
|
|
;; For buffers: replace text and adjust end position
|
|
(let ((old-text (if object
|
|
(with-current-buffer object
|
|
(buffer-substring-no-properties start end))
|
|
(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
|
|
(if object
|
|
(with-current-buffer object
|
|
(text-properties-at start))
|
|
(text-properties-at start)))))
|
|
(save-excursion
|
|
(if object
|
|
(with-current-buffer object
|
|
(let ((inhibit-read-only t))
|
|
(delete-region start end)
|
|
(goto-char start)
|
|
;; Insert without properties - we'll apply result-props later
|
|
(insert (substring-no-properties final-text))))
|
|
(let ((inhibit-read-only t))
|
|
(delete-region start end)
|
|
(goto-char start)
|
|
(insert (substring-no-properties final-text)))))
|
|
(let ((new-end (+ start (length final-text))))
|
|
;; Re-apply existing properties to new text region if preserving
|
|
(when existing-props
|
|
(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))))))))
|
|
;; Other types - return unchanged
|
|
(t (list props end object))))))
|
|
|
|
;;;============================================================================
|
|
;;; Layer 2: Core Property Functions - Argument Parsing
|
|
;;;============================================================================
|
|
|
|
(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
|
|
(when (and rest (or (bufferp (car rest))
|
|
(stringp (car rest))))
|
|
(setq object (car rest))))
|
|
(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--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.
|
|
|
|
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))
|
|
;; Build the result string piece by piece
|
|
(before (when (> start 0)
|
|
(substring str 0 start)))
|
|
(middle-text (substring-no-properties str start end))
|
|
(after (when (< end len)
|
|
(substring str end len)))
|
|
;; Get existing properties for the middle section
|
|
(existing-props (when (not (eq merge-mode :reset))
|
|
(text-properties-at start str)))
|
|
;; Calculate final properties for the middle section
|
|
(final-props
|
|
(cond
|
|
;; :reset - use only new props
|
|
((eq merge-mode :reset)
|
|
props)
|
|
;; :add - deep merge with face prepending
|
|
((eq merge-mode :add)
|
|
(let ((result existing-props))
|
|
(cl-loop
|
|
for (key val) on props by #'cddr
|
|
do (let* ((current-val (plist-get result key))
|
|
(new-val (cond
|
|
((eq key 'face) (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))))
|
|
(setq result (plist-put result key new-val))))
|
|
result))
|
|
;; nil/:set - set properties, preserving unspecified ones
|
|
(t
|
|
;; Build a new plist by iterating through existing props and overriding with new props
|
|
(let ((result nil))
|
|
;; First add all props from new props
|
|
(cl-loop for (key val) on props by #'cddr
|
|
do (setq result (plist-put result key val)))
|
|
;; Then add existing props that are not in new props
|
|
(cl-loop for (key val) on existing-props by #'cddr
|
|
unless (plist-member props key)
|
|
do (setq result (plist-put result key val)))
|
|
result))))
|
|
;; Create the middle section with properties using propertize
|
|
(middle-propertized (apply #'propertize middle-text final-props)))
|
|
;; Concatenate the parts
|
|
(concat before middle-propertized after)))
|
|
|
|
;;;============================================================================
|
|
;;; Layer 2: Core Property Functions - Set/Reset/Add
|
|
;;;============================================================================
|
|
|
|
(defun tp-set (start-or-string &optional end-or-prop props-or-val &rest rest)
|
|
"Set text properties on string or buffer region.
|
|
|
|
Supports four calling conventions:
|
|
1. (tp-set START END PROPS) - current buffer
|
|
2. (tp-set START END PROPS BUFFER/STRING) - specific object
|
|
3. (tp-set STRING PROP VAL ...) - entire string
|
|
|
|
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))))
|
|
(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.
|
|
For tp-text, embedded text properties are ignored - only props are used.
|
|
|
|
**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)
|
|
(cons start finish))))))
|
|
|
|
(defun tp--prepend-face (new-face existing-face)
|
|
"Prepend NEW-FACE to EXISTING-FACE for the face property.
|
|
Returns a face value where NEW-FACE takes precedence.
|
|
|
|
Examples:
|
|
(tp--prepend-face \\='shadow \\='bold) => (shadow bold)
|
|
(tp--prepend-face \\='shadow \\='(bold italic)) => (shadow bold italic)
|
|
(tp--prepend-face \\='(:foreground \"red\") \\='(:background \"blue\"))
|
|
=> (:background \"blue\" :foreground \"red\") ; merged plist
|
|
|
|
If NEW-FACE is a plist (like (:foreground \"red\")), deeply merge it.
|
|
If NEW-FACE is a symbol or list of faces, prepend it to create a face list.
|
|
For mixed lists containing both symbols and plists, plists are merged correctly.
|
|
Duplicate faces are not added."
|
|
(cond
|
|
;; No existing face - just use new face
|
|
((null existing-face) new-face)
|
|
;; New face is a plist - deep merge with existing
|
|
((and (listp new-face) (keywordp (car-safe new-face)))
|
|
(cond
|
|
((and (listp existing-face) (keywordp (car-safe existing-face)))
|
|
(tp--deep-merge-plist existing-face new-face))
|
|
;; Existing is a symbol or list of faces - wrap new plist and prepend
|
|
((symbolp existing-face)
|
|
(list new-face existing-face))
|
|
((listp existing-face)
|
|
;; Parse existing to extract any plists and merge them
|
|
(let* ((parsed (tp--parse-face-list existing-face))
|
|
(existing-symbols (car parsed))
|
|
(existing-plist (cdr parsed)))
|
|
(if existing-plist
|
|
;; Merge new-face plist with existing plist, prepend symbols
|
|
(let ((merged-plist (tp--deep-merge-plist existing-plist new-face)))
|
|
(if existing-symbols
|
|
(append existing-symbols (list merged-plist))
|
|
merged-plist))
|
|
(cons new-face existing-face))))
|
|
(t new-face)))
|
|
;; New face is a symbol - prepend to existing
|
|
((symbolp new-face)
|
|
(cond
|
|
((symbolp existing-face)
|
|
(if (eq new-face existing-face)
|
|
new-face
|
|
(list new-face existing-face)))
|
|
((listp existing-face)
|
|
(if (member new-face existing-face)
|
|
existing-face
|
|
(cons new-face existing-face)))
|
|
(t new-face)))
|
|
;; New face is a list of faces - parse and merge with existing
|
|
((listp new-face)
|
|
(cond
|
|
((symbolp existing-face)
|
|
(if (member existing-face new-face)
|
|
new-face
|
|
(append new-face (list existing-face))))
|
|
((listp existing-face)
|
|
;; Parse both to extract symbols and plists, then merge appropriately
|
|
(let* ((parsed-new (tp--parse-face-list new-face))
|
|
(new-symbols (car parsed-new))
|
|
(new-plist (cdr parsed-new))
|
|
(parsed-existing (tp--parse-face-list existing-face))
|
|
(existing-symbols (car parsed-existing))
|
|
(existing-plist (cdr parsed-existing))
|
|
;; Merge plists with new taking precedence
|
|
(merged-plist (cond
|
|
((and existing-plist new-plist)
|
|
(tp--deep-merge-plist existing-plist new-plist))
|
|
(new-plist new-plist)
|
|
(existing-plist existing-plist)
|
|
(t nil)))
|
|
;; Combine symbols: new symbols first, then existing symbols not in new
|
|
(merged-symbols (append new-symbols
|
|
(cl-remove-if (lambda (s) (member s new-symbols))
|
|
existing-symbols))))
|
|
;; Build result: symbols first, then merged plist if any
|
|
(if merged-plist
|
|
(append merged-symbols (list merged-plist))
|
|
merged-symbols)))
|
|
(t new-face)))
|
|
(t new-face)))
|
|
|
|
(defun tp-add (start-or-string &optional end-or-prop props-or-val &rest rest)
|
|
"Add or update text properties with deep merging.
|
|
Unlike `tp-set', deeply merges nested properties.
|
|
For `face' property, symbol faces are prepended to existing face list.
|
|
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
|
|
((eq key 'face) (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
|
|
((eq key 'face) (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))))
|
|
(cons start finish))))))
|
|
|
|
;;;============================================================================
|
|
;;; Layer 2: Core Property Functions - Get/At
|
|
;;;============================================================================
|
|
|
|
(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."
|
|
(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 '(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))))
|
|
|
|
;;;============================================================================
|
|
;;; Layer 2: Core Property Functions - Remove/Clear
|
|
;;;============================================================================
|
|
|
|
(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 a dummy arg (t) since we only need key names
|
|
(let* ((layer-props
|
|
(cond
|
|
((tp-layer-parameterized-p property)
|
|
(tp-layer-props-with-arg property t nil)) ; arg=t, include-tp-name=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)
|
|
(let ((props-to-remove (cl-remove-if-not #'symbolp
|
|
(list end-or-prop 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--expand-layer-to-props-list (layer-name str start)
|
|
"Expand LAYER-NAME to a list of property keys it contributes.
|
|
If LAYER-NAME is a layer defined in `tp-layer-alist', returns a list
|
|
of the property keys that the layer adds, plus 'tp-name.
|
|
STR and START are used to get the argument value for parameterized layers.
|
|
For non-layer symbols, returns a list containing just that symbol."
|
|
(if (tp--is-layer-name-p layer-name)
|
|
(let* ((existing-props (text-properties-at start str))
|
|
(existing-tp-name (plist-get existing-props 'tp-name))
|
|
(layer-prop-value (plist-get existing-props layer-name))
|
|
;; Proceed if tp-name matches OR if the layer property exists
|
|
;; (for cases where layer was used in mixed syntax without tp-name)
|
|
(layer-props
|
|
(cond
|
|
;; tp-name matches - traditional layer application
|
|
((eq existing-tp-name layer-name)
|
|
(cond
|
|
;; Parameterized layer - get property keys it would produce
|
|
;; We pass a dummy arg (t) since we only need the key names, not values
|
|
((tp-layer-parameterized-p layer-name)
|
|
(tp-layer-props-with-arg layer-name t nil)) ; arg=t, include-tp-name=nil
|
|
;; Non-parameterized layer
|
|
((assoc layer-name tp-layer-alist)
|
|
(tp-layer-props layer-name nil)) ; include-tp-name=nil
|
|
;; Layer group
|
|
((assoc layer-name tp-layer-groups)
|
|
(when-let ((layer-props-list (tp-group-props layer-name t)))
|
|
(tp--build-layer-props layer-props-list)))))
|
|
;; Layer property exists (mixed syntax like `tp-set str 'face 'bold 'layer arg`)
|
|
;; In this case, the layer's face properties are merged into face
|
|
(layer-prop-value
|
|
(cond
|
|
((tp-layer-parameterized-p layer-name)
|
|
(tp-layer-props-with-arg layer-name layer-prop-value nil))
|
|
((assoc layer-name tp-layer-alist)
|
|
(tp-layer-props layer-name nil))
|
|
((assoc layer-name tp-layer-groups)
|
|
(when-let ((layer-props-list (tp-group-props layer-name t)))
|
|
(tp--build-layer-props layer-props-list))))))))
|
|
(if layer-props
|
|
;; Return all property keys from the layer plus tp-name and the layer itself
|
|
(let ((keys (cl-loop for (key _val) on layer-props by #'cddr
|
|
collect key)))
|
|
(unless (memq 'tp-name keys)
|
|
(push 'tp-name keys))
|
|
(unless (memq layer-name keys)
|
|
(push layer-name keys))
|
|
keys)
|
|
;; Layer name doesn't match tp-name and layer property doesn't exist
|
|
;; Just remove the literal symbol
|
|
(list layer-name)))
|
|
;; Not a layer name, just return the symbol itself
|
|
(list layer-name)))
|
|
|
|
(defun tp--expand-props-to-remove (props-to-remove str start)
|
|
"Expand PROPS-TO-REMOVE list, expanding any layer names to their property keys.
|
|
STR and START are used to determine context for parameterized layers."
|
|
(let ((result nil))
|
|
(dolist (prop props-to-remove)
|
|
(dolist (expanded (tp--expand-layer-to-props-list prop str start))
|
|
(unless (memq expanded result)
|
|
(push expanded result))))
|
|
(nreverse result)))
|
|
|
|
(defun tp--get-layer-face-contribution (layer-name layer-prop-value)
|
|
"Get the face contribution from LAYER-NAME.
|
|
LAYER-PROP-VALUE is the value of the layer property (the argument passed to it).
|
|
Returns the face value that the layer adds, or nil if no face contribution."
|
|
(when (tp--is-layer-name-p layer-name)
|
|
(let ((layer-props
|
|
(cond
|
|
((tp-layer-parameterized-p layer-name)
|
|
(tp-layer-props-with-arg layer-name layer-prop-value nil))
|
|
((assoc layer-name tp-layer-alist)
|
|
(tp-layer-props layer-name nil))
|
|
((assoc layer-name tp-layer-groups)
|
|
(when-let ((layer-props-list (tp-group-props layer-name t)))
|
|
(tp--build-layer-props layer-props-list))))))
|
|
(when layer-props
|
|
(plist-get layer-props 'face)))))
|
|
|
|
(defun tp--remove-props-from-string (str start end props-to-remove)
|
|
"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.
|
|
Returns a new string (original is not modified)."
|
|
(let* ((len (length str))
|
|
(start (max 0 start))
|
|
(end (min end len))
|
|
(before (when (> start 0)
|
|
(substring str 0 start)))
|
|
(middle-text (substring-no-properties str start end))
|
|
(after (when (< end len)
|
|
(substring str end len)))
|
|
(existing-props (text-properties-at start str))
|
|
;; Remaining face after layer subtractions
|
|
(remaining-face nil)
|
|
;; 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
|
|
(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 final properties
|
|
(let* ((final-props
|
|
(let ((result 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 result (plist-put result key remaining-face))))
|
|
;; Property to remove entirely
|
|
((memq key props-to-remove-entirely)
|
|
nil) ; skip
|
|
;; Keep other properties
|
|
(t (setq result (plist-put result key val)))))
|
|
result))
|
|
(middle-propertized (if final-props
|
|
(apply #'propertize middle-text final-props)
|
|
middle-text)))
|
|
(concat before middle-propertized after))))
|
|
|
|
(defun tp--remove-sub-from-string (str start end property sub-key)
|
|
"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."
|
|
(let* ((len (length str))
|
|
(start (max 0 start))
|
|
(end (min end len))
|
|
(before (when (> start 0)
|
|
(substring str 0 start)))
|
|
(middle-text (substring-no-properties str start end))
|
|
(after (when (< end len)
|
|
(substring str end len)))
|
|
;; Get existing properties and modify the property
|
|
(existing-props (text-properties-at start str))
|
|
(prop-value (plist-get existing-props property))
|
|
;; Use the new helper to handle complex face values
|
|
(new-value (when prop-value
|
|
(tp--remove-sub-from-face-value prop-value sub-key)))
|
|
(final-props (let ((result nil))
|
|
(cl-loop for (key val) on existing-props by #'cddr
|
|
do (setq result (plist-put result key
|
|
(if (eq key property)
|
|
new-value
|
|
val))))
|
|
result))
|
|
(middle-propertized (if final-props
|
|
(apply #'propertize middle-text final-props)
|
|
middle-text)))
|
|
(concat before middle-propertized after)))
|
|
|
|
(defun tp--remove-property-from-string (str start end property-spec)
|
|
"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
|
|
((and sub-key nested-keys)
|
|
;; For complex nested removal, we need to handle this specially
|
|
(let* ((len (length str))
|
|
(start (max 0 start))
|
|
(end (min end len))
|
|
(before (when (> start 0)
|
|
(substring str 0 start)))
|
|
(middle-text (substring-no-properties str start end))
|
|
(after (when (< end len)
|
|
(substring str end len)))
|
|
(existing-props (text-properties-at start str))
|
|
(prop-value (plist-get existing-props property))
|
|
(new-value (when (and prop-value (listp prop-value))
|
|
(tp--remove-nested-sub-keys prop-value sub-key nested-keys)))
|
|
(final-props (let ((result nil))
|
|
(cl-loop for (key val) on existing-props by #'cddr
|
|
do (setq result (plist-put result key
|
|
(if (eq key property)
|
|
new-value
|
|
val))))
|
|
result))
|
|
(middle-propertized (if final-props
|
|
(apply #'propertize middle-text final-props)
|
|
middle-text)))
|
|
(concat before middle-propertized after)))
|
|
;; 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.
|
|
If START and END are not provided, clear the entire buffer."
|
|
(interactive)
|
|
(let ((beg (or start (point-min)))
|
|
(finish (or end (point-max))))
|
|
(set-text-properties beg finish nil object)))
|
|
|
|
;;;============================================================================
|
|
;;; Layer 5: High-Level API - Pattern Matching (match/regexp)
|
|
;;;============================================================================
|
|
|
|
(defun tp--match-apply-single (pattern properties apply-fn object)
|
|
"Apply APPLY-FN to matches of single PATTERN in OBJECT.
|
|
For strings, returns a new string with properties applied (non-destructive).
|
|
For buffers, modifies in-place and returns list of regions."
|
|
(cond
|
|
;; String object
|
|
((stringp object)
|
|
;; First, collect all match positions from the original string
|
|
(let ((matches nil)
|
|
(pos 0))
|
|
(while (string-match (regexp-quote pattern) object pos)
|
|
(let ((beg (match-beginning 0))
|
|
(end (match-end 0)))
|
|
(push (cons beg end) matches)
|
|
(setq pos (if (= beg end) (1+ beg) end))))
|
|
;; Apply function to each match in order (reverse to get correct order)
|
|
(let ((result object))
|
|
(dolist (match (nreverse matches))
|
|
(when properties
|
|
(setq result (funcall apply-fn (car match) (cdr match) properties result))))
|
|
result)))
|
|
;; Buffer or nil (current buffer)
|
|
(t
|
|
(let ((buf (or object (current-buffer))))
|
|
(tp-with-current-buffer buf
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(let (regions)
|
|
(while (search-forward pattern nil t)
|
|
(let ((beg (match-beginning 0))
|
|
(end (match-end 0)))
|
|
(when properties
|
|
(funcall apply-fn beg end properties buf))
|
|
(push (cons beg end) regions)))
|
|
(nreverse regions))))))))
|
|
|
|
(defun tp--match-apply (pattern properties apply-fn &optional object)
|
|
"Internal function to apply APPLY-FN to matches of PATTERN.
|
|
PATTERN can be a string or a list of strings (multiple patterns).
|
|
When PATTERN is a list, each element is a pattern to match.
|
|
APPLY-FN is called with (START END PROPS OBJECT) for each match.
|
|
For strings, returns a NEW string with properties applied (non-destructive).
|
|
For buffers, returns list of regions."
|
|
(let ((patterns (if (listp pattern) pattern (list pattern))))
|
|
(cond
|
|
;; String object
|
|
((stringp object)
|
|
(let ((result object))
|
|
(dolist (p patterns)
|
|
(setq result (tp--match-apply-single p properties apply-fn result)))
|
|
result))
|
|
;; Buffer or nil (current buffer)
|
|
(t
|
|
(let ((all-regions nil))
|
|
(dolist (p patterns)
|
|
(let ((regions (tp--match-apply-single p properties apply-fn object)))
|
|
(setq all-regions (append all-regions regions))))
|
|
all-regions)))))
|
|
|
|
(defun tp--regexp-apply-single (pattern properties apply-fn object)
|
|
"Apply APPLY-FN to regexp matches of single PATTERN in OBJECT.
|
|
APPLY-FN is called with (START END PROPS OBJECT) for each match.
|
|
For strings, returns a NEW string with properties applied (non-destructive).
|
|
For buffers, modifies in-place and returns list of regions."
|
|
(cond
|
|
;; String object
|
|
((stringp object)
|
|
;; First, collect all match positions from the original string
|
|
(let ((matches nil)
|
|
(pos 0))
|
|
(while (string-match pattern object pos)
|
|
(let ((beg (match-beginning 0))
|
|
(end (match-end 0)))
|
|
(push (cons beg end) matches)
|
|
(setq pos (if (= beg end) (1+ beg) end))))
|
|
;; Apply function to each match in order (reverse to get correct order)
|
|
(let ((result object))
|
|
(dolist (match (nreverse matches))
|
|
(when properties
|
|
(setq result (funcall apply-fn
|
|
(car match) (cdr match)
|
|
properties result))))
|
|
result)))
|
|
;; Buffer or nil (current buffer)
|
|
(t
|
|
(let ((buf (or object (current-buffer))))
|
|
(tp-with-current-buffer buf
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(let (regions)
|
|
(while (re-search-forward pattern nil t)
|
|
(let ((beg (match-beginning 0))
|
|
(end (match-end 0)))
|
|
(when properties
|
|
(funcall apply-fn beg end properties buf))
|
|
(push (cons beg end) regions)))
|
|
(nreverse regions))))))))
|
|
|
|
(defun tp--regexp-apply (pattern properties apply-fn &optional object)
|
|
"Internal function to apply APPLY-FN to regexp matches of PATTERN.
|
|
PATTERN can be a string (single regexp) or a list of strings (multiple regexps).
|
|
When PATTERN is a list, each element is a regexp to match.
|
|
APPLY-FN is called with (START END PROPS OBJECT) for each match.
|
|
For strings, returns a NEW string with properties applied (non-destructive).
|
|
For buffers, returns list of regions."
|
|
(let ((patterns (if (listp pattern) pattern (list pattern))))
|
|
(cond
|
|
;; String object
|
|
((stringp object)
|
|
(let ((result object))
|
|
(dolist (p patterns)
|
|
(setq result (tp--regexp-apply-single p properties apply-fn result)))
|
|
result))
|
|
;; Buffer or nil (current buffer)
|
|
(t
|
|
(let ((all-regions nil))
|
|
(dolist (p patterns)
|
|
(let ((regions (tp--regexp-apply-single p properties apply-fn object)))
|
|
(setq all-regions (append all-regions regions))))
|
|
all-regions)))))
|
|
|
|
(defun tp--deep-merge-apply (start end props obj)
|
|
"Apply PROPS to OBJ from START to END with deep merge.
|
|
Merges nested plists instead of replacing them.
|
|
For strings, returns a NEW string (original is not modified).
|
|
For buffers, modifies in-place."
|
|
(if (stringp obj)
|
|
;; For strings: create a new propertized string using tp--apply-props-to-string with :add mode
|
|
(tp--apply-props-to-string obj start end props :add)
|
|
;; For buffers: modify in-place
|
|
(let ((pos start))
|
|
(while (< pos end)
|
|
(let* ((current-props (text-properties-at pos obj))
|
|
(next-pos (or (next-property-change pos obj end) end)))
|
|
(cl-loop for (key val) on props by #'cddr
|
|
do (let* ((current-val (plist-get current-props key))
|
|
(new-val
|
|
(cond
|
|
((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 obj)))
|
|
(setq pos next-pos))))
|
|
obj))
|
|
|
|
(defun tp-match-set (pattern plist &optional object)
|
|
"Set properties on all occurrences of PATTERN.
|
|
|
|
(tp-match-set PATTERN PLIST &optional OBJECT)
|
|
|
|
PATTERN is a string (single pattern) or list of strings (multiple patterns).
|
|
Each pattern will be matched and have properties applied.
|
|
PLIST is a property list like \\='(face bold help-echo \"tip\"),
|
|
or a symbol representing a layer/group name defined by `define-tp'
|
|
or `define-tp-group'.
|
|
OBJECT is a buffer or string; nil means current buffer.
|
|
|
|
Returns:
|
|
- For strings: the modified string
|
|
- For buffers: list of (START . END) pairs for all matches."
|
|
(tp--match-apply pattern (tp--ensure-props plist) #'tp-set object))
|
|
|
|
(defun tp-match-reset (pattern plist &optional object)
|
|
"Reset (completely replace) properties on all occurrences of PATTERN.
|
|
|
|
(tp-match-reset PATTERN PLIST &optional OBJECT)
|
|
|
|
PATTERN is a string (single pattern) or list of strings (multiple patterns).
|
|
PLIST is a property list like \\='(face bold help-echo \"tip\"),
|
|
or a symbol representing a layer/group name defined by `define-tp'
|
|
or `define-tp-group'.
|
|
OBJECT is a buffer or string; nil means current buffer.
|
|
|
|
Unlike `tp-match-set', this completely replaces all existing properties.
|
|
|
|
For strings, returns a NEW string (original is not modified).
|
|
For buffers, modifies in-place and returns list of regions."
|
|
(tp--match-apply pattern (tp--ensure-props plist)
|
|
#'tp--reset-apply
|
|
object))
|
|
|
|
(defun tp--reset-apply (start end props obj)
|
|
"Apply PROPS to OBJ from START to END, completely replacing existing properties.
|
|
For strings, returns a NEW string.
|
|
For buffers, modifies in-place."
|
|
(if (stringp obj)
|
|
(tp--apply-props-to-string obj start end props :reset)
|
|
(set-text-properties start end props obj)
|
|
obj))
|
|
|
|
(defun tp-match-add (pattern plist &optional object)
|
|
"Add/update properties on all occurrences of PATTERN.
|
|
|
|
(tp-match-add PATTERN PLIST &optional OBJECT)
|
|
|
|
PATTERN is a string (single pattern) or list of strings (multiple patterns).
|
|
PLIST is a property list like \\='(face bold help-echo \"tip\"),
|
|
or a symbol representing a layer/group name defined by `define-tp'
|
|
or `define-tp-group'.
|
|
OBJECT is a buffer or string; nil means current buffer.
|
|
|
|
Unlike `tp-match-set', this deeply merges nested properties."
|
|
(tp--match-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply object))
|
|
|
|
(defun tp-regexp-set (pattern plist &optional object)
|
|
"Set properties on all matches of PATTERN (regexp).
|
|
|
|
(tp-regexp-set PATTERN PLIST &optional OBJECT)
|
|
|
|
PATTERN is a string (single regexp) or list of strings (multiple regexps).
|
|
Each pattern will be matched and have properties applied.
|
|
PLIST is a property list like \\='(face bold help-echo \"tip\"),
|
|
or a symbol representing a layer/group name defined by `define-tp'
|
|
or `define-tp-group'.
|
|
OBJECT is a buffer or string; nil means current buffer.
|
|
|
|
Returns:
|
|
- For strings: the modified string
|
|
- For buffers: list of (START . END) pairs for all matches."
|
|
(tp--regexp-apply pattern (tp--ensure-props plist) #'tp-set object))
|
|
|
|
(defun tp-regexp-reset (pattern plist &optional object)
|
|
"Reset (completely replace) properties on all regexp matches of PATTERN.
|
|
|
|
(tp-regexp-reset PATTERN PLIST &optional OBJECT)
|
|
|
|
PATTERN is a string (single regexp) or list of strings (multiple regexps).
|
|
PLIST is a property list like \\='(face bold help-echo \"tip\"),
|
|
or a symbol representing a layer/group name defined by `define-tp'
|
|
or `define-tp-group'.
|
|
OBJECT is a buffer or string; nil means current buffer.
|
|
|
|
Unlike `tp-regexp-set', this completely replaces all existing properties.
|
|
|
|
For strings, returns a NEW string (original is not modified).
|
|
For buffers, modifies in-place and returns list of regions."
|
|
(tp--regexp-apply pattern (tp--ensure-props plist)
|
|
#'tp--reset-apply
|
|
object))
|
|
|
|
(defun tp-regexp-add (pattern plist &optional object)
|
|
"Add/update properties on all regexp matches of PATTERN.
|
|
|
|
(tp-regexp-add PATTERN PLIST &optional OBJECT)
|
|
|
|
PATTERN is a string (single regexp) or list of strings (multiple regexps).
|
|
PLIST is a property list like \\='(face bold help-echo \"tip\"),
|
|
or a symbol representing a layer/group name defined by `define-tp'
|
|
or `define-tp-group'.
|
|
OBJECT is a buffer or string; nil means current buffer.
|
|
|
|
Unlike `tp-regexp-set', this deeply merges nested properties."
|
|
(tp--regexp-apply pattern (tp--ensure-props plist) #'tp--deep-merge-apply object))
|
|
|
|
;;;============================================================================
|
|
;;; Layer 5: High-Level API - Search and Navigation
|
|
;;;============================================================================
|
|
|
|
(defun tp-search-forward (property &optional value predicate not-current)
|
|
"Search forward for text with PROPERTY.
|
|
Wraps `text-property-search-forward'."
|
|
(text-property-search-forward property value predicate not-current))
|
|
|
|
(defun tp-search-backward (property &optional value predicate not-current)
|
|
"Search backward for text with PROPERTY.
|
|
Wraps `text-property-search-backward'."
|
|
(text-property-search-backward property value predicate not-current))
|
|
|
|
(defun tp-forward (property &optional value object n)
|
|
"Search forward N times for text with PROPERTY.
|
|
Returns prop-match for buffers or list of (START END VALUE) for strings."
|
|
(let ((count (or n 1)))
|
|
(cond
|
|
;; String object - use tp-search
|
|
((stringp object)
|
|
(let ((matches (tp-search object property value)))
|
|
(seq-take matches count)))
|
|
;; Buffer or nil
|
|
(t
|
|
(let ((result nil)
|
|
(buf (or object (current-buffer))))
|
|
(tp-with-current-buffer buf
|
|
(dotimes (_ count)
|
|
(setq result (tp-search-forward property value t))))
|
|
result)))))
|
|
|
|
(defun tp-backward (property &optional value object n)
|
|
"Search backward N times for text with PROPERTY.
|
|
|
|
N is the number of searches, defaulting to 1.
|
|
VALUE is the optional value to match.
|
|
OBJECT can be a buffer or string; nil defaults to current buffer.
|
|
|
|
For buffers, returns the prop-match object from the last successful search.
|
|
For strings, returns a list of (START END VALUE) for the last N matches
|
|
in reverse order (from end to start).
|
|
|
|
Uses `tp-search-backward' for buffers and `tp-search' for strings."
|
|
(let ((count (or n 1)))
|
|
(cond
|
|
;; String object - use tp-search and reverse
|
|
((stringp object)
|
|
(let ((matches (nreverse (tp-search object property value))))
|
|
(seq-take matches count)))
|
|
;; Buffer or nil
|
|
(t
|
|
(let ((result nil)
|
|
(buf (or object (current-buffer))))
|
|
(tp-with-current-buffer buf
|
|
(dotimes (_ count)
|
|
(setq result (tp-search-backward property value))))
|
|
result)))))
|
|
|
|
(defun tp--forward-do (function property &optional value object times start end)
|
|
"Internal: Search forward TIMES for PROPERTY and apply FUNCTION to the last match.
|
|
|
|
FUNCTION receives two arguments: the prop-match object (or list for strings)
|
|
and OBJECT.
|
|
TIMES is the number of searches, defaulting to 1.
|
|
VALUE is the optional value to match.
|
|
OBJECT can be a buffer or string; nil defaults to current buffer.
|
|
START and END define the search range; defaults are object start and end.
|
|
|
|
Returns the number of successful matches."
|
|
(let ((count (or times 1)))
|
|
(cond
|
|
;; String object
|
|
((stringp object)
|
|
(let* ((start-pos (or start 0))
|
|
(end-pos (or end (length object)))
|
|
(all-matches (tp-search object property value))
|
|
(filtered-matches (seq-filter (lambda (m)
|
|
(and (>= (car m) start-pos)
|
|
(<= (cadr m) end-pos)))
|
|
all-matches))
|
|
(matches (seq-take filtered-matches count)))
|
|
(when matches
|
|
(funcall function (car (last matches)) object))
|
|
(length matches)))
|
|
;; Buffer or nil
|
|
(t
|
|
(let* ((buf (or object (current-buffer)))
|
|
(matches 0))
|
|
(tp-with-current-buffer buf
|
|
(let ((search-start (or start (point-min)))
|
|
(search-end (or end (point-max))))
|
|
(save-excursion
|
|
(goto-char search-start)
|
|
(dotimes (i count)
|
|
(when-let ((match (tp-search-forward property value t)))
|
|
(when (<= (prop-match-end match) search-end)
|
|
(when (= i (1- count))
|
|
(funcall function match buf))
|
|
(cl-incf matches)))))))
|
|
matches)))))
|
|
|
|
(defun tp-forward-do (function property &optional value object times start end)
|
|
"Search forward for text with PROPERTY and apply FUNCTION to the last match.
|
|
|
|
FUNCTION receives (TEXT &optional START END) where TEXT is the matched text,
|
|
START and END are the positions of the match. The return value of FUNCTION
|
|
replaces the matched text in the string or buffer.
|
|
|
|
PROPERTY is the text property to search for.
|
|
VALUE is the optional value to match; nil means search for PROPERTY without
|
|
matching value.
|
|
OBJECT can be a buffer or string; nil defaults to current buffer.
|
|
TIMES is the number of searches, defaulting to 1. The function searches
|
|
TIMES times but only applies FUNCTION to the last (Nth) match found.
|
|
START and END define the search range; defaults are object start and end.
|
|
|
|
Returns the number of successful matches.
|
|
|
|
Note: For string objects, the replacement text must have the same length
|
|
as the original matched text, since strings have fixed length in Emacs.
|
|
If the replacement is shorter, only that portion will be replaced.
|
|
If the replacement is longer, it will be truncated.
|
|
|
|
Example:
|
|
;; Upcase only the last (2nd) match
|
|
(setq my-string (copy-sequence \"hello world hello\"))
|
|
(tp-set 0 5 \\='(marker t) my-string)
|
|
(tp-set 12 17 \\='(marker t) my-string)
|
|
(tp-forward-do #\\='upcase \\='marker nil my-string 2)
|
|
;; => \"hello world HELLO\" - only the 2nd match is upcased
|
|
|
|
;; Use start and end positions in function
|
|
(tp-forward-do (lambda (txt start end) (format \"[%d-%d]%s\" start end txt))
|
|
\\='marker nil my-string 2)
|
|
|
|
;; Search within a range
|
|
(tp-forward-do #\\='upcase \\='marker nil my-string 1 0 10)"
|
|
(let ((arity (func-arity function)))
|
|
(tp--forward-do
|
|
(lambda (match obj)
|
|
(let* ((m-start (if (listp match) (car match) (prop-match-beginning match)))
|
|
(m-end (if (listp match) (cadr match) (prop-match-end match)))
|
|
(text (if (stringp obj)
|
|
(substring obj m-start m-end)
|
|
(buffer-substring m-start m-end)))
|
|
(max-arity (cdr arity))
|
|
(can-accept-start (or (eq max-arity 'many)
|
|
(and (numberp max-arity) (>= max-arity 2))))
|
|
(can-accept-end (or (eq max-arity 'many)
|
|
(and (numberp max-arity) (>= max-arity 3))))
|
|
(new-text (cond
|
|
(can-accept-end (funcall function text m-start m-end))
|
|
(can-accept-start (funcall function text m-start))
|
|
(t (funcall function text)))))
|
|
(when (stringp new-text)
|
|
(if (stringp obj)
|
|
;; For strings: copy text content and properties separately
|
|
(let ((len (min (length new-text) (- m-end m-start))))
|
|
;; Copy text content
|
|
(store-substring obj m-start new-text)
|
|
;; Copy properties from new-text to obj
|
|
(let ((pos 0))
|
|
(while (< pos len)
|
|
(let* ((props (text-properties-at pos new-text))
|
|
(next-change (or (next-property-change pos new-text) len)))
|
|
(when props
|
|
(set-text-properties (+ m-start pos)
|
|
(+ m-start (min next-change len))
|
|
props
|
|
obj))
|
|
(setq pos next-change)))))
|
|
;; For buffers, delete and insert
|
|
(unless (equal new-text text)
|
|
(save-excursion
|
|
(delete-region m-start m-end)
|
|
(goto-char m-start)
|
|
(insert new-text)))))))
|
|
property value object times start end)))
|
|
|
|
(defun tp--backward-do (function property &optional value object times start end)
|
|
"Internal: Search backward TIMES for PROPERTY and apply FUNCTION to the last match.
|
|
|
|
FUNCTION receives two arguments: the prop-match object (or list for strings)
|
|
and OBJECT.
|
|
TIMES is the number of searches, defaulting to 1.
|
|
VALUE is the optional value to match.
|
|
OBJECT can be a buffer or string; nil defaults to current buffer.
|
|
START and END define the search range; defaults are object start and end.
|
|
|
|
Returns the number of successful matches."
|
|
(let ((count (or times 1)))
|
|
(cond
|
|
;; String object - reverse the matches
|
|
((stringp object)
|
|
(let* ((start-pos (or start 0))
|
|
(end-pos (or end (length object)))
|
|
(all-matches (tp-search object property value))
|
|
(filtered-matches
|
|
(seq-filter (lambda (m)
|
|
(and (>= (car m) start-pos)
|
|
(<= (cadr m) end-pos)))
|
|
all-matches))
|
|
(matches (seq-take (nreverse filtered-matches) count)))
|
|
(when matches
|
|
(funcall function (car (last matches)) object))
|
|
(length matches)))
|
|
;; Buffer or nil
|
|
(t
|
|
(let* ((buf (or object (current-buffer)))
|
|
(matches 0))
|
|
(tp-with-current-buffer buf
|
|
(let ((search-start (or start (point-min)))
|
|
(search-end (or end (point-max))))
|
|
(save-excursion
|
|
(goto-char search-end)
|
|
(dotimes (i count)
|
|
(when-let ((match (tp-search-backward property value)))
|
|
(when (>= (prop-match-beginning match) search-start)
|
|
(when (= i (1- count))
|
|
(funcall function match buf))
|
|
(cl-incf matches)))))))
|
|
matches)))))
|
|
|
|
(defun tp-backward-do (function property &optional value object times start end)
|
|
"Search backward for text with PROPERTY and apply FUNCTION to the last match.
|
|
|
|
FUNCTION receives (TEXT &optional START END) where TEXT is the matched text,
|
|
START and END are the positions of the match. The return value of FUNCTION
|
|
replaces the matched text in the string or buffer.
|
|
|
|
PROPERTY is the text property to search for.
|
|
VALUE is the optional value to match; nil means search for PROPERTY without
|
|
matching value.
|
|
OBJECT can be a buffer or string; nil defaults to current buffer.
|
|
TIMES is the number of searches, defaulting to 1. The function searches
|
|
TIMES times but only applies FUNCTION to the last (Nth) match found.
|
|
START and END define the search range; defaults are object start and end.
|
|
|
|
Returns the number of successful matches.
|
|
|
|
Note: For string objects, the replacement text must have the same length
|
|
as the original matched text, since strings have fixed length in Emacs.
|
|
If the replacement is shorter, only that portion will be replaced.
|
|
If the replacement is longer, it will be truncated.
|
|
|
|
Example:
|
|
;; Upcase only the last (2nd) match
|
|
(setq my-string (copy-sequence \"hello world hello\"))
|
|
(tp-set 0 5 \\='(marker t) my-string)
|
|
(tp-set 12 17 \\='(marker t) my-string)
|
|
(tp-backward-do #\\='upcase \\='marker nil my-string 2)
|
|
;; => \"HELLO world hello\" - only the 2nd (last) match is upcased
|
|
|
|
;; Use start and end positions in function
|
|
(tp-backward-do (lambda (txt start end) (format \"[%d-%d]%s\" start end txt))
|
|
\\='marker nil my-string 2)
|
|
|
|
;; Search within a range
|
|
(tp-backward-do #\\='upcase \\='marker nil my-string 1 0 10)"
|
|
(let ((arity (func-arity function)))
|
|
(tp--backward-do
|
|
(lambda (match obj)
|
|
(let* ((m-start (if (listp match) (car match) (prop-match-beginning match)))
|
|
(m-end (if (listp match) (cadr match) (prop-match-end match)))
|
|
(text (if (stringp obj)
|
|
(substring obj m-start m-end)
|
|
(buffer-substring m-start m-end)))
|
|
(max-arity (cdr arity))
|
|
(can-accept-start (or (eq max-arity 'many)
|
|
(and (numberp max-arity) (>= max-arity 2))))
|
|
(can-accept-end (or (eq max-arity 'many)
|
|
(and (numberp max-arity) (>= max-arity 3))))
|
|
(new-text (cond
|
|
(can-accept-end (funcall function text m-start m-end))
|
|
(can-accept-start (funcall function text m-start))
|
|
(t (funcall function text)))))
|
|
(when (stringp new-text)
|
|
(if (stringp obj)
|
|
;; For strings: copy text content and properties separately
|
|
(let ((len (min (length new-text) (- m-end m-start))))
|
|
;; Copy text content
|
|
(store-substring obj m-start new-text)
|
|
;; Copy properties from new-text to obj
|
|
(let ((pos 0))
|
|
(while (< pos len)
|
|
(let* ((props (text-properties-at pos new-text))
|
|
(next-change (or (next-property-change pos new-text) len)))
|
|
(when props
|
|
(set-text-properties (+ m-start pos)
|
|
(+ m-start (min next-change len))
|
|
props
|
|
obj))
|
|
(setq pos next-change)))))
|
|
;; For buffers, delete and insert
|
|
(unless (equal new-text text)
|
|
(save-excursion
|
|
(delete-region m-start m-end)
|
|
(goto-char m-start)
|
|
(insert new-text)))))))
|
|
property value object times start end)))
|
|
|
|
(defun tp-search (start-or-string
|
|
&optional end-or-property property-or-value value object)
|
|
"Search for all text with PROPERTY in a buffer/string range or entire string.
|
|
|
|
This function supports two calling conventions:
|
|
|
|
1. Buffer/string region:
|
|
(tp-search START END PROPERTY &optional VALUE OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-search STRING PROPERTY &optional VALUE)
|
|
|
|
Returns a list of (START END VALUE) lists for all matching regions.
|
|
Each element contains the start position, end position, and property value."
|
|
(cond
|
|
;; Entire string form: (tp-search string property &optional value)
|
|
((stringp start-or-string)
|
|
(let* ((str start-or-string)
|
|
(property end-or-property)
|
|
(value property-or-value)
|
|
(results nil)
|
|
(pos 0)
|
|
(len (length str)))
|
|
(while (< pos len)
|
|
(let* ((props (text-properties-at pos str))
|
|
(has-prop (plist-member props property))
|
|
(prop-val (plist-get props property)))
|
|
(if (and has-prop
|
|
(or (null value)
|
|
(equal prop-val value)))
|
|
;; Find the extent of this property
|
|
(let ((next-change
|
|
(or (next-single-property-change
|
|
pos property str len)
|
|
len)))
|
|
(push (list pos next-change prop-val) results)
|
|
(setq pos next-change))
|
|
;; No match, move to next change
|
|
(setq pos (or (next-single-property-change
|
|
pos property str len)
|
|
len)))))
|
|
(nreverse results)))
|
|
;; Buffer/string region form: (tp-search start end property &optional value object)
|
|
((numberp start-or-string)
|
|
(let* ((start start-or-string)
|
|
(end end-or-property)
|
|
(property property-or-value)
|
|
(value value)
|
|
(obj (or object (current-buffer)))
|
|
(results nil)
|
|
(pos start))
|
|
(if (stringp obj)
|
|
;; String object
|
|
(while (< pos end)
|
|
(let* ((props (text-properties-at pos obj))
|
|
(has-prop (plist-member props property))
|
|
(prop-val (plist-get props property)))
|
|
(if (and has-prop
|
|
(or (null value)
|
|
(equal prop-val value)))
|
|
(let ((next-change
|
|
(or (next-single-property-change
|
|
pos property obj end)
|
|
end)))
|
|
(push (list pos next-change prop-val) results)
|
|
(setq pos next-change))
|
|
(setq pos (or (next-single-property-change
|
|
pos property obj end)
|
|
end)))))
|
|
;; Buffer object
|
|
(tp-with-current-buffer obj
|
|
(while (< pos end)
|
|
(let* ((props (text-properties-at pos))
|
|
(has-prop (plist-member props property))
|
|
(prop-val (plist-get props property)))
|
|
(if (and has-prop
|
|
(or (null value)
|
|
(equal prop-val value)))
|
|
(let ((next-change
|
|
(or (next-single-property-change
|
|
pos property nil end)
|
|
end)))
|
|
(push (list pos next-change prop-val) results)
|
|
(setq pos next-change))
|
|
(setq pos (or (next-single-property-change
|
|
pos property nil end)
|
|
end)))))))
|
|
(nreverse results)))
|
|
(t (error "Invalid first argument: %S" start-or-string))))
|
|
|
|
(defun tp--search-do (function property &optional value object start end)
|
|
"Internal: Execute FUNCTION on all matches of PROPERTY.
|
|
|
|
Signature: (tp--search-do FUNCTION PROPERTY &optional VALUE OBJECT START END)
|
|
|
|
FUNCTION receives two arguments: the prop-match (list of START END VALUE) and OBJECT.
|
|
PROPERTY is the text property to search for.
|
|
VALUE is the optional value to match; nil means search for PROPERTY without matching value.
|
|
OBJECT can be a buffer or string; nil defaults to current buffer.
|
|
START and END define the search range; defaults are object start and end.
|
|
|
|
Returns the number of matches processed."
|
|
(let* ((obj (or object (current-buffer)))
|
|
(all-matches (if (stringp obj)
|
|
(tp-search obj property value)
|
|
(let ((s (or start (point-min)))
|
|
(e (or end (point-max))))
|
|
(tp-search s e property value obj))))
|
|
(filtered-matches
|
|
(if (and (not (stringp obj)) start end)
|
|
(seq-filter (lambda (m)
|
|
(and (>= (car m) start)
|
|
(<= (cadr m) end)))
|
|
all-matches)
|
|
(if (stringp obj)
|
|
(let ((s (or start 0))
|
|
(e (or end (length obj))))
|
|
(seq-filter (lambda (m)
|
|
(and (>= (car m) s)
|
|
(<= (cadr m) e)))
|
|
all-matches))
|
|
all-matches))))
|
|
(dolist (match filtered-matches)
|
|
(funcall function match obj))
|
|
(length filtered-matches)))
|
|
|
|
(defun tp-search-map (function property &optional value object start end)
|
|
"Apply FUNCTION to all matches of PROPERTY in OBJECT.
|
|
|
|
Signature: (tp-search-map FUNCTION PROPERTY &optional VALUE OBJECT START END)
|
|
|
|
FUNCTION receives (TEXT &optional START END IDX) where:
|
|
- TEXT is the matched text
|
|
- START and END are the positions of the match
|
|
- IDX is the 0-based index of the current match
|
|
|
|
FUNCTION can either:
|
|
- Return a new/modified string to replace the matched text
|
|
- Modify the text properties of the argument and return it
|
|
- Return nil to skip replacement
|
|
|
|
PROPERTY is the text property to search for.
|
|
VALUE is the optional value to match; nil means search for PROPERTY without
|
|
matching value.
|
|
OBJECT can be a buffer or string; nil defaults to current buffer.
|
|
START and END define the search range; defaults are object start and end.
|
|
|
|
Returns the number of matches processed.
|
|
|
|
Note: For string objects, replacement text must have the same length
|
|
as the original matched text, since strings have fixed length in Emacs.
|
|
If the replacement is shorter, only that portion will be replaced.
|
|
If the replacement is longer, it will be truncated.
|
|
|
|
Example:
|
|
;; Upcase all matched text
|
|
(tp-search-map #\\='upcase \\='marker nil my-string)
|
|
|
|
;; Add properties to matched text
|
|
(tp-search-map (lambda (txt) (tp-add txt \\='face \\='bold)) \\='marker nil str)
|
|
|
|
;; Use start, end, and index
|
|
(tp-search-map (lambda (txt start end idx)
|
|
(format \"[%d:%d-%d]%s\" idx start end txt))
|
|
\\='marker nil str)
|
|
|
|
;; Search within a range
|
|
(tp-search-map #\\='upcase \\='marker nil my-string 0 10)"
|
|
(let* ((obj (or object (current-buffer)))
|
|
(idx 0)
|
|
(arity (func-arity function)))
|
|
(tp--search-do
|
|
(lambda (match obj)
|
|
(let* ((m-start (car match))
|
|
(m-end (cadr match))
|
|
(text (if (stringp obj)
|
|
(substring obj m-start m-end)
|
|
(buffer-substring m-start m-end)))
|
|
(max-arity (cdr arity))
|
|
(can-accept-start (or (eq max-arity 'many)
|
|
(and (numberp max-arity) (>= max-arity 2))))
|
|
(can-accept-end (or (eq max-arity 'many)
|
|
(and (numberp max-arity) (>= max-arity 3))))
|
|
(can-accept-idx (or (eq max-arity 'many)
|
|
(and (numberp max-arity) (>= max-arity 4))))
|
|
(new-text (cond
|
|
(can-accept-idx (funcall function text m-start m-end idx))
|
|
(can-accept-end (funcall function text m-start m-end))
|
|
(can-accept-start (funcall function text m-start))
|
|
(t (funcall function text)))))
|
|
(setq idx (1+ idx))
|
|
(when (stringp new-text)
|
|
(if (stringp obj)
|
|
;; For strings: copy text content and properties separately
|
|
(let ((len (min (length new-text) (- m-end m-start))))
|
|
;; Copy text content
|
|
(store-substring obj m-start new-text)
|
|
;; Copy properties from new-text to obj
|
|
(let ((pos 0))
|
|
(while (< pos len)
|
|
(let* ((props (text-properties-at pos new-text))
|
|
(next-change (or (next-property-change pos new-text) len)))
|
|
(when props
|
|
(set-text-properties (+ m-start pos)
|
|
(+ m-start (min next-change len))
|
|
props
|
|
obj))
|
|
(setq pos next-change)))))
|
|
;; For buffers, delete and insert
|
|
(unless (equal new-text text)
|
|
(save-excursion
|
|
(delete-region m-start m-end)
|
|
(goto-char m-start)
|
|
(insert new-text)))))))
|
|
property value object start end)))
|
|
|
|
;;;============================================================================
|
|
;;; Layer 3-4: Layer Definition and Management
|
|
;;;============================================================================
|
|
|
|
(defun tp--parse-define-layer-args (args)
|
|
"Parse ARGS for tp--define-layer-internal function.
|
|
Returns plist with keys :props, :data, :watch, :compute, :transform.
|
|
- Keyword arguments: :props PLIST [:data DATA] [:watch WATCH] [:compute COMPUTE] [:transform FN]"
|
|
(let (props data watch compute transform has-keywords)
|
|
(cond
|
|
;; Check for keyword arguments format
|
|
((and (keywordp (car args))
|
|
(memq (car args) '(:props :data :watch :compute :transform)))
|
|
(setq has-keywords t)
|
|
;; Parse keyword arguments
|
|
(let ((rest args))
|
|
(while rest
|
|
(pcase (car rest)
|
|
(:props (setq props (cadr rest) rest (cddr rest)))
|
|
(:data (setq data (cadr rest) rest (cddr rest)))
|
|
(:watch (setq watch (cadr rest) rest (cddr rest)))
|
|
(:compute (setq compute (cadr rest) rest (cddr rest)))
|
|
(:transform (setq transform (cadr rest) rest (cddr rest)))
|
|
(_ (error "Unknown keyword in tp--define-layer-internal: %s" (car rest))))))
|
|
;; Validate: if :watch, :compute, or :data present, :props must be present
|
|
(when (and (or watch compute data) (null props))
|
|
(error "When using :watch, :compute, or :data, :props must be explicitly specified")))
|
|
;; Format 1: single plist (the plist directly as first arg)
|
|
((and (= (length args) 1)
|
|
(listp (car args)))
|
|
(setq props (car args)))
|
|
(t (error "Invalid tp--define-layer-internal format")))
|
|
(list :props props :data data :watch watch :compute compute :transform transform)))
|
|
|
|
(defun tp--define-layer-internal (name &rest args)
|
|
"Define a single text property layer named NAME.
|
|
|
|
This function supports two formats:
|
|
|
|
Format 1 - Direct plist (no :watch/:compute/:data/:transform support):
|
|
(tp--define-layer-internal \\='layer-name
|
|
\\='(display \"🌑\" face (:height 1.0)))
|
|
|
|
Format 2 - With :props, :data, :watch, :compute, and/or :transform (Vue 3 style reactivity):
|
|
(tp--define-layer-internal \\='layer-name
|
|
;; props: $-prefixed symbols are reactive variables; auto-defined if not bound
|
|
:props \\='(face (:foreground $my-color) help-echo $full-name)
|
|
;; data: additional reactive variables not used in props; auto-defined if not bound
|
|
:data \\='((first-name . \"John\") (last-name . \"Doe\"))
|
|
;; compute: list of (VAR-NAME FUNCTION) - compute reactive variable values
|
|
:compute \\='((full-name (lambda () (concat first-name \" \" last-name))))
|
|
;; watch: list of (VAR-NAME CALLBACK) - side effects when vars change
|
|
:watch \\='((my-color (lambda (new old layer)
|
|
(message \"Color changed from %s to %s\" old new))))
|
|
;; transform: function to transform tp-text values before display
|
|
:transform (lambda (text) (upcase text)))
|
|
|
|
Reactive Variables:
|
|
If any symbol in :props starts with $, it is treated as a reactive variable.
|
|
Variables in :data are also reactive. All reactive variables are automatically
|
|
defined as global variables if they are not already bound.
|
|
|
|
:data - A list of variable symbols or cons cells (SYMBOL . INITIAL-VALUE)
|
|
for additional reactive state not in :props.
|
|
|
|
:compute - A list of (VAR-SYMBOL COMPUTE-FN) pairs. COMPUTE-FN is evaluated
|
|
to compute the value of VAR-SYMBOL. Can reference other reactive variables
|
|
from both :props and :data.
|
|
|
|
:watch - A list of (VAR-SYMBOL CALLBACK) pairs. CALLBACK is called when
|
|
VAR-SYMBOL changes, receiving (NEW-VALUE OLD-VALUE LAYER-NAME).
|
|
|
|
:transform - A function that receives the tp-text value and returns a
|
|
transformed string. Useful for formatting numbers, dates, or other values
|
|
before display. Example: (lambda (text) (format \"$%.2f\" (string-to-number text)))
|
|
|
|
Note: When using :watch, :compute, or :data, you MUST use :props to specify
|
|
the text properties explicitly.
|
|
|
|
If a layer with the same NAME already exists, it will be overwritten.
|
|
The layer is stored in `tp-layer-alist'."
|
|
(declare (indent defun))
|
|
(let* ((parsed (tp--parse-define-layer-args args))
|
|
(properties (plist-get parsed :props))
|
|
(data (plist-get parsed :data))
|
|
(watch (plist-get parsed :watch))
|
|
(compute (plist-get parsed :compute))
|
|
(transform (plist-get parsed :transform))
|
|
(reactive-syms (tp--collect-reactive-symbols properties))
|
|
;; Collect computed variable names (they become reactive too)
|
|
(computed-vars (when compute (mapcar #'car compute)))
|
|
;; All variables that need to be reactive
|
|
(all-reactive-syms (delete-dups (append reactive-syms)))
|
|
;; Variables from :props that need to be defined (without initial values)
|
|
(props-vars (mapcar #'tp--reactive-var-symbol reactive-syms))
|
|
;; All variables to ensure are defined:
|
|
;; - :data entries (may have initial values as cons cells)
|
|
;; - :props reactive symbols (no initial values)
|
|
;; - :compute variable names (no initial values)
|
|
(all-vars-to-define (delete-dups
|
|
(append data
|
|
props-vars
|
|
computed-vars))))
|
|
;; Register or unregister transform function
|
|
(if transform
|
|
(if (assoc name tp-layer-transforms)
|
|
(setcdr (assoc name tp-layer-transforms) transform)
|
|
(push (cons name transform) tp-layer-transforms))
|
|
;; Remove any existing transform when redefining without one
|
|
(setq tp-layer-transforms (assq-delete-all name tp-layer-transforms)))
|
|
(if (or all-reactive-syms data compute)
|
|
;; Has reactive features - register dependencies and resolve at runtime
|
|
(progn
|
|
;; Clean up old reactive dependencies, watchers, computed properties, and data (for re-definition)
|
|
(tp--unregister-reactive-deps name)
|
|
;; Ensure all reactive variables are defined
|
|
(tp--ensure-reactive-variables all-vars-to-define)
|
|
;; Register data variables
|
|
(when data
|
|
(tp--register-layer-data name data))
|
|
;; Register computed variable definitions
|
|
(when compute
|
|
(tp--register-layer-computed name compute)
|
|
;; Apply initial computed values
|
|
(tp--apply-initial-computed compute))
|
|
;; Register reactive dependencies
|
|
(tp--register-reactive-deps name all-reactive-syms properties)
|
|
;; Register watchers
|
|
(when watch
|
|
(tp--register-layer-watchers name watch))
|
|
;; Set layer properties with resolved values
|
|
(let ((resolved-props (tp--resolve-reactive-symbols properties)))
|
|
(tp--set-layer-props name resolved-props))
|
|
;; Update any text regions that already have this layer applied
|
|
;; This ensures re-definition immediately updates applied text
|
|
(tp--update-layer-regions name)
|
|
(assoc name tp-layer-alist))
|
|
;; No reactive symbols - use static properties
|
|
(progn
|
|
;; Clean up old reactive dependencies, watchers, computed properties, and data (for re-definition)
|
|
(tp--unregister-reactive-deps name)
|
|
(tp--set-layer-props name properties)
|
|
;; Update any text regions that already have this layer applied
|
|
(tp--update-layer-regions name)
|
|
(assoc name tp-layer-alist)))))
|
|
|
|
(defmacro define-tp (name arglist &rest body)
|
|
"Define a text property layer named NAME.
|
|
|
|
This macro supports three formats:
|
|
|
|
Format 1 - Non-parameterized simple (empty arglist, simple body):
|
|
(define-tp tp-bold ()
|
|
\\='(face bold))
|
|
|
|
Format 2 - Parameterized simple (single argument, simple body):
|
|
(define-tp tp-space (pixel)
|
|
\\=`(display (space :width (,pixel))))
|
|
|
|
Format 3 - Non-parameterized with reactive features (requires $-prefixed variables):
|
|
(define-tp my-layer ()
|
|
:props \\='(face (:foreground $my-color))
|
|
:data \\='((my-color . \"red\"))
|
|
:compute \\='((full-name (lambda () (concat first-name \" \" last-name))))
|
|
:watch \\='((my-color (lambda (new old layer) (message \"Color changed!\"))))
|
|
:transform (lambda (text) (upcase text)))
|
|
|
|
Usage:
|
|
(tp-set \"emacs\" \\='tp-bold t)
|
|
(tp-set 0 5 \\='(tp-bold t) \"emacs\")
|
|
;; => #(\"emacs\" 0 5 (tp-name tp-bold face bold))
|
|
|
|
ARGLIST must be either:
|
|
- An empty list () for non-parameterized layers
|
|
- A list containing exactly one symbol for parameterized layers
|
|
|
|
BODY is either:
|
|
- A single property list expression (simple format)
|
|
- Keyword arguments starting with :props, :data, :compute, :watch, or :transform
|
|
(reactive format - only for non-parameterized layers with $-prefixed variables)
|
|
|
|
Note: NAME cannot be a built-in Emacs text property name like `face',
|
|
`display', `invisible', etc. See `tp--builtin-text-properties' for the
|
|
complete list of reserved names."
|
|
(declare (indent defun))
|
|
(unless (listp arglist)
|
|
(error "define-tp ARGLIST must be a list"))
|
|
;; Check for built-in text property name conflict
|
|
(when (tp--builtin-text-property-p name)
|
|
(error "define-tp: '%s' is a built-in Emacs text property name and cannot be used as a layer name" name))
|
|
;; Check if body starts with keyword (reactive format)
|
|
(let ((first-elem (car body)))
|
|
(if (and (keywordp first-elem)
|
|
(memq first-elem '(:props :data :compute :watch :transform)))
|
|
;; Reactive format - only allowed for non-parameterized layers
|
|
(if arglist
|
|
(error "define-tp: reactive keywords (:props, :data, :compute, :watch, :transform) are only supported for non-parameterized layers (empty arglist)")
|
|
;; Non-parameterized reactive: use tp--define-layer-internal directly
|
|
`(tp--define-layer-internal ',name ,@body))
|
|
;; Simple format (original behavior)
|
|
(let ((simple-body (car body)))
|
|
(cond
|
|
;; Non-parameterized: empty arglist - store as (LAYER-NAME nil BODY-FORM)
|
|
((null arglist)
|
|
`(tp--define-layer-unified ',name nil ,simple-body))
|
|
;; Parameterized: single argument - store as (LAYER-NAME ARGLIST BODY-FORM)
|
|
((and (= (length arglist) 1)
|
|
(symbolp (car arglist)))
|
|
`(tp--define-layer-unified ',name ',arglist ',simple-body))
|
|
(t
|
|
(error "define-tp ARGLIST must be empty or contain exactly one symbol")))))))
|
|
|
|
(defun tp--define-layer-unified (name arglist body)
|
|
"Define a layer NAME with ARGLIST and BODY using unified structure.
|
|
For non-parameterized layers, ARGLIST is nil and BODY is the evaluated plist.
|
|
For parameterized layers, ARGLIST contains one symbol and BODY is the unevaluated form.
|
|
Stores the layer in `tp-layer-alist' with format: (LAYER-NAME ARGLIST BODY-FORM).
|
|
|
|
For non-parameterized layers, if BODY contains reactive symbols ($-prefixed),
|
|
delegates to `tp--define-layer-internal' for proper reactive handling."
|
|
(if arglist
|
|
;; Parameterized - store for later evaluation
|
|
(let ((entry (list arglist body)))
|
|
(if (assoc name tp-layer-alist)
|
|
(setf (cdr (assoc name tp-layer-alist)) entry)
|
|
(push (cons name entry) tp-layer-alist))
|
|
(assoc name tp-layer-alist))
|
|
;; Non-parameterized - check for reactive symbols
|
|
(let ((reactive-syms (tp--collect-reactive-symbols body)))
|
|
(if reactive-syms
|
|
;; Has reactive symbols - use tp--define-layer-internal for proper handling
|
|
(tp--define-layer-internal name body)
|
|
;; No reactive symbols - store as static layer
|
|
;; Clean up old reactive dependencies if the layer was previously reactive
|
|
(tp--unregister-reactive-deps name)
|
|
(let ((entry (list nil `',body)))
|
|
(if (assoc name tp-layer-alist)
|
|
(setf (cdr (assoc name tp-layer-alist)) entry)
|
|
(push (cons name entry) tp-layer-alist))
|
|
(assoc name tp-layer-alist))))))
|
|
|
|
(defun tp--layer-group-element-format (element)
|
|
"Determine the format type of ELEMENT.
|
|
Returns 'symbol, 'format-1, 'format-2, 'format-3, 'format-4, or nil if invalid."
|
|
(cond
|
|
;; Symbol - reference to existing layer
|
|
((symbolp element) 'symbol)
|
|
;; Format 4 - ("name" :props (plist...) [:data ...] [:watch ...] [:compute ...])
|
|
;; Named layer with :props and optional :data/:watch/:compute
|
|
((and (listp element)
|
|
(> (length element) 3)
|
|
(stringp (car element))
|
|
(eq (cadr element) :props)
|
|
(listp (caddr element))
|
|
;; Must have additional keywords after :props
|
|
(let ((rest (cdddr element)))
|
|
(and rest (keywordp (car rest)))))
|
|
'format-4)
|
|
;; Format 3 - ("name" :props (plist...))
|
|
((and (listp element)
|
|
(= (length element) 3)
|
|
(stringp (car element))
|
|
(eq (cadr element) :props)
|
|
(listp (caddr element)))
|
|
'format-3)
|
|
;; Format 2 - ("name" . (plist...)) - cons cell with proper list cdr
|
|
((and (consp element)
|
|
(stringp (car element))
|
|
(listp (cdr element))
|
|
(not (eq (cadr element) :props))) ; Distinguish from format-3
|
|
'format-2)
|
|
;; Format 1 - (plist...) - anonymous, must start with a symbol
|
|
((and (listp element)
|
|
(symbolp (car element)))
|
|
'format-1)
|
|
(t nil)))
|
|
|
|
(defun tp--parse-layer-group-element (group-name element idx)
|
|
"Parse a layer group element and return (layer-name . properties) or extended form.
|
|
GROUP-NAME is the name of the layer group.
|
|
ELEMENT is the element to parse (can be anonymous plist, cons-cell, or :props form).
|
|
IDX is the index for anonymous elements.
|
|
|
|
Returns a cons cell (LAYER-NAME . PROPERTIES) or a symbol if ELEMENT
|
|
references an already-defined layer.
|
|
For format-4 elements, returns (LAYER-NAME :props PROPS :data DATA :watch WATCH :compute COMPUTE)."
|
|
(let ((format (tp--layer-group-element-format element)))
|
|
(pcase format
|
|
('symbol element)
|
|
('format-4
|
|
;; Parse named layer with :props and optional :data/:watch/:compute
|
|
(let* ((layer-suffix (car element))
|
|
(layer-name (intern (format "%s-%s" group-name layer-suffix)))
|
|
(rest (cdr element))
|
|
(props nil)
|
|
(data nil)
|
|
(watch nil)
|
|
(compute nil))
|
|
;; Parse keyword arguments
|
|
(while rest
|
|
(pcase (car rest)
|
|
(:props (setq props (cadr rest) rest (cddr rest)))
|
|
(:data (setq data (cadr rest) rest (cddr rest)))
|
|
(:watch (setq watch (cadr rest) rest (cddr rest)))
|
|
(:compute (setq compute (cadr rest) rest (cddr rest)))
|
|
(_ (setq rest (cdr rest)))))
|
|
(list layer-name :props props :data data :watch watch :compute compute)))
|
|
('format-3
|
|
(let* ((layer-suffix (car element))
|
|
(layer-name (intern (format "%s-%s" group-name layer-suffix)))
|
|
(props (caddr element)))
|
|
(cons layer-name props)))
|
|
('format-2
|
|
(let* ((layer-suffix (car element))
|
|
(layer-name (intern (format "%s-%s" group-name layer-suffix)))
|
|
(props (cdr element)))
|
|
(cons layer-name props)))
|
|
('format-1
|
|
(let ((layer-name (intern (format "%s-%d" group-name idx))))
|
|
(cons layer-name element)))
|
|
(_ (error "Invalid layer group element: %S" element)))))
|
|
|
|
(defun tp--define-layer-from-parsed (layer-name props data watch compute)
|
|
"Internal helper to define a layer from parsed components.
|
|
LAYER-NAME is the symbol name for the layer.
|
|
PROPS is the property list.
|
|
DATA is the list of data variables.
|
|
WATCH is the list of watcher definitions.
|
|
COMPUTE is the list of computed variable definitions."
|
|
(let* ((reactive-syms (tp--collect-reactive-symbols props))
|
|
(computed-vars (when compute (mapcar #'car compute)))
|
|
(all-reactive-syms (delete-dups reactive-syms))
|
|
(props-vars (mapcar #'tp--reactive-var-symbol reactive-syms))
|
|
(all-vars-to-define (delete-dups
|
|
(append data
|
|
props-vars
|
|
computed-vars))))
|
|
(if (or all-reactive-syms data compute)
|
|
;; Has reactive features - register dependencies and resolve at runtime
|
|
(progn
|
|
(tp--unregister-reactive-deps layer-name)
|
|
(tp--ensure-reactive-variables all-vars-to-define)
|
|
(when data
|
|
(tp--register-layer-data layer-name data))
|
|
(when compute
|
|
(tp--register-layer-computed layer-name compute)
|
|
(tp--apply-initial-computed compute))
|
|
(tp--register-reactive-deps layer-name all-reactive-syms props)
|
|
(when watch
|
|
(tp--register-layer-watchers layer-name watch))
|
|
(let ((resolved-props (tp--resolve-reactive-symbols props)))
|
|
(tp--set-layer-props layer-name resolved-props))
|
|
(tp--update-layer-regions layer-name))
|
|
;; No reactive symbols - use static properties
|
|
(progn
|
|
(tp--unregister-reactive-deps layer-name)
|
|
(tp--set-layer-props layer-name props)
|
|
(tp--update-layer-regions layer-name)))
|
|
layer-name))
|
|
|
|
(defun tp--define-layer-internal-group (name &rest elements)
|
|
"Define a layer group named NAME containing multiple layers.
|
|
|
|
This function accepts a list of layer definitions in ELEMENTS.
|
|
Each element in ELEMENTS should be one of:
|
|
|
|
- A symbol: reference to an existing layer
|
|
- A plist: anonymous layer (named as NAME-0, NAME-1, etc.)
|
|
- A cons cell (\"suffix\" . plist): named layer (named as NAME-suffix)
|
|
- A list (\"suffix\" :props plist [:data data] [:watch watch] [:compute compute]):
|
|
named layer with reactive features
|
|
|
|
All property lists should be evaluated (quoted in the call).
|
|
|
|
Example:
|
|
(tp--define-layer-internal-group \\='my-group
|
|
\\='existing-layer
|
|
\\='(face bold)
|
|
\\='(\"named\" . (face italic))
|
|
\\='(\"reactive\" :props (face (:foreground $color))
|
|
:data ((color . \"red\"))))
|
|
|
|
If a layer group with the same NAME already exists, it will be overwritten.
|
|
Individual layers created by the group are stored in `tp-layer-alist',
|
|
and the group itself is stored in `tp-layer-groups'."
|
|
(declare (indent defun))
|
|
(let ((layer-names nil)
|
|
(idx 0))
|
|
(dolist (element elements)
|
|
(let ((parsed (tp--parse-layer-group-element name element idx)))
|
|
(cond
|
|
;; Reference to existing layer (symbol)
|
|
((symbolp parsed)
|
|
(push parsed layer-names))
|
|
;; Extended format with :data/:watch/:compute (format-4)
|
|
((and (listp parsed) (plist-get (cdr parsed) :props))
|
|
(let* ((layer-name (car parsed))
|
|
(props (plist-get (cdr parsed) :props))
|
|
(data (plist-get (cdr parsed) :data))
|
|
(watch (plist-get (cdr parsed) :watch))
|
|
(compute (plist-get (cdr parsed) :compute)))
|
|
(tp--define-layer-from-parsed layer-name props data watch compute)
|
|
(push layer-name layer-names)))
|
|
;; Simple format (cons cell of name . props)
|
|
((consp parsed)
|
|
(let* ((layer-name (car parsed))
|
|
(props (cdr parsed)))
|
|
(tp--define-layer-from-parsed layer-name props nil nil nil)
|
|
(push layer-name layer-names)
|
|
;; Only increment idx for anonymous (Format 1) elements
|
|
(when (eq (tp--layer-group-element-format element) 'format-1)
|
|
(cl-incf idx)))))))
|
|
(setq layer-names (nreverse layer-names))
|
|
(tp--set-group-layers name layer-names)
|
|
(assoc name tp-layer-groups)))
|
|
|
|
(defun tp--define-layer-group-internal (name arglist elements)
|
|
"Internal function for define-tps with ARGLIST and ELEMENTS.
|
|
NAME is the group name symbol.
|
|
ARGLIST is nil for non-parameterized groups, or a list with one symbol.
|
|
ELEMENTS is the list of layer definitions."
|
|
(if arglist
|
|
;; Parameterized group - store for later evaluation
|
|
(let ((entry (list arglist elements)))
|
|
(if (assoc name tp-layer-groups)
|
|
(setf (cdr (assoc name tp-layer-groups)) entry)
|
|
(push (cons name entry) tp-layer-groups))
|
|
(assoc name tp-layer-groups))
|
|
;; Non-parameterized - define immediately using tp--define-layer-internal-group
|
|
(apply #'tp--define-layer-internal-group name elements)))
|
|
|
|
(defun tp--define-layer-group-unified (name arglist body-form)
|
|
"Define a parameterized layer group NAME with ARGLIST and BODY-FORM.
|
|
Stores the group in `tp-layer-groups' with format: (GROUP-NAME ARGLIST BODY-FORM)."
|
|
(let ((entry (list arglist body-form)))
|
|
(if (assoc name tp-layer-groups)
|
|
(setf (cdr (assoc name tp-layer-groups)) entry)
|
|
(push (cons name entry) tp-layer-groups)))
|
|
(assoc name tp-layer-groups))
|
|
|
|
(defmacro define-tps (name arglist &rest body)
|
|
"Define a text property group named NAME.
|
|
|
|
This macro defines a group of text properties (layers) that can be used together.
|
|
It follows the same format as `define-tp' for consistency.
|
|
|
|
ARGLIST must be either:
|
|
- An empty list () for non-parameterized groups
|
|
- A list containing exactly one symbol for parameterized groups
|
|
|
|
BODY contains the layer definitions, which should be quoted lists.
|
|
|
|
Format 1 - Non-parameterized (empty arglist):
|
|
(define-tps my-moon-phases ()
|
|
\\='(display \"🌑\")
|
|
\\='(display \"🌕\"))
|
|
|
|
Format 2 - Parameterized (with argument):
|
|
(define-tps my-status (color)
|
|
\\=`((face (:foreground ,color)))
|
|
\\='(face (:weight bold)))
|
|
|
|
Supported formats for each element in BODY:
|
|
|
|
Format 1 - Existing layer reference:
|
|
\\='existing-layer-name
|
|
|
|
Format 2 - Anonymous layer (named as NAME-0, NAME-1, etc.):
|
|
\\='(display \"🌑\" face (:height 1.0))
|
|
|
|
Format 3 - Named layer with cons-cell (named as NAME-suffix):
|
|
\\='(\"新月\" . (display \"🌑\" face (:height 1.0)))
|
|
|
|
Format 4 - Named layer with :props keyword (named as NAME-suffix):
|
|
\\='(\"新月\" :props (display \"🌑\" face (:height 1.0)))
|
|
|
|
Format 5 - Named layer with :props, :data, :watch, and/or :compute:
|
|
\\='(\"reactive\" :props (face (:foreground $my-color))
|
|
:data ((my-color . \"red\"))
|
|
:watch ((my-color (lambda (new old layer) (message \"Changed!\")))))
|
|
|
|
Note: NAME cannot be a built-in Emacs text property name like `face',
|
|
`display', `invisible', etc. See `tp--builtin-text-properties' for the
|
|
complete list of reserved names."
|
|
(declare (indent defun))
|
|
(unless (listp arglist)
|
|
(error "define-tps ARGLIST must be a list"))
|
|
;; Check for built-in text property name conflict
|
|
(when (tp--builtin-text-property-p name)
|
|
(error "define-tps: '%s' is a built-in Emacs text property name and cannot be used as a group name" name))
|
|
(cond
|
|
;; Non-parameterized: empty arglist
|
|
((null arglist)
|
|
`(tp--define-layer-group-internal ',name nil (list ,@body)))
|
|
;; Parameterized: single argument
|
|
((and (= (length arglist) 1)
|
|
(symbolp (car arglist)))
|
|
`(tp--define-layer-group-unified ',name ',arglist '(list ,@body)))
|
|
(t
|
|
(error "define-tps ARGLIST must be empty or contain exactly one symbol"))))
|
|
|
|
;; For backward compatibility, keep define-tp-group as an alias
|
|
(defalias 'define-tp-group 'define-tps
|
|
"Alias for `define-tps' for backward compatibility.")
|
|
|
|
(defun tp--set-layer-props (layer-name properties)
|
|
"Set PROPERTIES for layer LAYER-NAME in `tp-layer-alist'.
|
|
If the layer already exists, updates its properties; otherwise creates it.
|
|
Stores as (LAYER-NAME . PROPERTIES) for backward compatibility with reactive layers.
|
|
This is an internal function used by layer definition macros and reactive updates."
|
|
(if (assoc layer-name tp-layer-alist)
|
|
(setf (cdr (assoc layer-name tp-layer-alist)) properties)
|
|
(push (cons layer-name properties) tp-layer-alist)))
|
|
|
|
(defun tp--set-group-layers (group-name layer-names)
|
|
"Set LAYER-NAMES for group GROUP-NAME in `tp-layer-groups'.
|
|
If the group already exists, updates its layer list; otherwise creates it.
|
|
This is an internal function used by group definition macros."
|
|
(if (assoc group-name tp-layer-groups)
|
|
(setf (cdr (assoc group-name tp-layer-groups)) layer-names)
|
|
(push (cons group-name layer-names) tp-layer-groups)))
|
|
|
|
(defun tp-layer-props (layer-name &optional include-tp-name)
|
|
"Return properties for layer LAYER-NAME from `tp-layer-alist'.
|
|
If INCLUDE-TP-NAME is non-nil, appends 'tp-name property to identify the layer.
|
|
Also includes tp-name automatically if the layer has reactive dependencies registered.
|
|
Handles two storage formats:
|
|
1. Old format (from tp--set-layer-props): (LAYER-NAME . PLIST) - flat plist
|
|
2. Unified format (from define-tp): (LAYER-NAME ARGLIST BODY-FORM)
|
|
For parameterized layers (ARGLIST non-nil), returns nil - use `tp-layer-props-with-arg'.
|
|
Recursively expands any nested layer names in the returned plist."
|
|
(when-let ((entry (cdr (assoc layer-name tp-layer-alist))))
|
|
;; Auto-include tp-name for layers with reactive deps
|
|
(let ((needs-tp-name (or include-tp-name
|
|
(tp--layer-has-reactive-deps-p layer-name))))
|
|
(cond
|
|
;; Unified format: entry is (ARGLIST BODY-FORM) where first elem is nil or a list
|
|
;; Check: exactly 2 elements and first is nil or a list of symbols
|
|
((and (= (length entry) 2)
|
|
(or (null (car entry))
|
|
(and (listp (car entry))
|
|
(cl-every #'symbolp (car entry)))))
|
|
(let ((arglist (car entry))
|
|
(body (cadr entry)))
|
|
(if arglist
|
|
;; Parameterized - needs argument, return nil
|
|
nil
|
|
;; Non-parameterized - evaluate body and return props
|
|
(let ((plist (eval body)))
|
|
(when plist
|
|
;; Recursively expand nested layer names
|
|
(when (tp--plist-has-layer-key-p plist)
|
|
(setq plist (tp--expand-layer-in-plist plist)))
|
|
(if needs-tp-name
|
|
(append plist (list 'tp-name layer-name))
|
|
plist))))))
|
|
;; Old format: entry is just a flat plist
|
|
(t
|
|
(let ((plist entry))
|
|
;; Recursively expand nested layer names
|
|
(when (tp--plist-has-layer-key-p plist)
|
|
(setq plist (tp--expand-layer-in-plist plist)))
|
|
(if needs-tp-name
|
|
(append plist (list 'tp-name layer-name))
|
|
plist)))))))
|
|
|
|
(defun tp-layer-parameterized-p (layer-name)
|
|
"Return non-nil if LAYER-NAME is a parameterized layer.
|
|
Parameterized layers are stored in unified format (LAYER-NAME ARGLIST BODY-FORM)
|
|
where ARGLIST is a non-nil list of argument symbols."
|
|
(when-let ((entry (cdr (assoc layer-name tp-layer-alist))))
|
|
;; Unified format: entry is (ARGLIST BODY-FORM) with exactly 2 elements
|
|
;; and first element is a non-nil list of symbols
|
|
(and (= (length entry) 2)
|
|
(listp (car entry))
|
|
(not (null (car entry)))
|
|
(cl-every #'symbolp (car entry)))))
|
|
|
|
(defun tp-layer-props-with-arg (layer-name arg &optional include-tp-name)
|
|
"Return properties for parameterized layer LAYER-NAME with ARG.
|
|
Evaluates the body form with the argument bound to the parameter.
|
|
If INCLUDE-TP-NAME is non-nil, appends 'tp-name property to identify the layer.
|
|
Recursively expands any nested layer names in the returned plist."
|
|
(when-let ((entry (cdr (assoc layer-name tp-layer-alist))))
|
|
;; entry is (ARGLIST BODY-FORM)
|
|
(let ((arglist (car entry))
|
|
(body (cadr entry)))
|
|
(when arglist ; Only for parameterized layers
|
|
(let* ((arg-sym (car arglist))
|
|
;; Evaluate the body with the argument bound
|
|
(plist (eval `(let ((,arg-sym ',arg)) ,body))))
|
|
(when plist
|
|
;; Recursively expand nested layer names
|
|
(when (tp--plist-has-layer-key-p plist)
|
|
(setq plist (tp--expand-layer-in-plist plist)))
|
|
(if include-tp-name
|
|
(append plist (list 'tp-name layer-name))
|
|
plist)))))))
|
|
|
|
(defun tp-group-props (group-name &optional include-tp-name)
|
|
"Return list of properties for all layers in GROUP-NAME.
|
|
If INCLUDE-TP-NAME is non-nil, each layer's props will include tp-name.
|
|
Handles both old format (list of layer names) and new unified format
|
|
from `define-tps` (parameterized groups store ARGLIST and BODY-FORM)."
|
|
(when-let ((entry (cdr (assoc group-name tp-layer-groups))))
|
|
;; Check if it's the unified format from define-tps (ARGLIST BODY-FORM)
|
|
;; Unified format: (ARGLIST BODY-FORM) where ARGLIST is a list of symbols or nil
|
|
;; Old format: (layer1 layer2 ...) where each element is a symbol referring to a layer
|
|
(cond
|
|
;; Unified parameterized format: (ARGLIST BODY-FORM) with non-nil ARGLIST
|
|
((and (= (length entry) 2)
|
|
(listp (car entry))
|
|
(not (null (car entry)))
|
|
(cl-every #'symbolp (car entry)))
|
|
;; Parameterized group - can't get props without argument
|
|
nil)
|
|
;; Old format or non-parameterized define-tps: list of layer names
|
|
(t
|
|
(mapcar (lambda (layer)
|
|
(tp-layer-props layer include-tp-name))
|
|
entry)))))
|
|
|
|
(defun tp-group-parameterized-p (group-name)
|
|
"Return non-nil if GROUP-NAME is a parameterized group.
|
|
Parameterized groups are stored in format (GROUP-NAME ARGLIST BODY-FORM)
|
|
where ARGLIST is a non-nil list of argument symbols."
|
|
(when-let ((entry (cdr (assoc group-name tp-layer-groups))))
|
|
;; Check for unified format: (ARGLIST BODY-FORM) with non-nil ARGLIST
|
|
(and (= (length entry) 2)
|
|
(listp (car entry))
|
|
(not (null (car entry)))
|
|
(cl-every #'symbolp (car entry)))))
|
|
|
|
(defun tp-group-props-with-arg (group-name arg &optional include-tp-name)
|
|
"Return list of properties for parameterized group GROUP-NAME with ARG.
|
|
Evaluates the body form with the argument bound to the parameter.
|
|
Each evaluated element is a layer reference like (layer-name arg) or just layer-name.
|
|
Returns a list of property lists for each layer in the group."
|
|
(when-let ((entry (cdr (assoc group-name tp-layer-groups))))
|
|
;; entry is (ARGLIST BODY-FORM)
|
|
(let ((arglist (car entry))
|
|
(body-form (cadr entry)))
|
|
(when arglist ; Only for parameterized groups
|
|
(let* ((arg-sym (car arglist))
|
|
;; Evaluate the body with the argument bound - returns list of layer specs
|
|
(layer-specs (eval `(let ((,arg-sym ',arg)) ,body-form))))
|
|
;; Convert layer specs to property lists
|
|
(mapcar (lambda (spec)
|
|
(cond
|
|
;; spec is a symbol - just a layer name
|
|
((symbolp spec)
|
|
(tp-layer-props spec include-tp-name))
|
|
;; spec is (layer-name arg) - parameterized layer
|
|
((and (listp spec) (symbolp (car spec)))
|
|
(let ((layer-name (car spec))
|
|
(layer-arg (cadr spec)))
|
|
(if (tp-layer-parameterized-p layer-name)
|
|
(tp-layer-props-with-arg layer-name layer-arg include-tp-name)
|
|
;; Non-parameterized layer - arg should be t or ignored
|
|
(tp-layer-props layer-name include-tp-name))))
|
|
(t nil)))
|
|
layer-specs))))))
|
|
|
|
(defun tp--is-layer-name-p (sym)
|
|
"Return non-nil if SYM is a defined layer, parameterized layer, or group name."
|
|
(and (symbolp sym)
|
|
(or (assoc sym tp-layer-alist)
|
|
(assoc sym tp-layer-groups))))
|
|
|
|
(defun tp--plist-has-layer-key-p (plist)
|
|
"Return non-nil if PLIST contains any layer names as keys."
|
|
(cl-loop for (key _val) on plist by #'cddr
|
|
thereis (tp--is-layer-name-p key)))
|
|
|
|
(defun tp--expand-layer-in-plist (props)
|
|
"Expand any layer names found in PROPS plist.
|
|
Scans through PROPS treating it as a plist (key value pairs).
|
|
When a key is a layer/group name, expands it with its properties.
|
|
Recursively expands until no more layer names are found in the result.
|
|
Does NOT add tp-name - this is for direct property setting (tp-set/add/reset).
|
|
Returns the expanded plist."
|
|
(let ((result nil)
|
|
(remaining props))
|
|
(while remaining
|
|
(let ((key (car remaining))
|
|
(val (cadr remaining)))
|
|
(cond
|
|
;; Key is a layer/parameterized layer/group name - expand it
|
|
((tp--is-layer-name-p key)
|
|
(let ((layer-props
|
|
(cond
|
|
;; Parameterized layer - evaluate with the argument (val)
|
|
((tp-layer-parameterized-p key)
|
|
(tp-layer-props-with-arg key val nil)) ; no tp-name
|
|
;; Non-parameterized layer - val should be t
|
|
((assoc key tp-layer-alist)
|
|
(tp-layer-props key nil)) ; no tp-name
|
|
;; Parameterized layer group - evaluate with the argument (val)
|
|
((tp-group-parameterized-p key)
|
|
(when-let ((layer-props-list (tp-group-props-with-arg key val t)))
|
|
;; Build layered structure: first layer at top, rest in tp-layers
|
|
(tp--build-layer-props layer-props-list)))
|
|
;; Non-parameterized layer group - build layered structure
|
|
((assoc key tp-layer-groups)
|
|
(when-let ((layer-props-list (tp-group-props key t)))
|
|
;; Build layered structure: first layer at top, rest in tp-layers
|
|
(tp--build-layer-props layer-props-list))))))
|
|
(when layer-props
|
|
;; Recursively expand if the layer props contain more layer names
|
|
(when (tp--plist-has-layer-key-p layer-props)
|
|
(setq layer-props (tp--expand-layer-in-plist layer-props)))
|
|
(setq result (append result layer-props)))))
|
|
;; Regular property - keep as-is
|
|
(t
|
|
(setq result (append result (list key val)))))
|
|
(setq remaining (cddr remaining))))
|
|
;; Merge duplicate keys in the expanded result
|
|
;; Use (cdddr result) for O(1) check - need at least 4 elements (2 key-value pairs) for possible duplicates
|
|
(if (cdddr result)
|
|
(tp--merge-duplicate-keys result)
|
|
result)))
|
|
|
|
(defun tp--resolve-props (props)
|
|
"Resolve PROPS to a property list with layer metadata.
|
|
PROPS can be:
|
|
- A symbol (layer name from `tp-layer-alist' or group name from `tp-layer-groups')
|
|
- A two-element list (LAYER-NAME ARG) where LAYER-NAME is a defined layer
|
|
and ARG is either `t' for non-parameterized layers or the argument value
|
|
for parameterized layers
|
|
- A list starting with (LAYER-NAME ARG EXTRA-PROPS...) where extra properties
|
|
are merged with the layer properties
|
|
- A plist with layer names at any position - they will be expanded inline
|
|
- A plist (handles anonymous layers with reactive variables)
|
|
|
|
If PROPS is a symbol:
|
|
- First checks `tp-layer-alist' and returns the layer properties WITH `tp-name'
|
|
- Then checks `tp-layer-groups' and returns properties WITH `tp-layers'
|
|
|
|
If PROPS is (LAYER-NAME ARG) or (LAYER-NAME ARG EXTRA-PROPS...):
|
|
- For non-parameterized layers: if ARG is t, returns the layer properties
|
|
- For parameterized layers: evaluates the body with ARG and returns the result
|
|
- Extra properties after ARG are appended to the layer properties
|
|
|
|
If PROPS is a plist with layer names at any position:
|
|
- Layer names are expanded inline with their properties
|
|
- Other properties are preserved in order
|
|
|
|
If PROPS is a plist:
|
|
- If it contains reactive variables ($...), generates a UUID for `tp-name',
|
|
registers reactive dependencies, and returns the resolved props with `tp-name'.
|
|
If the plist already has a `tp-name', uses that instead of generating a new one.
|
|
- If no reactive variables, returns props as-is (no tp-name added).
|
|
|
|
Returns nil if PROPS is a symbol but no matching layer/group is found.
|
|
|
|
For layer names, includes `tp-name' property for reactive text property support.
|
|
For group names, includes `tp-layers' property with the full layer stack."
|
|
(cond
|
|
;; Already a plist - check for reactive variables and add tp-name
|
|
((listp props)
|
|
(let ((first-elem (car-safe props))
|
|
(second-elem (cadr props))
|
|
(extra-props (cddr props)))
|
|
(cond
|
|
;; Handle (layer-name arg ...) format for defined layers at the START
|
|
;; This includes both (layer-name arg) and (layer-name arg extra-prop val ...)
|
|
((and (>= (length props) 2)
|
|
(tp--is-layer-name-p first-elem))
|
|
(let ((layer-props
|
|
(cond
|
|
;; Parameterized layer - evaluate with the argument
|
|
((tp-layer-parameterized-p first-elem)
|
|
(tp-layer-props-with-arg first-elem second-elem nil)) ; no tp-name
|
|
;; Non-parameterized layer - arg should be t, return the layer props
|
|
;; (silently ignore non-t values for flexibility)
|
|
((assoc first-elem tp-layer-alist)
|
|
(tp-layer-props first-elem nil)) ; no tp-name
|
|
;; Parameterized layer group - evaluate with the argument
|
|
((tp-group-parameterized-p first-elem)
|
|
(when-let ((layer-props-list (tp-group-props-with-arg first-elem second-elem t)))
|
|
;; Build layered structure: first layer at top, rest in tp-layers
|
|
(tp--build-layer-props layer-props-list)))
|
|
;; Non-parameterized layer group - build layered structure
|
|
((assoc first-elem tp-layer-groups)
|
|
(when-let ((layer-props-list (tp-group-props first-elem t)))
|
|
;; Build layered structure: first layer at top, rest in tp-layers
|
|
(tp--build-layer-props layer-props-list))))))
|
|
;; Recursively resolve extra properties (they may also contain layer names)
|
|
(let ((expanded-props
|
|
(if (and layer-props extra-props)
|
|
(let* ((resolved-extra (tp--expand-layer-in-plist extra-props))
|
|
(combined (append layer-props resolved-extra)))
|
|
;; Merge duplicate keys after combining layer props with extra props
|
|
;; Need at least 4 elements (2 key-value pairs) for possible duplicates
|
|
(if (cdddr combined)
|
|
(tp--merge-duplicate-keys combined)
|
|
combined))
|
|
layer-props)))
|
|
;; After expansion, check for reactive symbols in the merged props
|
|
;; (original props may contain $vars that need reactive tracking)
|
|
(let ((reactive-syms (tp--collect-reactive-symbols props)))
|
|
(if reactive-syms
|
|
;; Has reactive symbols - need anonymous tp-name for reactive tracking
|
|
(let* ((existing-tp-name (plist-get props 'tp-name))
|
|
(layer-name (or existing-tp-name
|
|
(tp--generate-anonymous-layer-name)))
|
|
;; Resolve reactive symbols in expanded props
|
|
(resolved-props (tp--resolve-reactive-symbols expanded-props)))
|
|
;; Register reactive dependencies
|
|
(tp--set-layer-props layer-name resolved-props)
|
|
(tp--register-reactive-deps layer-name reactive-syms props)
|
|
(append resolved-props (list 'tp-name layer-name)))
|
|
;; No reactive symbols - return expanded props as-is (no tp-name)
|
|
expanded-props)))))
|
|
|
|
;; Handle single-element list containing a layer/group name symbol.
|
|
;; This can happen when tp-set is called with string form: (tp-set str 'layer-name)
|
|
;; which produces props = (layer-name) in tp--parse-args.
|
|
((and (= (length props) 1)
|
|
(symbolp first-elem)
|
|
(or (assoc first-elem tp-layer-alist)
|
|
(assoc first-elem tp-layer-groups)))
|
|
;; It's a layer/group name wrapped in a list - recurse with the symbol
|
|
(tp--resolve-props first-elem))
|
|
|
|
;; Check if any key in the plist is a layer name (layer at any position)
|
|
((cl-some #'tp--is-layer-name-p
|
|
(cl-loop for (key _val) on props by #'cddr collect key))
|
|
;; Expand all layer names in the plist
|
|
(let ((expanded-props (tp--expand-layer-in-plist props)))
|
|
;; After expansion, check for reactive symbols in the original props
|
|
;; (they may contain $vars that need reactive tracking)
|
|
(let ((reactive-syms (tp--collect-reactive-symbols props)))
|
|
(if reactive-syms
|
|
;; Has reactive symbols - need anonymous tp-name for reactive tracking
|
|
(let* ((existing-tp-name (plist-get props 'tp-name))
|
|
(layer-name (or existing-tp-name
|
|
(tp--generate-anonymous-layer-name)))
|
|
;; Resolve reactive symbols in expanded props
|
|
(resolved-props (tp--resolve-reactive-symbols expanded-props)))
|
|
;; Register reactive dependencies
|
|
(tp--set-layer-props layer-name resolved-props)
|
|
(tp--register-reactive-deps layer-name reactive-syms props)
|
|
(append resolved-props (list 'tp-name layer-name)))
|
|
;; No reactive symbols - return expanded props as-is (no tp-name)
|
|
expanded-props))))
|
|
|
|
;; Normal plist processing
|
|
(t
|
|
(let* ((existing-tp-name (plist-get props 'tp-name))
|
|
(reactive-syms (tp--collect-reactive-symbols props)))
|
|
(if reactive-syms
|
|
;; Has reactive symbols - need to handle as anonymous reactive layer
|
|
(let* ((layer-name (or existing-tp-name
|
|
(tp--generate-anonymous-layer-name)))
|
|
;; Resolve reactive symbols to get current values
|
|
(resolved-props (tp--resolve-reactive-symbols props)))
|
|
;; Register this anonymous layer in tp-layer-alist with resolved props
|
|
(tp--set-layer-props layer-name resolved-props)
|
|
;; Register reactive dependencies with the original props
|
|
(tp--register-reactive-deps layer-name reactive-syms props)
|
|
;; Return resolved props with tp-name for reactive tracking
|
|
(append resolved-props (list 'tp-name layer-name)))
|
|
;; No reactive symbols - return props as-is (no tp-name needed)
|
|
;; This preserves the native text property behavior for non-reactive plists
|
|
props))))))
|
|
;; Symbol - check if it's a layer or group name
|
|
((symbolp props)
|
|
(cond
|
|
;; Parameterized layer without argument - cannot resolve, return nil
|
|
((tp-layer-parameterized-p props)
|
|
nil)
|
|
;; Check layer - get props without tp-name for direct property setting
|
|
((assoc props tp-layer-alist)
|
|
(tp-layer-props props nil)) ; no tp-name
|
|
;; Check group - build layered structure with tp-layers
|
|
((assoc props tp-layer-groups)
|
|
(when-let ((layer-props-list (tp-group-props props t))) ; include tp-name
|
|
;; Build layered structure: first layer at top, rest in tp-layers
|
|
(tp--build-layer-props layer-props-list)))
|
|
;; Parameterized group without argument - cannot resolve, return nil
|
|
((tp-group-parameterized-p props)
|
|
nil)
|
|
;; Not found - return nil (let caller decide how to handle)
|
|
(t nil)))
|
|
(t nil)))
|
|
|
|
(defun tp--ensure-props (plist)
|
|
"Ensure PLIST is a property list, resolving layer names and handling reactive vars.
|
|
If PLIST is a symbol, resolve it via `tp--resolve-props'.
|
|
If PLIST is a plist, also process it via `tp--resolve-props' to handle
|
|
anonymous reactive layers.
|
|
If resolution fails, return PLIST unchanged (for backward compatibility)."
|
|
(or (tp--resolve-props plist) plist))
|
|
|
|
(defun tp-layer-reset ()
|
|
"Reset all layer definitions.
|
|
Clears both `tp-layer-alist' and `tp-layer-groups'.
|
|
Also resets all reactive text property watchers, dependencies, and transforms."
|
|
(interactive)
|
|
(tp-reactive-reset)
|
|
(setq tp-layer-alist nil)
|
|
(setq tp-layer-groups nil)
|
|
(setq tp-layer-transforms nil))
|
|
|
|
(defun tp-undefine-layer (name)
|
|
"Remove layer NAME from `tp-layer-alist'.
|
|
Also unregisters any reactive dependencies and transforms for this layer."
|
|
(tp--unregister-reactive-deps name)
|
|
(setq tp-layer-alist (assq-delete-all name tp-layer-alist))
|
|
(setq tp-layer-transforms (assq-delete-all name tp-layer-transforms)))
|
|
|
|
(defun tp-undefine-group (name)
|
|
"Remove layer group NAME from `tp-layer-groups'."
|
|
(setq tp-layer-groups (assq-delete-all name tp-layer-groups)))
|
|
|
|
;;;============================================================================
|
|
;;; Layer 3: Layer Stack Operations
|
|
;;;============================================================================
|
|
|
|
(defun tp-intervals-map (function start end &optional object)
|
|
"Apply FUNCTION to all intervals between START and END in OBJECT.
|
|
FUNCTION receives (i-start i-end top-props below-props-lst)."
|
|
(remove
|
|
nil
|
|
(mapcar
|
|
(lambda (tp)
|
|
(let* ((interval-start (nth 0 tp)) ;; start from 0
|
|
(interval-end (nth 1 tp))
|
|
(interval-props (nth 2 tp))
|
|
(top-props
|
|
(if-let ((idx (-elem-index 'tp-layers interval-props)))
|
|
(-remove-at-indices (list idx (1+ idx)) interval-props)
|
|
interval-props))
|
|
(below-props-lst (plist-get interval-props 'tp-layers)))
|
|
(funcall function
|
|
interval-start interval-end
|
|
top-props below-props-lst)))
|
|
(tp-intervals start end object))))
|
|
|
|
(defun tp-region-layer-props (start end layer-name &optional object)
|
|
"Return layer properties for LAYER-NAME in region from START to END.
|
|
OBJECT defaults to current buffer.
|
|
Returns a list of (START END PROPERTIES) for matching intervals."
|
|
(tp-intervals-map
|
|
(lambda (i-start i-end top belows)
|
|
(when-let ((props (seq-find
|
|
(lambda (props)
|
|
(equal layer-name
|
|
(plist-get props 'tp-name)))
|
|
(append (list top) belows))))
|
|
(list (+ start i-start) (+ start i-end) props)))
|
|
start end object))
|
|
|
|
;;; --- Layer Stack Utilities ---
|
|
|
|
(defun tp--normalize-layer-spec (layer-spec)
|
|
"Normalize LAYER-SPEC to a plist with tp-name.
|
|
Used by layer stack functions that need tp-name for identification.
|
|
|
|
LAYER-SPEC can be:
|
|
- A symbol (non-parameterized layer name from define-tp or tp--define-layer-internal)
|
|
- A list (LAYER-NAME ARG) for parameterized layers from define-tp
|
|
- A plist for inline layer definition
|
|
- A list (NAME &rest PLIST) for named inline layer"
|
|
(cond
|
|
;; Symbol - look up in tp-layer-alist (non-parameterized layer)
|
|
((symbolp layer-spec)
|
|
(cond
|
|
;; Parameterized layer symbol without arg - error
|
|
((tp-layer-parameterized-p layer-spec)
|
|
(error "Parameterized layer %S requires an argument, use '(%S arg)"
|
|
layer-spec layer-spec))
|
|
;; Non-parameterized layer or old-format layer
|
|
((assoc layer-spec tp-layer-alist)
|
|
(or (tp-layer-props layer-spec t) ; include tp-name for layer stack
|
|
(error "Layer %S not found in tp-layer-alist" layer-spec)))
|
|
(t (error "Layer %S not found in tp-layer-alist" layer-spec))))
|
|
|
|
;; List starting with symbol - check if it's a parameterized layer
|
|
((and (listp layer-spec)
|
|
(symbolp (car layer-spec))
|
|
(not (keywordp (car layer-spec))))
|
|
(let ((name (car layer-spec))
|
|
(rest (cdr layer-spec)))
|
|
(cond
|
|
;; Parameterized layer: (LAYER-NAME ARG)
|
|
((and (tp-layer-parameterized-p name)
|
|
(= (length rest) 1))
|
|
(or (tp-layer-props-with-arg name (car rest) t) ; include tp-name
|
|
(error "Failed to resolve parameterized layer %S with arg %S"
|
|
name (car rest))))
|
|
;; Named inline layer: (NAME &rest PLIST)
|
|
(rest
|
|
(append rest (list 'tp-name name)))
|
|
;; Just a symbol in a list - treat as non-parameterized layer
|
|
((null rest)
|
|
(or (tp-layer-props name t)
|
|
(error "Layer %S not found in tp-layer-alist" name))))))
|
|
|
|
;; Plist (starts with keyword or property name)
|
|
((and (listp layer-spec) layer-spec)
|
|
layer-spec)
|
|
(t (error "Invalid layer spec: %S" layer-spec))))
|
|
|
|
(defun tp--get-layer-stack (pos object)
|
|
"Get the layer stack at POS in OBJECT as a list.
|
|
Returns (TOP-PROPS . BELOW-PROPS-LIST)."
|
|
(let* ((props (text-properties-at pos object))
|
|
(tp-layers-idx (-elem-index 'tp-layers props))
|
|
(top-props (if tp-layers-idx
|
|
(-remove-at-indices
|
|
(list tp-layers-idx (1+ tp-layers-idx)) props)
|
|
props))
|
|
(below-props (plist-get props 'tp-layers)))
|
|
(cons top-props below-props)))
|
|
|
|
(defun tp--build-layer-props (layer-list)
|
|
"Build text properties from LAYER-LIST.
|
|
First element is top layer, rest are in tp-layers."
|
|
(if (null layer-list)
|
|
nil
|
|
(append (car layer-list)
|
|
(list 'tp-layers (cdr layer-list)))))
|
|
|
|
(defun tp--layer-stack-to-list (top belows)
|
|
"Convert TOP and BELOWS to a flat list of layers."
|
|
(if top
|
|
(cons top belows)
|
|
belows))
|
|
|
|
(defun tp--get-layer-by-idx-or-name (layers idx-or-name)
|
|
"Find layer in LAYERS by IDX-OR-NAME.
|
|
Returns (index . layer-props) or nil."
|
|
(cond
|
|
((integerp idx-or-name)
|
|
(let ((actual-idx (if (< idx-or-name 0)
|
|
(+ (length layers) idx-or-name)
|
|
idx-or-name)))
|
|
(when (and (>= actual-idx 0) (< actual-idx (length layers)))
|
|
(cons actual-idx (nth actual-idx layers)))))
|
|
((symbolp idx-or-name)
|
|
(cl-loop for layer in layers
|
|
for i from 0
|
|
when (equal idx-or-name (plist-get layer 'tp-name))
|
|
return (cons i layer)))
|
|
(t nil)))
|
|
|
|
(defun tp--parse-layer-args (args)
|
|
"Parse flexible layer function arguments.
|
|
Returns (START END LAYER-SPEC IDX OBJECT) for buffer/string range,
|
|
or (STRING LAYER-SPEC IDX nil nil) for entire string."
|
|
(cond
|
|
;; First arg is a string - apply to entire string
|
|
;; (tp-put-layer string layer idx)
|
|
((stringp (car args))
|
|
(list (car args) (cadr args) (caddr args) nil nil))
|
|
;; First arg is a number - buffer/string region
|
|
;; (tp-put-layer start end layer idx object)
|
|
((numberp (car args))
|
|
(list (car args) (cadr args) (caddr args) (cadddr args) (nth 4 args)))
|
|
(t (error "Invalid arguments: %S" args))))
|
|
|
|
(defun tp-put-layer (start-or-string &optional end-or-layer layer-or-idx idx-or-object object)
|
|
"Set layer(s) at a specific index position.
|
|
|
|
Calling conventions:
|
|
1. Buffer/string region:
|
|
(tp-put-layer START END LAYER IDX OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-put-layer STRING LAYER IDX)
|
|
|
|
LAYER can be:
|
|
- A symbol (layer name from tp-layer-alist or tp-layer-groups)
|
|
- A plist (inline layer definition)
|
|
- A list (NAME &rest PLIST) for named inline layer
|
|
- A list of the above for multiple layers
|
|
|
|
IDX specifies where to insert:
|
|
- 0 means top (visible layer)
|
|
- -1 means bottom
|
|
- Other values insert at that position
|
|
|
|
OBJECT defaults to current buffer for region form."
|
|
(let (start end layer-spec idx obj)
|
|
(cond
|
|
;; Entire string form: (tp-put-layer string layer idx)
|
|
((stringp start-or-string)
|
|
(setq obj start-or-string
|
|
start 0
|
|
end (length start-or-string)
|
|
layer-spec end-or-layer
|
|
idx (or layer-or-idx 0)))
|
|
;; Region form: (tp-put-layer start end layer idx object)
|
|
((numberp start-or-string)
|
|
(setq start start-or-string
|
|
end end-or-layer
|
|
layer-spec layer-or-idx
|
|
idx (or idx-or-object 0)
|
|
obj object)))
|
|
|
|
;; Normalize layer-spec to a list of layer property lists
|
|
(let ((layers-to-add
|
|
(cond
|
|
;; Check if it's a group name
|
|
((and (symbolp layer-spec)
|
|
(assoc layer-spec tp-layer-groups))
|
|
(tp-group-props layer-spec t)) ; include tp-name for layer stack
|
|
;; Single layer spec
|
|
((or (symbolp layer-spec)
|
|
(and (listp layer-spec)
|
|
(or (keywordp (car layer-spec))
|
|
(and (symbolp (car layer-spec))
|
|
(cdr layer-spec)
|
|
(not (listp (cadr layer-spec)))))))
|
|
(list (tp--normalize-layer-spec layer-spec)))
|
|
;; List of layer specs (multiple layers)
|
|
((and (listp layer-spec)
|
|
(listp (car layer-spec)))
|
|
(mapcar #'tp--normalize-layer-spec layer-spec))
|
|
(t (list (tp--normalize-layer-spec layer-spec))))))
|
|
|
|
;; Apply layers at specified index
|
|
(if (tp-empty-p (or obj (current-buffer)))
|
|
;; No existing properties
|
|
(set-text-properties start end
|
|
(tp--build-layer-props layers-to-add)
|
|
obj)
|
|
;; Has existing properties
|
|
(tp-intervals-map
|
|
(lambda (i-start i-end top belows)
|
|
(let* ((current-stack (tp--layer-stack-to-list top belows))
|
|
(actual-idx (cond
|
|
((= idx 0) 0)
|
|
((< idx 0) (max 0 (+ (length current-stack) 1 idx)))
|
|
(t (min idx (length current-stack)))))
|
|
;; Insert new layers at the specified position
|
|
(new-stack (append (seq-take current-stack actual-idx)
|
|
layers-to-add
|
|
(seq-drop current-stack actual-idx))))
|
|
(set-text-properties
|
|
(+ start i-start) (+ start i-end)
|
|
(tp--build-layer-props new-stack)
|
|
obj)))
|
|
start end obj)))
|
|
(or obj (cons start end))))
|
|
|
|
(defun tp-push-layer (start-or-string &optional end-or-layer layer-or-object object)
|
|
"Push layer(s) to the top of the layer stack.
|
|
|
|
This is equivalent to (tp-put-layer ... LAYER 0 ...).
|
|
|
|
Calling conventions:
|
|
1. Buffer/string region:
|
|
(tp-push-layer START END LAYER OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-push-layer STRING LAYER)"
|
|
(cond
|
|
((stringp start-or-string)
|
|
(tp-put-layer start-or-string end-or-layer 0))
|
|
((numberp start-or-string)
|
|
(tp-put-layer start-or-string end-or-layer layer-or-object 0 object))))
|
|
|
|
(defun tp-delete-layer (start-or-string &optional end-or-idx idx-or-object object)
|
|
"Delete layer by name or index.
|
|
|
|
Calling conventions:
|
|
1. Buffer/string region:
|
|
(tp-delete-layer START END LAYER-NAME/IDX OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-delete-layer STRING LAYER-NAME/IDX)
|
|
|
|
LAYER-NAME/IDX can be:
|
|
- A symbol (layer name)
|
|
- An integer (layer index, 0=top, -1=bottom)"
|
|
(let (start end layer-id obj)
|
|
(cond
|
|
((stringp start-or-string)
|
|
(setq obj start-or-string
|
|
start 0
|
|
end (length start-or-string)
|
|
layer-id end-or-idx))
|
|
((numberp start-or-string)
|
|
(setq start start-or-string
|
|
end end-or-idx
|
|
layer-id idx-or-object
|
|
obj object)))
|
|
|
|
(tp-intervals-map
|
|
(lambda (i-start i-end top belows)
|
|
(let* ((current-stack (tp--layer-stack-to-list top belows))
|
|
(found (tp--get-layer-by-idx-or-name current-stack layer-id)))
|
|
(when found
|
|
(let ((new-stack (-remove-at (car found) current-stack)))
|
|
(set-text-properties
|
|
(+ start i-start) (+ start i-end)
|
|
(tp--build-layer-props new-stack)
|
|
obj)))))
|
|
start end obj)
|
|
nil))
|
|
|
|
(defun tp-pop-layer (start-or-string &optional end-or-object object)
|
|
"Pop the top layer from the layer stack.
|
|
|
|
This is equivalent to (tp-delete-layer ... 0 ...).
|
|
|
|
Calling conventions:
|
|
1. Buffer/string region:
|
|
(tp-pop-layer START END OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-pop-layer STRING)"
|
|
(cond
|
|
((stringp start-or-string)
|
|
(tp-delete-layer start-or-string 0))
|
|
((numberp start-or-string)
|
|
(tp-delete-layer start-or-string end-or-object 0 object))))
|
|
|
|
(defun tp--move-layer-in-stack (stack from-id to-idx)
|
|
"Move layer at FROM-ID to TO-IDX position in STACK.
|
|
FROM-ID can be an integer index or a layer name symbol.
|
|
TO-IDX must be an integer index.
|
|
Both indices refer to positions before the move and can be negative (counting from end).
|
|
TO-IDX is clamped to valid range (0 to stack length - 1) if out of bounds.
|
|
Returns the new stack, or nil if FROM-ID is invalid."
|
|
(let* ((len (length stack))
|
|
;; Resolve from-id to actual index
|
|
(found (tp--get-layer-by-idx-or-name stack from-id))
|
|
(actual-from (when found (car found)))
|
|
;; Normalize to-idx
|
|
(actual-to (if (< to-idx 0)
|
|
(+ len to-idx)
|
|
to-idx)))
|
|
;; Only proceed if from-id is valid
|
|
(when actual-from
|
|
(let* ((layer-props (cdr found))
|
|
(stack-without (-remove-at actual-from stack))
|
|
;; Clamp to-idx to valid range for insertion
|
|
(clamped-to (max 0 (min actual-to (length stack-without)))))
|
|
(append (seq-take stack-without clamped-to)
|
|
(list layer-props)
|
|
(seq-drop stack-without clamped-to))))))
|
|
|
|
(defun tp--raise-layer-in-stack (stack from-id n)
|
|
"Raise layer at FROM-ID by N positions in STACK.
|
|
FROM-ID can be an integer index or a layer name symbol.
|
|
Positive N moves the layer up (toward top/visible).
|
|
Negative N moves the layer down (toward bottom).
|
|
The resulting position is clamped to valid range (0 to stack length - 1).
|
|
Returns the new stack, or nil if FROM-ID is invalid."
|
|
(let* ((found (tp--get-layer-by-idx-or-name stack from-id))
|
|
(actual-from (when found (car found))))
|
|
(when actual-from
|
|
(let* ((len (length stack))
|
|
;; Calculate new position: subtracting N because lower index = higher in stack
|
|
(new-idx (max 0 (min (1- len) (- actual-from n)))))
|
|
(tp--move-layer-in-stack stack actual-from new-idx)))))
|
|
|
|
(defun tp--switch-layers-in-stack (stack id1 id2)
|
|
"Swap layers at ID1 and ID2 positions in STACK.
|
|
ID1 and ID2 can be integer indices or layer name symbols.
|
|
Returns the new stack, or nil if either ID is invalid."
|
|
(let* ((found1 (tp--get-layer-by-idx-or-name stack id1))
|
|
(found2 (tp--get-layer-by-idx-or-name stack id2)))
|
|
(when (and found1 found2)
|
|
(let* ((idx1 (car found1))
|
|
(idx2 (car found2))
|
|
(props1 (cdr found1))
|
|
(props2 (cdr found2))
|
|
(new-stack (copy-sequence stack)))
|
|
(setf (nth idx1 new-stack) props2)
|
|
(setf (nth idx2 new-stack) props1)
|
|
new-stack))))
|
|
|
|
(defun tp-move-layer (start-or-string &optional end-or-from from-or-to to-or-object object)
|
|
"Move a layer from one position to another in the layer stack.
|
|
|
|
Calling conventions:
|
|
1. Buffer/string region:
|
|
(tp-move-layer START END FROM-ID TO-IDX OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-move-layer STRING FROM-ID TO-IDX)
|
|
|
|
FROM-ID identifies the layer to move:
|
|
- An integer index (0 = top, 1 = second from top, -1 = bottom, etc.)
|
|
- A layer name symbol
|
|
|
|
TO-IDX is the target position (integer index):
|
|
- 0 means top (visible)
|
|
- Positive integers count from top
|
|
- -1 means bottom
|
|
- Negative integers count from bottom
|
|
|
|
Both indices refer to positions before the move.
|
|
The layer at FROM-ID is removed and inserted at TO-IDX position.
|
|
OBJECT defaults to current buffer for region form."
|
|
(let (start end from-id to-idx obj)
|
|
(cond
|
|
;; Entire string form: (tp-move-layer string from-id to-idx)
|
|
((stringp start-or-string)
|
|
(setq obj start-or-string
|
|
start 0
|
|
end (length start-or-string)
|
|
from-id end-or-from
|
|
to-idx from-or-to))
|
|
;; Region form: (tp-move-layer start end from-id to-idx object)
|
|
((numberp start-or-string)
|
|
(setq start start-or-string
|
|
end end-or-from
|
|
from-id from-or-to
|
|
to-idx to-or-object
|
|
obj object)))
|
|
|
|
(tp-intervals-map
|
|
(lambda (i-start i-end top belows)
|
|
(let* ((current-stack (tp--layer-stack-to-list top belows))
|
|
(new-stack (tp--move-layer-in-stack current-stack from-id to-idx)))
|
|
(when new-stack
|
|
(set-text-properties
|
|
(+ start i-start) (+ start i-end)
|
|
(tp--build-layer-props new-stack)
|
|
obj))))
|
|
start end obj)
|
|
nil))
|
|
|
|
(defun tp-raise-layer (start-or-string &optional end-or-idx idx-or-n n-or-object object)
|
|
"Raise a layer by N positions in the stack.
|
|
|
|
Calling conventions:
|
|
1. Buffer/string region:
|
|
(tp-raise-layer START END IDX/LAYER-NAME N OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-raise-layer STRING IDX/LAYER-NAME N)
|
|
|
|
Positive N moves the layer up (toward top/visible).
|
|
Negative N moves the layer down (toward bottom).
|
|
|
|
Uses `tp--raise-layer-in-stack' internally, which is built on `tp--move-layer-in-stack'."
|
|
(let (start end layer-id n obj)
|
|
(cond
|
|
((stringp start-or-string)
|
|
(setq obj start-or-string
|
|
start 0
|
|
end (length start-or-string)
|
|
layer-id end-or-idx
|
|
n (or idx-or-n 1)))
|
|
((numberp start-or-string)
|
|
(setq start start-or-string
|
|
end end-or-idx
|
|
layer-id idx-or-n
|
|
n (or n-or-object 1)
|
|
obj object)))
|
|
|
|
(tp-intervals-map
|
|
(lambda (i-start i-end top belows)
|
|
(let* ((current-stack (tp--layer-stack-to-list top belows))
|
|
(new-stack (tp--raise-layer-in-stack current-stack layer-id n)))
|
|
(when new-stack
|
|
(set-text-properties
|
|
(+ start i-start) (+ start i-end)
|
|
(tp--build-layer-props new-stack)
|
|
obj))))
|
|
start end obj)
|
|
nil))
|
|
|
|
(defun tp-rotate-layer (start-or-string &optional end-or-object object)
|
|
"Rotate layers, moving top layer to bottom.
|
|
|
|
Calling conventions:
|
|
1. Buffer/string region:
|
|
(tp-rotate-layer START END OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-rotate-layer STRING)
|
|
|
|
Uses `tp-move-layer' internally to move layer at index 0 to index -1."
|
|
(cond
|
|
((stringp start-or-string)
|
|
(tp-move-layer start-or-string 0 -1))
|
|
((numberp start-or-string)
|
|
(tp-move-layer start-or-string end-or-object 0 -1 object))))
|
|
|
|
(defun tp-pin-layer (start-or-string &optional end-or-idx idx-or-object object)
|
|
"Pin a layer to the top (make it visible).
|
|
|
|
Calling conventions:
|
|
1. Buffer/string region:
|
|
(tp-pin-layer START END IDX/LAYER-NAME OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-pin-layer STRING IDX/LAYER-NAME)
|
|
|
|
Uses `tp-move-layer' internally to move the specified layer to index 0 (top)."
|
|
(cond
|
|
((stringp start-or-string)
|
|
(tp-move-layer start-or-string end-or-idx 0))
|
|
((numberp start-or-string)
|
|
(tp-move-layer start-or-string end-or-idx idx-or-object 0 object))))
|
|
|
|
(defun tp-switch-layer (start-or-string &optional end-or-id1 id1-or-id2 id2-or-object object)
|
|
"Switch between two layers by name or index.
|
|
|
|
Calling conventions:
|
|
1. Buffer/string region:
|
|
(tp-switch-layer START END IDX1/NAME1 IDX2/NAME2 OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-switch-layer STRING IDX1/NAME1 IDX2/NAME2)
|
|
|
|
Uses `tp--switch-layers-in-stack' internally."
|
|
(let (start end id1 id2 obj)
|
|
(cond
|
|
((stringp start-or-string)
|
|
(setq obj start-or-string
|
|
start 0
|
|
end (length start-or-string)
|
|
id1 end-or-id1
|
|
id2 id1-or-id2))
|
|
((numberp start-or-string)
|
|
(setq start start-or-string
|
|
end end-or-id1
|
|
id1 id1-or-id2
|
|
id2 id2-or-object
|
|
obj object)))
|
|
|
|
(tp-intervals-map
|
|
(lambda (i-start i-end top belows)
|
|
(let* ((current-stack (tp--layer-stack-to-list top belows))
|
|
(new-stack (tp--switch-layers-in-stack current-stack id1 id2)))
|
|
(when new-stack
|
|
(set-text-properties
|
|
(+ start i-start) (+ start i-end)
|
|
(tp--build-layer-props new-stack)
|
|
obj))))
|
|
start end obj)
|
|
nil))
|
|
|
|
(defun tp-merge-layers (start-or-string &optional end-or-name name-or-ids ids-or-object object)
|
|
"Merge specified layers into a new layer.
|
|
|
|
Calling conventions:
|
|
1. Buffer/string region:
|
|
(tp-merge-layers START END NEW-LAYER-NAME \\='(IDX1 LAYER-NAME1 IDX2 ...) OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-merge-layers STRING NEW-LAYER-NAME \\='(IDX1 LAYER-NAME1 IDX2 ...))"
|
|
(let (start end new-name layer-ids obj)
|
|
(cond
|
|
((stringp start-or-string)
|
|
(setq obj start-or-string
|
|
start 0
|
|
end (length start-or-string)
|
|
new-name end-or-name
|
|
layer-ids name-or-ids))
|
|
((numberp start-or-string)
|
|
(setq start start-or-string
|
|
end end-or-name
|
|
new-name name-or-ids
|
|
layer-ids ids-or-object
|
|
obj object)))
|
|
|
|
(tp-intervals-map
|
|
(lambda (i-start i-end top belows)
|
|
(let* ((current-stack (tp--layer-stack-to-list top belows))
|
|
;; Find all layers to merge
|
|
(layers-to-merge
|
|
(cl-loop for id in layer-ids
|
|
for found = (tp--get-layer-by-idx-or-name current-stack id)
|
|
when found collect found))
|
|
;; Sort by index (descending) to remove from end first
|
|
(sorted-layers (sort (copy-sequence layers-to-merge)
|
|
(lambda (a b) (> (car a) (car b))))))
|
|
(when layers-to-merge
|
|
;; Merge properties (earlier in list takes precedence)
|
|
(let* ((merged-props
|
|
(cl-reduce (lambda (acc layer)
|
|
(let ((props (cdr layer)))
|
|
(cl-loop for (key val) on props by #'cddr
|
|
do (unless (plist-get acc key)
|
|
(setq acc (plist-put acc key val))))
|
|
acc))
|
|
layers-to-merge
|
|
:initial-value (list 'tp-name new-name)))
|
|
;; Remove old layers from stack
|
|
(indices-to-remove (mapcar #'car sorted-layers))
|
|
(new-stack current-stack))
|
|
(dolist (idx indices-to-remove)
|
|
(setq new-stack (-remove-at idx new-stack)))
|
|
;; Add merged layer at top
|
|
(setq new-stack (cons merged-props new-stack))
|
|
(set-text-properties
|
|
(+ start i-start) (+ start i-end)
|
|
(tp--build-layer-props new-stack)
|
|
obj)))))
|
|
start end obj)
|
|
nil))
|
|
|
|
(defun tp-flatten-layers (start-or-string &optional end-or-name name-or-object object)
|
|
"Flatten all layers into a single layer.
|
|
|
|
Calling conventions:
|
|
1. Buffer/string region:
|
|
(tp-flatten-layers START END NAME OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-flatten-layers STRING NAME)
|
|
|
|
NAME can be nil for an unnamed layer."
|
|
(let (start end name obj)
|
|
(cond
|
|
((stringp start-or-string)
|
|
(setq obj start-or-string
|
|
start 0
|
|
end (length start-or-string)
|
|
name end-or-name))
|
|
((numberp start-or-string)
|
|
(setq start start-or-string
|
|
end end-or-name
|
|
name name-or-object
|
|
obj object)))
|
|
|
|
(tp-intervals-map
|
|
(lambda (i-start i-end top belows)
|
|
(let* ((current-stack (tp--layer-stack-to-list top belows))
|
|
(layer-count (length current-stack)))
|
|
(when (> layer-count 0)
|
|
;; Create list of all indices
|
|
(let ((all-ids (cl-loop for i from 0 below layer-count collect i)))
|
|
;; Use merge with all layers
|
|
(let* ((layers-to-merge
|
|
(cl-loop for id in all-ids
|
|
for found = (tp--get-layer-by-idx-or-name
|
|
current-stack id)
|
|
when found collect found))
|
|
(merged-props
|
|
(cl-reduce (lambda (acc layer)
|
|
(let ((props (cdr layer)))
|
|
(cl-loop for (key val) on props by #'cddr
|
|
unless (eq key 'tp-name)
|
|
do (unless (plist-get acc key)
|
|
(setq acc (plist-put acc key val))))
|
|
acc))
|
|
layers-to-merge
|
|
:initial-value (if name (list 'tp-name name) nil))))
|
|
(set-text-properties
|
|
(+ start i-start) (+ start i-end)
|
|
merged-props
|
|
obj))))))
|
|
start end obj)
|
|
nil))
|
|
|
|
;;; --- Layer Query Functions ---
|
|
|
|
(defun tp-layer-list (start end &optional object)
|
|
"Return list of all layer names in region from START to END."
|
|
(let ((layers nil))
|
|
(tp-intervals-map
|
|
(lambda (_i-start _i-end top belows)
|
|
(when-let ((name (plist-get top 'tp-name)))
|
|
(cl-pushnew name layers :test #'equal))
|
|
(dolist (below belows)
|
|
(when-let ((name (plist-get below 'tp-name)))
|
|
(cl-pushnew name layers :test #'equal))))
|
|
start end object)
|
|
(nreverse layers)))
|
|
|
|
(defun tp-layer-count (start end &optional object)
|
|
"Return number of layers in region from START to END.
|
|
OBJECT defaults to current buffer."
|
|
(let ((max-count 0))
|
|
(tp-intervals-map
|
|
(lambda (_i-start _i-end top belows)
|
|
(let ((count (+ (if top 1 0) (length belows))))
|
|
(when (> count max-count)
|
|
(setq max-count count))))
|
|
start end object)
|
|
max-count))
|
|
|
|
(defun tp-layer-exists-p (start end name &optional object)
|
|
"Return t if layer NAME exists in region from START to END.
|
|
OBJECT defaults to current buffer."
|
|
(not (null (tp-region-layer-props start end name object))))
|
|
|
|
(defun tp-layer-top (start end &optional object)
|
|
"Return the name of the top layer at START in OBJECT.
|
|
OBJECT defaults to current buffer."
|
|
(when-let ((intervals (tp-intervals start end object)))
|
|
(plist-get (nth 2 (car intervals)) 'tp-name)))
|
|
|
|
;;; --- Layer Property Manipulation Functions ---
|
|
|
|
(defun tp-add-to-layers (idx-or-layer-name-list start-or-string &optional end-or-plist plist-or-object &rest rest)
|
|
"Add/merge properties to specified layers.
|
|
|
|
IDX-OR-LAYER-NAME-LIST is a list of layer indices (integers) or
|
|
layer names (symbols) specifying which layers to add properties to.
|
|
For indices: 0 means top layer, -1 means bottom layer.
|
|
|
|
For region form, PLIST is a property list to merge into the specified layers.
|
|
For string form, PROP VAL ... are property-value pairs to merge.
|
|
Properties are deeply merged (nested plists are merged, not replaced).
|
|
|
|
OBJECT defaults to current buffer for region form.
|
|
|
|
Returns the modified object (string) or nil for buffer operations."
|
|
(let (start end plist obj layer-ids)
|
|
(setq layer-ids idx-or-layer-name-list)
|
|
(cond
|
|
;; Entire string form: (tp-add-to-layers ids string prop val ...)
|
|
((stringp start-or-string)
|
|
(setq obj start-or-string
|
|
start 0
|
|
end (length start-or-string))
|
|
;; Construct plist from end-or-plist, plist-or-object, and rest
|
|
;; Always include plist-or-object even if nil, to handle (... 'prop nil)
|
|
(when end-or-plist
|
|
(setq plist (cons end-or-plist (cons plist-or-object rest)))))
|
|
;; Region form: (tp-add-to-layers ids start end plist object)
|
|
((numberp start-or-string)
|
|
(setq start start-or-string
|
|
end end-or-plist
|
|
plist plist-or-object
|
|
obj (car rest))))
|
|
|
|
;; Handle plist wrapped in a list (from region form)
|
|
(when (and (listp plist)
|
|
(not (keywordp (car-safe plist)))
|
|
(listp (car-safe plist)))
|
|
(setq plist (car plist)))
|
|
|
|
;; Process each interval
|
|
(tp-intervals-map
|
|
(lambda (i-start i-end top belows)
|
|
(let* ((current-stack (tp--layer-stack-to-list top belows))
|
|
(modified-stack
|
|
(cl-loop for layer in current-stack
|
|
for i from 0
|
|
collect
|
|
(if (cl-some
|
|
(lambda (id)
|
|
(let ((found (tp--get-layer-by-idx-or-name
|
|
current-stack id)))
|
|
(and found (= (car found) i))))
|
|
layer-ids)
|
|
;; Merge plist into this layer
|
|
(tp--deep-merge-plist layer plist)
|
|
;; Keep layer unchanged
|
|
layer))))
|
|
(set-text-properties
|
|
(+ start i-start) (+ start i-end)
|
|
(tp--build-layer-props modified-stack)
|
|
obj)))
|
|
start end obj)
|
|
(if (stringp obj) obj nil)))
|
|
|
|
(defun tp-add-to-all-layers (start-or-string &optional end-or-plist plist-or-object &rest rest)
|
|
"Add/merge properties to all layers.
|
|
|
|
This function supports two calling conventions:
|
|
|
|
1. Buffer/string region:
|
|
(tp-add-to-all-layers START END PLIST OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-add-to-all-layers STRING PROP VAL ...)
|
|
|
|
For region form, PLIST is a property list to merge into all layers.
|
|
For string form, PROP VAL ... are property-value pairs to merge.
|
|
Properties are deeply merged (nested plists are merged, not replaced).
|
|
|
|
OBJECT defaults to current buffer for region form.
|
|
|
|
This function uses `tp-add-to-layers' internally, collecting all
|
|
layer indices and passing them to add the plist to every layer.
|
|
|
|
Returns the modified object (string) or nil for buffer operations."
|
|
(let (start end plist obj)
|
|
(cond
|
|
;; Entire string form: (tp-add-to-all-layers string prop val ...)
|
|
((stringp start-or-string)
|
|
(setq obj start-or-string
|
|
start 0
|
|
end (length start-or-string))
|
|
;; Construct plist from end-or-plist, plist-or-object, and rest
|
|
;; Always include plist-or-object even if nil, to handle (... 'prop nil)
|
|
(when end-or-plist
|
|
(setq plist (cons end-or-plist (cons plist-or-object rest)))))
|
|
;; Region form: (tp-add-to-all-layers start end plist object)
|
|
((numberp start-or-string)
|
|
(setq start start-or-string
|
|
end end-or-plist
|
|
plist plist-or-object
|
|
obj (car rest))))
|
|
|
|
;; Handle plist wrapped in a list (from region form)
|
|
(when (and (listp plist)
|
|
(not (keywordp (car-safe plist)))
|
|
(listp (car-safe plist)))
|
|
(setq plist (car plist)))
|
|
|
|
;; Get the maximum layer count in the region to build a list of all indices
|
|
(let ((max-count (tp-layer-count start end obj)))
|
|
(when (> max-count 0)
|
|
(let ((all-indices (cl-loop for i from 0 below max-count collect i)))
|
|
(tp-add-to-layers all-indices start end plist obj))))
|
|
(if (stringp obj) obj nil)))
|
|
|
|
;;; Utilities
|
|
|
|
(defmacro tp-pop-to-buffer (buffer-or-name &rest body)
|
|
(declare (indent defun))
|
|
`(let ((buffer (get-buffer-create ,buffer-or-name)))
|
|
(tp-with-current-buffer buffer
|
|
(erase-buffer)
|
|
,@body
|
|
(local-set-key "q" (lambda ()
|
|
(interactive)
|
|
(local-unset-key "q")
|
|
(quit-window)))
|
|
(read-only-mode 1))
|
|
(pop-to-buffer buffer)))
|
|
|
|
(defmacro tp-switch-to-buffer (buffer-or-name &rest body)
|
|
(declare (indent defun))
|
|
`(let ((buffer (get-buffer-create ,buffer-or-name)))
|
|
(tp-with-current-buffer buffer
|
|
(erase-buffer)
|
|
,@body
|
|
(local-set-key "q" (lambda ()
|
|
(interactive)
|
|
(local-unset-key "q")
|
|
(quit-window)))
|
|
(read-only-mode 1))
|
|
(switch-to-buffer buffer)))
|
|
|
|
(defun tp-theme-dark-p ()
|
|
(eq (frame-parameter nil 'background-mode) 'dark))
|
|
|
|
(defun tp-theme-light-p ()
|
|
(eq (frame-parameter nil 'background-mode) 'light))
|
|
|
|
(defun tp-parse-color (color)
|
|
"e.g.1 (tp-parse-color \"red\")
|
|
e.g.2 (tp-parse-color '(\"red\" . \"green\"))
|
|
e.g.3 (tp-parse-color '(:light \"red\" :dark \"green\"))"
|
|
(cond ((stringp color) color)
|
|
((and (consp color)
|
|
(stringp (car color))
|
|
(stringp (cdr color)))
|
|
(cond
|
|
((tp-theme-light-p) (car color))
|
|
((tp-theme-dark-p) (cdr color))))
|
|
((and (plistp color)
|
|
(or (plist-member color :light)
|
|
(plist-member color :dark)))
|
|
(cond
|
|
((tp-theme-light-p) (plist-get color :light))
|
|
((tp-theme-dark-p) (plist-get color :dark))))
|
|
((null color) nil)
|
|
(t (error "Invalid format of color %S" color))))
|
|
|
|
;;; Built-in text properties
|
|
|
|
(require 'tp-palette)
|
|
|
|
(define-tp tp-palette (palette)
|
|
(let* ((pure-palette (tp-palette-pure palette))
|
|
(fg-color (or (tp-palette-fg-color pure-palette)
|
|
(face-attribute 'default :foreground)))
|
|
(bg-color (or (tp-palette-bg-color pure-palette)
|
|
(face-attribute 'default :background)))
|
|
(border-color (or (tp-palette-border-color pure-palette)
|
|
(face-attribute 'default :foreground))))
|
|
(pcase palette
|
|
((pred tp-palette-p)
|
|
`(face ( :foreground ,fg-color
|
|
:background ,bg-color
|
|
:box (:color ,border-color))))
|
|
((pred tp-palette-fg-p)
|
|
`(face (:foreground ,fg-color)))
|
|
((pred tp-palette-bg-p)
|
|
`(face (:background ,bg-color)))
|
|
((pred tp-palette-fbg-p)
|
|
`(face (:foreground ,fg-color :background ,bg-color)))
|
|
((pred tp-palette-border-p)
|
|
`(face (:box (:color ,border-color))))
|
|
(_ (error "Invalid palette: %S" palette)))))
|
|
|
|
(defun tp-suffix-symbol (symbol string)
|
|
(intern (concat (symbol-name symbol) string)))
|
|
|
|
;;;###autoload
|
|
(defun tp-palette-show ()
|
|
(interactive)
|
|
(let ((alist (seq-reverse tp-palette-alist)))
|
|
(tp-switch-to-buffer "*tp-palette-gallery*"
|
|
(insert
|
|
"Please set " (tp-set "'tp-palette" 'tp-palette 'code)
|
|
" text property with following symbols:\n\n"
|
|
(mapconcat
|
|
(lambda (item)
|
|
(let* ((symbol (car item))
|
|
(name (symbol-name symbol)))
|
|
(concat (tp-set name 'tp-palette symbol)
|
|
" "
|
|
(tp-set (concat name "-fg")
|
|
'tp-palette
|
|
(tp-suffix-symbol symbol "-fg"))
|
|
" "
|
|
(tp-set (concat name "-bg")
|
|
'tp-palette
|
|
(tp-suffix-symbol symbol "-bg"))
|
|
" "
|
|
(tp-set (concat name "-fbg")
|
|
'tp-palette
|
|
(tp-suffix-symbol symbol "-fbg"))
|
|
" "
|
|
(tp-set (concat name "-border")
|
|
'tp-palette
|
|
(tp-suffix-symbol symbol "-border")))))
|
|
alist "\n")))))
|
|
|
|
(define-tp tp-fg (color)
|
|
`(face (:foreground ,color)))
|
|
|
|
(define-tp tp-bg (color)
|
|
`(face (:background ,color)))
|
|
|
|
(define-tp tp-button (type)
|
|
(let ((palette (intern
|
|
(format "%s%s%s" "button-" (symbol-name type) "-fbg"))))
|
|
`( tp-palette ,palette
|
|
mouse-face highlight cursor hand
|
|
face (:box ( :line-width -1
|
|
:style released-button)))))
|
|
|
|
(define-tp tp-underline (color)
|
|
`(face (:underline (:color ,color))))
|
|
|
|
(define-tp tp-delete (color)
|
|
`(face (:strike-through ,color)))
|
|
|
|
(define-tp tp-link ()
|
|
(let ((color (tp-palette-fg-color 'info)))
|
|
`( tp-underline ,color
|
|
tp-palette info-fg
|
|
mouse-face highlight
|
|
cursor hand)))
|
|
|
|
(define-tp tp-space (width)
|
|
`(display (space :width ,width)))
|
|
|
|
(define-tp tp-headline (props)
|
|
(let (height boldp)
|
|
(cond ((floatp props)
|
|
(setq height props boldp t))
|
|
((plistp props)
|
|
(setq height (plist-get props :height)
|
|
boldp (plist-get props :bold))))
|
|
`(face (:height ,height
|
|
,@(when boldp '(:weight bold))))))
|
|
|
|
(define-tp tp-action (sexp)
|
|
;; SEXP is a function or plist
|
|
(let (action keys)
|
|
(if (functionp sexp)
|
|
(progn
|
|
(setq action sexp)
|
|
(setq keys `(,(kbd "RET") [mouse-1])))
|
|
(setq action (plist-get sexp :action))
|
|
(setq keys (or (plist-get sexp :keys)
|
|
`(,(kbd "RET") [mouse-1]))))
|
|
`( keymap ,(let ((keymap (make-sparse-keymap)))
|
|
(dolist (key keys)
|
|
(define-key keymap key action))
|
|
keymap)
|
|
rear-nonsticky (keymap))))
|
|
|
|
(provide 'tp)
|
|
;;; tp.el ends here
|