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