Split tp.el monolith into layered modules (behavior-preserving)
tp.el (4866 lines) is now an umbrella over nine modules with an enforceable dependency order: tp-core -> tp-reactive -> tp-layer -> tp-ops -> tp-search -> tp-render -> tp-stack -> tp-palette -> tp-builtins. Upward dependencies are inverted through four hook variables installed by tp-render.el. Also: require text-property-search (fixes tp-backward void-function), clip tp-intervals to the requested range, add the shared clipping interval walker tp--map-intervals and tp-face-properties, remove synced-conflict junk files, byte-compilation now succeeds (define-tp macroexpansion previously failed at compile time). All 280 legacy tests pass plus 8 new tp-core tests. Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
This commit is contained in:
Kinneyzhang
parent
af0980efef
commit
5e5017a726
7
.gitignore
vendored
7
.gitignore
vendored
@ -7,3 +7,10 @@ dash.el
|
||||
# Backup files
|
||||
*~
|
||||
\#*\#
|
||||
|
||||
# macOS
|
||||
.DS_Store
|
||||
|
||||
# Syncthing conflict files
|
||||
*.sync-conflict-*
|
||||
.syncthing.*
|
||||
|
||||
Binary file not shown.
@ -1,212 +0,0 @@
|
||||
# tp.el 响应式系统优化文档
|
||||
|
||||
本文档基于 [twidget](https://github.com/Kinneyzhang/twidget.git) 项目的实践经验，对 tp.el 的响应式系统进行了优化和增强。
|
||||
|
||||
## 优化建议评估
|
||||
|
||||
以下是针对 tp.el 响应式系统的六项优化建议的评估和实现情况：
|
||||
|
||||
### 1. 细粒度响应式更新（Granular Reactive Updates）
|
||||
|
||||
**建议**：支持区域内的部分更新，只更新响应式部分，保留周围文本属性。
|
||||
|
||||
**评估**：已经实现。tp.el 通过 `tp-intervals-map` 和基于区间的更新机制，已经支持细粒度的属性更新。更新只影响具有特定 `tp-name` 的区域。
|
||||
|
||||
### 2. 响应式符号清理（Reactive Symbol Cleanup）✅ 已实现
|
||||
|
||||
**建议**：当 widget 销毁时，添加注销响应式符号的机制。
|
||||
|
||||
**评估**：已经实现。`tp--unregister-reactive-deps` 函数负责清理：
|
||||
- 当层被重新定义时自动调用
|
||||
- 当层被取消定义（`tp-undefine-layer`）时自动调用
|
||||
- 清理变量监听器、计算属性和数据变量
|
||||
|
||||
**关键函数**：
|
||||
- `tp--unregister-reactive-deps`
|
||||
- `tp--unregister-layer-watchers`
|
||||
- `tp--unregister-layer-computed`
|
||||
- `tp--unregister-layer-data`
|
||||
|
||||
### 3. 作用域响应式（Scoped Reactivity）✅ 已实现
|
||||
|
||||
**建议**：为响应式变量添加实例/上下文作用域。
|
||||
|
||||
**评估**：已经实现。`where` 参数在以下函数中支持缓冲区局部更新：
|
||||
- `tp--update-layer-regions`
|
||||
- `tp--update-reactive-text`
|
||||
|
||||
当使用 `setq-local` 时，更新只影响特定缓冲区。
|
||||
|
||||
### 4. 批量更新（Batched Updates）🆕 新增
|
||||
|
||||
**建议**：当多个响应式值同时变化时，批量处理更新以避免冗余的缓冲区修改。
|
||||
|
||||
**实现**：新增 `tp-with-batch-updates` 宏：
|
||||
|
||||
```elisp
|
||||
;; 使用批量更新
|
||||
(tp-with-batch-updates
|
||||
(setq my-color "red")
|
||||
(setq my-size 14)
|
||||
(setq my-text "Hello"))
|
||||
;; 所有更新在批量结束后一次性应用到缓冲区
|
||||
```
|
||||
|
||||
**关键函数和变量**：
|
||||
- `tp-with-batch-updates` - 批量更新宏
|
||||
- `tp--batch-update-active` - 标记是否在批量更新中
|
||||
- `tp--batch-update-pending` - 待处理的更新列表
|
||||
- `tp--flush-batch-updates` - 应用所有待处理更新
|
||||
|
||||
### 5. 值转换（Value Transformation）🆕 新增
|
||||
|
||||
**建议**：允许注册转换函数，在 tp-text 更新时运行。
|
||||
|
||||
**实现**：新增 `:transform` 选项：
|
||||
|
||||
```elisp
|
||||
;; 定义带转换的层
|
||||
(define-tp currency-display ()
|
||||
:props '(face bold tp-text $amount)
|
||||
:data '((amount . "100"))
|
||||
:transform (lambda (text)
|
||||
(format "$%s.00" text)))
|
||||
|
||||
;; 使用后，100 会显示为 $100.00
|
||||
```
|
||||
|
||||
**关键函数和变量**：
|
||||
- `tp-layer-transforms` - 存储层转换函数
|
||||
- 转换在 `tp--handle-tp-text-property` 和 `tp--update-reactive-text` 中应用
|
||||
|
||||
### 6. 调试模式（Debug Mode）🆕 新增
|
||||
|
||||
**建议**：添加调试模式以追踪响应式更新。
|
||||
|
||||
**实现**：新增调试功能：
|
||||
|
||||
```elisp
|
||||
;; 启用调试模式
|
||||
(setq tp-debug-mode t)
|
||||
|
||||
;; 同时在 minibuffer 显示调试信息
|
||||
(setq tp-debug-echo t)
|
||||
|
||||
;; 查看调试日志
|
||||
(tp-debug-show)
|
||||
|
||||
;; 清除调试日志
|
||||
(tp-debug-clear)
|
||||
```
|
||||
|
||||
**关键函数和变量**：
|
||||
- `tp-debug-mode` - 启用/禁用调试模式
|
||||
- `tp-debug-echo` - 是否在 minibuffer 显示调试信息
|
||||
- `tp-debug-log` - 记录调试信息
|
||||
- `tp-debug-show` - 显示调试缓冲区
|
||||
- `tp-debug-clear` - 清除调试日志
|
||||
|
||||
调试日志包含：
|
||||
- 变量变化通知（旧值 → 新值）
|
||||
- 层更新追踪
|
||||
- 批量更新开始/结束
|
||||
- 转换应用信息
|
||||
|
||||
## 新增功能详解
|
||||
|
||||
### 批量更新 (tp-with-batch-updates)
|
||||
|
||||
当需要同时修改多个响应式变量时，使用批量更新可以避免多次缓冲区更新：
|
||||
|
||||
```elisp
|
||||
(define-tp themed-text ()
|
||||
:props '(face (:foreground $fg-color :background $bg-color))
|
||||
:data '((fg-color . "white") (bg-color . "black")))
|
||||
|
||||
(with-temp-buffer
|
||||
(insert "Hello World")
|
||||
(tp-set 1 12 'themed-text)
|
||||
|
||||
;; 不使用批量更新：每个 setq 都会触发一次缓冲区更新
|
||||
(setq fg-color "yellow") ; 第一次更新
|
||||
(setq bg-color "navy") ; 第二次更新
|
||||
|
||||
;; 使用批量更新：所有变化在结束时一次性应用
|
||||
(tp-with-batch-updates
|
||||
(setq fg-color "red")
|
||||
(setq bg-color "blue"))) ; 只更新一次
|
||||
```
|
||||
|
||||
### 值转换 (:transform)
|
||||
|
||||
转换函数允许在显示前处理 tp-text 的值：
|
||||
|
||||
```elisp
|
||||
;; 数字格式化
|
||||
(define-tp price-display ()
|
||||
:props '(tp-text $price)
|
||||
:data '((price . "99.9"))
|
||||
:transform (lambda (text)
|
||||
(format "$%.2f" (string-to-number text))))
|
||||
|
||||
;; 日期格式化
|
||||
(define-tp date-display ()
|
||||
:props '(tp-text $timestamp)
|
||||
:data '((timestamp . "1703865600"))
|
||||
:transform (lambda (text)
|
||||
(format-time-string "%Y-%m-%d"
|
||||
(seconds-to-time (string-to-number text)))))
|
||||
|
||||
;; 大写转换
|
||||
(define-tp uppercase-text ()
|
||||
:props '(tp-text $content)
|
||||
:data '((content . "hello"))
|
||||
:transform #'upcase)
|
||||
```
|
||||
|
||||
### 调试模式
|
||||
|
||||
调试模式帮助开发者理解响应式更新流程：
|
||||
|
||||
```elisp
|
||||
;; 启用完整调试
|
||||
(setq tp-debug-mode t)
|
||||
(setq tp-debug-echo t)
|
||||
|
||||
;; 定义和使用响应式层
|
||||
(define-tp test-layer ()
|
||||
:props '(face (:foreground $my-color))
|
||||
:data '((my-color . "red")))
|
||||
|
||||
(with-temp-buffer
|
||||
(insert "Test")
|
||||
(tp-set 1 5 'test-layer)
|
||||
(setq my-color "blue"))
|
||||
|
||||
;; 调试输出示例：
|
||||
;; [12:34:56.789] Variable my-color changed: "red" -> "blue" (where: global)
|
||||
;; [12:34:56.790] Updating layer test-layer (tp-text affected: no)
|
||||
```
|
||||
|
||||
## 架构说明
|
||||
|
||||
这些优化遵循 tp.el 的分层架构原则：
|
||||
|
||||
1. **调试模式** - 作为基础工具层功能
|
||||
2. **批量更新** - 在响应式系统层实现
|
||||
3. **值转换** - 在层定义和响应式文本处理中实现
|
||||
|
||||
所有新功能都与现有的响应式系统无缝集成，不破坏现有 API。
|
||||
|
||||
## 相关函数一览
|
||||
|
||||
| 函数/变量 | 描述 |
|
||||
|----------|------|
|
||||
| `tp-debug-mode` | 启用调试模式 |
|
||||
| `tp-debug-echo` | 启用 minibuffer 调试输出 |
|
||||
| `tp-debug-log` | 记录调试信息 |
|
||||
| `tp-debug-show` | 显示调试缓冲区 |
|
||||
| `tp-debug-clear` | 清除调试日志 |
|
||||
| `tp-with-batch-updates` | 批量更新宏 |
|
||||
| `tp-layer-transforms` | 层转换函数存储 |
|
||||
| `:transform` | 层定义中的转换选项 |
|
||||
@ -1,507 +0,0 @@
|
||||
# tp.el Complete Guide to Reactive Text Properties
|
||||
|
||||
> Bringing modern frontend framework reactive programming paradigms to the Emacs text properties world
|
||||
|
||||
## Introduction
|
||||
|
||||
In traditional Emacs development, managing text properties has always been a tedious task. Whenever you want to change a property value, you need to manually find all related text regions and update them one by one. This approach is not only error-prone but also difficult to maintain.
|
||||
|
||||
**Reactive Text Properties** is one of the most innovative features in the tp.el library. It borrows the reactive programming concepts from modern frontend frameworks like Vue.js and React, allowing Emacs text properties to **automatically respond to variable changes**.
|
||||
|
||||
Imagine: you define the relationship between a variable and a property once, and from then on, whenever you change the variable's value, all text regions using that variable will **automatically update**. This is the magic of reactive text properties!
|
||||
|
||||
## From Traditional to Reactive
|
||||
|
||||
### Pain Points of the Traditional Approach
|
||||
|
||||
Let's first look at how the traditional approach handles dynamic text properties:
|
||||
|
||||
```lisp
|
||||
;; Traditional approach: define a color variable
|
||||
(defvar my-color "red")
|
||||
|
||||
(tp-pop-to-buffer "*tp-test*"
|
||||
(insert "Hello World")
|
||||
(tp-set 1 12 `(face (:foreground ,my-color)))
|
||||
|
||||
;; Here comes the problem: when you want to change the color...
|
||||
(setq my-color "blue")
|
||||
;; The text doesn't update automatically! You must manually reapply:
|
||||
(tp-set 1 12 `(face (:foreground ,my-color))))
|
||||
```
|
||||
|
||||
The problems with this approach are obvious:
|
||||
1. **Manual tracking**: You need to remember which text regions use which variables
|
||||
2. **Easy to miss**: In complex applications, it's easy to forget to update some regions
|
||||
3. **Code redundancy**: Update logic is scattered throughout the code
|
||||
|
||||
### The Elegance of Reactive Approach
|
||||
|
||||
Now let's see how the reactive approach solves these problems:
|
||||
|
||||
```lisp
|
||||
;; Reactive approach: define a color variable
|
||||
(defvar my-color "red")
|
||||
|
||||
;; Define a reactive layer using $my-color to reference the variable
|
||||
(define-tp my-highlight ()
|
||||
'(face (:foreground $my-color)))
|
||||
|
||||
;; Apply to text
|
||||
(tp-pop-to-buffer "*tp-test*"
|
||||
(insert "Hello World")
|
||||
(tp-set 1 12 'my-highlight)
|
||||
|
||||
;; Now, just change the variable!
|
||||
(setq my-color "blue")
|
||||
;; Magic happens: the text automatically turns blue!
|
||||
)
|
||||
```
|
||||
|
||||
Isn't that amazing? Let's dive deep into how this powerful feature works.
|
||||
|
||||
## Core Concepts
|
||||
|
||||
### Reactive Variables
|
||||
|
||||
In tp.el, any symbol starting with `$` is treated as a **reactive variable**. For example:
|
||||
- `$my-color` → references variable `my-color`
|
||||
- `$font-size` → references variable `font-size`
|
||||
- `$theme-background` → references variable `theme-background`
|
||||
|
||||
When you use these `$`-prefixed symbols in property definitions, tp.el will:
|
||||
1. Automatically resolve the variable's current value
|
||||
2. Register a watcher to monitor variable changes
|
||||
3. When the variable changes, automatically update all related text regions
|
||||
|
||||
## Basic Usage
|
||||
|
||||
### Your First Reactive Layer
|
||||
|
||||
Let's start with a simple example:
|
||||
|
||||
```lisp
|
||||
;; Define a global variable
|
||||
(defvar highlight-bg "yellow")
|
||||
|
||||
;; Define a reactive layer
|
||||
(define-tp simple-highlight ()
|
||||
'(face (:background $highlight-bg)))
|
||||
|
||||
;; Create a test buffer and apply the layer
|
||||
(tp-pop-to-buffer "*tp-test*"
|
||||
(insert "This is text that needs highlighting")
|
||||
(tp-set 1 (point-max) 'simple-highlight)
|
||||
;; => "Initial background color: yellow"
|
||||
;; Change the variable
|
||||
(setq highlight-bg "cyan")
|
||||
;; => "Updated background color: cyan"
|
||||
)
|
||||
```
|
||||
|
||||
### Multiple Reactive Variables
|
||||
|
||||
A layer can reference multiple reactive variables:
|
||||
|
||||
```lisp
|
||||
;; Define multiple variables
|
||||
(defvar fg-color "white")
|
||||
(defvar bg-color "darkGreen")
|
||||
(defvar underline-color "red")
|
||||
|
||||
;; Define a layer using multiple variables
|
||||
(define-tp multi-var-layer ()
|
||||
'(face ( :foreground $fg-color
|
||||
:background $bg-color
|
||||
:underline (:color $underline-color))))
|
||||
|
||||
;; Test
|
||||
(tp-pop-to-buffer "*tp-test*"
|
||||
(insert "Multi-variable reactive example")
|
||||
(tp-set 1 (point-max) 'multi-var-layer)
|
||||
|
||||
;; Changing any variable triggers an update
|
||||
(setq fg-color "yellow") ; Foreground turns yellow
|
||||
(setq bg-color "navy") ; Background turns navy
|
||||
(setq underline-color "lime") ; Underline turns lime green
|
||||
)
|
||||
```
|
||||
|
||||
## Advanced Features: :data, :compute, and :watch
|
||||
|
||||
tp.el's reactive system borrows from Vue's API, providing three powerful keywords:
|
||||
|
||||
### :data - Define Additional Reactive State
|
||||
|
||||
Sometimes you need reactive variables that aren't directly used in `:props`. This is where `:data` comes in.
|
||||
|
||||
Main uses of `:data`:
|
||||
1. Define auxiliary variables that don't appear directly in properties
|
||||
2. Provide initial values for variables
|
||||
3. Work together with `:compute`
|
||||
|
||||
### :compute - Computed Properties
|
||||
|
||||
`:compute` lets you define **derived values**—their values are computed from other variables:
|
||||
|
||||
```lisp
|
||||
;; Complete computed properties example
|
||||
(define-tp computed-greeting ()
|
||||
:props '(display $full-greeting face (:foreground $status-color))
|
||||
:data '((user-name . "John")
|
||||
(greeting-prefix . "Hello"))
|
||||
:compute '((full-greeting (lambda ()
|
||||
(format "%s, %s! Welcome back."
|
||||
greeting-prefix user-name)))
|
||||
(status-color (lambda ()
|
||||
(if (string= user-name "Admin")
|
||||
"red"
|
||||
"green")))))
|
||||
|
||||
;; Test
|
||||
(tp-pop-to-buffer "*tp-test*"
|
||||
(insert "Test text")
|
||||
(tp-set 1 (point-max) 'computed-greeting)
|
||||
;; Initial state
|
||||
(message "full-greeting = %s" full-greeting)
|
||||
;; => "Hello, John! Welcome back."
|
||||
(message "status-color = %s" status-color)
|
||||
;; => "green"
|
||||
;; Change user-name
|
||||
(setq user-name "Admin")
|
||||
;; Computed properties update automatically!
|
||||
(message "full-greeting = %s" full-greeting)
|
||||
;; => "Hello, Admin! Welcome back."
|
||||
(message "status-color = %s" status-color)
|
||||
;; => "red"
|
||||
;; Change greeting-prefix
|
||||
(setq greeting-prefix "Hi")
|
||||
(message "full-greeting = %s" full-greeting))
|
||||
;; => "Hi, Admin! Welcome back."
|
||||
```
|
||||
|
||||
### :watch - Watch Variable Changes
|
||||
|
||||
`:watch` lets you execute **side effect** operations when variables change:
|
||||
|
||||
```lisp
|
||||
;; Layer with watchers
|
||||
(define-tp watched-layer ()
|
||||
:props '(face (:foreground $status-color))
|
||||
:data '((status-color . "green"))
|
||||
:watch '((status-color
|
||||
(lambda (new-val old-val layer-name)
|
||||
(message "[%s] Color changed from %s to %s"
|
||||
layer-name old-val new-val)))))
|
||||
|
||||
;; Test
|
||||
(tp-pop-to-buffer "*tp-test*"
|
||||
(insert "Test text")
|
||||
(tp-set 1 (point-max) 'watched-layer)
|
||||
|
||||
;; Change color - triggers watcher
|
||||
(setq status-color "yellow")
|
||||
;; Message: "[watched-layer] Color changed from green to yellow"
|
||||
|
||||
(setq status-color "red"))
|
||||
;; Message: "[watched-layer] Color changed from yellow to red"
|
||||
```
|
||||
|
||||
Typical uses for `:watch`:
|
||||
- Logging
|
||||
- Updating external state
|
||||
- Triggering notifications
|
||||
- Performing cleanup operations
|
||||
|
||||
## Complete Practical Examples
|
||||
|
||||
### Example 1: Dynamic Color Status Indicator
|
||||
|
||||
This example shows how to create an indicator that automatically changes color based on status:
|
||||
|
||||
```lisp
|
||||
(tp-layer-reset)
|
||||
|
||||
;; Define status color variables
|
||||
(defvar status-color "gray")
|
||||
(defvar status-text "Not Started")
|
||||
|
||||
;; Define status indicator layer
|
||||
(define-tp status-indicator ()
|
||||
'(face (:background $status-color) display $status-text))
|
||||
|
||||
;; Define status update function
|
||||
(defun set-status (status)
|
||||
"Set status, automatically update color and text"
|
||||
(pcase status
|
||||
('pending (setq status-color "gray" status-text "Pending"))
|
||||
('running (setq status-color "blue" status-text "Running"))
|
||||
('success (setq status-color "green" status-text "Success"))
|
||||
('warning (setq status-color "orange" status-text "Warning"))
|
||||
('error (setq status-color "red" status-text "Error"))))
|
||||
|
||||
;; Test the status indicator
|
||||
(tp-pop-to-buffer "*tp-test*"
|
||||
(insert "Status")
|
||||
(tp-set 1 (point-max) 'status-indicator)
|
||||
|
||||
;; Simulate status changes
|
||||
(set-status 'pending)
|
||||
(message "Status: %s, Color: %s" status-text status-color)
|
||||
;; => "Status: Pending, Color: gray"
|
||||
|
||||
(set-status 'running)
|
||||
(message "Status: %s, Color: %s" status-text status-color)
|
||||
;; => "Status: Running, Color: blue"
|
||||
|
||||
(set-status 'success)
|
||||
(message "Status: %s, Color: %s" status-text status-color))
|
||||
;; => "Status: Success, Color: green"
|
||||
```
|
||||
|
||||
### Example 2: Theme Switching System
|
||||
|
||||
This example shows how to create a switchable theme system:
|
||||
|
||||
```lisp
|
||||
(tp-layer-reset)
|
||||
|
||||
;; Define theme color variables
|
||||
(defvar keyword-color nil)
|
||||
(defvar string-color nil)
|
||||
|
||||
;; Define theme-related reactive layers
|
||||
(define-tp themed-keyword ()
|
||||
'(face (:foreground $keyword-color :weight bold)))
|
||||
|
||||
(define-tp themed-string ()
|
||||
'(face (:foreground $string-color)))
|
||||
|
||||
;; Define theme switching functions
|
||||
(defun switch-to-dark-theme ()
|
||||
"Switch to dark theme"
|
||||
(interactive)
|
||||
(setq keyword-color "light blue"
|
||||
string-color "green")
|
||||
(message "Switched to dark theme"))
|
||||
|
||||
(defun switch-to-light-theme ()
|
||||
"Switch to light theme"
|
||||
(interactive)
|
||||
(setq keyword-color "blue"
|
||||
string-color "dark green")
|
||||
(message "Switched to light theme"))
|
||||
|
||||
;; Test theme switching
|
||||
(tp-pop-to-buffer "*tp-test*"
|
||||
(insert "(defun hello () \"greeting\")")
|
||||
|
||||
;; Apply different theme layers
|
||||
(tp-match-set "defun" 'themed-keyword)
|
||||
(tp-regexp-set "\".+\"" 'themed-string)
|
||||
|
||||
(switch-to-dark-theme)
|
||||
;; Initially using dark theme
|
||||
(message "Keyword color: %s" keyword-color)
|
||||
(message "String color: %s" string-color)
|
||||
|
||||
;; Switch to light theme
|
||||
(switch-to-light-theme)
|
||||
;; Text updates automatically!
|
||||
(message "Keyword color: %s" keyword-color)
|
||||
(message "String color: %s" string-color))
|
||||
```
|
||||
|
||||
## Anonymous Reactive Layers
|
||||
|
||||
Besides using `define-tp` to define named layers, you can also use reactive variables directly in property lists. tp.el will automatically generate unique names for these anonymous layers:
|
||||
|
||||
```lisp
|
||||
(tp-layer-reset)
|
||||
|
||||
(defvar inline-color "purple")
|
||||
|
||||
(tp-pop-to-buffer "*tp-test*"
|
||||
(insert "Anonymous reactive layer example")
|
||||
|
||||
;; Use $inline-color directly, no need to pre-define a layer
|
||||
(tp-set 1 (point-max) '(face (:foreground $inline-color)))
|
||||
|
||||
;; Text is now purple
|
||||
(message "Color: %s" (plist-get (tp-at 1 'face) :foreground))
|
||||
;; => "purple"
|
||||
|
||||
;; Change the variable
|
||||
(setq inline-color "orange")
|
||||
|
||||
;; Text automatically turns orange
|
||||
(message "Color: %s" (plist-get (tp-at 1 'face) :foreground)))
|
||||
;; => "orange"
|
||||
```
|
||||
|
||||
Anonymous reactive layers are suitable for simple scenarios where you don't need to reuse the same layer definition in multiple places.
|
||||
|
||||
## Reactive Text (tp-text)
|
||||
|
||||
Besides reactive text **properties**, tp.el also supports reactive **text content** itself. Through the special `tp-text` property, you can make the text content reactive too—when the bound variable changes, the text content automatically updates.
|
||||
|
||||
### Basic Usage
|
||||
|
||||
The `tp-text` property has two ways to use:
|
||||
|
||||
#### 1. Initialize with Current Text
|
||||
|
||||
When `tp-text` is `nil`, it will be automatically set to the current region's text content:
|
||||
|
||||
```lisp
|
||||
(tp-pop-to-buffer "*tp-test*"
|
||||
(insert "Hello World")
|
||||
;; When tp-text is nil, auto-initialize to current text "Hello"
|
||||
(tp-set 1 6 '(face bold tp-text nil))
|
||||
;; Now tp-text value is "Hello"
|
||||
(message "tp-text = %s" (tp-at 1 'tp-text)))
|
||||
;; => "Hello"
|
||||
```
|
||||
|
||||
#### 2. Replace Text Content
|
||||
|
||||
When `tp-text` is a string, it replaces the text in the region while preserving other text properties:
|
||||
|
||||
```lisp
|
||||
(tp-pop-to-buffer "*tp-test*"
|
||||
(insert "Hello World")
|
||||
;; When tp-text is a string, replace the text content
|
||||
(tp-set 1 6 '(face bold tp-text "Hi"))
|
||||
;; Text becomes "Hi World", and "Hi" still has bold style
|
||||
(message "buffer = %s" (buffer-string)))
|
||||
;; => "Hi World"
|
||||
```
|
||||
|
||||
### Reactive Text Layers
|
||||
|
||||
The real power of `tp-text` comes from combining it with reactive variables:
|
||||
|
||||
```lisp
|
||||
;; Define a reactive variable
|
||||
(defvar my-dynamic-text "Loading...")
|
||||
|
||||
;; Define a layer containing tp-text
|
||||
(define-tp dynamic-content ()
|
||||
:props '(face (:foreground "blue") tp-text $my-dynamic-text))
|
||||
|
||||
;; Apply to text
|
||||
(tp-pop-to-buffer "*tp-test*"
|
||||
(insert "placeholder")
|
||||
(tp-set 1 12 'dynamic-content)
|
||||
;; Text now shows "Loading..."
|
||||
(message "Initial text: %s" (buffer-string))
|
||||
;; => "Loading... "
|
||||
|
||||
;; Change the variable
|
||||
(setq my-dynamic-text "Data loaded successfully!")
|
||||
;; Text updates automatically!
|
||||
(message "After update: %s" (buffer-string)))
|
||||
;; => "Data loaded successfully! "
|
||||
```
|
||||
|
||||
### Using :compute for Dynamic Text
|
||||
|
||||
`tp-text` can be combined with `:compute` to create dynamic text derived from other variables:
|
||||
|
||||
```lisp
|
||||
(define-tp greeting-layer ()
|
||||
:props '(face (:foreground "green") tp-text $full-greeting)
|
||||
:data '((user-name . "Guest")
|
||||
(greeting-prefix . "Welcome"))
|
||||
:compute '((full-greeting
|
||||
(lambda ()
|
||||
(format "%s, %s!" greeting-prefix user-name)))))
|
||||
|
||||
;; Apply to text
|
||||
(tp-pop-to-buffer "*tp-test*"
|
||||
(insert "placeholder")
|
||||
(tp-set 1 12 'greeting-layer)
|
||||
;; Shows "Welcome, Guest!"
|
||||
(message "Initial: %s" (buffer-string))
|
||||
|
||||
;; Change user name
|
||||
(setq user-name "John")
|
||||
;; Text automatically updates to "Welcome, John!"
|
||||
(message "After update: %s" (buffer-string)))
|
||||
```
|
||||
|
||||
### Anonymous Reactive Text
|
||||
|
||||
You can also use reactive `tp-text` directly in property lists without defining a layer:
|
||||
|
||||
```lisp
|
||||
(defvar inline-text "Original content")
|
||||
|
||||
(tp-pop-to-buffer "*tp-test*"
|
||||
(insert "placeholder")
|
||||
;; Directly use reactive tp-text
|
||||
(tp-set 1 12 '(face bold tp-text $inline-text))
|
||||
;; Shows "Original content"
|
||||
|
||||
;; Change the variable
|
||||
(setq inline-text "New content")
|
||||
;; Text automatically updates to "New content"
|
||||
)
|
||||
```
|
||||
|
||||
### Important Notes
|
||||
|
||||
1. **tp-text only affects buffer text**: For string objects, since Emacs string length is fixed, `tp-text` won't replace string content.
|
||||
2. **Preserves existing properties**: When using `tp-set` or `tp-add` to set `tp-text`, existing text properties are preserved.
|
||||
3. **Non-reactive properties don't add tp-name**: If there are no reactive variables (`$` prefix) in the text properties, `tp-name` and other reactive-specific properties won't be added, maintaining native text property behavior.
|
||||
|
||||
## Value Transformation with :transform
|
||||
|
||||
The `:transform` keyword allows you to register a transformation function that processes `tp-text` values before they are displayed. This is useful for formatting numbers, dates, or other values:
|
||||
|
||||
```lisp
|
||||
;; Number formatting
|
||||
(define-tp price-display ()
|
||||
:props '(tp-text $price)
|
||||
:data '((price . "99.9"))
|
||||
:transform (lambda (text)
|
||||
(format "$%.2f" (string-to-number text))))
|
||||
;; 99.9 displays as $99.00
|
||||
|
||||
;; Date formatting
|
||||
(define-tp date-display ()
|
||||
:props '(tp-text $timestamp)
|
||||
:data '((timestamp . "1703865600"))
|
||||
:transform (lambda (text)
|
||||
(format-time-string "%Y-%m-%d"
|
||||
(seconds-to-time (string-to-number text)))))
|
||||
|
||||
;; Uppercase conversion
|
||||
(define-tp uppercase-text ()
|
||||
:props '(tp-text $content)
|
||||
:data '((content . "hello"))
|
||||
:transform #'upcase)
|
||||
;; "hello" displays as "HELLO"
|
||||
```
|
||||
|
||||
The transform function:
|
||||
- Receives the raw `tp-text` string value
|
||||
- Returns the transformed string for display
|
||||
- Is applied both on initial display and reactive updates
|
||||
- Errors in transform functions are caught and logged
|
||||
|
||||
> 📖 **For more optimization features like batched updates and debug mode, see [Reactive System Optimization](reactive-optimization-en.md)**
|
||||
|
||||
## Summary
|
||||
|
||||
tp.el's reactive text properties feature brings a modern reactive programming experience to Emacs development. By using `$`-prefixed reactive variables, `:data` to define state, `:compute` for derived values, `:watch` to monitor changes, and `:transform` for value formatting, you can build a more dynamic and maintainable text property system.
|
||||
|
||||
Key points:
|
||||
1. **Reactive Variables**: Use `$` prefix to reference variables
|
||||
2. **:props**: Define properties containing reactive variables
|
||||
3. **:data**: Define additional reactive state and initial values
|
||||
4. **:compute**: Define computed properties derived from other variables
|
||||
5. **:watch**: Watch variable changes and execute side effects
|
||||
6. **:transform**: Transform tp-text values before display
|
||||
7. **Automatic Updates**: Change variable values, all related text updates automatically
|
||||
8. **Reactive Text (tp-text)**: Make text content itself reactive
|
||||
163
tp-builtins.el
Normal file
163
tp-builtins.el
Normal file
@ -0,0 +1,163 @@
|
||||
;;; tp-builtins.el --- Built-in layers and display helpers for tp -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2024-2026 Geekinney
|
||||
|
||||
;; Author: Geekinney (kinneyzhang666@gmail.com)
|
||||
|
||||
;; This program is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation; either version 3 of
|
||||
;; the License, or (at your option) any later version.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Batteries: the built-in layers (tp-fg, tp-bg, tp-button, tp-link,
|
||||
;; tp-space, tp-headline, tp-action, ...), the palette gallery command
|
||||
;; `tp-palette-show', and the read-only display buffer macros.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'tp-core)
|
||||
(require 'tp-layer)
|
||||
(require 'tp-ops)
|
||||
(require 'tp-palette)
|
||||
|
||||
(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)))
|
||||
|
||||
(define-tp tp-palette (palette)
|
||||
(let* ((pure-palette (tp-palette-pure palette))
|
||||
(fg-color (tp-palette-fg-color pure-palette))
|
||||
(bg-color (tp-palette-bg-color pure-palette))
|
||||
(border-color (tp-palette-border-color pure-palette)))
|
||||
(pcase palette
|
||||
((pred tp-palette-p)
|
||||
`(face (,@(when fg-color (list :foreground fg-color))
|
||||
,@(when bg-color (list :background bg-color))
|
||||
,@(when border-color (list :box (list :color border-color))))))
|
||||
((pred tp-palette-fg-p)
|
||||
`(face (,@(when fg-color (list :foreground fg-color)))))
|
||||
((pred tp-palette-bg-p)
|
||||
`(face (,@(when bg-color (list :background bg-color)))))
|
||||
((pred tp-palette-fbg-p)
|
||||
`(face (,@(when fg-color (list :foreground fg-color))
|
||||
,@(when bg-color (list :background bg-color)))))
|
||||
((pred tp-palette-border-p)
|
||||
`(face (,@(when border-color (list :box (list :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 pointer 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
|
||||
pointer 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-builtins)
|
||||
;;; tp-builtins.el ends here
|
||||
72
tp-core-tests.el
Normal file
72
tp-core-tests.el
Normal file
@ -0,0 +1,72 @@
|
||||
;;; tp-core-tests.el --- ERT tests for tp-core.el -*- lexical-binding: t -*-
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Unit tests for the tp-core foundation module.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'tp-core)
|
||||
|
||||
;;; tp--map-intervals
|
||||
|
||||
(ert-deftest tp-core-test-map-intervals-string-clips ()
|
||||
"Intervals extending beyond the range are clipped to it."
|
||||
(let ((str (copy-sequence "hello world")))
|
||||
(put-text-property 0 11 'face 'bold str)
|
||||
(should (equal (tp--map-intervals str 3 7 #'list)
|
||||
'((3 7 (face bold)))))))
|
||||
|
||||
(ert-deftest tp-core-test-map-intervals-string-full ()
|
||||
"Full-range walk over a string returns each property run."
|
||||
(let ((str (copy-sequence "hello world")))
|
||||
(put-text-property 0 5 'face 'bold str)
|
||||
(should (equal (tp--map-intervals str nil nil #'list)
|
||||
'((0 5 (face bold)) (5 11 nil))))))
|
||||
|
||||
(ert-deftest tp-core-test-map-intervals-single-property ()
|
||||
"PROPERTY narrows runs to that property and passes its value."
|
||||
(let ((str (copy-sequence "hello world")))
|
||||
(put-text-property 0 5 'face 'bold str)
|
||||
(put-text-property 2 8 'help-echo "tip" str)
|
||||
(should (equal (tp--map-intervals str nil nil #'list 'face)
|
||||
'((0 5 bold) (5 11 nil))))))
|
||||
|
||||
(ert-deftest tp-core-test-map-intervals-buffer-clips ()
|
||||
"Buffer walk clips to the requested range with 1-based positions."
|
||||
(with-temp-buffer
|
||||
(insert "hello world")
|
||||
(put-text-property 1 12 'face 'bold)
|
||||
(should (equal (tp--map-intervals nil 4 8 #'list)
|
||||
'((4 8 (face bold)))))))
|
||||
|
||||
(ert-deftest tp-core-test-map-intervals-buffer-multiple-runs ()
|
||||
"Multiple runs in a buffer are visited in order, gaps included."
|
||||
(with-temp-buffer
|
||||
(insert "hello world")
|
||||
(put-text-property 1 6 'face 'bold)
|
||||
(put-text-property 7 12 'face 'italic)
|
||||
(should (equal (tp--map-intervals nil nil nil #'list 'face)
|
||||
'((1 6 bold) (6 7 nil) (7 12 italic))))))
|
||||
|
||||
(ert-deftest tp-core-test-map-intervals-out-of-range-normalized ()
|
||||
"Out-of-bounds START/END are clamped, not signaled."
|
||||
(let ((str (copy-sequence "abc")))
|
||||
(put-text-property 0 3 'p 1 str)
|
||||
(should (equal (tp--map-intervals str -5 99 #'list 'p)
|
||||
'((0 3 1))))))
|
||||
|
||||
(ert-deftest tp-core-test-map-intervals-empty-range ()
|
||||
"An empty range visits nothing."
|
||||
(let ((str (copy-sequence "abc")))
|
||||
(should (equal (tp--map-intervals str 1 1 #'list) nil))))
|
||||
|
||||
;;; tp-face-properties
|
||||
|
||||
(ert-deftest tp-core-test-face-properties ()
|
||||
"The face-family property list contains the three face properties."
|
||||
(should (equal tp-face-properties '(face font-lock-face mouse-face))))
|
||||
|
||||
(provide 'tp-core-tests)
|
||||
;;; tp-core-tests.el ends here
|
||||
750
tp-core.el
Normal file
750
tp-core.el
Normal file
@ -0,0 +1,750 @@
|
||||
;;; tp-core.el --- Foundation utilities for tp -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2024-2026 Geekinney
|
||||
|
||||
;; Author: Geekinney (kinneyzhang666@gmail.com)
|
||||
|
||||
;; This program is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation; either version 3 of
|
||||
;; the License, or (at your option) any later version.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Foundation layer of the tp library. No dependencies on other tp
|
||||
;; modules. Provides: debug logging, interval/property inspection
|
||||
;; (`tp-intervals', `tp-plist', `tp-empty-p', `tp-intervals-map'),
|
||||
;; plist utilities (deep merge, duplicate-key merge, nested access),
|
||||
;; the face merge engine, pure reactive-symbol ($var) utilities, and
|
||||
;; small shared helpers.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'dash)
|
||||
(require 'seq)
|
||||
|
||||
(defgroup tp nil
|
||||
"Group for tp.el text property manipulation."
|
||||
:prefix "tp-"
|
||||
:group 'development)
|
||||
|
||||
(defvar tp--anonymous-layer-counter 0
|
||||
"Counter for generating unique anonymous layer names.")
|
||||
|
||||
(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)
|
||||
|
||||
(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))
|
||||
|
||||
(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*")))
|
||||
|
||||
(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)))
|
||||
|
||||
(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)))
|
||||
|
||||
(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.
|
||||
Intervals that extend beyond the requested range are clipped to it, so
|
||||
returned positions never fall outside [START, END)."
|
||||
(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 (- (max (nth 0 tp) filter-start) offset))
|
||||
(tp-end (- (min (nth 1 tp) filter-end) 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)))
|
||||
|
||||
(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))))
|
||||
|
||||
(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--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)))
|
||||
|
||||
(defconst tp-face-properties '(face font-lock-face mouse-face)
|
||||
"Text properties whose values follow face merging semantics.
|
||||
These properties hold face specs (symbols, plists or lists thereof)
|
||||
and are merged with face-aware logic instead of plain replacement.")
|
||||
|
||||
(defun tp--map-intervals (object start end function &optional property)
|
||||
"Iterate property intervals of OBJECT between START and END, clipped.
|
||||
|
||||
OBJECT is a string, a buffer, or nil for the current buffer.
|
||||
FUNCTION is called with (ISTART IEND VALUE) for each interval, where
|
||||
ISTART/IEND are clipped to the [START, END) range and expressed in
|
||||
OBJECT's native coordinates (0-based for strings, 1-based for
|
||||
buffers). START and END may be nil, meaning the object's bounds.
|
||||
|
||||
When PROPERTY is nil, intervals are maximal runs with an identical
|
||||
full property list and VALUE is that plist. When PROPERTY is
|
||||
non-nil, intervals are maximal runs of `eq' values of that single
|
||||
property and VALUE is the property's value (which may be nil).
|
||||
|
||||
Unlike `tp-intervals', intervals that extend beyond the requested
|
||||
range are clipped to it, so FUNCTION never sees positions outside
|
||||
\[START, END). Returns the list of FUNCTION's return values, in
|
||||
order."
|
||||
(let* ((is-string (stringp object))
|
||||
(buf (unless is-string (or object (current-buffer)))))
|
||||
(if is-string
|
||||
(let* ((min-pos 0)
|
||||
(max-pos (length object))
|
||||
(from (max (or start min-pos) min-pos))
|
||||
(to (min (or end max-pos) max-pos))
|
||||
(pos from)
|
||||
(results nil))
|
||||
(while (< pos to)
|
||||
(let ((next (if property
|
||||
(or (next-single-property-change
|
||||
pos property object to)
|
||||
to)
|
||||
(or (next-property-change pos object to) to)))
|
||||
(val (if property
|
||||
(get-text-property pos property object)
|
||||
(text-properties-at pos object))))
|
||||
(push (funcall function pos next val) results)
|
||||
(setq pos next)))
|
||||
(nreverse results))
|
||||
(with-current-buffer buf
|
||||
(let* ((from (max (or start (point-min)) (point-min)))
|
||||
(to (min (or end (point-max)) (point-max)))
|
||||
(pos from)
|
||||
(results nil))
|
||||
(while (< pos to)
|
||||
(let ((next (if property
|
||||
(or (next-single-property-change pos property nil to)
|
||||
to)
|
||||
(or (next-property-change pos nil to) to)))
|
||||
(val (if property
|
||||
(get-text-property pos property)
|
||||
(text-properties-at pos))))
|
||||
(push (funcall function pos next val) results)
|
||||
(setq pos next)))
|
||||
(nreverse results))))))
|
||||
|
||||
(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))))
|
||||
|
||||
(provide 'tp-core)
|
||||
;;; tp-core.el ends here
|
||||
1133
tp-layer.el
Normal file
1133
tp-layer.el
Normal file
File diff suppressed because it is too large
Load Diff
863
tp-ops.el
Normal file
863
tp-ops.el
Normal file
@ -0,0 +1,863 @@
|
||||
;;; tp-ops.el --- Core text property operations for tp -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2024-2026 Geekinney
|
||||
|
||||
;; Author: Geekinney (kinneyzhang666@gmail.com)
|
||||
|
||||
;; This program is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation; either version 3 of
|
||||
;; the License, or (at your option) any later version.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; The public property primitives: `tp-set', `tp-reset', `tp-add',
|
||||
;; `tp-get', `tp-at', `tp-remove', `tp-clear', built on the shared
|
||||
;; argument parser. Layer names in property specs are resolved through
|
||||
;; tp-layer.el. The reactive `tp-text' property is handled through
|
||||
;; `tp--tp-text-handler-function', installed by tp-render.el.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'dash)
|
||||
(require 'tp-core)
|
||||
(require 'tp-layer)
|
||||
|
||||
(defvar tp--tp-text-handler-function nil
|
||||
"Function that handles the reactive `tp-text' property, or nil.
|
||||
Installed by tp-render.el. Called with (START END PROPS OBJECT
|
||||
PRESERVE-PROPS MERGE-MODE) and must return (PROPS NEW-END NEW-OBJECT).
|
||||
When nil, `tp-text' is treated as an ordinary text property.")
|
||||
|
||||
(defun tp--handle-tp-text (start end props object preserve-props merge-mode)
|
||||
"Dispatch `tp-text' handling for PROPS between START and END in OBJECT.
|
||||
PRESERVE-PROPS and MERGE-MODE are forwarded to the installed handler.
|
||||
Returns (PROPS NEW-END NEW-OBJECT); a pass-through when no handler is
|
||||
installed (see `tp--tp-text-handler-function')."
|
||||
(if tp--tp-text-handler-function
|
||||
(funcall tp--tp-text-handler-function
|
||||
start end props object preserve-props merge-mode)
|
||||
(list props end object)))
|
||||
|
||||
(defun tp--parse-args (start-or-string end-or-prop props-or-val rest)
|
||||
"Parse flexible function arguments and return (OBJECT START END PROPS).
|
||||
Supports multiple calling conventions:
|
||||
1. Buffer region: (START END PROPS)
|
||||
2. Buffer region with object: (START END PROPS OBJECT)
|
||||
3. String region: (START END PROPS STRING)
|
||||
4. Entire string with plist: (STRING PROP VAL ...)
|
||||
5. Entire string with layer: (STRING LAYER-NAME ARG)
|
||||
6. Entire string with layer and extra props: (STRING LAYER-NAME ARG PROP VAL ...)"
|
||||
(let (object start finish props)
|
||||
(cond
|
||||
;; First arg is a string - apply to entire string
|
||||
((stringp start-or-string)
|
||||
(setq object start-or-string
|
||||
start 0
|
||||
finish (length start-or-string))
|
||||
;; Check if second arg is a layer/group name or parameterized layer
|
||||
(cond
|
||||
;; (tp-set "str" 'layer-name arg ...) - layer with argument and optional extra props
|
||||
((and (symbolp end-or-prop)
|
||||
(or (assoc end-or-prop tp-layer-alist)
|
||||
(assoc end-or-prop tp-layer-groups))
|
||||
props-or-val)
|
||||
;; Build props: (layer-name arg extra-prop1 val1 ...)
|
||||
(setq props (cons end-or-prop (cons props-or-val rest))))
|
||||
;; (tp-set "str" 'layer-name) - layer without argument (legacy)
|
||||
((and (symbolp end-or-prop)
|
||||
(or (assoc end-or-prop tp-layer-alist)
|
||||
(assoc end-or-prop tp-layer-groups))
|
||||
(null props-or-val)
|
||||
(null rest))
|
||||
(setq props (list end-or-prop)))
|
||||
;; Standard flat plist: (tp-set "str" 'prop1 val1 'prop2 val2 ...)
|
||||
;; Always include props-or-val even if it's nil, to handle (tp-set "str" 'prop nil)
|
||||
(t
|
||||
(setq props (if end-or-prop
|
||||
(cons end-or-prop (cons props-or-val rest))
|
||||
nil)))))
|
||||
;; First arg is a number - region convention
|
||||
((numberp start-or-string)
|
||||
(setq start start-or-string
|
||||
finish end-or-prop
|
||||
props props-or-val)
|
||||
;; Check if 4th arg (first of rest) is a buffer or string
|
||||
(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.
|
||||
Preserves the original text property intervals.
|
||||
|
||||
MERGE-MODE controls how properties are applied:
|
||||
nil or :set - Set properties, preserving existing unspecified ones
|
||||
:reset - Completely replace all properties
|
||||
:add - Merge properties deeply (for face, prepend symbols)
|
||||
|
||||
Returns a new propertized string."
|
||||
(let* ((len (length str))
|
||||
;; Ensure bounds are valid
|
||||
(start (max 0 start))
|
||||
(end (min end len)))
|
||||
(cond
|
||||
;; :reset - completely replace properties in the range
|
||||
((eq merge-mode :reset)
|
||||
(let ((result (copy-sequence str)))
|
||||
(set-text-properties start end props result)
|
||||
result))
|
||||
;; :add - deep merge with face prepending
|
||||
((eq merge-mode :add)
|
||||
(let ((result (copy-sequence str)))
|
||||
(cl-loop
|
||||
for (key val) on props by #'cddr
|
||||
do (let ((pos start))
|
||||
(while (< pos end)
|
||||
(let* ((current-val (get-text-property pos key result))
|
||||
(new-val (cond
|
||||
((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)))
|
||||
(next-change (or (next-single-property-change pos key result end) end)))
|
||||
(put-text-property pos next-change key new-val result)
|
||||
(setq pos next-change)))))
|
||||
result))
|
||||
;; nil/:set - set properties while preserving existing ones
|
||||
;; If applying to the entire string, use propertize for efficiency
|
||||
;; Otherwise, use copy-sequence + put-text-property to apply to specific range
|
||||
(t
|
||||
(if (and (= start 0) (= end len))
|
||||
;; Entire string: use propertize which creates a new copy and preserves existing properties
|
||||
(apply #'propertize str props)
|
||||
;; Partial range: copy string and apply properties to the range
|
||||
(let ((result (copy-sequence str)))
|
||||
(cl-loop for (key val) on props by #'cddr
|
||||
do (put-text-property start end key val result))
|
||||
result))))))
|
||||
|
||||
(defun tp-set (start-or-string &optional end-or-prop props-or-val &rest rest)
|
||||
"Set text properties on string or buffer region.
|
||||
|
||||
Supports 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 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 preserved (props override if there's a conflict).
|
||||
|
||||
**String Modification Behavior:**
|
||||
- Entire string form (tp-reset STRING ...): Returns a NEW propertized string
|
||||
(original is not modified). Uses `propertize' internally.
|
||||
- Region form with string (tp-reset START END PROPS STRING): Modifies the
|
||||
original string in-place using `set-text-properties'.
|
||||
- Buffer forms: Always modify in-place.
|
||||
|
||||
Returns: For buffers, (START . END) cons. For strings, the result string."
|
||||
;; Determine if this is the "entire string" form (first arg is a string)
|
||||
(let ((entire-string-form (stringp start-or-string)))
|
||||
(pcase-let ((`(,object ,start ,finish ,props)
|
||||
(tp--parse-args start-or-string end-or-prop props-or-val rest)))
|
||||
;; Handle tp-text property - :reset means only use props, ignore embedded props
|
||||
(pcase-let ((`(,new-props ,new-finish ,new-object)
|
||||
(tp--handle-tp-text 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-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 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))))))
|
||||
|
||||
(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))))
|
||||
|
||||
(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--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)))
|
||||
|
||||
(provide 'tp-ops)
|
||||
;;; tp-ops.el ends here
|
||||
331
tp-reactive.el
Normal file
331
tp-reactive.el
Normal file
@ -0,0 +1,331 @@
|
||||
;;; tp-reactive.el --- Reactive state storage and registration for tp -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2024-2026 Geekinney
|
||||
|
||||
;; Author: Geekinney (kinneyzhang666@gmail.com)
|
||||
|
||||
;; This program is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation; either version 3 of
|
||||
;; the License, or (at your option) any later version.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Reactive core of tp: storage for variable dependencies, watchers,
|
||||
;; computed properties and data variables; registration/unregistration;
|
||||
;; the variable-watcher shell and the batching queue. The actual
|
||||
;; re-rendering of buffers lives in tp-render.el, which installs
|
||||
;; itself via `tp--reactive-update-function' / `tp--reactive-flush-function'.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'tp-core)
|
||||
|
||||
(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--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.")
|
||||
|
||||
(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))
|
||||
|
||||
(defvar tp--reactive-update-function nil
|
||||
"Function applying a reactive update to layer definitions and buffers.
|
||||
Installed by tp-render.el. Called with (LAYER-NAME REACTIVE-PROPS
|
||||
SYMBOL NEWVAL WHERE OVERRIDE-ALIST) after the user watch callbacks
|
||||
have run. When nil, variable changes only invoke watch callbacks and
|
||||
no re-rendering happens.")
|
||||
|
||||
(defvar tp--reactive-flush-function nil
|
||||
"Function flushing one pending batched update entry.
|
||||
Installed by tp-render.el. Called with (LAYER-NAME WHERE
|
||||
TP-TEXT-AFFECTED).")
|
||||
|
||||
(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.
|
||||
|
||||
The actual recomputation and buffer re-rendering is delegated to
|
||||
`tp--reactive-update-function', installed by tp-render.el."
|
||||
(when (and (not (tp--equal-including-string-properties
|
||||
(when (boundp symbol)
|
||||
(symbol-value symbol))
|
||||
newval))
|
||||
(eq operation 'set))
|
||||
(tp-debug-log "Variable %s changed: %S -> %S (where: %s)"
|
||||
symbol (when (boundp symbol) (symbol-value symbol)) newval
|
||||
(if where (buffer-name where) "global"))
|
||||
(let ((deps (cdr (assoc symbol tp-reactive-deps)))
|
||||
(oldval (when (boundp symbol) (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)))
|
||||
;; Call user-defined watch callbacks for this layer
|
||||
(tp--invoke-layer-watchers layer-name symbol newval oldval)
|
||||
;; Delegate recomputation and re-rendering to the update engine
|
||||
(when tp--reactive-update-function
|
||||
(funcall tp--reactive-update-function
|
||||
layer-name reactive-props symbol newval
|
||||
where override-alist)))))))
|
||||
|
||||
(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))))))))
|
||||
|
||||
(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"))
|
||||
(when tp--reactive-flush-function
|
||||
(funcall tp--reactive-flush-function
|
||||
layer-name where tp-text-affected))))))
|
||||
(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--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-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))
|
||||
|
||||
(provide 'tp-reactive)
|
||||
;;; tp-reactive.el ends here
|
||||
359
tp-render.el
Normal file
359
tp-render.el
Normal file
@ -0,0 +1,359 @@
|
||||
;;; tp-render.el --- Reactive re-rendering engine for tp -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2024-2026 Geekinney
|
||||
|
||||
;; Author: Geekinney (kinneyzhang666@gmail.com)
|
||||
|
||||
;; This program is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation; either version 3 of
|
||||
;; the License, or (at your option) any later version.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; The reactive update engine: when a reactive variable changes, this
|
||||
;; module recomputes layer definitions and re-renders every affected
|
||||
;; buffer region, including live `tp-text' text replacement. It
|
||||
;; installs itself into tp-reactive.el (update/flush hooks) and
|
||||
;; tp-ops.el (`tp-text' handler).
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'tp-core)
|
||||
(require 'tp-reactive)
|
||||
(require 'tp-layer)
|
||||
(require 'tp-ops)
|
||||
(require 'tp-search)
|
||||
|
||||
(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--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--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)))))))))))
|
||||
|
||||
(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.
|
||||
The new properties completely reset/replace the old properties."
|
||||
(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)))
|
||||
(if (equal old-text (substring-no-properties new-text))
|
||||
;; Text content is the same, but properties may differ
|
||||
;; Use set-text-properties to reset with new properties
|
||||
(set-text-properties m-start m-end merged-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 new properties
|
||||
(let ((new-end (+ m-start (length new-text))))
|
||||
(set-text-properties m-start new-end merged-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 is retained for backward compatibility but no longer affects behavior.
|
||||
All modes now preserve embedded text properties from tp-text, with props taking
|
||||
precedence over embedded props when there's a conflict.
|
||||
Returns (PROPS NEW-END NEW-OBJECT) where PROPS is the updated props,
|
||||
NEW-END is the new end position after any text replacement, and
|
||||
NEW-OBJECT is the new string object (only different for strings 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))
|
||||
;; Embedded text properties from tp-text are now preserved in all cases.
|
||||
;; The props passed to this function take precedence over embedded props
|
||||
;; when there's a conflict (e.g., both have 'face' property).
|
||||
;; The merge-mode parameter is retained for backward compatibility but
|
||||
;; no longer affects behavior in this function - all modes use the same
|
||||
;; merging strategy via tp--merge-string-props-into-plist.
|
||||
(result-props
|
||||
(tp--merge-string-props-into-plist final-text 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))))))
|
||||
|
||||
(defun tp--reactive-apply-update (layer-name reactive-props symbol newval
|
||||
where override-alist)
|
||||
"Recompute LAYER-NAME's definition and re-render affected regions.
|
||||
REACTIVE-PROPS are the layer's props that reference the changed
|
||||
variable SYMBOL; NEWVAL is its new value. WHERE is the buffer for
|
||||
`setq-local' changes, nil for global ones. OVERRIDE-ALIST maps SYMBOL
|
||||
to NEWVAL (the watcher runs before the variable is actually set).
|
||||
|
||||
When `tp--batch-update-active' is non-nil the buffer update is queued
|
||||
in `tp--batch-update-pending' instead of applied immediately.
|
||||
|
||||
This is the engine behind `tp--reactive-variable-watcher'; it is
|
||||
installed as `tp--reactive-update-function'."
|
||||
(let ((tp-text-affected (plist-member reactive-props 'tp-text)))
|
||||
;; 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 to preserve nested plist values (like face)
|
||||
(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"))
|
||||
(tp--reactive-flush-entry layer-name where tp-text-affected))))
|
||||
|
||||
(defun tp--reactive-flush-entry (layer-name where tp-text-affected)
|
||||
"Re-render LAYER-NAME's regions in WHERE (or all buffers when nil).
|
||||
TP-TEXT-AFFECTED non-nil means the layer's `tp-text' changed and the
|
||||
text itself must be replaced. Installed as
|
||||
`tp--reactive-flush-function'."
|
||||
(if tp-text-affected
|
||||
(tp--update-reactive-text layer-name where)
|
||||
(tp--update-layer-regions layer-name where)))
|
||||
|
||||
;; Install the engine into the lower modules.
|
||||
(setq tp--reactive-update-function #'tp--reactive-apply-update)
|
||||
(setq tp--reactive-flush-function #'tp--reactive-flush-entry)
|
||||
(setq tp--tp-text-handler-function #'tp--handle-tp-text-property)
|
||||
(setq tp--layer-refresh-function #'tp--update-layer-regions)
|
||||
|
||||
(provide 'tp-render)
|
||||
;;; tp-render.el ends here
|
||||
799
tp-search.el
Normal file
799
tp-search.el
Normal file
@ -0,0 +1,799 @@
|
||||
;;; tp-search.el --- Pattern matching and property search for tp -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2024-2026 Geekinney
|
||||
|
||||
;; Author: Geekinney (kinneyzhang666@gmail.com)
|
||||
|
||||
;; This program is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation; either version 3 of
|
||||
;; the License, or (at your option) any later version.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Pattern-driven property application (`tp-match-*', `tp-regexp-*')
|
||||
;; and property-run search/navigation (`tp-search', `tp-search-map',
|
||||
;; `tp-forward', `tp-backward', `tp-forward-do', `tp-backward-do').
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'text-property-search)
|
||||
(require 'tp-core)
|
||||
(require 'tp-layer)
|
||||
(require 'tp-ops)
|
||||
|
||||
(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)
|
||||
;; Make a copy to ensure original string is not modified
|
||||
(let ((result (copy-sequence 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)
|
||||
;; Make a copy to ensure original string is not modified
|
||||
(let ((result (copy-sequence 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))
|
||||
|
||||
(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)))
|
||||
|
||||
(provide 'tp-search)
|
||||
;;; tp-search.el ends here
|
||||
701
tp-stack.el
Normal file
701
tp-stack.el
Normal file
@ -0,0 +1,701 @@
|
||||
;;; tp-stack.el --- Layer stack operations for tp -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2024-2026 Geekinney
|
||||
|
||||
;; Author: Geekinney (kinneyzhang666@gmail.com)
|
||||
|
||||
;; This program is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation; either version 3 of
|
||||
;; the License, or (at your option) any later version.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Photoshop-style layer stack operations on text regions: put/push/
|
||||
;; delete/pop/move/raise/rotate/pin/switch/merge/flatten, stack queries,
|
||||
;; and bulk layer property manipulation.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'dash)
|
||||
(require 'tp-core)
|
||||
(require 'tp-layer)
|
||||
(require 'tp-ops)
|
||||
|
||||
(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))
|
||||
|
||||
(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))
|
||||
|
||||
(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)))
|
||||
|
||||
(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)))
|
||||
|
||||
(provide 'tp-stack)
|
||||
;;; tp-stack.el ends here
|
||||
Loading…
Reference in New Issue
Block a user