972b6d4e4c
Add canonical query semantics, managed metadata and transactions, overlay-aware lookup, reproducible benchmarks, and synchronized API documentation.
1555 lines
63 KiB
EmacsLisp
1555 lines
63 KiB
EmacsLisp
;;; 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/lower/rotate/pin/switch/hide/show/merge/
|
|
;; flatten, stack queries, and bulk layer property manipulation.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'dash)
|
|
(require 'tp-core)
|
|
(require 'tp-reactive)
|
|
(require 'tp-layer)
|
|
|
|
;;; Shared argument parsing and region iteration
|
|
|
|
(defun tp--parse-layer-args (start-or-string rest n)
|
|
"Normalize a layer operation's positional arguments.
|
|
|
|
START-OR-STRING is the caller's first positional argument and REST the
|
|
list of its remaining positional arguments, in order. N is the number
|
|
of operation-specific arguments the caller takes (for example 2 for
|
|
`tp-put-layer's LAYER and IDX).
|
|
|
|
Two calling conventions are supported:
|
|
- (STRING ARG1 ... ARGN): operate on the whole STRING.
|
|
- (START END ARG1 ... ARGN OBJECT): operate on a region of OBJECT,
|
|
where nil means the current buffer.
|
|
|
|
Returns the list (START END OBJECT ARG1 ... ARGN) with START/END in
|
|
OBJECT's native coordinates (0-based for strings, 1-based for
|
|
buffers)."
|
|
(cond
|
|
((stringp start-or-string)
|
|
(let ((range (tp--native-range-from-object
|
|
start-or-string 0 (length start-or-string))))
|
|
(append (list (tp--native-range-start range)
|
|
(tp--native-range-end range)
|
|
(tp--native-range-object range))
|
|
(seq-take rest n))))
|
|
((numberp start-or-string)
|
|
(let* ((operation-args (seq-take (cdr rest) n))
|
|
(object (nth (1+ n) rest))
|
|
(range (tp--native-range-from-object
|
|
object start-or-string (car rest))))
|
|
(append (list (tp--native-range-start range)
|
|
(tp--native-range-end range)
|
|
(tp--native-range-object range))
|
|
operation-args)))
|
|
(t (error "Invalid layer arguments: %S" (cons start-or-string rest)))))
|
|
|
|
(defun tp--plist-remove (plist key)
|
|
"Return a copy of PLIST without KEY and its value.
|
|
Comparison uses `eq'. PLIST itself is not modified."
|
|
(cl-loop for (k v) on plist by #'cddr
|
|
unless (eq k key) append (list k v)))
|
|
|
|
(define-error 'tp-layer-transaction-error "tp layer transaction failed")
|
|
|
|
(defvar tp--managed-operation-counter 0
|
|
"Monotonic counter for managed lifecycle operation ids.")
|
|
|
|
(defun tp--managed-next-operation-id ()
|
|
"Return a fresh managed lifecycle operation id."
|
|
(setq tp--managed-operation-counter (1+ tp--managed-operation-counter))
|
|
(intern (format "tp-managed-op-%d" tp--managed-operation-counter)))
|
|
|
|
(defun tp--plist-remove-keys (plist keys)
|
|
"Return a copy of PLIST without any key in KEYS."
|
|
(cl-loop for (k v) on plist by #'cddr
|
|
unless (memq k keys) append (list k v)))
|
|
|
|
(defun tp--managed-render-props (layer)
|
|
"Return LAYER without lifecycle-only storage properties."
|
|
(tp--entry-render-projection layer))
|
|
|
|
(defun tp--managed-public-layer-props (layer)
|
|
"Return LAYER's public stack query properties."
|
|
(tp--plist-remove-keys layer '(tp-name tp-meta)))
|
|
|
|
(defun tp--managed-spec-arglist (name)
|
|
"Return NAME's parameter arglist when available."
|
|
(cond
|
|
((and (fboundp 'tp-layer-parameterized-p)
|
|
(tp-layer-parameterized-p name))
|
|
(tp-layer-arglist name))
|
|
((and (fboundp 'tp-group-parameterized-p)
|
|
(tp-group-parameterized-p name))
|
|
(tp--group-arglist name))))
|
|
|
|
(defun tp--managed-meta-for-spec (spec layer)
|
|
"Build managed metadata for SPEC mounted as LAYER."
|
|
(let* ((name (plist-get layer 'tp-name))
|
|
(spec-name (if (consp spec) (car spec) spec))
|
|
(group-p (and (symbolp spec-name)
|
|
(assoc spec-name tp-layer-groups)))
|
|
(parameterized-p (and (symbolp spec-name)
|
|
(tp--managed-spec-arglist spec-name)))
|
|
(args (when (and (consp spec) (or group-p parameterized-p))
|
|
(copy-tree (cdr spec))))
|
|
(origin (cond
|
|
(group-p 'group)
|
|
(args 'parameterized)
|
|
((assoc name tp-layer-alist) 'defined)
|
|
(name 'inline)
|
|
(t 'anonymous))))
|
|
(tp--managed-entry-meta
|
|
name origin spec args (tp--managed-spec-arglist spec-name))))
|
|
|
|
(defun tp--managed-add-meta-to-layers (spec layers)
|
|
"Return LAYERS with managed metadata derived from SPEC."
|
|
(mapcar (lambda (layer)
|
|
(if (plist-member layer 'tp-meta)
|
|
layer
|
|
(append layer
|
|
(list 'tp-meta
|
|
(tp--managed-meta-for-spec spec layer)))))
|
|
layers))
|
|
|
|
(defun tp--stack-map-region (start end object function)
|
|
"Call FUNCTION over each property run of [START, END) in OBJECT.
|
|
|
|
OBJECT is a string, a buffer, or nil for the current buffer.
|
|
FUNCTION receives (ABS-START ABS-END STACK): the run's bounds, clipped
|
|
to [START, END) and expressed in OBJECT's native coordinates (0-based
|
|
for strings, 1-based for buffers), and the run's layer stack as a list
|
|
of layer plists, top layer first (empty for bare text). Hidden layers
|
|
\(see `tp-hide-layer') are included at their stack position.
|
|
|
|
Returns the list of FUNCTION's non-nil results, in order.
|
|
|
|
Unlike `tp-intervals-map', runs never extend beyond the requested
|
|
region, positions are absolute for strings as well as buffers, and
|
|
bare text is visited (with an empty STACK) so layers can be applied to
|
|
previously property-less text."
|
|
(delq nil
|
|
(tp--map-intervals
|
|
object start end
|
|
(lambda (i-start i-end props)
|
|
(funcall function i-start i-end
|
|
(tp--stack-props-to-list props))))))
|
|
|
|
(defun tp--stack-register-layers (stack object)
|
|
"Register OBJECT in the reactive buffer registry for every layer in STACK.
|
|
STACK is a list of layer plists as stored by the stack operations.
|
|
When OBJECT is a buffer or nil (the current buffer), every plist
|
|
carrying a `tp-name' - buried and hidden layers included - registers
|
|
that buffer via `tp-reactive--register-layer-buffer', so reactive
|
|
updates and the anonymous-layer GC keep seeing buffers whose layers
|
|
were written by stack mutators rather than by `tp-set'. String
|
|
OBJECTs are not registered; see `tp-reactive-layer-buffers' for that
|
|
gap. Registration is idempotent, so calling this once per rewritten
|
|
run is cheap."
|
|
(when (or (null object) (bufferp object))
|
|
(let ((buf (or object (current-buffer))))
|
|
(dolist (layer stack)
|
|
(when-let ((name (plist-get layer 'tp-name)))
|
|
(tp-reactive--register-layer-buffer name buf))))))
|
|
|
|
;;; Queries
|
|
|
|
(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, with
|
|
positions in OBJECT's native coordinates (0-based for strings, 1-based
|
|
for buffers) and clipped to the requested region."
|
|
(tp--stack-map-region
|
|
start end object
|
|
(lambda (abs-start abs-end stack)
|
|
(when-let ((props (seq-find
|
|
(lambda (props)
|
|
(equal layer-name
|
|
(plist-get props 'tp-name)))
|
|
stack)))
|
|
(list abs-start abs-end
|
|
(tp--plist-remove props 'tp-meta))))))
|
|
|
|
(defun tp-layer-list (start end &optional object)
|
|
"Return list of all layer names in region from START to END."
|
|
(let ((layers nil))
|
|
(tp--stack-map-region
|
|
start end object
|
|
(lambda (_abs-start _abs-end stack)
|
|
(dolist (layer stack)
|
|
(when-let ((name (plist-get layer 'tp-name)))
|
|
(cl-pushnew name layers :test #'equal)))))
|
|
(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--stack-map-region
|
|
start end object
|
|
(lambda (_abs-start _abs-end stack)
|
|
(setq max-count (max max-count (length stack)))))
|
|
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 topmost named layer in START..END of OBJECT.
|
|
Scans the region's property runs in order and returns the `tp-name'
|
|
of the first top layer that has one, so bare or unnamed runs (for
|
|
example before a layer that starts mid-region) do not hide layers
|
|
later in the region. Returns nil when no run in the region has a
|
|
named top layer. OBJECT defaults to current buffer.
|
|
|
|
The topmost layer is reported in stack order even when it is hidden
|
|
\(see `tp-hide-layer'); use `tp-layer-stack-at' to distinguish hidden
|
|
layers from visible ones."
|
|
(car (tp--stack-map-region
|
|
start end object
|
|
(lambda (_abs-start _abs-end stack)
|
|
(plist-get (car stack) 'tp-name)))))
|
|
|
|
(defun tp-layer-stack-at (pos &optional object)
|
|
"Return the full ordered layer stack at POS in OBJECT.
|
|
|
|
The result is a list with one element per layer, topmost layer first
|
|
and bottommost last, where each element is a cons (NAME . PROPS):
|
|
- NAME is the layer's `tp-name' symbol, or nil for an unnamed layer.
|
|
- PROPS is the layer's property plist without its `tp-name' entry.
|
|
A hidden layer (see `tp-hide-layer') is distinguishable by the
|
|
entry `tp-hidden' with value t in PROPS; visible layers never
|
|
carry a `tp-hidden' entry.
|
|
|
|
Hidden layers are included at their stack position. Returns nil for
|
|
bare text. POS is in OBJECT's native coordinates (0-based for
|
|
strings, 1-based for buffers). OBJECT is a string, a buffer, or nil
|
|
for the current buffer."
|
|
(mapcar (lambda (layer)
|
|
(cons (plist-get layer 'tp-name)
|
|
(tp--managed-public-layer-props layer)))
|
|
(tp--stack-props-to-list (text-properties-at pos object))))
|
|
|
|
;;; Managed lifecycle APIs
|
|
|
|
(defun tp--managed-layer-names-in-stack (stack)
|
|
"Return named managed layers from STACK in stack order."
|
|
(let (names)
|
|
(dolist (layer stack)
|
|
(when-let ((name (plist-get layer 'tp-name)))
|
|
(cl-pushnew name names :test #'equal)))
|
|
(nreverse names)))
|
|
|
|
(defun tp--managed-legacy-meta (layer)
|
|
"Return safe legacy metadata for LAYER."
|
|
(plist-put
|
|
(tp--managed-meta-for-spec (plist-get layer 'tp-name) layer)
|
|
:legacy-no-args t))
|
|
|
|
(defun tp--managed-normalize-stack (stack)
|
|
"Return STACK with safe legacy managed entries migrated."
|
|
(mapcar (lambda (layer)
|
|
(if (or (not (plist-get layer 'tp-name))
|
|
(plist-member layer 'tp-meta))
|
|
layer
|
|
(append layer (list 'tp-meta
|
|
(tp--managed-legacy-meta layer)))))
|
|
stack))
|
|
|
|
;;;###autoload
|
|
(defun tp-attach-managed-layers (start end &optional object)
|
|
"Attach managed layer identity in START..END of OBJECT.
|
|
The scan is limited to the requested range. Return discovered layer
|
|
names in range order."
|
|
(let ((found nil))
|
|
(tp--stack-map-region
|
|
start end object
|
|
(lambda (abs-start abs-end stack)
|
|
(let ((new-stack (tp--managed-normalize-stack stack)))
|
|
(unless (equal new-stack stack)
|
|
(set-text-properties abs-start abs-end
|
|
(tp--stack-build-props new-stack)
|
|
object))
|
|
(dolist (name (tp--managed-layer-names-in-stack new-stack))
|
|
(cl-pushnew name found :test #'equal)))))
|
|
(dolist (name (nreverse found))
|
|
(when (or (null object) (bufferp object))
|
|
(tp-reactive--register-layer-buffer
|
|
name (or object (current-buffer)))))
|
|
(nreverse found)))
|
|
|
|
(defun tp--managed-detached-props (stack keep-rendered)
|
|
"Return raw properties for detaching STACK.
|
|
When KEEP-RENDERED is non-nil, preserve the current visible
|
|
projection without managed storage properties."
|
|
(when keep-rendered
|
|
(tp--plist-remove
|
|
(tp--managed-render-props
|
|
(seq-find (lambda (layer)
|
|
(not (tp--stack-hidden-p layer)))
|
|
stack))
|
|
'tp-name)))
|
|
|
|
;;;###autoload
|
|
(defun tp-detach-managed-layers (start end &optional object keep-rendered)
|
|
"Detach managed layer storage in START..END of OBJECT.
|
|
When KEEP-RENDERED is non-nil, preserve currently visible text
|
|
properties after removing lifecycle storage. Return detached layer
|
|
names in range order."
|
|
(let ((found nil))
|
|
(tp--stack-map-region
|
|
start end object
|
|
(lambda (abs-start abs-end stack)
|
|
(when stack
|
|
(dolist (name (tp--managed-layer-names-in-stack stack))
|
|
(cl-pushnew name found :test #'equal))
|
|
(set-text-properties abs-start abs-end
|
|
(tp--managed-detached-props
|
|
stack keep-rendered)
|
|
object))))
|
|
(let ((result (nreverse found)))
|
|
(when (or (null object) (bufferp object))
|
|
(let* ((buffer (or object (current-buffer)))
|
|
(remaining (tp-reactive--buffer-layer-names buffer)))
|
|
(dolist (name result)
|
|
(unless (member name remaining)
|
|
(tp-reactive--unregister-layer-buffer name buffer)))))
|
|
result)))
|
|
|
|
(defun tp--managed-layer-entry (start end layer)
|
|
"Return a diagnostics entry for LAYER covering START..END."
|
|
(let ((meta (plist-get layer 'tp-meta)))
|
|
(list :range (cons start end)
|
|
:name (plist-get layer 'tp-name)
|
|
:entry-id (plist-get meta :entry-id)
|
|
:origin (plist-get meta :origin)
|
|
:spec (copy-tree (plist-get meta :spec))
|
|
:args (copy-tree (plist-get meta :args))
|
|
:arglist (copy-tree (plist-get meta :arglist))
|
|
:definition-version (plist-get meta :definition-version)
|
|
:entry-version (plist-get meta :entry-version)
|
|
:hidden (tp--stack-hidden-p layer)
|
|
:palette-deps (copy-tree (plist-get meta :palette-deps))
|
|
:palette-generation (plist-get meta :palette-generation)
|
|
:legacy-no-args (plist-get meta :legacy-no-args))))
|
|
|
|
(defun tp--managed-buffer-diagnostic-data (buffer layer-filter)
|
|
"Collect managed diagnostics in BUFFER for LAYER-FILTER or all layers."
|
|
(let ((layers nil)
|
|
(entries nil)
|
|
(errors nil))
|
|
(when (buffer-live-p buffer)
|
|
(tp--map-intervals
|
|
buffer nil nil
|
|
(lambda (start end props)
|
|
(condition-case err
|
|
(dolist (layer (tp--stack-props-to-list props))
|
|
(let ((name (plist-get layer 'tp-name)))
|
|
(when (and name
|
|
(or (null layer-filter)
|
|
(equal name layer-filter)))
|
|
(cl-pushnew name layers :test #'equal)
|
|
(push (tp--managed-layer-entry start end layer)
|
|
entries))))
|
|
(error
|
|
(push (list :range (cons start end)
|
|
:condition err)
|
|
errors))))))
|
|
(list :buffer buffer
|
|
:layers (nreverse layers)
|
|
:entries (nreverse entries)
|
|
:observer-errors (copy-tree tp-reactive-observer-errors)
|
|
:errors (nreverse errors))))
|
|
|
|
;;;###autoload
|
|
(defun tp-managed-layer-diagnostics (layer-name)
|
|
"Return read-only managed diagnostics for LAYER-NAME."
|
|
(let ((entries nil)
|
|
(buffers nil)
|
|
(errors nil)
|
|
(registered (tp-reactive-layer-buffers layer-name)))
|
|
(dolist (buffer (if (eq registered 'unknown)
|
|
(buffer-list)
|
|
registered))
|
|
(when (buffer-live-p buffer)
|
|
(let ((diag (tp--managed-buffer-diagnostic-data
|
|
buffer layer-name)))
|
|
(when (plist-get diag :entries)
|
|
(push buffer buffers)
|
|
(setq entries (append entries
|
|
(plist-get diag :entries))))
|
|
(setq errors (append errors (plist-get diag :errors))))))
|
|
(list :layer layer-name
|
|
:definition-version (tp--layer-definition-version layer-name)
|
|
:entries entries
|
|
:args (mapcar (lambda (entry)
|
|
(plist-get entry :args))
|
|
entries)
|
|
:registry registered
|
|
:buffers (nreverse buffers)
|
|
:observer-errors
|
|
(cl-remove-if-not
|
|
(lambda (entry) (equal (plist-get entry :layer) layer-name))
|
|
(copy-tree tp-reactive-observer-errors))
|
|
:errors errors)))
|
|
|
|
;;;###autoload
|
|
(defun tp-managed-buffer-diagnostics (&optional buffer)
|
|
"Return read-only managed diagnostics for BUFFER."
|
|
(tp--managed-buffer-diagnostic-data
|
|
(or buffer (current-buffer)) nil))
|
|
|
|
(defun tp--managed-theme-diagnostics ()
|
|
"Return read-only managed theme diagnostics."
|
|
(list :generation (if (boundp 'tp-theme-generation)
|
|
tp-theme-generation 0)
|
|
:last-hook-source (and (boundp 'tp-theme-last-hook-source)
|
|
tp-theme-last-hook-source)
|
|
:refresh-mode (if (boundp 'tp-theme-last-refresh-mode)
|
|
tp-theme-last-refresh-mode :conservative)
|
|
:refreshed-ranges
|
|
(and (boundp 'tp-theme-last-refreshed-ranges)
|
|
tp-theme-last-refreshed-ranges)
|
|
:errors (and (boundp 'tp-theme-last-refresh-errors)
|
|
tp-theme-last-refresh-errors)))
|
|
|
|
;;;###autoload
|
|
(defun tp-managed-diagnostics ()
|
|
"Return read-only global managed lifecycle diagnostics."
|
|
(let ((layers nil)
|
|
(buffers nil)
|
|
(entries nil)
|
|
(errors nil))
|
|
(dolist (buffer (buffer-list))
|
|
(when (buffer-live-p buffer)
|
|
(let ((diag (tp--managed-buffer-diagnostic-data buffer nil)))
|
|
(when (plist-get diag :entries)
|
|
(push buffer buffers)
|
|
(setq layers (append layers (plist-get diag :layers)))
|
|
(setq entries (append entries
|
|
(plist-get diag :entries))))
|
|
(setq errors (append errors (plist-get diag :errors))))))
|
|
(list :layers (delete-dups layers)
|
|
:buffers (nreverse buffers)
|
|
:entries entries
|
|
:args (mapcar (lambda (entry)
|
|
(plist-get entry :args))
|
|
entries)
|
|
:registry (copy-hash-table tp--layer-buffers)
|
|
:observer-errors (copy-tree tp-reactive-observer-errors)
|
|
:errors errors
|
|
:theme (tp--managed-theme-diagnostics))))
|
|
|
|
(defun tp--transaction-snapshot (start end object)
|
|
"Snapshot exact text and properties in START..END of OBJECT."
|
|
(if (stringp object)
|
|
(substring object start end)
|
|
(let ((buf (or object (current-buffer))))
|
|
(with-current-buffer buf
|
|
(buffer-substring start end)))))
|
|
|
|
(defun tp--transaction-restore (start end object snapshot)
|
|
"Restore SNAPSHOT over START..END of OBJECT."
|
|
(if (stringp object)
|
|
(progn
|
|
(unless (= (- end start) (length snapshot))
|
|
(error "Cannot restore a resized string transaction"))
|
|
(store-substring object start (substring-no-properties snapshot))
|
|
(set-text-properties start end nil object)
|
|
(tp--map-intervals
|
|
snapshot 0 (length snapshot)
|
|
(lambda (from to props)
|
|
(set-text-properties (+ start from) (+ start to) props object))))
|
|
(let ((buf (or object (current-buffer))))
|
|
(with-current-buffer buf
|
|
(let ((inhibit-read-only t))
|
|
(delete-region start end)
|
|
(goto-char start)
|
|
(insert snapshot))))))
|
|
|
|
(defun tp--transaction-runs (start end object)
|
|
"Return exact property intervals for START..END of OBJECT."
|
|
(tp-intervals start end object t))
|
|
|
|
(defun tp--transaction-changed-ranges (before after)
|
|
"Return ranges whose text/property intervals differ between BEFORE and AFTER."
|
|
(let (ranges)
|
|
(cl-loop for b in before
|
|
for a in after
|
|
unless (equal b a)
|
|
do (push (cons (nth 0 (or a b))
|
|
(nth 1 (or a b)))
|
|
ranges))
|
|
(when (/= (length before) (length after))
|
|
(dolist (entry (nthcdr (min (length before) (length after))
|
|
(append before after)))
|
|
(push (cons (nth 0 entry) (nth 1 entry)) ranges)))
|
|
(nreverse ranges)))
|
|
|
|
(defun tp--transaction-live-bounds (from to markers)
|
|
"Return the live transaction bounds for FROM, TO, and MARKERS."
|
|
(if markers
|
|
(cons (marker-position (car markers))
|
|
(marker-position (cdr markers)))
|
|
(cons from to)))
|
|
|
|
(defun tp--transaction-result
|
|
(status operation-id stage start end object result condition rollback changed)
|
|
"Build a structured transaction result plist."
|
|
(list :status status
|
|
:ok (eq status 'ok)
|
|
:result result
|
|
:operation-id operation-id
|
|
:stage stage
|
|
:object object
|
|
:range (cons start end)
|
|
:current-run (car (tp--transaction-runs start end object))
|
|
:layer nil
|
|
:entry-id nil
|
|
:expected-version nil
|
|
:actual-version nil
|
|
:expected-properties nil
|
|
:actual-properties nil
|
|
:original-condition condition
|
|
:rollback-applied rollback
|
|
:changed-ranges changed))
|
|
|
|
;;;###autoload
|
|
(defun tp-layer-transaction (start end object function &optional noerror)
|
|
"Run FUNCTION as a managed layer transaction over START..END of OBJECT.
|
|
On success, return a structured plist whose `:result' is FUNCTION's
|
|
value. On failure, restore the exact pre-transaction text/property
|
|
state. Signal `tp-layer-transaction-error' unless NOERROR is non-nil,
|
|
in which case return the structured failure plist."
|
|
(let* ((range (tp--native-range-from-object object start end))
|
|
(obj (tp--native-range-object range))
|
|
(from (tp--native-range-start range))
|
|
(to (tp--native-range-end range))
|
|
(operation-id (tp--managed-next-operation-id))
|
|
(snapshot (tp--transaction-snapshot from to obj))
|
|
(before (tp--transaction-runs from to obj))
|
|
(markers (unless (stringp obj)
|
|
(cons (copy-marker from nil)
|
|
(copy-marker to nil)))))
|
|
(unwind-protect
|
|
(condition-case err
|
|
(let* ((result (funcall function))
|
|
(live (tp--transaction-live-bounds from to markers)))
|
|
(tp--transaction-result
|
|
'ok operation-id 'commit from to obj result nil nil
|
|
(tp--transaction-changed-ranges
|
|
before (tp--transaction-runs
|
|
(car live) (cdr live) obj))))
|
|
(error
|
|
(let* ((live (tp--transaction-live-bounds from to markers))
|
|
(rollback-applied nil)
|
|
rollback-condition)
|
|
(condition-case rollback-err
|
|
(progn
|
|
(tp--transaction-restore
|
|
(car live) (cdr live) obj snapshot)
|
|
(setq rollback-applied t))
|
|
(error (setq rollback-condition rollback-err)))
|
|
(let ((result (tp--transaction-result
|
|
'error operation-id 'body from to obj nil err
|
|
rollback-applied
|
|
(tp--transaction-changed-ranges
|
|
before (tp--transaction-runs from to obj)))))
|
|
(when rollback-condition
|
|
(setq result
|
|
(plist-put result :rollback-condition
|
|
rollback-condition)))
|
|
(if noerror
|
|
result
|
|
(signal 'tp-layer-transaction-error (list result)))))))
|
|
(when markers
|
|
(set-marker (car markers) nil)
|
|
(set-marker (cdr markers) nil)))))
|
|
|
|
;;; Layer spec normalization for tp-put-layer
|
|
|
|
(defun tp--put-layer-specs (layer-spec)
|
|
"Normalize LAYER-SPEC into a list of layer plists for `tp-put-layer'.
|
|
|
|
LAYER-SPEC can be:
|
|
- a layer name or group name (symbol);
|
|
- (LAYER-NAME ARG) or (GROUP-NAME ARG) for parameterized layers/groups;
|
|
- an inline plist, e.g. (face bold) or (:foreground \"red\");
|
|
- (NAME PROP VAL ...) for a named inline layer;
|
|
- a list of any of the above.
|
|
|
|
An inline plist is recognized by its even length together with a head
|
|
that is a keyword or an ordinary property symbol (one that is not a
|
|
defined layer or group name); a named inline layer has odd length
|
|
\(NAME plus prop/value pairs)."
|
|
(cond
|
|
;; Group name symbol.
|
|
((and (symbolp layer-spec)
|
|
(assoc layer-spec tp-layer-groups))
|
|
(if (tp-group-parameterized-p layer-spec)
|
|
(error "Parameterized group %S requires an argument, use '(%S ARG)"
|
|
layer-spec layer-spec)
|
|
(tp-group-props layer-spec t))) ; include tp-name for layer stack
|
|
;; Any other symbol: a single layer name.
|
|
((symbolp layer-spec)
|
|
(list (tp--normalize-layer-spec layer-spec)))
|
|
;; (GROUP-NAME ARG1 ... ARGN) or (GROUP-NAME (ARG1 ... ARGN)):
|
|
;; multi-argument parameterized group (arity >= 2). Checked before
|
|
;; the single-arg forms so the wrapped variant is not mistaken for
|
|
;; one list-valued argument.
|
|
((and (consp layer-spec)
|
|
(symbolp (car layer-spec))
|
|
(proper-list-p layer-spec)
|
|
(let ((arity (length (tp--group-arglist (car layer-spec)))))
|
|
(and (>= arity 2)
|
|
(or (= (length (cdr layer-spec)) arity)
|
|
(and (= (length (cdr layer-spec)) 1)
|
|
(proper-list-p (cadr layer-spec))
|
|
(= (length (cadr layer-spec)) arity))))))
|
|
(let* ((arity (length (tp--group-arglist (car layer-spec))))
|
|
(args (if (= (length (cdr layer-spec)) arity)
|
|
(cdr layer-spec)
|
|
(cadr layer-spec))))
|
|
(tp--group-props-with-args (car layer-spec) args t)))
|
|
;; (LAYER-NAME ARG1 ... ARGN) or (LAYER-NAME (ARG1 ... ARGN)):
|
|
;; multi-argument parameterized layer (arity >= 2).
|
|
((and (consp layer-spec)
|
|
(symbolp (car layer-spec))
|
|
(proper-list-p layer-spec)
|
|
(let ((arity (length (tp-layer-arglist (car layer-spec)))))
|
|
(and (>= arity 2)
|
|
(or (= (length (cdr layer-spec)) arity)
|
|
(and (= (length (cdr layer-spec)) 1)
|
|
(proper-list-p (cadr layer-spec))
|
|
(= (length (cadr layer-spec)) arity))))))
|
|
(let* ((arity (length (tp-layer-arglist (car layer-spec))))
|
|
(args (if (= (length (cdr layer-spec)) arity)
|
|
(cdr layer-spec)
|
|
(cadr layer-spec))))
|
|
(list (tp--normalize-layer-spec (cons (car layer-spec) args)))))
|
|
;; (GROUP-NAME ARG): parameterized group.
|
|
((and (consp layer-spec)
|
|
(symbolp (car layer-spec))
|
|
(= (safe-length layer-spec) 2)
|
|
(tp-group-parameterized-p (car layer-spec)))
|
|
(tp-group-props-with-arg (car layer-spec) (cadr layer-spec) t))
|
|
;; (LAYER-NAME ARG): parameterized layer.
|
|
((and (consp layer-spec)
|
|
(symbolp (car layer-spec))
|
|
(= (safe-length layer-spec) 2)
|
|
(tp-layer-parameterized-p (car layer-spec)))
|
|
(list (tp--normalize-layer-spec layer-spec)))
|
|
;; Keyword-headed plist: a single inline layer.
|
|
((and (consp layer-spec) (keywordp (car layer-spec)))
|
|
(list (tp--normalize-layer-spec layer-spec)))
|
|
;; Even-length plist headed by an ordinary (non-layer) property
|
|
;; symbol, e.g. (face bold): a single inline layer.
|
|
((and (consp layer-spec)
|
|
(car layer-spec)
|
|
(symbolp (car layer-spec))
|
|
(not (tp--is-layer-name-p (car layer-spec)))
|
|
(proper-list-p layer-spec)
|
|
(cl-evenp (length layer-spec)))
|
|
(list layer-spec))
|
|
;; List whose every element is itself a spec (a layer/group name or
|
|
;; a list): multiple layers.
|
|
((and (consp layer-spec)
|
|
(proper-list-p layer-spec)
|
|
(cl-every (lambda (el)
|
|
(or (consp el) (tp--is-layer-name-p el)))
|
|
layer-spec))
|
|
(apply #'append (mapcar #'tp--put-layer-specs layer-spec)))
|
|
;; Anything else, including (NAME PROP VAL ...) named inline
|
|
;; layers; tp--normalize-layer-spec signals on invalid specs.
|
|
(t
|
|
(list (tp--normalize-layer-spec layer-spec)))))
|
|
|
|
;;; Mutators
|
|
|
|
(defun tp-put-layer (start-or-string &optional end-or-layer layer-or-idx idx-or-object object noerror)
|
|
"Set layer(s) at a specific index position.
|
|
|
|
Calling conventions:
|
|
1. Buffer/string region:
|
|
(tp-put-layer START END LAYER IDX OBJECT NOERROR)
|
|
|
|
2. Entire string:
|
|
(tp-put-layer STRING LAYER IDX NOERROR)
|
|
|
|
LAYER can be:
|
|
- A symbol (layer name from `tp-layer-alist' or `tp-layer-groups')
|
|
- A list (LAYER-NAME ARG) or (GROUP-NAME ARG) for parameterized
|
|
layers or groups
|
|
- A plist (inline layer definition), e.g. (face bold)
|
|
- 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. Only text inside
|
|
\[START, END) is modified.
|
|
|
|
A LAYER naming an undefined layer or group normally signals an
|
|
error. If NOERROR is non-nil, return nil instead of signaling when
|
|
LAYER cannot be resolved; nothing is modified in that case.
|
|
|
|
Unlike `tp-set', the string form modifies STRING destructively (in
|
|
place) rather than returning a propertized copy: never pass a string
|
|
literal or a shared string you do not own. The returned string is
|
|
that same mutated object.
|
|
|
|
Returns OBJECT when one was given (in particular the string in
|
|
string forms), otherwise the cons (START . END)."
|
|
(pcase-let ((`(,start ,end ,obj ,layer-spec ,idx)
|
|
(tp--parse-layer-args
|
|
start-or-string
|
|
(list end-or-layer layer-or-idx idx-or-object object) 2)))
|
|
(setq idx (or idx 0))
|
|
(let* ((noerr (if (stringp start-or-string) idx-or-object noerror))
|
|
(layers-to-add
|
|
(if noerr
|
|
(condition-case nil
|
|
(tp--put-layer-specs layer-spec)
|
|
(tp-unresolved-layer 'tp--unresolved))
|
|
(tp--put-layer-specs layer-spec))))
|
|
(unless (eq layers-to-add 'tp--unresolved)
|
|
(setq layers-to-add
|
|
(tp--managed-add-meta-to-layers layer-spec layers-to-add))
|
|
(tp--stack-map-region
|
|
start end obj
|
|
(lambda (abs-start abs-end stack)
|
|
(let* ((actual-idx (if (< idx 0)
|
|
(max 0 (+ (length stack) 1 idx))
|
|
(min idx (length stack))))
|
|
(new-stack (append (seq-take stack actual-idx)
|
|
layers-to-add
|
|
(seq-drop stack actual-idx))))
|
|
(set-text-properties abs-start abs-end
|
|
(tp--stack-build-props new-stack)
|
|
obj)
|
|
(tp--stack-register-layers new-stack obj))))
|
|
(or obj (cons start end))))))
|
|
|
|
(defun tp-push-layer (start-or-string &optional end-or-layer layer-or-object object noerror)
|
|
"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 NOERROR)
|
|
|
|
2. Entire string:
|
|
(tp-push-layer STRING LAYER NOERROR)
|
|
|
|
A LAYER naming an undefined layer or group normally signals an
|
|
error. If NOERROR is non-nil, return nil instead of signaling when
|
|
LAYER cannot be resolved; nothing is modified in that case.
|
|
|
|
Unlike `tp-set', the string form modifies STRING destructively (in
|
|
place) rather than returning a propertized copy: never pass a string
|
|
literal or a shared string you do not own. The returned string is
|
|
that same mutated object.
|
|
|
|
Returns what `tp-put-layer' returns: OBJECT when one was given (in
|
|
particular the string in string forms), otherwise (START . END)."
|
|
(pcase-let ((`(,start ,end ,obj ,layer)
|
|
(tp--parse-layer-args
|
|
start-or-string
|
|
(list end-or-layer layer-or-object object) 1)))
|
|
(let ((noerr (if (stringp start-or-string) layer-or-object noerror)))
|
|
(tp-put-layer start end layer 0 obj noerr))))
|
|
|
|
(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)
|
|
|
|
Only text inside [START, END) is modified.
|
|
|
|
Unlike `tp-set', the string form modifies STRING destructively (in
|
|
place) rather than returning a propertized copy: never pass a string
|
|
literal or a shared string you do not own.
|
|
|
|
Returns the number of property runs modified. A LAYER-NAME/IDX
|
|
matching no layer never signals: unmatched runs are silently left
|
|
alone and a return value of 0 means nothing matched at all."
|
|
(pcase-let ((`(,start ,end ,obj ,layer-id)
|
|
(tp--parse-layer-args
|
|
start-or-string
|
|
(list end-or-idx idx-or-object object) 1)))
|
|
(let ((count 0))
|
|
(tp--stack-map-region
|
|
start end obj
|
|
(lambda (abs-start abs-end stack)
|
|
(when-let ((found (tp--get-layer-by-idx-or-name stack layer-id)))
|
|
(let ((new-stack (-remove-at (car found) stack)))
|
|
(set-text-properties abs-start abs-end
|
|
(tp--stack-build-props new-stack)
|
|
obj)
|
|
(tp--stack-register-layers new-stack obj))
|
|
(setq count (1+ count)))))
|
|
count)))
|
|
|
|
(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)
|
|
|
|
Unlike `tp-set', the string form modifies STRING destructively (in
|
|
place) rather than returning a propertized copy: never pass a string
|
|
literal or a shared string you do not own.
|
|
|
|
Returns the number of property runs modified; 0 means no run in the
|
|
region had a layer to pop."
|
|
(pcase-let ((`(,start ,end ,obj)
|
|
(tp--parse-layer-args
|
|
start-or-string (list end-or-object object) 0)))
|
|
(tp-delete-layer start end 0 obj)))
|
|
|
|
(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.
|
|
|
|
Unlike `tp-set', the string form modifies STRING destructively (in
|
|
place) rather than returning a propertized copy: never pass a string
|
|
literal or a shared string you do not own.
|
|
|
|
Returns the number of property runs modified. A FROM-ID matching no
|
|
layer never signals: unmatched runs are silently left alone and a
|
|
return value of 0 means nothing matched at all."
|
|
(pcase-let ((`(,start ,end ,obj ,from-id ,to-idx)
|
|
(tp--parse-layer-args
|
|
start-or-string
|
|
(list end-or-from from-or-to to-or-object object) 2)))
|
|
(let ((count 0))
|
|
(tp--stack-map-region
|
|
start end obj
|
|
(lambda (abs-start abs-end stack)
|
|
(when-let ((new-stack (tp--move-layer-in-stack stack from-id to-idx)))
|
|
(set-text-properties abs-start abs-end
|
|
(tp--stack-build-props new-stack)
|
|
obj)
|
|
(tp--stack-register-layers new-stack obj)
|
|
(setq count (1+ count)))))
|
|
count)))
|
|
|
|
(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).
|
|
N defaults to 1. The resulting position is clamped to the stack.
|
|
|
|
Uses `tp--raise-layer-in-stack' internally, which is built on
|
|
`tp--move-layer-in-stack'.
|
|
|
|
Unlike `tp-set', the string form modifies STRING destructively (in
|
|
place) rather than returning a propertized copy: never pass a string
|
|
literal or a shared string you do not own.
|
|
|
|
Returns the number of property runs modified. An IDX/LAYER-NAME
|
|
matching no layer never signals: unmatched runs are silently left
|
|
alone and a return value of 0 means nothing matched at all."
|
|
(pcase-let ((`(,start ,end ,obj ,layer-id ,n)
|
|
(tp--parse-layer-args
|
|
start-or-string
|
|
(list end-or-idx idx-or-n n-or-object object) 2)))
|
|
(setq n (or n 1))
|
|
(let ((count 0))
|
|
(tp--stack-map-region
|
|
start end obj
|
|
(lambda (abs-start abs-end stack)
|
|
(when-let ((new-stack (tp--raise-layer-in-stack stack layer-id n)))
|
|
(set-text-properties abs-start abs-end
|
|
(tp--stack-build-props new-stack)
|
|
obj)
|
|
(tp--stack-register-layers new-stack obj)
|
|
(setq count (1+ count)))))
|
|
count)))
|
|
|
|
(defun tp-lower-layer (start-or-string &optional end-or-idx idx-or-n n-or-object object)
|
|
"Lower a layer by N positions in the stack.
|
|
|
|
This is the mirror image of `tp-raise-layer': lowering by N is
|
|
raising by -N.
|
|
|
|
Calling conventions:
|
|
1. Buffer/string region:
|
|
(tp-lower-layer START END IDX/LAYER-NAME N OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-lower-layer STRING IDX/LAYER-NAME N)
|
|
|
|
IDX/LAYER-NAME identifies the layer: a layer name symbol or an
|
|
integer index (0 = top, negative indices count from the bottom, so
|
|
-1 = bottom).
|
|
|
|
Positive N moves the layer down (toward bottom).
|
|
Negative N moves the layer up (toward top/visible).
|
|
N defaults to 1. The resulting position is clamped to the stack.
|
|
|
|
OBJECT defaults to current buffer for region form.
|
|
|
|
Unlike `tp-set', the string form modifies STRING destructively (in
|
|
place) rather than returning a propertized copy: never pass a string
|
|
literal or a shared string you do not own.
|
|
|
|
Returns the number of property runs modified. An IDX/LAYER-NAME
|
|
matching no layer never signals: unmatched runs are silently left
|
|
alone and a return value of 0 means nothing matched at all."
|
|
(pcase-let ((`(,start ,end ,obj ,layer-id ,n)
|
|
(tp--parse-layer-args
|
|
start-or-string
|
|
(list end-or-idx idx-or-n n-or-object object) 2)))
|
|
(setq n (or n 1))
|
|
(tp-raise-layer start end layer-id (- n) obj)))
|
|
|
|
(defun tp-rotate-layer (start-or-string &optional end-or-direction
|
|
direction-object-or-count
|
|
count-or-direction object-or-count)
|
|
"Rotate layers, by default moving the top layer to the bottom.
|
|
|
|
Calling conventions:
|
|
1. Buffer/string region (canonical order, OBJECT last like the rest
|
|
of the stack family):
|
|
(tp-rotate-layer START END DIRECTION &optional COUNT OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-rotate-layer STRING DIRECTION COUNT)
|
|
|
|
3. Buffer/string region (legacy 0.3.0 order, kept working forever):
|
|
(tp-rotate-layer START END OBJECT DIRECTION COUNT)
|
|
|
|
The two region orders are told apart by the third argument: the
|
|
symbols `up' and `down' are never valid OBJECTs, so a third argument
|
|
of `up'/`down' unambiguously selects the canonical order, e.g.
|
|
\(tp-rotate-layer 1 5 \\='up) - no nil OBJECT placeholder needed.
|
|
Any other third argument (a buffer, a string, or nil for the current
|
|
buffer) selects the legacy order.
|
|
|
|
DIRECTION is `down' or nil to move the top layer to the bottom (the
|
|
historical behavior), or `up' to move the bottom layer to the top;
|
|
any other value signals an error. COUNT is the number of rotation
|
|
steps and defaults to 1; a COUNT below 1 rotates nothing. Layers
|
|
keep their relative order; hidden layers rotate with the rest of the
|
|
stack.
|
|
|
|
OBJECT defaults to current buffer for region forms.
|
|
|
|
Unlike `tp-set', the string form modifies STRING destructively (in
|
|
place) rather than returning a propertized copy: never pass a string
|
|
literal or a shared string you do not own.
|
|
|
|
Returns the number of property runs modified; 0 means no run in the
|
|
region had layers to rotate (or COUNT was below 1)."
|
|
(let (start end obj dir cnt)
|
|
(cond
|
|
;; Entire string form: (STRING DIRECTION COUNT).
|
|
((stringp start-or-string)
|
|
(setq start 0
|
|
end (length start-or-string)
|
|
obj start-or-string
|
|
dir end-or-direction
|
|
cnt direction-object-or-count))
|
|
((numberp start-or-string)
|
|
(setq start start-or-string
|
|
end end-or-direction)
|
|
(if (memq direction-object-or-count '(up down))
|
|
;; Canonical region order: (START END DIRECTION COUNT OBJECT).
|
|
(setq dir direction-object-or-count
|
|
cnt count-or-direction
|
|
obj object-or-count)
|
|
;; Legacy region order: (START END OBJECT DIRECTION COUNT).
|
|
(setq obj direction-object-or-count
|
|
dir count-or-direction
|
|
cnt object-or-count)))
|
|
(t (error "Invalid layer arguments: %S"
|
|
(cons start-or-string
|
|
(list end-or-direction direction-object-or-count)))))
|
|
(let ((applied 0))
|
|
(setq dir (or dir 'down)
|
|
cnt (or cnt 1))
|
|
(unless (memq dir '(up down))
|
|
(error "Invalid rotate direction: %S" dir))
|
|
(when (>= cnt 1)
|
|
(tp--stack-map-region
|
|
start end obj
|
|
(lambda (abs-start abs-end stack)
|
|
(when stack
|
|
(let* ((len (length stack))
|
|
(k (mod (if (eq dir 'up) (- cnt) cnt) len))
|
|
(new-stack (append (seq-drop stack k)
|
|
(seq-take stack k))))
|
|
(set-text-properties abs-start abs-end
|
|
(tp--stack-build-props new-stack)
|
|
obj)
|
|
(tp--stack-register-layers new-stack obj)
|
|
(setq applied (1+ applied)))))))
|
|
applied)))
|
|
|
|
(defun tp-pin-layer (start-or-string &optional end-or-idx idx-or-object object)
|
|
"Move layer IDX/LAYER-NAME to the top of the stack (one-shot).
|
|
|
|
Despite the name, nothing stays pinned: this is a single move to
|
|
index 0, exactly (tp-move-layer ... IDX/LAYER-NAME 0 ...), and
|
|
nothing prevents a later `tp-push-layer' or `tp-put-layer' from
|
|
covering the moved layer again.
|
|
|
|
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)
|
|
|
|
Unlike `tp-set', the string form modifies STRING destructively (in
|
|
place) rather than returning a propertized copy: never pass a string
|
|
literal or a shared string you do not own.
|
|
|
|
Returns the number of property runs modified. An IDX/LAYER-NAME
|
|
matching no layer never signals: unmatched runs are silently left
|
|
alone and a return value of 0 means nothing matched at all."
|
|
(pcase-let ((`(,start ,end ,obj ,layer-id)
|
|
(tp--parse-layer-args
|
|
start-or-string
|
|
(list end-or-idx idx-or-object object) 1)))
|
|
(tp-move-layer start end layer-id 0 obj)))
|
|
|
|
(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.
|
|
|
|
Unlike `tp-set', the string form modifies STRING destructively (in
|
|
place) rather than returning a propertized copy: never pass a string
|
|
literal or a shared string you do not own.
|
|
|
|
Returns the number of property runs modified. When either layer is
|
|
missing from a run's stack nothing signals: such runs are silently
|
|
left alone and a return value of 0 means nothing matched at all."
|
|
(pcase-let ((`(,start ,end ,obj ,id1 ,id2)
|
|
(tp--parse-layer-args
|
|
start-or-string
|
|
(list end-or-id1 id1-or-id2 id2-or-object object) 2)))
|
|
(let ((count 0))
|
|
(tp--stack-map-region
|
|
start end obj
|
|
(lambda (abs-start abs-end stack)
|
|
(when-let ((new-stack (tp--switch-layers-in-stack stack id1 id2)))
|
|
(set-text-properties abs-start abs-end
|
|
(tp--stack-build-props new-stack)
|
|
obj)
|
|
(tp--stack-register-layers new-stack obj)
|
|
(setq count (1+ count)))))
|
|
count)))
|
|
|
|
(defun tp-hide-layer (start-or-string &optional end-or-name name-or-object object)
|
|
"Hide layer NAME in region from START to END without removing it.
|
|
|
|
Calling conventions:
|
|
1. Buffer/string region:
|
|
(tp-hide-layer START END NAME OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-hide-layer STRING NAME)
|
|
|
|
NAME identifies the layer: a layer name symbol or an integer index
|
|
into the full stack, hidden layers included (0 = top, -1 = bottom).
|
|
|
|
A hidden layer stays in the stack -- it still counts for
|
|
`tp-layer-count', appears in `tp-layer-list' and `tp-layer-stack-at'
|
|
and can be moved, raised or lowered -- but it no longer renders: the
|
|
text shows the properties of the topmost non-hidden layer instead.
|
|
Hiding the currently visible top layer therefore reveals the next
|
|
visible layer below it. When every layer of a run is hidden the text
|
|
keeps only the `tp-layers' bookkeeping property (so not even
|
|
`tp-name' renders) while all layers stay queryable. Use
|
|
`tp-show-layer' to make a hidden layer render again.
|
|
|
|
Hiddenness is stored as a `tp-hidden' flag entry inside the layer's
|
|
plist in the `tp-layers' stack storage, so `tp-hidden' is a reserved
|
|
property name inside layers, like `tp-name'.
|
|
|
|
OBJECT defaults to current buffer for region form.
|
|
|
|
Unlike `tp-set', the string form modifies STRING destructively (in
|
|
place) rather than returning a propertized copy: never pass a string
|
|
literal or a shared string you do not own.
|
|
|
|
Returns the number of property runs modified. A NAME matching no
|
|
layer never signals; runs whose match is already hidden are left
|
|
alone as well, so a return value of 0 means nothing changed."
|
|
(pcase-let ((`(,start ,end ,obj ,name)
|
|
(tp--parse-layer-args
|
|
start-or-string
|
|
(list end-or-name name-or-object object) 1)))
|
|
(let ((count 0))
|
|
(tp--stack-map-region
|
|
start end obj
|
|
(lambda (abs-start abs-end stack)
|
|
(when-let ((found (tp--get-layer-by-idx-or-name stack name)))
|
|
(unless (tp--stack-hidden-p (cdr found))
|
|
(let ((new-stack (-replace-at (car found)
|
|
(append (list 'tp-hidden t)
|
|
(cdr found))
|
|
stack)))
|
|
(set-text-properties abs-start abs-end
|
|
(tp--stack-build-props new-stack)
|
|
obj)
|
|
(tp--stack-register-layers new-stack obj)
|
|
(setq count (1+ count)))))))
|
|
count)))
|
|
|
|
(defun tp-show-layer (start-or-string &optional end-or-name name-or-object object)
|
|
"Show layer NAME in region from START to END, undoing `tp-hide-layer'.
|
|
|
|
Calling conventions:
|
|
1. Buffer/string region:
|
|
(tp-show-layer START END NAME OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-show-layer STRING NAME)
|
|
|
|
NAME identifies the layer: a layer name symbol or an integer index
|
|
into the full stack, hidden layers included (0 = top, -1 = bottom).
|
|
|
|
The layer's `tp-hidden' flag is removed. When the shown layer sits
|
|
above the currently visible top layer it becomes the rendered layer
|
|
again, restoring its properties onto the text.
|
|
|
|
OBJECT defaults to current buffer for region form.
|
|
|
|
Unlike `tp-set', the string form modifies STRING destructively (in
|
|
place) rather than returning a propertized copy: never pass a string
|
|
literal or a shared string you do not own.
|
|
|
|
Returns the number of property runs modified. A NAME matching no
|
|
layer never signals; runs whose match is not hidden are left alone
|
|
as well, so a return value of 0 means nothing changed."
|
|
(pcase-let ((`(,start ,end ,obj ,name)
|
|
(tp--parse-layer-args
|
|
start-or-string
|
|
(list end-or-name name-or-object object) 1)))
|
|
(let ((count 0))
|
|
(tp--stack-map-region
|
|
start end obj
|
|
(lambda (abs-start abs-end stack)
|
|
(when-let ((found (tp--get-layer-by-idx-or-name stack name)))
|
|
(when (tp--stack-hidden-p (cdr found))
|
|
(let ((new-stack (-replace-at (car found)
|
|
(tp--plist-remove (cdr found)
|
|
'tp-hidden)
|
|
stack)))
|
|
(set-text-properties abs-start abs-end
|
|
(tp--stack-build-props new-stack)
|
|
obj)
|
|
(tp--stack-register-layers new-stack obj)
|
|
(setq count (1+ count)))))))
|
|
count)))
|
|
|
|
(defun tp--merge-layer-props (layers initial)
|
|
"Merge the plists of LAYERS into the INITIAL plist and return it.
|
|
LAYERS is a list of (INDEX . PROPS) conses as returned by
|
|
`tp--get-layer-by-idx-or-name'. Earlier layers take precedence: a key
|
|
already present in the accumulator is never overwritten, and presence
|
|
is tested with `plist-member' so an explicit nil value in a higher
|
|
layer shadows lower layers' values. `tp-name' keys of the merged
|
|
layers are dropped (INITIAL may seed its own), as are `tp-hidden'
|
|
bookkeeping flags (see `tp-hide-layer')."
|
|
(cl-reduce (lambda (acc layer)
|
|
(cl-loop for (key val) on (cdr layer) by #'cddr
|
|
unless (memq key '(tp-name tp-hidden))
|
|
do (unless (plist-member acc key)
|
|
(setq acc (plist-put acc key val))))
|
|
acc)
|
|
layers
|
|
:initial-value initial))
|
|
|
|
(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 ...))
|
|
|
|
Earlier layers in the list take precedence; a property explicitly set
|
|
to nil in a higher-precedence layer stays nil in the merged layer.
|
|
|
|
Hidden matched layers (see `tp-hide-layer') are merged away with the
|
|
rest but contribute NO properties to the merged layer, so a merge can
|
|
never render what was hidden. When EVERY matched layer of a run is
|
|
hidden, the merged layer keeps their merged properties but carries
|
|
the `tp-hidden' flag itself: the data is preserved without un-hiding
|
|
anything, and `tp-show-layer' on the merged layer renders it.
|
|
|
|
Unlike `tp-set', the string form modifies STRING destructively (in
|
|
place) rather than returning a propertized copy: never pass a string
|
|
literal or a shared string you do not own.
|
|
|
|
Returns the number of property runs modified, counting like
|
|
`tp-delete-layer': a run counts when at least one listed layer
|
|
matched and the merge rewrote it, and 0 means nothing matched at
|
|
all."
|
|
(pcase-let ((`(,start ,end ,obj ,new-name ,layer-ids)
|
|
(tp--parse-layer-args
|
|
start-or-string
|
|
(list end-or-name name-or-ids ids-or-object object) 2)))
|
|
(let ((count 0))
|
|
(tp--stack-map-region
|
|
start end obj
|
|
(lambda (abs-start abs-end stack)
|
|
(let* ((layers-to-merge
|
|
(cl-loop for id in layer-ids
|
|
for found = (tp--get-layer-by-idx-or-name 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).
|
|
;; Hidden layers contribute no props unless ALL matched
|
|
;; layers are hidden, in which case the merged layer
|
|
;; keeps their props but stays hidden itself.
|
|
(let* ((visible (seq-remove (lambda (found)
|
|
(tp--stack-hidden-p (cdr found)))
|
|
layers-to-merge))
|
|
(merged-props
|
|
(if visible
|
|
(tp--merge-layer-props
|
|
visible (list 'tp-name new-name))
|
|
(tp--merge-layer-props
|
|
layers-to-merge
|
|
(list 'tp-name new-name 'tp-hidden t))))
|
|
(new-stack stack))
|
|
;; Remove old layers from stack
|
|
(dolist (idx (mapcar #'car sorted-layers))
|
|
(setq new-stack (-remove-at idx new-stack)))
|
|
;; Add merged layer at top
|
|
(setq new-stack (cons merged-props new-stack))
|
|
(set-text-properties abs-start abs-end
|
|
(tp--stack-build-props new-stack)
|
|
obj)
|
|
(tp--stack-register-layers new-stack obj)
|
|
(setq count (1+ count)))))))
|
|
count)))
|
|
|
|
(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. Higher layers take precedence;
|
|
a property explicitly set to nil in a higher layer stays nil in the
|
|
flattened result.
|
|
|
|
Hidden layers (see `tp-hide-layer') are DISCARDED, mirroring
|
|
image-editor flatten semantics: only the visible layers' properties
|
|
merge into the flattened result, so flattening can never render what
|
|
was hidden. When EVERY layer of a run is hidden, the run's
|
|
properties are cleared entirely (bare text), consistent with the
|
|
all-hidden rendering of `tp-hide-layer'.
|
|
|
|
Unlike `tp-set', the string form modifies STRING destructively (in
|
|
place) rather than returning a propertized copy: never pass a string
|
|
literal or a shared string you do not own.
|
|
|
|
Returns the number of property runs modified, counting like
|
|
`tp-delete-layer': every run that had layers to flatten counts, and
|
|
0 means no run in the region had any layers."
|
|
(pcase-let ((`(,start ,end ,obj ,name)
|
|
(tp--parse-layer-args
|
|
start-or-string
|
|
(list end-or-name name-or-object object) 1)))
|
|
(let ((count 0))
|
|
(tp--stack-map-region
|
|
start end obj
|
|
(lambda (abs-start abs-end stack)
|
|
(when stack
|
|
;; Hidden layers are discarded; an all-hidden run flattens
|
|
;; to bare text.
|
|
(let* ((visible (seq-remove #'tp--stack-hidden-p stack))
|
|
(merged-props
|
|
(when visible
|
|
(tp--merge-layer-props
|
|
(cl-loop for layer in visible
|
|
for i from 0
|
|
collect (cons i layer))
|
|
(when name (list 'tp-name name))))))
|
|
(set-text-properties abs-start abs-end merged-props obj)
|
|
(when merged-props
|
|
(tp--stack-register-layers (list merged-props) obj))
|
|
(setq count (1+ count))))))
|
|
count)))
|
|
|
|
(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.
|
|
|
|
Unlike `tp-set', the string form modifies STRING destructively (in
|
|
place) rather than returning a propertized copy: never pass a string
|
|
literal or a shared string you do not own. The returned string is
|
|
that same mutated object.
|
|
|
|
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)))
|
|
(t (error "Invalid layer arguments: %S"
|
|
(cons start-or-string (list end-or-plist plist-or-object)))))
|
|
|
|
;; 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--stack-map-region
|
|
start end obj
|
|
(lambda (abs-start abs-end stack)
|
|
(let ((modified-stack
|
|
(cl-loop for layer in stack
|
|
for i from 0
|
|
collect
|
|
(if (cl-some
|
|
(lambda (id)
|
|
(let ((found (tp--get-layer-by-idx-or-name
|
|
stack id)))
|
|
(and found (= (car found) i))))
|
|
layer-ids)
|
|
;; Merge plist into this layer
|
|
(tp--deep-merge-plist layer plist)
|
|
;; Keep layer unchanged
|
|
layer))))
|
|
(when stack
|
|
(set-text-properties abs-start abs-end
|
|
(tp--stack-build-props modified-stack)
|
|
obj)
|
|
(tp--stack-register-layers modified-stack 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.
|
|
|
|
Unlike `tp-set', the string form modifies STRING destructively (in
|
|
place) rather than returning a propertized copy: never pass a string
|
|
literal or a shared string you do not own. The returned string is
|
|
that same mutated object.
|
|
|
|
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)))
|
|
(t (error "Invalid layer arguments: %S"
|
|
(cons start-or-string (list end-or-plist plist-or-object)))))
|
|
|
|
;; 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
|