1040 lines
39 KiB
EmacsLisp
1040 lines
39 KiB
EmacsLisp
;;; tp.el --- Text Properties manipulation library for Emacs Lisp -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2024
|
|
|
|
;; Version: 0.1.0
|
|
;; Keywords: convenience text-properties
|
|
;; Package-Requires: ((emacs "28.1") (dash "2.19.1"))
|
|
|
|
;; This program is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU General Public License as
|
|
;; published by the Free Software Foundation; either version 2 of
|
|
;; the License, or (at your option) any later version.
|
|
|
|
;;; Commentary:
|
|
|
|
;; tp.el provides a 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
|
|
;;
|
|
;; Requires Emacs 28.1+ for `object-intervals' function.
|
|
|
|
;;; 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 where each element is (LAYER-NAME . PROPERTIES).
|
|
Stores individual layer definitions.")
|
|
|
|
(defvar tp-layer-groups nil
|
|
"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)
|
|
"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)
|
|
(setf (cdr (assoc ',name tp-layer-alist)) ,properties)
|
|
(push (cons ',name ,properties) tp-layer-alist))
|
|
(assoc ',name tp-layer-alist)))
|
|
|
|
(defmacro tp-group-define (name &rest 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
|
|
(-map (lambda (lst)
|
|
(let ((layer-name (car lst)))
|
|
(eval `(tp-layer-define ,layer-name ,(cadr lst)))
|
|
layer-name))
|
|
(-partition 2 ',layers)))))
|
|
(if (assoc ',name tp-layer-groups)
|
|
(setf (cdr (assoc ',name tp-layer-groups)) layer-names)
|
|
(push (cons ',name layer-names) tp-layer-groups))
|
|
(assoc ',name tp-layer-groups)))
|
|
|
|
(defalias 'tp-layer-group-define 'tp-group-define
|
|
"Alias for `tp-group-define'.")
|
|
|
|
(defun tp-layer-props (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 layer-name))))
|
|
|
|
(defalias 'tp-layer-properties 'tp-layer-props
|
|
"Alias for `tp-layer-props'.")
|
|
|
|
(defun tp-group-props (group-name)
|
|
"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-props layer))
|
|
layers)))
|
|
|
|
(defalias 'tp-layer-group-properties 'tp-group-props
|
|
"Alias for `tp-group-props'.")
|
|
|
|
;;; Basic text property functions (similar to ov.el)
|
|
|
|
(defun tp-put (start-or-string &optional end-or-prop props-or-val &rest rest)
|
|
"Set text properties on string or buffer region.
|
|
|
|
This function supports four calling conventions:
|
|
|
|
1. Current buffer:
|
|
(tp-put START END \\='(PROPERTY VALUE ...))
|
|
|
|
2. Specific buffer:
|
|
(tp-put START END \\='(PROPERTY VALUE ...) BUFFER)
|
|
|
|
3. Specific string (0-indexed positions):
|
|
(tp-put START END \\='(PROPERTY VALUE ...) STRING)
|
|
|
|
4. Entire string:
|
|
(tp-put STRING PROPERTY VALUE ...)
|
|
|
|
PROPERTIES is a plist of property-value pairs.
|
|
Return the modified object (string) or region (START . END) for buffer."
|
|
(let (object start finish props)
|
|
;; Determine calling convention based on first argument type
|
|
(cond
|
|
;; First arg is a string - apply to entire string
|
|
;; In this case: end-or-prop is first property, props-or-val is first value
|
|
((stringp start-or-string)
|
|
(setq object start-or-string
|
|
start 0
|
|
finish (length start-or-string)
|
|
props (if end-or-prop
|
|
(if props-or-val
|
|
(cons end-or-prop (cons props-or-val rest))
|
|
(list end-or-prop))
|
|
nil)))
|
|
;; First arg is a number - region convention
|
|
;; In this case: end-or-prop is end position, props-or-val is plist
|
|
((numberp start-or-string)
|
|
(setq start start-or-string
|
|
finish end-or-prop)
|
|
;; Check if 4th arg (first of rest) is a buffer or string
|
|
(if (and rest (or (bufferp (car rest)) (stringp (car rest))))
|
|
(setq object (car rest)
|
|
props props-or-val)
|
|
(setq object nil
|
|
props props-or-val)))
|
|
(t (error "Invalid first argument: %S" start-or-string)))
|
|
;; Handle properties as a list
|
|
(when (listp (car-safe props))
|
|
(setq props (car props)))
|
|
;; Apply properties
|
|
(let ((len (length props))
|
|
(i 0))
|
|
(while (< i len)
|
|
(put-text-property start finish
|
|
(nth i props)
|
|
(nth (1+ i) props)
|
|
object)
|
|
(setq i (+ i 2))))
|
|
;; Return result
|
|
(if (stringp object)
|
|
object
|
|
(cons start finish))))
|
|
|
|
(defalias 'tp-set 'tp-put
|
|
"Alias for `tp-put'.")
|
|
|
|
(defun tp-get (pos-or-start &optional property-or-end &rest args)
|
|
"Get text property value(s).
|
|
|
|
This function supports multiple calling conventions:
|
|
|
|
1. Single position, single property:
|
|
(tp-get POSITION PROPERTY)
|
|
(tp-get POSITION PROPERTY OBJECT)
|
|
|
|
2. Range, single property:
|
|
(tp-get START END PROPERTY)
|
|
(tp-get START END PROPERTY OBJECT)
|
|
|
|
3. Range, all properties (returns plist):
|
|
(tp-get START END)
|
|
(tp-get START END OBJECT)
|
|
|
|
For buffers, positions are 1-indexed.
|
|
For strings, positions are 0-indexed.
|
|
OBJECT defaults to current buffer."
|
|
(cond
|
|
;; (tp-get POS PROP) or (tp-get POS PROP OBJECT) - single position
|
|
((and (numberp pos-or-start)
|
|
(symbolp property-or-end))
|
|
(let ((object (car args)))
|
|
(get-text-property pos-or-start property-or-end object)))
|
|
;; (tp-get START END ...) - range form
|
|
((and (numberp pos-or-start)
|
|
(numberp property-or-end))
|
|
(let* ((start pos-or-start)
|
|
(end property-or-end)
|
|
(property (car args))
|
|
(object (cadr args)))
|
|
(if property
|
|
;; Get specific property from range - return first non-nil value
|
|
(let ((pos start)
|
|
(result nil))
|
|
(while (and (< pos end) (null result))
|
|
(setq result (get-text-property pos property object))
|
|
(setq pos (next-single-property-change pos property object end)))
|
|
result)
|
|
;; Get all properties from range - merge into plist
|
|
(let ((props nil)
|
|
(pos start)
|
|
(obj (or object (current-buffer))))
|
|
(while (< pos end)
|
|
(let ((current-props (text-properties-at pos obj)))
|
|
(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 obj end)))
|
|
props))))
|
|
(t (error "Invalid arguments to tp-get"))))
|
|
|
|
;;; Fine-grained property manipulation for nested properties
|
|
|
|
(defun tp-get-sub (position property sub-property &optional object)
|
|
"Get SUB-PROPERTY from PROPERTY at POSITION in OBJECT.
|
|
For example, get :foreground from a face property.
|
|
OBJECT defaults to current buffer."
|
|
(let ((prop-value (get-text-property position property object)))
|
|
(cond
|
|
;; Property is a plist (e.g., (:foreground \"red\" :weight bold))
|
|
((and (listp prop-value) (keywordp (car prop-value)))
|
|
(plist-get prop-value sub-property))
|
|
;; Property is an alist
|
|
((and (listp prop-value) (consp (car prop-value)))
|
|
(cdr (assoc sub-property prop-value)))
|
|
;; Property is a list of face specs
|
|
((listp prop-value)
|
|
(cl-loop for spec in prop-value
|
|
when (and (listp spec) (keywordp (car spec)))
|
|
thereis (plist-get spec sub-property)))
|
|
(t nil))))
|
|
|
|
(defun tp-put-sub (start end property sub-property value &optional object)
|
|
"Set SUB-PROPERTY of PROPERTY to VALUE from START to END in OBJECT.
|
|
Merges the sub-property into the existing property value.
|
|
For example, set :foreground of a face property.
|
|
OBJECT defaults to current buffer."
|
|
(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
|
|
;; No existing value - create new plist
|
|
((null current-value)
|
|
(list sub-property value))
|
|
;; Existing plist
|
|
((and (listp current-value) (keywordp (car current-value)))
|
|
(plist-put (copy-sequence current-value) sub-property value))
|
|
;; Existing symbol (e.g., 'bold) - convert to list and add
|
|
((symbolp current-value)
|
|
(list current-value sub-property value))
|
|
;; Other list - wrap and add
|
|
((listp current-value)
|
|
(append current-value (list sub-property value)))
|
|
(t (list sub-property value)))))
|
|
(put-text-property pos next-pos property new-value object)
|
|
(setq pos next-pos))))
|
|
(if (stringp object)
|
|
object
|
|
(cons start end)))
|
|
|
|
(defun tp-remove-sub (start end property sub-property &optional object)
|
|
"Remove SUB-PROPERTY from PROPERTY between START and END in OBJECT.
|
|
For example, remove :foreground from a face property.
|
|
OBJECT defaults to current buffer."
|
|
(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 (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
|
|
;; Note: Uses `object-intervals' which requires Emacs 28.1+
|
|
|
|
(defun tp-intervals (start end &optional object)
|
|
"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.
|
|
Uses `object-intervals' (Emacs 28.1+)."
|
|
(let ((object (or object (current-buffer))))
|
|
(cond
|
|
((stringp object)
|
|
(object-intervals (substring object start end)))
|
|
((bufferp object)
|
|
(with-current-buffer (get-buffer-create object)
|
|
(object-intervals (buffer-substring start end))))
|
|
(t (error "Invalid format of object: %S"
|
|
(type-of object))))))
|
|
|
|
(defun tp-empty-p (object)
|
|
"Return t if OBJECT has no text properties.
|
|
Uses `object-intervals' (Emacs 28.1+)."
|
|
(null (object-intervals object)))
|
|
|
|
(defun tp-intervals-map (function start end &optional object)
|
|
"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
|
|
(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))
|
|
|
|
(defun tp-layer-set (start end name &optional 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
|
|
(+ start i-start) (+ start i-end)
|
|
(append (plist-put top 'tp-name name)
|
|
(list 'tp-layers belows))
|
|
object))
|
|
start end object))
|
|
object)
|
|
|
|
;;;###autoload
|
|
(defun tp-layer-push (start end name &optional object)
|
|
"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 start end name object)
|
|
(error "Already exist layer named %S" name))
|
|
(let ((props (tp-layer-props name)))
|
|
(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)
|
|
"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)
|
|
;; 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 is not the top layer, remove from belows
|
|
(append top
|
|
(list 'tp-layers
|
|
(-remove (lambda (props)
|
|
(equal name (plist-get props 'tp-name)))
|
|
belows))))
|
|
object))
|
|
start end object)
|
|
nil)
|
|
|
|
(defun tp-layer-rotate (start end &optional object)
|
|
"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)
|
|
(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)
|
|
"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)
|
|
;; 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))
|
|
belows))
|
|
;; Remove the promoted layer from belows
|
|
(rest-belows
|
|
(-remove (lambda (props)
|
|
(equal (plist-get props 'tp-name) name))
|
|
belows)))
|
|
(append new-top
|
|
(list 'tp-layers
|
|
(append (list top) rest-belows))))
|
|
object)))
|
|
start end object)
|
|
nil)
|
|
|
|
;;; Propertize functions
|
|
|
|
(defun tp-propertize (object-or-string &rest args)
|
|
"Apply text properties to OBJECT.
|
|
|
|
This function supports multiple calling conventions:
|
|
|
|
1. String only (create propertized string):
|
|
(tp-propertize STRING PROPERTY VALUE ...)
|
|
(tp-propertize STRING \\='(PROPERTY VALUE ...))
|
|
|
|
2. With region (apply to object):
|
|
(tp-propertize OBJECT START END PROPERTY VALUE ...)
|
|
(tp-propertize OBJECT START END \\='(PROPERTY VALUE ...))
|
|
|
|
When called with just a string and properties, returns a new
|
|
propertized string. When called with an object, start, and end,
|
|
applies properties to the region and returns the object.
|
|
|
|
PROPERTIES should be a plist of property-value pairs."
|
|
(declare (indent defun))
|
|
(cond
|
|
;; Called with just string and properties (no start/end)
|
|
;; Detect by checking if first arg is not a number (not a start position)
|
|
((and (stringp object-or-string)
|
|
(or (null args)
|
|
(not (numberp (car args)))))
|
|
(let ((properties args))
|
|
(when (listp (car-safe properties))
|
|
(setq properties (car properties)))
|
|
(if properties
|
|
(apply #'propertize object-or-string properties)
|
|
(copy-sequence object-or-string))))
|
|
;; Called with object, start, end, properties
|
|
((and (or (stringp object-or-string) (bufferp object-or-string))
|
|
(>= (length args) 2)
|
|
(numberp (car args))
|
|
(numberp (cadr args)))
|
|
(let ((object object-or-string)
|
|
(start (car args))
|
|
(end (cadr args))
|
|
(properties (cddr args)))
|
|
(when (listp (car-safe properties))
|
|
(setq properties (car properties)))
|
|
(tp-put start end properties object)
|
|
object)) ; Always return the object
|
|
(t (error "Invalid arguments to tp-propertize"))))
|
|
|
|
(defun tp-layer-propertize (object layer &optional start end)
|
|
"Apply LAYER properties to OBJECT.
|
|
|
|
OBJECT can be a string or buffer.
|
|
LAYER must be defined in `tp-layer-alist'.
|
|
|
|
Calling conventions:
|
|
1. String (full string):
|
|
(tp-layer-propertize STRING LAYER)
|
|
|
|
2. String with range:
|
|
(tp-layer-propertize STRING LAYER START END)
|
|
|
|
3. Buffer with range:
|
|
(tp-layer-propertize BUFFER LAYER START END)
|
|
|
|
Returns the modified object."
|
|
(if-let ((layer-info (assoc layer tp-layer-alist)))
|
|
(let ((props (cdr layer-info)))
|
|
(cond
|
|
;; String without range - apply to whole string
|
|
((and (stringp object) (null start))
|
|
(apply #'propertize object props))
|
|
;; String or buffer with range
|
|
((or (stringp object) (bufferp object))
|
|
(let ((beg (or start 0))
|
|
(fin (or end (if (stringp object)
|
|
(length object)
|
|
(with-current-buffer object (point-max))))))
|
|
(tp-put beg fin props object)
|
|
object)) ; Always return the object
|
|
(t (error "Invalid object type: %S" (type-of object)))))
|
|
(error "Layer %S doesn't exist!" layer)))
|
|
|
|
(defun tp-group-propertize (object layer-group &optional start end)
|
|
"Apply all layers from LAYER-GROUP to OBJECT.
|
|
|
|
OBJECT can be a string or buffer.
|
|
LAYER-GROUP must be defined in `tp-layer-groups'.
|
|
Layers are applied in order, with later layers on top.
|
|
|
|
Calling conventions:
|
|
1. String (full string):
|
|
(tp-group-propertize STRING LAYER-GROUP)
|
|
|
|
2. String with range:
|
|
(tp-group-propertize STRING LAYER-GROUP START END)
|
|
|
|
3. Buffer with range:
|
|
(tp-group-propertize BUFFER LAYER-GROUP START END)
|
|
|
|
Returns the modified object."
|
|
(if-let* ((group-info (assoc layer-group tp-layer-groups))
|
|
(layers (cdr group-info)))
|
|
(let* ((beg (or start 0))
|
|
(fin (or end (if (stringp object)
|
|
(length object)
|
|
(with-current-buffer object (point-max)))))
|
|
(result (if (stringp object)
|
|
(copy-sequence object)
|
|
object)))
|
|
;; Apply base layer first
|
|
(when-let ((first-layer (car layers)))
|
|
(if (stringp result)
|
|
(setq result (tp-layer-propertize result first-layer beg fin))
|
|
(tp-layer-propertize result first-layer beg fin)))
|
|
;; Apply additional layers using the layer system
|
|
(dolist (layer (cdr layers))
|
|
(when-let ((props (tp-layer-props layer)))
|
|
(if (stringp result)
|
|
(set-text-properties beg fin
|
|
(append props
|
|
(list 'tp-layers
|
|
(list (tp-at beg result))))
|
|
result)
|
|
(with-current-buffer result
|
|
(tp-intervals-map
|
|
(lambda (i-start i-end top belows)
|
|
(set-text-properties
|
|
(+ beg i-start) (+ beg i-end)
|
|
(append props
|
|
(list 'tp-layers (append (list top) belows)))
|
|
result))
|
|
beg fin result)))))
|
|
result)
|
|
(error "Layer group %S doesn't exist!" layer-group)))
|
|
|
|
(defalias 'tp-layer-group-propertize 'tp-group-propertize
|
|
"Alias for `tp-group-propertize'.")
|
|
|
|
;;; 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)
|
|
"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))
|
|
(val (prop-match-value match)))
|
|
(funcall function start end val)))
|
|
|
|
(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))
|
|
(val (prop-match-value match)))
|
|
(funcall function start end val)))
|
|
|
|
(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)
|
|
(while-let ((match (tp-forward property value predicate))
|
|
(start (prop-match-beginning match))
|
|
(end (prop-match-end match)))
|
|
(let ((res (funcall function start end idx)))
|
|
(when collect (push res lst)))
|
|
(cl-incf idx 1))
|
|
(nreverse lst))))
|
|
|
|
(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 collect))
|
|
|
|
;;; Match and regexp functions (similar to ov-match and ov-regexp)
|
|
|
|
(defun tp-match (pattern &rest args)
|
|
"Set properties on all occurrences of PATTERN.
|
|
|
|
This function supports two calling conventions:
|
|
|
|
1. With OBJECT (string or buffer):
|
|
(tp-match PATTERN OBJECT PROPERTY VALUE ...)
|
|
(tp-match PATTERN OBJECT \\='(PROPERTY VALUE ...))
|
|
|
|
2. Without OBJECT (current buffer):
|
|
(tp-match PATTERN PROPERTY VALUE ...)
|
|
(tp-match PATTERN \\='(PROPERTY VALUE ...))
|
|
|
|
PATTERN is the string to search for.
|
|
PROPERTIES is a plist of property-value pairs.
|
|
Returns:
|
|
- For strings: the modified string
|
|
- For buffers: list of (START . END) pairs for all matches."
|
|
(let (object properties)
|
|
;; Determine calling convention based on second argument type
|
|
(cond
|
|
;; Second arg is a string - it's the object
|
|
((and args (stringp (car args)))
|
|
(setq object (car args)
|
|
properties (cdr args)))
|
|
;; Second arg is a buffer - it's the object
|
|
((and args (bufferp (car args)))
|
|
(setq object (car args)
|
|
properties (cdr args)))
|
|
;; No object specified, use current buffer
|
|
(t
|
|
(setq object nil
|
|
properties args)))
|
|
;; Handle properties as a list
|
|
(when (listp (car-safe properties))
|
|
(setq properties (car properties)))
|
|
;; Dispatch based on object type
|
|
(cond
|
|
;; String object
|
|
((stringp object)
|
|
(let ((pos 0))
|
|
(while (string-match (regexp-quote pattern) object pos)
|
|
(let ((beg (match-beginning 0))
|
|
(end (match-end 0)))
|
|
(when properties
|
|
(tp-put beg end properties object))
|
|
;; Advance position: for zero-width match, advance by 1 to avoid infinite loop
|
|
(setq pos (if (= beg end) (1+ beg) end))))
|
|
object))
|
|
;; Buffer or nil (current buffer)
|
|
(t
|
|
(let ((buf (or object (current-buffer))))
|
|
(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
|
|
(tp-put beg end properties buf))
|
|
(push (cons beg end) regions)))
|
|
(nreverse regions)))))))))
|
|
|
|
(defun tp-regexp (pattern &rest args)
|
|
"Set properties on all matches of PATTERN (regexp).
|
|
|
|
This function supports two calling conventions:
|
|
|
|
1. With OBJECT (string or buffer):
|
|
(tp-regexp PATTERN OBJECT PROPERTY VALUE ...)
|
|
(tp-regexp PATTERN OBJECT \\='(PROPERTY VALUE ...))
|
|
|
|
2. Without OBJECT (current buffer):
|
|
(tp-regexp PATTERN PROPERTY VALUE ...)
|
|
(tp-regexp PATTERN \\='(PROPERTY VALUE ...))
|
|
|
|
PATTERN is the regexp to search for.
|
|
PROPERTIES is a plist of property-value pairs.
|
|
Returns:
|
|
- For strings: the modified string
|
|
- For buffers: list of (START . END) pairs for all matches."
|
|
(let (object properties)
|
|
;; Determine calling convention based on second argument type
|
|
(cond
|
|
;; Second arg is a string - it's the object
|
|
((and args (stringp (car args)))
|
|
(setq object (car args)
|
|
properties (cdr args)))
|
|
;; Second arg is a buffer - it's the object
|
|
((and args (bufferp (car args)))
|
|
(setq object (car args)
|
|
properties (cdr args)))
|
|
;; No object specified, use current buffer
|
|
(t
|
|
(setq object nil
|
|
properties args)))
|
|
;; Handle properties as a list
|
|
(when (listp (car-safe properties))
|
|
(setq properties (car properties)))
|
|
;; Dispatch based on object type
|
|
(cond
|
|
;; String object
|
|
((stringp object)
|
|
(let ((pos 0))
|
|
(while (string-match pattern object pos)
|
|
(let ((beg (match-beginning 0))
|
|
(end (match-end 0)))
|
|
(when properties
|
|
(tp-put beg end properties object))
|
|
;; Advance position: for zero-width match, advance by 1 to avoid infinite loop
|
|
(setq pos (if (= beg end) (1+ beg) end))))
|
|
object))
|
|
;; Buffer or nil (current buffer)
|
|
(t
|
|
(let ((buf (or object (current-buffer))))
|
|
(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
|
|
(tp-put beg end properties buf))
|
|
(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-group-undefine (name)
|
|
"Remove layer group NAME from `tp-layer-groups'."
|
|
(setq tp-layer-groups (assq-delete-all name tp-layer-groups)))
|
|
|
|
(defalias 'tp-layer-group-undefine 'tp-group-undefine
|
|
"Alias for `tp-group-undefine'.")
|
|
|
|
(provide 'tp)
|
|
;;; tp.el ends here
|