geekinney/tp
1
0
Fork 0
Code Issues Pull Requests Actions 2 Packages Projects Releases Wiki Activity

Optimize and extend tp.el with layer system and text property functions

Browse Source 
Co-authored-by: Kinneyzhang <38454496+Kinneyzhang@users.noreply.github.com>
This commit is contained in:
copilot-swe-agent[bot] 2025-12-11 02:42:53 +00:00
parent 6333a09856
commit d1428a0748
2 changed files with 720 additions and 128 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

275
readme.md
View File

@ -1,36 +1,257 @@
## The project is in progress...
# tp.el - Text Properties Library for Emacs
### text properties layer
- `tp-layer-set (name start end &optional object)`\
将 object 在 start 到 end 范围内的文本当前展示的文本属性层命名为 name。
A convenient wrapper around Emacs text properties with an innovative **layer system** that allows setting multiple layers of text properties on the same text region.
- `tp-layer-push (name start end properties &optional object)`\
给 object 在 start 到 end 范围内的文本设置 properties 并 push 到最上层。
Inspired by [ov.el](https://github.com/emacsorphanage/ov) for overlays.
- `tp-layer-delete (name start end &optional object)`\
删除 object 在 start 到 end 范围内的文本名称为 name 的层。
## Features
- `tp-layer-rotate (start end &optional object)`\
循环移动 object 在 start 到 end 范围内的文本的属性层。即每次将最上面的层移到最下面，交替使用每个层的文本属性。
- **Simple API** for text property manipulation (similar to ov.el for overlays)
- **Innovative tp-layer system** for multi-layer text properties
- **Layer groups** for defining reusable property sets
- **Search and navigation** functions for text properties
- **Match and regexp** functions for applying properties to text patterns
- `tp-layer-pin (name start end &optional object)`\
将 object 在 start 到 end 范围内的文本的名称为 name 的层移到最上面。
## Installation
- `tp-layer-define (name properties)`\
定义 properties 为名称为 name 的文本属性层。
```elisp
(require 'tp)
```
- `tp-layer-group-define (name &rest layers)`\
定义 layers 为名称为 name 的文本属性层的组合。
Dependencies: `dash` (for list manipulation utilities)
### text properties propertize
- tp-propertize (string properties &optional layer)
- tp-layer-propertize (string layer)
- tp-layer-group-propertize (string layer-group)
## Quick Start
### text properties search
- tp-forward (property &optional value predicate not-current)
- tp-backward (property &optional value predicate not-current)
- tp-forward-do (function property &optional value predicate not-current)
- tp-backward-do (function property &optional value predicate not-current)
- tp-regions-map (function property &optional value predicate collect)
- tp-strings-map (function property &optional value predicate collect)
### Basic Text Properties
```elisp
;; Set properties on a region
(tp-put 10 20 'face 'warning 'help-echo "Hello!")
;; Get property at point
(tp-get 15 'face) ; => warning
;; Remove a property
(tp-remove 10 20 'face)
;; Clear all properties in region
(tp-clear 10 20)
;; Get all properties at point
(tp-at 15) ; => (face warning help-echo "Hello!")
```
### Match and Regexp
```elisp
;; Apply properties to all matches of a string
(tp-match "TODO" 'face 'warning)
;; Apply properties to all matches of a regexp
(tp-regexp "\\bfunction\\b" 'face 'font-lock-function-name-face)
```
### The Layer System
The layer system allows you to stack multiple sets of properties on the same text. Only the top layer is visible, but you can rotate, pin, or delete layers to reveal hidden ones.
```elisp
;; Define reusable layers
(tp-layer-define highlight
'(face (:background "yellow" :foreground "black")))
(tp-layer-define urgent
'(face (:background "red" :foreground "white")))
(tp-layer-define info
'(face (:background "blue" :foreground "white")))
;; Push layers onto text (first pushed is bottom, last is top)
(tp-layer-push 1 10 'highlight)
(tp-layer-push 1 10 'urgent) ; urgent is now visible
;; Rotate layers (urgent moves to bottom, highlight becomes visible)
(tp-layer-rotate 1 10)
;; Pin a specific layer to top
(tp-layer-pin 1 10 'urgent)
;; Delete a layer
(tp-layer-delete 1 10 'highlight)
```
### Layer Groups
Define groups of layers that work together:
```elisp
(tp-layer-group-define my-status-group
status-normal '(face (:background "green" :foreground "black"))
status-warning '(face (:background "yellow" :foreground "black"))
status-error '(face (:background "red" :foreground "white")))
;; Apply all layers from a group to a string
(tp-layer-group-propertize "Status" 'my-status-group)
```
## API Reference
### Basic Text Property Functions
| Function | Description |
|----------|-------------|
| `tp-put (start end &rest properties)` | Set text properties on region |
| `tp-get (position property &optional object)` | Get property value at position |
| `tp-remove (start end property &optional object)` | Remove a property from region |
| `tp-remove-list (start end properties &optional object)` | Remove multiple properties |
| `tp-clear (&optional start end object)` | Clear all properties in region |
| `tp-at (&optional point object)` | Get all properties at point |
| `tp-plist (start end &optional object)` | Get merged plist for region |
### Match and Regexp Functions
| Function | Description |
|----------|-------------|
| `tp-match (string &rest properties)` | Set properties on string matches |
| `tp-regexp (regexp &rest properties)` | Set properties on regexp matches |
### Layer Definition Functions
| Function | Description |
|----------|-------------|
| `tp-layer-define (name properties)` | Define a named layer |
| `tp-layer-group-define (name &rest layers)` | Define a layer group |
| `tp-layer-properties (layer-name)` | Get properties for a layer |
| `tp-layer-group-properties (group-name)` | Get properties for all layers in group |
| `tp-layer-undefine (name)` | Remove a layer definition |
| `tp-layer-group-undefine (name)` | Remove a layer group definition |
| `tp-layer-reset ()` | Clear all layer definitions |
### Layer Manipulation Functions
| Function | Description |
|----------|-------------|
| `tp-layer-push (start end name &optional object)` | Push layer to top of stack |
| `tp-layer-delete (start end name &optional object)` | Delete layer from stack |
| `tp-layer-rotate (start end &optional object)` | Rotate layers (top to bottom) |
| `tp-layer-pin (start end name &optional object)` | Pin layer to top |
| `tp-layer-set (start end name &optional object)` | Name the current top layer |
| `tp-layer-hide (start end name &optional object)` | Move layer to bottom |
| `tp-layer-show (start end name &optional object)` | Move layer to top (alias for pin) |
| `tp-layer-merge (start end layer1 layer2 new-name &optional object)` | Merge two layers |
### Layer Query Functions
| Function | Description |
|----------|-------------|
| `tp-layer-list (start end &optional object)` | List all layer names in region |
| `tp-layer-count (start end &optional object)` | Count layers in region |
| `tp-layer-exists-p (start end name &optional object)` | Check if layer exists |
| `tp-layer-top (start end &optional object)` | Get name of top layer |
| `tp-region-layer-props (start end layer-name &optional object)` | Get layer properties in region |
### Propertize String Functions
| Function | Description |
|----------|-------------|
| `tp-propertize (string &rest properties)` | Propertize string |
| `tp-layer-propertize (string layer)` | Apply layer to string |
| `tp-layer-group-propertize (string layer-group)` | Apply layer group to string |
### Search Functions
| Function | Description |
|----------|-------------|
| `tp-forward (property &optional value predicate not-current)` | Search forward for property |
| `tp-backward (property &optional value predicate not-current)` | Search backward for property |
| `tp-forward-do (function property &optional ...)` | Search forward and apply function |
| `tp-backward-do (function property &optional ...)` | Search backward and apply function |
| `tp-regions-map (function property &optional ...)` | Apply function to all matching regions |
| `tp-strings-map (function property &optional ...)` | Apply function to all matching strings |
### Navigation Functions
| Function | Description |
|----------|-------------|
| `tp-next (&optional point property value)` | Get next position with property |
| `tp-prev (&optional point property value)` | Get previous position with property |
| `tp-goto-next (&optional property value)` | Move to next property |
| `tp-goto-prev (&optional property value)` | Move to previous property |
### Query Functions
| Function | Description |
|----------|-------------|
| `tp-in (property &optional value start end)` | Get regions with property |
| `tp-all (&optional start end)` | Get all regions with properties |
| `tp-intervals (start end &optional object)` | Get all property intervals |
| `tp-empty-p (object)` | Check if object has no properties |
## The Layer Concept
The layer system stores multiple sets of properties in a stack structure:
```
┌─────────────────────────┐
│ TOP LAYER (visible) │ <- Properties you see
├─────────────────────────┤
│ Middle Layer │ <- Hidden, but preserved
├─────────────────────────┤
│ Bottom Layer │ <- Hidden, but preserved
└─────────────────────────┘
```
Each layer is identified by a name (symbol) and contains:
- Standard text properties (face, display, help-echo, etc.)
- A special `tp-name` property for identification
- A `tp-layers` property containing the list of layers below
### Layer Operations
- **Push**: Add a new layer on top
- **Delete**: Remove a layer from anywhere in the stack
- **Rotate**: Move top layer to bottom (cycles visibility)
- **Pin**: Move any layer to the top
- **Hide**: Move a layer to the bottom
- **Merge**: Combine two layers into one
## Examples
### Syntax Highlighting with Layers
```elisp
;; Define layers for different highlighting purposes
(tp-layer-define code-syntax
'(face font-lock-keyword-face))
(tp-layer-define code-error
'(face (:underline (:color "red" :style wave))))
(tp-layer-define code-selection
'(face (:background "light blue")))
;; Apply base syntax highlighting
(tp-layer-push 1 100 'code-syntax)
;; Add error highlighting on top (doesn't remove syntax highlighting)
(tp-layer-push 1 100 'code-error)
;; Toggle between showing error and syntax
(tp-layer-rotate 1 100)
```
### Interactive Layer Switching
```elisp
(defun my-toggle-layers ()
"Toggle between different property layers on current line."
(interactive)
(tp-layer-rotate (line-beginning-position)
(line-end-position)))
(global-set-key (kbd "C-c t") 'my-toggle-layers)
```
## License
GNU General Public License v2 or later.

573
tp.el
View File

@ -1,24 +1,54 @@
;; 对 text properties 的封装
;; elisp 原生的 text properties 函数的局限性
;; https://github.com/emacsorphanage/ov
;;; tp.el --- Text Properties manipulation library for Emacs Lisp -*- lexical-binding: t -*-
;; (put 'my-keyword-category 'face '(:foreground "blue" :weight bold))
;; (put 'my-keyword-category 'help-echo "This is a keyword.")
;; (symbol-plist 'my-keyword-category)
;; (put-text-property 10 20 'category 'my-keyword-category)
;; Copyright (C) 2024
;; Version: 0.1.0
;; Keywords: convenience text-properties
;; Package-Requires: ((emacs "27.1") (dash "2.19.1"))
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;; Commentary:
;; tp.el provides a convenient wrapper around Emacs text properties,
;; with an innovative layer system that allows setting multiple layers
;; of text properties on the same text region.
;;
;; Features:
;; - Simple API for text property manipulation (similar to ov.el for overlays)
;; - Innovative tp-layer system for multi-layer text properties
;; - Layer groups for defining reusable property sets
;; - Search and navigation functions for text properties
;;
;; Inspired by https://github.com/emacsorphanage/ov
;;; Code:
(require 'cl-lib)
(require 'dash)
;;; tp layer define
(defgroup tp nil
"Group for tp.el text property manipulation."
:prefix "tp-"
:group 'development)
(defvar tp-layer-alist nil
"Alist 的每个元素是单个 layer")
"Alist where each element is (LAYER-NAME . PROPERTIES).
Stores individual layer definitions.")
(defvar tp-layer-groups nil
"group 的每个元素是 layer 组，组中存储的是多个 layer")
"Alist where each element is (GROUP-NAME . (LAYER-NAME1 LAYER-NAME2 ...)).
Stores layer group definitions, where each group contains multiple layer names.")
(defmacro tp-layer-define (name properties)
"定义一个名称为 name 的文本属性层，数据存放在 tp-layer-alist 中"
"Define a text property layer named NAME with PROPERTIES.
The layer is stored in `tp-layer-alist'.
PROPERTIES should be a plist of text properties."
(declare (indent defun))
`(progn
(if (assoc ',name tp-layer-alist)
@ -27,8 +57,10 @@
(assoc ',name tp-layer-alist)))
(defmacro tp-layer-group-define (name &rest layers)
"每个属性层在 tp-layer-alist 中，属性组指在 tp-layer-groups 中存储属性层的名称
层级关系与layers定义顺序一致。最上面的定义表示顶层，渲染时会显示出来。"
"Define a layer group named NAME containing LAYERS.
LAYERS are specified as alternating NAME PROPERTIES pairs.
The first layer in the definition is the top layer (visible by default).
All layers are stored in `tp-layer-alist' and the group in `tp-layer-groups'."
(declare (indent defun))
`(let ((layer-names
(nreverse
@ -43,20 +75,89 @@
(assoc ',name tp-layer-groups)))
(defun tp-layer-properties (layer-name)
"Return properties for layer LAYER-NAME from `tp-layer-alist'.
Appends 'tp-name property to identify the layer."
(when-let ((plist (cdr (assoc layer-name tp-layer-alist))))
(append plist (list 'tp-name name))))
(append plist (list 'tp-name layer-name))))
(defun tp-layer-group-properties (group-name)
"返回使用 `tp-layer-group-define' 定义的 layer 的属性"
"Return list of properties for all layers in GROUP-NAME."
(when-let ((layers (cdr (assoc group-name tp-layer-groups))))
(mapcar (lambda (layer)
(tp-layer-properties layer))
layers)))
;;; Basic text property functions (similar to ov.el)
(defun tp-put (start end &rest properties)
"Set text PROPERTIES from START to END in current buffer.
PROPERTIES is a plist of property-value pairs.
Return the modified region as (START . END)."
(when (listp (car-safe properties))
(setq properties (car properties)))
(let ((len (length properties))
(i 0))
(while (< i len)
(put-text-property start end
(nth i properties)
(nth (1+ i) properties))
(setq i (+ i 2))))
(cons start end))
(defalias 'tp-set 'tp-put
"Alias for `tp-put'.")
(defun tp-get (position property &optional object)
"Get the value of PROPERTY at POSITION in OBJECT.
OBJECT defaults to current buffer."
(get-text-property position property object))
(defun tp-remove (start end property &optional object)
"Remove PROPERTY from text between START and END in OBJECT.
OBJECT defaults to current buffer."
(remove-text-properties start end (list property nil) object))
(defun tp-remove-list (start end properties &optional object)
"Remove list of PROPERTIES from text between START and END in OBJECT.
PROPERTIES should be a list of property names."
(let ((plist (mapcan (lambda (p) (list p nil)) properties)))
(remove-text-properties start end plist object)))
;;;###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.
OBJECT defaults to current buffer."
(interactive)
(let ((beg (or start (point-min)))
(finish (or end (point-max))))
(set-text-properties beg finish nil object)))
(defun tp-at (&optional point object)
"Get all text properties at POINT in OBJECT.
POINT defaults to current point.
OBJECT defaults to current buffer."
(text-properties-at (or point (point)) object))
(defun tp-plist (start end &optional object)
"Get the property list of text at START to END in OBJECT.
Returns a plist of all properties in the region."
(let ((props nil)
(pos start))
(while (< pos end)
(let ((current-props (tp-at pos object)))
(cl-loop for (key val) on current-props by #'cddr
do (unless (plist-member props key)
(setq props (plist-put props key val)))))
(setq pos (next-single-property-change pos nil object end)))
props))
;;; Text property intervals
(defun tp-intervals (start end &optional object)
"获取 OBJECT 的 start 到 end 范围内文本的所有 text properties。
OBJECT 可以为 buffer 或 string，nil 默认为当前 buffer。
point 从 0 开始。"
"Get all text property intervals from START to END in OBJECT.
OBJECT can be a buffer or string; nil defaults to current buffer.
Returns a list of (START END PROPERTIES) for each interval."
(let ((object (or object (current-buffer))))
(cond
((stringp object)
@ -68,11 +169,14 @@ point 从 0 开始。"
(type-of object))))))
(defun tp-empty-p (object)
"Return t if OBJECT has no text properties."
(null (object-intervals object)))
(defun tp-intervals-map (function start end &optional object)
"处理 start，end 之间的所有 intervals 的文本属性
function 的四个参数分别为:区间开始位置，区间结束位置，顶层属性和下层属性列表"
"Apply FUNCTION to all intervals between START and END in OBJECT.
FUNCTION receives four arguments: interval-start, interval-end,
top-props (the visible layer properties), and below-props-lst (list of hidden layers).
OBJECT can be a buffer or string; nil defaults to current buffer."
(remove
nil
(mapcar
@ -81,8 +185,8 @@ function 的四个参数分别为:区间开始位置，区间结束位置，顶
(interval-end (nth 1 tp))
(interval-props (nth 2 tp))
(top-props
(if-let ((idx (-elem-index 'tp-layers properties)))
(-remove-at-indices (list idx (1+ idx)) properties)
(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
@ -91,7 +195,9 @@ function 的四个参数分别为:区间开始位置，区间结束位置，顶
(tp-intervals start end object))))
(defun tp-region-layer-props (start end layer-name &optional object)
"返回 object 的 start 和 end 之间文本属性层为 name 的属性列表"
"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
@ -103,10 +209,11 @@ function 的四个参数分别为:区间开始位置，区间结束位置，顶
start end object))
(defun tp-layer-set (start end name &optional object)
"将 object 的 start 和 end 之间的文本当前的属性层命名为 name"
(if (tp-empty-p object)
(add-text-properties
start end (list 'tp-name name) end object)
"Set NAME as the layer name for text from START to END in OBJECT.
This names the current visible layer without adding new properties.
OBJECT defaults to current buffer."
(if (tp-empty-p (or object (current-buffer)))
(add-text-properties start end (list 'tp-name name) object)
(tp-intervals-map
(lambda (i-start i-end top belows)
(set-text-properties
@ -117,89 +224,94 @@ function 的四个参数分别为:区间开始位置，区间结束位置，顶
start end object))
object)
;; (if (tp-empty-p object)
;; (set-text-properties
;; start end (append properties (list 'tp-name name))
;; object)
;; )
;;;###autoload
(defun tp-layer-push (start end name &optional object)
"设置 properties 为最上面的 prop 层，name 是 layer 的名字;
如果 properties 是 nil，则 `tp-layer-define' 定义的名称为 name 的 layer 设置。"
"Push layer NAME to top of the layer stack from START to END.
Uses properties from `tp-layer-alist' if NAME is defined there.
OBJECT defaults to current buffer.
Signals an error if layer NAME already exists in the region."
(declare (indent defun))
(when (tp-region-layer-props name start end object)
(when (tp-region-layer-props start end name object)
(error "Already exist layer named %S" name))
(let ((props (tp-layer-properties name)))
(tp-intervals-map
(lambda (i-start i-end top belows)
(set-text-properties
(+ start i-start) (+ start i-end)
(append props
(list 'tp-layers (append (list top) belows)))
object))
start end object))
(if (tp-empty-p (or object (current-buffer)))
;; No existing properties, just set the layer properties
(set-text-properties start end
(append props (list 'tp-layers nil))
object)
;; Has existing properties, push to layer stack
(tp-intervals-map
(lambda (i-start i-end top belows)
(set-text-properties
(+ start i-start) (+ start i-end)
(append props
(list 'tp-layers (append (list top) belows)))
object))
start end object)))
object)
(defun tp-layer-delete (start end name &optional object)
"移除 object 的 start 和 end 之间文本的名称为 name 的层"
;; 当前顶层放到 tp-layers 开头，properties 设置为当前顶层。
;; FIXME: 需要检查 name 是否已经存在，存在则报错
"Delete layer NAME from the layer stack between START and END.
If NAME is the top layer, the next layer becomes visible.
OBJECT defaults to current buffer."
(declare (indent defun))
(tp-intervals-map
(lambda (i-start i-end top belows)
(set-text-properties
(+ start i-start) (+ start i-end)
;; name 是顶层，删除该层后，下一层上移
;; If NAME is the top layer, promote the next layer
(if (equal name (plist-get top 'tp-name))
(append (nth 0 belows)
(list 'tp-layers (seq-drop belows 1)))
;; name 不是顶层，直接删除
;; NAME is not the top layer, remove from belows
(append top
(list 'tp-layers
(-remove (lambda (props)
(equal name (plist-get
props 'tp-name)))
(equal name (plist-get props 'tp-name)))
belows))))
object))
start end object)
nil)
(defun tp-layer-rotate (start end &optional object)
"将 start 和 end 之间的顶层文本属性移到最后一层，相当于循环显示不同层。"
"Rotate layers from START to END, moving top layer to bottom.
This cycles through the layer stack, making each layer visible in turn.
OBJECT defaults to current buffer."
(tp-intervals-map
(lambda (i-start i-end top belows)
(set-text-properties
(+ start i-start) (+ start i-end)
(append (nth 0 belows)
(list 'tp-layers
(append (seq-drop belows 1)
(list top))))
object))
(when belows
(set-text-properties
(+ start i-start) (+ start i-end)
(append (nth 0 belows)
(list 'tp-layers
(append (seq-drop belows 1)
(list top))))
object)))
start end object)
nil)
(defun tp-layer-pin (start end name &optional object)
"将 start 和 end 之间名称为 name 的层移动最上面。"
(unless (tp-region-layer-props name start end object)
"Pin layer NAME to the top of the layer stack from START to END.
Moves the layer named NAME to the top, making it visible.
OBJECT defaults to current buffer.
Signals an error if layer NAME does not exist in the region."
(unless (tp-region-layer-props start end name object)
(error "Doesn't exist a layer named %S" name))
(tp-intervals-map
(lambda (i-start i-end top belows)
;; name layer 本身就位于最上层时，无需操作
;; Only do something if NAME is not already at top
(unless (equal (plist-get top 'tp-name) name)
(set-text-properties
(+ start i-start) (+ start i-end)
(let ((new-top
;; 获取新的置顶层
;; Find the layer to promote
(seq-find (lambda (props)
(equal (plist-get props 'tp-name)
name))
(equal (plist-get props 'tp-name) name))
belows))
;; 移除掉被置顶的层
;; Remove the promoted layer from belows
(rest-belows
(-remove (lambda (props)
(equal (plist-get props 'tp-name)
name))
(equal (plist-get props 'tp-name) name))
belows)))
(append new-top
(list 'tp-layers
@ -208,61 +320,78 @@ function 的四个参数分别为:区间开始位置，区间结束位置，顶
start end object)
nil)
;;; propertize string
;;; Propertize string functions
;; FIXME: 第二个参数兼容三种情况
;; 1. layer 2. layer group 3. normal properties
(defun tp-propertize (string layer-name &optional properties)
(defun tp-propertize (string &rest properties)
"Return a copy of STRING with PROPERTIES applied.
PROPERTIES should be a plist of property-value pairs."
(declare (indent defun))
(let ((layer (or layer (org-id-uuid))))
(tp-layer-push 0 (length string)
layer-name properties string)
string))
(when (listp (car-safe properties))
(setq properties (car properties)))
(apply #'propertize string properties))
(defun tp-layer-propertize (string layer)
"Return STRING with properties from LAYER applied.
LAYER must be defined in `tp-layer-alist'."
(if-let ((layer-info (assoc layer tp-layer-alist)))
(tp-propertize string
(cdr layer-info) (car layer-info))
(error "layer %S doesn't exist!" layer)))
(apply #'propertize string (cdr layer-info))
(error "Layer %S doesn't exist!" layer)))
(defun tp-layer-group-propertize (string layer-group)
"Return STRING with all layers from LAYER-GROUP applied.
LAYER-GROUP must be defined in `tp-layer-groups'.
Layers are applied in order, with later layers on top."
(if-let* ((group-info (assoc layer-group tp-layer-groups))
(layers (cdr group-info)))
(progn
(dolist (layer layers)
(setq string (tp-layer-propertize string layer)))
string)
(error "layer group %S doesn't exist!" layer-group)))
(let ((result string))
;; Apply base layer first
(when-let ((first-layer (car layers)))
(setq result (tp-layer-propertize result first-layer)))
;; Apply additional layers using the layer system
(dolist (layer (cdr layers))
(when-let ((props (tp-layer-properties layer)))
(set-text-properties 0 (length result)
(append props
(list 'tp-layers
(list (tp-at 0 result))))
result)))
result)
(error "Layer group %S doesn't exist!" layer-group)))
;;; search
;;; Search functions
(defun tp-forward (property &optional value predicate not-current)
"Search forward for text with PROPERTY.
VALUE, PREDICATE, and NOT-CURRENT work as in `text-property-search-forward'."
(text-property-search-forward property value predicate not-current))
(defun tp-backward (property &optional value predicate not-current)
"Search backward for text with PROPERTY.
VALUE, PREDICATE, and NOT-CURRENT work as in `text-property-search-backward'."
(text-property-search-backward property value predicate not-current))
(defun tp-forward-do (function property &optional
value predicate not-current)
"从当前位置向前搜索，并执行 function，function的参数是 start end value"
(defun tp-forward-do (function property &optional value predicate not-current)
"Search forward for PROPERTY and apply FUNCTION to the match.
FUNCTION receives three arguments: START, END, and VALUE."
(when-let* ((match (tp-forward property value predicate not-current))
(start (prop-match-beginning match))
(end (prop-match-end match))
(value (prop-match-value match)))
(funcall function start end value)))
(val (prop-match-value match)))
(funcall function start end val)))
(defun tp-backward-do (function property &optional
value predicate not-current)
"从当前位置向后搜索，并执行 function，function的参数是 start end value"
(defun tp-backward-do (function property &optional value predicate not-current)
"Search backward for PROPERTY and apply FUNCTION to the match.
FUNCTION receives three arguments: START, END, and VALUE."
(when-let* ((match (tp-backward property value predicate not-current))
(start (prop-match-beginning match))
(end (prop-match-end match))
(value (prop-match-value match)))
(funcall function start end value)))
(val (prop-match-value match)))
(funcall function start end val)))
(defun tp-regions-map (function property &optional
value predicate collect)
"对属性匹配的开头和结尾 point 执行 function。collect 为 t 时返回结果列表"
(defun tp-regions-map (function property &optional value predicate collect)
"Apply FUNCTION to all regions with PROPERTY in current buffer.
FUNCTION receives three arguments: START, END, and INDEX.
If COLLECT is non-nil, return list of results."
(save-excursion
(goto-char (point-min))
(let ((idx 0) lst)
@ -274,12 +403,254 @@ function 的四个参数分别为:区间开始位置，区间结束位置，顶
(cl-incf idx 1))
(nreverse lst))))
(defun tp-strings-map (function property &optional
value predicate collect)
"对属性匹配的字符串执行 function"
(defun tp-strings-map (function property &optional value predicate collect)
"Apply FUNCTION to all strings with PROPERTY in current buffer.
FUNCTION receives two arguments: STRING and INDEX."
(tp-regions-map
(lambda (start end idx)
(funcall function (buffer-substring start end) idx))
property value predicate))
property value predicate collect))
;;; Match and regexp functions (similar to ov-match and ov-regexp)
(defun tp-match (string &rest properties)
"Set PROPERTIES on all occurrences of STRING in current buffer.
Returns list of (START . END) pairs for all matches."
(when (listp (car-safe properties))
(setq properties (car properties)))
(save-excursion
(goto-char (point-min))
(let (regions)
(while (search-forward string nil t)
(let ((beg (match-beginning 0))
(end (match-end 0)))
(when properties
(tp-put beg end properties))
(push (cons beg end) regions)))
(nreverse regions))))
(defun tp-regexp (regexp &rest properties)
"Set PROPERTIES on all matches of REGEXP in current buffer.
Returns list of (START . END) pairs for all matches."
(when (listp (car-safe properties))
(setq properties (car properties)))
(save-excursion
(goto-char (point-min))
(let (regions)
(while (re-search-forward regexp nil t)
(let ((beg (match-beginning 0))
(end (match-end 0)))
(when properties
(tp-put beg end properties))
(push (cons beg end) regions)))
(nreverse regions))))
;;; Layer list and query functions
(defun tp-layer-list (start end &optional object)
"Return list of all layer names in region from START to END.
OBJECT defaults to current buffer."
(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 visibility functions
(defun tp-layer-hide (start end name &optional object)
"Hide layer NAME by moving it below all other layers.
OBJECT defaults to current buffer."
(unless (tp-region-layer-props start end name object)
(error "Doesn't exist a layer named %S" name))
(tp-intervals-map
(lambda (i-start i-end top belows)
(if (equal (plist-get top 'tp-name) name)
;; NAME is top, move it to bottom
(when belows
(set-text-properties
(+ start i-start) (+ start i-end)
(append (nth 0 belows)
(list 'tp-layers
(append (seq-drop belows 1)
(list top))))
object))
;; NAME is in belows, move it to bottom
(let ((layer (seq-find (lambda (p)
(equal name (plist-get p 'tp-name)))
belows)))
(when layer
(set-text-properties
(+ start i-start) (+ start i-end)
(append top
(list 'tp-layers
(append (-remove (lambda (p)
(equal name (plist-get p 'tp-name)))
belows)
(list layer))))
object)))))
start end object)
nil)
(defun tp-layer-show (start end name &optional object)
"Show layer NAME by moving it to the top.
Alias for `tp-layer-pin'.
OBJECT defaults to current buffer."
(tp-layer-pin start end name object))
;;; Layer merge function
(defun tp-layer-merge (start end layer1 layer2 new-name &optional object)
"Merge LAYER1 and LAYER2 into a new layer named NEW-NAME.
Properties from LAYER1 take precedence over LAYER2.
OBJECT defaults to current buffer."
(let ((props1 (tp-region-layer-props start end layer1 object))
(props2 (tp-region-layer-props start end layer2 object)))
(unless (and props1 props2)
(error "Both layers must exist in the region"))
;; Get the properties from both layers
(let* ((layer1-props (nth 2 (car props1)))
(layer2-props (nth 2 (car props2)))
;; Merge properties (layer1 takes precedence)
(merged-props
(let ((result (copy-sequence layer2-props)))
(cl-loop for (key val) on layer1-props by #'cddr
do (setq result (plist-put result key val)))
(plist-put result 'tp-name new-name))))
;; Delete old layers and push merged layer
(tp-layer-delete start end layer1 object)
(tp-layer-delete start end layer2 object)
;; Define the new merged layer
(if (assoc new-name tp-layer-alist)
(setf (cdr (assoc new-name tp-layer-alist)) merged-props)
(push (cons new-name merged-props) tp-layer-alist))
;; Apply the merged layer
(tp-layer-push start end new-name object)))
nil)
;;; Utility functions
(defun tp-in (property &optional value start end)
"Get all regions with PROPERTY in current buffer.
If VALUE is specified, only return regions where PROPERTY equals VALUE.
If START and END are specified, limit search to that region.
Returns list of (START END PROPERTIES) for each match."
(let ((beg (or start (point-min)))
(finish (or end (point-max)))
(regions nil))
(save-excursion
(goto-char beg)
(while (< (point) finish)
(let* ((props (tp-at (point)))
(prop-val (plist-get props property)))
(when (and prop-val
(or (null value)
(equal prop-val value)))
(let ((region-start (point))
(region-end (next-single-property-change (point) property nil finish)))
(push (list region-start region-end props) regions)
(goto-char region-end)))
(goto-char (next-single-property-change (point) property nil finish)))))
(nreverse regions)))
(defun tp-all (&optional start end)
"Get all regions with any text properties in current buffer.
If START and END are specified, limit search to that region.
Returns list of (START END PROPERTIES)."
(let ((beg (or start (point-min)))
(finish (or end (point-max)))
(regions nil))
(save-excursion
(goto-char beg)
(while (< (point) finish)
(let* ((props (tp-at (point)))
(region-start (point))
(region-end (next-property-change (point) nil finish)))
(when props
(push (list region-start region-end props) regions))
(goto-char (or region-end finish)))))
(nreverse regions)))
(defun tp-next (&optional point property value)
"Get the next position with text properties after POINT.
If PROPERTY is specified, find next position with that property.
If VALUE is also specified, the property must equal that value."
(let ((pos (or point (point))))
(if property
(save-excursion
(goto-char pos)
(when-let ((match (tp-forward property value)))
(prop-match-beginning match)))
(next-property-change pos))))
(defun tp-prev (&optional point property value)
"Get the previous position with text properties before POINT.
If PROPERTY is specified, find previous position with that property.
If VALUE is also specified, the property must equal that value."
(let ((pos (or point (point))))
(if property
(save-excursion
(goto-char pos)
(when-let ((match (tp-backward property value)))
(prop-match-beginning match)))
(previous-property-change pos))))
(defun tp-goto-next (&optional property value)
"Move point to next text with PROPERTY (optionally equal to VALUE)."
(interactive)
(when-let ((pos (tp-next (point) property value)))
(goto-char pos)))
(defun tp-goto-prev (&optional property value)
"Move point to previous text with PROPERTY (optionally equal to VALUE)."
(interactive)
(when-let ((pos (tp-prev (point) property value)))
(goto-char pos)))
;;; Layer reset functions
(defun tp-layer-reset ()
"Reset all layer definitions.
Clears both `tp-layer-alist' and `tp-layer-groups'."
(interactive)
(setq tp-layer-alist nil)
(setq tp-layer-groups nil))
(defun tp-layer-undefine (name)
"Remove layer NAME from `tp-layer-alist'."
(setq tp-layer-alist (assq-delete-all name tp-layer-alist)))
(defun tp-layer-group-undefine (name)
"Remove layer group NAME from `tp-layer-groups'."
(setq tp-layer-groups (assq-delete-all name tp-layer-groups)))
(provide 'tp)
;;; tp.el ends here