8c28361640
API-NAME-02: tp-define-layer, tp-define-group and tp-define-palette are new permanent aliases of define-tp, define-tps and define-tp-palette, each with a real docstring and the defun indent spec, so C-h f tp-TAB finds the library's definition macros and package-prefix review passes. The historical names stay forever; zero callers change. API-SYM-01: tp-group-props-with-args is now public, delegating to the private implementation, mirroring tp-layer-props-with-args - multi-argument parameterized groups are a public feature (reachable via tp-put-layer specs) and previously had no public introspection path. All four -with-arg/-with-args docstrings now cross-reference their singular/plural sibling (calling out the one-character name difference) and their layer/group counterpart. Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
1681 lines
78 KiB
EmacsLisp
1681 lines
78 KiB
EmacsLisp
;;; tp-layer.el --- Layer definition and registry for tp -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2024-2026 Geekinney
|
|
|
|
;; Author: Geekinney (kinneyzhang666@gmail.com)
|
|
|
|
;; This program is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU General Public License as
|
|
;; published by the Free Software Foundation; either version 3 of
|
|
;; the License, or (at your option) any later version.
|
|
|
|
;;; Commentary:
|
|
|
|
;; The layer registry: `define-tp' / `define-tps' and all machinery to
|
|
;; define, store, resolve and expand named property layers and groups,
|
|
;; plus the layer-stack representation helpers shared with tp-stack.el.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'dash)
|
|
(require 'tp-core)
|
|
(require 'tp-reactive)
|
|
|
|
(defvar tp--layer-refresh-function nil
|
|
"Function re-rendering regions that carry a given layer, or nil.
|
|
Installed by tp-render.el. Called with (LAYER-NAME) after a layer is
|
|
redefined, so text that already uses the layer picks up the new
|
|
definition. When nil, redefinition only updates the registry.")
|
|
|
|
(defun tp--layer-refresh (layer-name)
|
|
"Re-render regions carrying LAYER-NAME via `tp--layer-refresh-function'."
|
|
(when tp--layer-refresh-function
|
|
(funcall tp--layer-refresh-function layer-name)))
|
|
|
|
(defvar tp-layer-alist nil
|
|
"Alist of layer definitions: (LAYER-NAME . PROPERTIES).")
|
|
|
|
(defvar tp-layer-groups nil
|
|
"Alist of layer groups: (GROUP-NAME . (LAYER-NAME1 LAYER-NAME2 ...)).")
|
|
|
|
(defvar tp-layer-transforms nil
|
|
"Alist of layer transforms: (LAYER-NAME . TRANSFORM-FN).
|
|
TRANSFORM-FN receives the value and returns the transformed value.
|
|
Used for tp-text transformations like formatting numbers or dates.")
|
|
|
|
(defvar tp--group-generated-layers nil
|
|
"Alist tracking layers generated by each group: (GROUP-NAME . LAYER-NAMES).
|
|
Only layers created by the group definition itself (anonymous and
|
|
named elements) are recorded here; layers merely referenced by name
|
|
are not. Used to clean up orphaned layers when a group is redefined
|
|
or undefined.")
|
|
|
|
;; The counter below INTENTIONALLY survives `tp-layer-reset' (which
|
|
;; clears `tp--anonymous-layer-registry' but not this): detached
|
|
;; strings can outlive a reset while still carrying `tp-anon-N'
|
|
;; property values, so the counter must keep increasing monotonically
|
|
;; - a post-reset anonymous layer must never be minted under a name a
|
|
;; stale string still holds. Do not "fix" this by resetting it.
|
|
(defvar tp--anonymous-layer-counter 0
|
|
"Counter for generating unique anonymous layer names.
|
|
Never reset - not even by `tp-layer-reset' - so freshly minted
|
|
`tp-anon-N' names cannot collide with names living on in detached
|
|
strings (see the comment above).")
|
|
|
|
(defun tp--generate-anonymous-layer-name ()
|
|
"Generate a unique symbol for anonymous reactive layers."
|
|
(setq tp--anonymous-layer-counter (1+ tp--anonymous-layer-counter))
|
|
(intern (format "tp-anon-%d" tp--anonymous-layer-counter)))
|
|
|
|
(defvar tp--anonymous-layer-registry nil
|
|
"Alist interning anonymous reactive layers: (PROPS-SPEC . LAYER-NAME).
|
|
PROPS-SPEC is the original (unresolved) props spec passed to
|
|
`tp--resolve-props'; LAYER-NAME is the anonymous layer registered for
|
|
it. Lookup is `equal'-based, so resolving an identical spec reuses
|
|
the existing anonymous layer instead of minting a new registry entry
|
|
on every call.")
|
|
|
|
(defun tp--anonymous-layer-name-for (props)
|
|
"Return the interned anonymous layer name for reactive spec PROPS.
|
|
If an `equal' spec was registered before, reuse its layer name;
|
|
otherwise generate a fresh name via `tp--generate-anonymous-layer-name'
|
|
and record it in `tp--anonymous-layer-registry'."
|
|
(or (cdr (assoc props tp--anonymous-layer-registry))
|
|
(let ((name (tp--generate-anonymous-layer-name)))
|
|
(push (cons (copy-tree props) name) tp--anonymous-layer-registry)
|
|
name)))
|
|
|
|
(defun tp--buffer-has-layer-region-p (layer-name &optional buffer)
|
|
"Return non-nil when BUFFER has a region carrying LAYER-NAME.
|
|
BUFFER defaults to the current buffer; a dead BUFFER yields nil.
|
|
Stack-aware: the layer counts as present when it is the rendered top
|
|
layer (direct `tp-name' text property) or sits anywhere inside the
|
|
`tp-layers' stack-storage property - buried below another layer, or
|
|
hidden (see `tp-hide-layer') - so liveness checks never miss a layer
|
|
a live buffer still holds. Built on the shared scan
|
|
`tp-reactive--buffer-layer-names'."
|
|
(and (member layer-name (tp-reactive--buffer-layer-names buffer)) t))
|
|
|
|
;;;###autoload
|
|
(defun tp-gc-anonymous-layers ()
|
|
"Collect anonymous layers that no live buffer displays anymore.
|
|
Walk `tp--anonymous-layer-registry' and, for every interned anonymous
|
|
layer whose buffer registry has real knowledge (see
|
|
`tp-reactive-layer-buffers'), check whether any registered live
|
|
buffer still contains a region carrying the layer - as the rendered
|
|
top layer or anywhere inside `tp-layers' stack storage, so buried and
|
|
hidden layers count as alive (see `tp--buffer-has-layer-region-p').
|
|
Layers displayed nowhere are undefined via `tp-undefine-layer', which
|
|
also drops their reactive dependencies, transforms and registry
|
|
entries.
|
|
|
|
Layers whose registry state is `unknown' are conservatively kept:
|
|
they were never seen in any buffer through the registering paths,
|
|
and detached strings may still reference them. A layer becomes
|
|
collectable only after it was registered for at least one buffer and
|
|
none of the registered buffers still shows it (for example after the
|
|
buffers were killed); call `tp-reactive-track-buffer' after
|
|
inserting propertized strings so their buffers are registered too.
|
|
|
|
Return the list of collected layer names."
|
|
(interactive)
|
|
(let ((collected nil))
|
|
;; Snapshot the names first: `tp-undefine-layer' mutates the
|
|
;; anonymous-layer registry while we iterate.
|
|
(dolist (name (mapcar #'cdr tp--anonymous-layer-registry))
|
|
(let ((bufs (tp-reactive-layer-buffers name)))
|
|
(when (and (not (eq bufs 'unknown))
|
|
(not (cl-some (lambda (buf)
|
|
(tp--buffer-has-layer-region-p name buf))
|
|
bufs)))
|
|
(tp-undefine-layer name)
|
|
(push name collected))))
|
|
(when (called-interactively-p 'interactive)
|
|
(message "tp: collected %d anonymous layer(s)" (length collected)))
|
|
(nreverse collected)))
|
|
|
|
(defvar tp--layer-expansion-stack nil
|
|
"Layer names currently being expanded, innermost first.
|
|
Dynamically bound during `tp-layer-props' / `tp-layer-props-with-arg'
|
|
to detect cyclic layer references.")
|
|
|
|
(defun tp--check-layer-cycle (layer-name)
|
|
"Signal a clear error if LAYER-NAME is already being expanded.
|
|
The error message names the full cycle, e.g. \"a -> b -> a\"."
|
|
(when (memq layer-name tp--layer-expansion-stack)
|
|
(error "tp: cyclic layer reference: %s"
|
|
(mapconcat #'symbol-name
|
|
(reverse (cons layer-name tp--layer-expansion-stack))
|
|
" -> "))))
|
|
|
|
(defun tp--get-layer-face-contribution (layer-name layer-prop-value)
|
|
"Get the face contribution from LAYER-NAME.
|
|
LAYER-PROP-VALUE is the value of the layer property (the argument passed to it).
|
|
Returns the face value that the layer adds, or nil if no face contribution."
|
|
(when (tp--is-layer-name-p layer-name)
|
|
(let ((layer-props
|
|
(cond
|
|
((tp-layer-parameterized-p layer-name)
|
|
(tp--layer-props-for-arg-value layer-name layer-prop-value nil))
|
|
((assoc layer-name tp-layer-alist)
|
|
(tp-layer-props layer-name nil))
|
|
((assoc layer-name tp-layer-groups)
|
|
(when-let ((layer-props-list (tp-group-props layer-name t)))
|
|
(tp--build-layer-props layer-props-list))))))
|
|
(when layer-props
|
|
(plist-get layer-props 'face)))))
|
|
|
|
(defun tp--parse-define-layer-args (args)
|
|
"Parse ARGS for tp--define-layer-internal function.
|
|
Returns plist with keys :props, :data, :watch, :compute, :transform.
|
|
- Keyword arguments: :props PLIST [:data DATA] [:watch WATCH]
|
|
[:compute COMPUTE] [:transform FN]"
|
|
(let (props data watch compute transform)
|
|
(cond
|
|
;; Check for keyword arguments format
|
|
((and (keywordp (car args))
|
|
(memq (car args) '(:props :data :watch :compute :transform)))
|
|
;; Parse keyword arguments
|
|
(let ((rest args))
|
|
(while rest
|
|
(pcase (car rest)
|
|
(:props (setq props (cadr rest) rest (cddr rest)))
|
|
(:data (setq data (cadr rest) rest (cddr rest)))
|
|
(:watch (setq watch (cadr rest) rest (cddr rest)))
|
|
(:compute (setq compute (cadr rest) rest (cddr rest)))
|
|
(:transform (setq transform (cadr rest) rest (cddr rest)))
|
|
(_ (error "Unknown keyword in tp--define-layer-internal: %s" (car rest))))))
|
|
;; Validate: if :watch, :compute, or :data present, :props must be present
|
|
(when (and (or watch compute data) (null props))
|
|
(error "When using :watch, :compute, or :data, :props must be explicitly specified")))
|
|
;; Format 1: single plist (the plist directly as first arg)
|
|
((and (= (length args) 1)
|
|
(listp (car args)))
|
|
(setq props (car args)))
|
|
(t (error "Invalid tp--define-layer-internal format")))
|
|
(list :props props :data data :watch watch :compute compute :transform transform)))
|
|
|
|
(defun tp--define-layer-internal (name &rest args)
|
|
"Define a single text property layer named NAME.
|
|
|
|
This function supports two formats:
|
|
|
|
Format 1 - Direct plist (no :watch/:compute/:data/:transform support):
|
|
(tp--define-layer-internal \\='layer-name
|
|
\\='(display \"🌑\" face (:height 1.0)))
|
|
|
|
Format 2 - With :props, :data, :watch, :compute, and/or :transform
|
|
\(Vue 3 style reactivity):
|
|
(tp--define-layer-internal \\='layer-name
|
|
;; props: $-prefixed symbols are reactive variables;
|
|
;; auto-defined if not bound
|
|
:props \\='(face (:foreground $my-color) help-echo $full-name)
|
|
;; data: additional reactive variables not used in props;
|
|
;; auto-defined if not bound
|
|
:data \\='((first-name . \"John\") (last-name . \"Doe\"))
|
|
;; compute: list of (VAR-NAME FUNCTION) - compute reactive variable values
|
|
:compute \\='((full-name (lambda () (concat first-name \" \" last-name))))
|
|
;; watch: list of (VAR-NAME CALLBACK) - side effects when vars change
|
|
:watch \\='((my-color (lambda (new old layer)
|
|
(message \"Color changed from %s to %s\" old new))))
|
|
;; transform: function to transform tp-text values before display
|
|
:transform (lambda (text) (upcase text)))
|
|
|
|
Reactive Variables:
|
|
If any symbol in :props starts with $, it is treated as a reactive variable.
|
|
Variables in :data are also reactive. All reactive variables are automatically
|
|
defined as global variables if they are not already bound.
|
|
|
|
:data - A list of variable symbols or cons cells (SYMBOL . INITIAL-VALUE)
|
|
for additional reactive state not in :props.
|
|
|
|
:compute - A list of (VAR-SYMBOL COMPUTE-FN) pairs. COMPUTE-FN is evaluated
|
|
to compute the value of VAR-SYMBOL. Can reference other reactive variables
|
|
from both :props and :data.
|
|
|
|
:watch - A list of (VAR-SYMBOL CALLBACK) pairs. CALLBACK is called when
|
|
VAR-SYMBOL changes, receiving (NEW-VALUE OLD-VALUE LAYER-NAME).
|
|
|
|
:transform - A function that receives the tp-text value and returns a
|
|
transformed string. Useful for formatting numbers, dates, or other values
|
|
before display.
|
|
Example: (lambda (text) (format \"$%.2f\" (string-to-number text)))
|
|
|
|
Note: When using :watch, :compute, or :data, you MUST use :props to specify
|
|
the text properties explicitly.
|
|
|
|
If a layer with the same NAME already exists, it will be overwritten.
|
|
The layer is stored in `tp-layer-alist'."
|
|
(declare (indent defun))
|
|
(let* ((parsed (tp--parse-define-layer-args args))
|
|
(properties (plist-get parsed :props))
|
|
(data (plist-get parsed :data))
|
|
(watch (plist-get parsed :watch))
|
|
(compute (plist-get parsed :compute))
|
|
(transform (plist-get parsed :transform))
|
|
(reactive-syms (tp--collect-reactive-symbols properties))
|
|
;; Collect computed variable names (they become reactive too)
|
|
(computed-vars (when compute (mapcar #'car compute)))
|
|
;; All variables that need to be reactive
|
|
(all-reactive-syms (delete-dups (append reactive-syms)))
|
|
;; Variables from :props that need to be defined (without initial values)
|
|
(props-vars (mapcar #'tp--reactive-var-symbol reactive-syms))
|
|
;; All variables to ensure are defined:
|
|
;; - :data entries (may have initial values as cons cells)
|
|
;; - :props reactive symbols (no initial values)
|
|
;; - :compute variable names (no initial values)
|
|
(all-vars-to-define (delete-dups
|
|
(append data
|
|
props-vars
|
|
computed-vars))))
|
|
;; Register or unregister transform function
|
|
(if transform
|
|
(if (assoc name tp-layer-transforms)
|
|
(setcdr (assoc name tp-layer-transforms) transform)
|
|
(push (cons name transform) tp-layer-transforms))
|
|
;; Remove any existing transform when redefining without one
|
|
(setq tp-layer-transforms (assq-delete-all name tp-layer-transforms)))
|
|
(if (or all-reactive-syms data compute)
|
|
;; Has reactive features - register dependencies and resolve at runtime
|
|
(progn
|
|
;; Clean up old reactive dependencies, watchers, computed properties, and data (for re-definition)
|
|
(tp--unregister-reactive-deps name)
|
|
;; Ensure all reactive variables are defined
|
|
(tp--ensure-reactive-variables all-vars-to-define)
|
|
;; Register data variables
|
|
(when data
|
|
(tp--register-layer-data name data))
|
|
;; Register computed variable definitions
|
|
(when compute
|
|
(tp--register-layer-computed name compute)
|
|
;; Apply initial computed values
|
|
(tp--apply-initial-computed compute))
|
|
;; Register reactive dependencies
|
|
(tp--register-reactive-deps name all-reactive-syms properties)
|
|
;; Register watchers
|
|
(when watch
|
|
(tp--register-layer-watchers name watch))
|
|
;; Set layer properties with resolved values
|
|
(let ((resolved-props (tp--resolve-reactive-symbols properties)))
|
|
(tp--set-layer-props name resolved-props))
|
|
;; Update any text regions that already have this layer applied
|
|
;; This ensures re-definition immediately updates applied text
|
|
(tp--layer-refresh name)
|
|
(assoc name tp-layer-alist))
|
|
;; No reactive symbols - use static properties
|
|
(progn
|
|
;; Clean up old reactive dependencies, watchers, computed properties, and data (for re-definition)
|
|
(tp--unregister-reactive-deps name)
|
|
(tp--set-layer-props name properties)
|
|
;; Update any text regions that already have this layer applied
|
|
(tp--layer-refresh name)
|
|
(assoc name tp-layer-alist)))))
|
|
|
|
;;;###autoload
|
|
(defmacro define-tp (name arglist &rest body)
|
|
"Define a text property layer named NAME.
|
|
|
|
This macro supports three formats:
|
|
|
|
Format 1 - Non-parameterized simple (empty arglist, simple body):
|
|
(define-tp tp-bold ()
|
|
\\='(face bold))
|
|
|
|
Format 2 - Parameterized simple (one or more arguments, simple body):
|
|
(define-tp tp-space (pixel)
|
|
\\=`(display (space :width (,pixel))))
|
|
(define-tp tp-colors (fg bg)
|
|
\\=`(face (:foreground ,fg :background ,bg)))
|
|
|
|
Format 3 - Non-parameterized with reactive features
|
|
\(requires $-prefixed variables):
|
|
(define-tp my-layer ()
|
|
:props \\='(face (:foreground $my-color))
|
|
:data \\='((my-color . \"red\"))
|
|
:compute \\='((full-name (lambda () (concat first-name \" \" last-name))))
|
|
:watch \\='((my-color (lambda (new old layer) (message \"Color changed!\"))))
|
|
:transform (lambda (text) (upcase text)))
|
|
|
|
Usage:
|
|
(tp-set \"emacs\" \\='tp-bold t)
|
|
(tp-set 0 5 \\='(tp-bold t) \"emacs\")
|
|
;; => #(\"emacs\" 0 5 (tp-name tp-bold face bold))
|
|
|
|
ARGLIST must be either:
|
|
- An empty list () for non-parameterized layers
|
|
- A list of one or more parameter symbols for parameterized layers
|
|
|
|
BODY is either:
|
|
- A single property list expression (simple format)
|
|
- Keyword arguments starting with :props, :data, :compute, :watch, or :transform
|
|
(reactive format - only for non-parameterized layers with $-prefixed
|
|
variables)
|
|
|
|
In simple format, exactly one body form is accepted; supplying more
|
|
than one signals an error at macro-expansion time instead of silently
|
|
discarding the extra forms.
|
|
|
|
$-prefixed reactive symbols appearing in a PARAMETERIZED body do not
|
|
create reactive dependencies (parameterized layers cannot be
|
|
reactive); they are resolved to the current value of the corresponding
|
|
variable each time the layer is evaluated via
|
|
`tp-layer-props-with-arg' or `tp-layer-props-with-args'.
|
|
|
|
Note: NAME cannot be a built-in Emacs text property name like `face',
|
|
`display', `invisible', etc. See `tp--builtin-text-properties' for the
|
|
complete list of reserved names."
|
|
(declare (indent defun))
|
|
(unless (listp arglist)
|
|
(error "define-tp ARGLIST must be a list"))
|
|
;; Check for built-in text property name conflict
|
|
(when (tp--builtin-text-property-p name)
|
|
(error "define-tp: '%s' is a built-in Emacs text property name and cannot be used as a layer name" name))
|
|
;; Check if body starts with keyword (reactive format)
|
|
(let ((first-elem (car body)))
|
|
(if (and (keywordp first-elem)
|
|
(memq first-elem '(:props :data :compute :watch :transform)))
|
|
;; Reactive format - only allowed for non-parameterized layers
|
|
(if arglist
|
|
(error "define-tp: reactive keywords (:props, :data, :compute, :watch, :transform) are only supported for non-parameterized layers (empty arglist)")
|
|
;; Non-parameterized reactive: use tp--define-layer-internal directly
|
|
`(tp--define-layer-internal ',name ,@body))
|
|
;; Simple format (original behavior)
|
|
(progn
|
|
(when (cdr body)
|
|
(error "define-tp %s: simple format takes exactly one body form, got %d (use the :props keyword format to combine multiple components)"
|
|
name (length body)))
|
|
(let ((simple-body (car body)))
|
|
(cond
|
|
;; Non-parameterized: empty arglist - store as (LAYER-NAME nil BODY-FORM)
|
|
((null arglist)
|
|
`(tp--define-layer-unified ',name nil ,simple-body))
|
|
;; Parameterized: one or more argument symbols - store as
|
|
;; (LAYER-NAME ARGLIST BODY-FORM)
|
|
((cl-every #'symbolp arglist)
|
|
`(tp--define-layer-unified ',name ',arglist ',simple-body))
|
|
(t
|
|
(error "define-tp ARGLIST must be empty or a list of symbols"))))))))
|
|
|
|
;;;###autoload
|
|
(defalias 'tp-define-layer 'define-tp
|
|
"Define a text property layer named NAME; alias of `define-tp'.
|
|
This is the package-prefix-conforming name for the layer definition
|
|
macro, so it is discoverable via the tp- prefix; `define-tp' is the
|
|
historical name and both are permanent - neither will be removed.
|
|
See `define-tp' for the full documentation of NAME, ARGLIST and
|
|
BODY.")
|
|
(function-put 'tp-define-layer 'lisp-indent-function 'defun)
|
|
|
|
(defun tp--define-layer-unified (name arglist body)
|
|
"Define a layer NAME with ARGLIST and BODY using unified structure.
|
|
For non-parameterized layers, ARGLIST is nil and BODY is the evaluated plist.
|
|
For parameterized layers, ARGLIST is a list of one or more parameter
|
|
symbols and BODY is the unevaluated form.
|
|
Stores the layer in `tp-layer-alist' with format:
|
|
\(LAYER-NAME ARGLIST BODY-FORM).
|
|
|
|
For non-parameterized layers, if BODY contains reactive symbols ($-prefixed),
|
|
delegates to `tp--define-layer-internal' for proper reactive handling."
|
|
(if arglist
|
|
;; Parameterized - store for later evaluation
|
|
(let ((entry (list arglist body)))
|
|
(if (assoc name tp-layer-alist)
|
|
(setf (cdr (assoc name tp-layer-alist)) entry)
|
|
(push (cons name entry) tp-layer-alist))
|
|
(assoc name tp-layer-alist))
|
|
;; Non-parameterized - check for reactive symbols
|
|
(let ((reactive-syms (tp--collect-reactive-symbols body)))
|
|
(if reactive-syms
|
|
;; Has reactive symbols - use tp--define-layer-internal for proper handling
|
|
(tp--define-layer-internal name body)
|
|
;; No reactive symbols - store as static layer
|
|
;; Clean up old reactive dependencies if the layer was previously reactive
|
|
(tp--unregister-reactive-deps name)
|
|
(let ((entry (list nil `',body)))
|
|
(if (assoc name tp-layer-alist)
|
|
(setf (cdr (assoc name tp-layer-alist)) entry)
|
|
(push (cons name entry) tp-layer-alist))
|
|
(assoc name tp-layer-alist))))))
|
|
|
|
(defun tp--layer-group-element-format (element)
|
|
"Determine the format type of ELEMENT.
|
|
Returns `symbol', `format-1', `format-2', `format-3', `format-4', or
|
|
nil if invalid."
|
|
(cond
|
|
;; Symbol - reference to existing layer
|
|
((symbolp element) 'symbol)
|
|
;; Format 4 - ("name" :props (plist...) [:data ...] [:watch ...] [:compute ...])
|
|
;; Named layer with :props and optional :data/:watch/:compute
|
|
((and (listp element)
|
|
(> (length element) 3)
|
|
(stringp (car element))
|
|
(eq (cadr element) :props)
|
|
(listp (caddr element))
|
|
;; Must have additional keywords after :props
|
|
(let ((rest (cdddr element)))
|
|
(and rest (keywordp (car rest)))))
|
|
'format-4)
|
|
;; Format 3 - ("name" :props (plist...))
|
|
((and (listp element)
|
|
(= (length element) 3)
|
|
(stringp (car element))
|
|
(eq (cadr element) :props)
|
|
(listp (caddr element)))
|
|
'format-3)
|
|
;; Format 2 - ("name" . (plist...)) - cons cell with proper list cdr
|
|
((and (consp element)
|
|
(stringp (car element))
|
|
(listp (cdr element))
|
|
(not (eq (cadr element) :props))) ; Distinguish from format-3
|
|
'format-2)
|
|
;; Format 1 - (plist...) - anonymous, must start with a symbol
|
|
((and (listp element)
|
|
(symbolp (car element)))
|
|
'format-1)
|
|
(t nil)))
|
|
|
|
(defun tp--parse-layer-group-element (group-name element idx)
|
|
"Parse a layer group element and return (layer-name . properties)
|
|
or extended form.
|
|
GROUP-NAME is the name of the layer group.
|
|
ELEMENT is the element to parse (can be anonymous plist, cons-cell,
|
|
or :props form).
|
|
IDX is the index for anonymous elements.
|
|
|
|
Returns a cons cell (LAYER-NAME . PROPERTIES) or a symbol if ELEMENT
|
|
references an already-defined layer.
|
|
For format-4 elements, returns (LAYER-NAME :props PROPS :data DATA
|
|
:watch WATCH :compute COMPUTE :transform TRANSFORM).
|
|
Unknown keywords in format-4 elements signal an error."
|
|
(let ((format (tp--layer-group-element-format element)))
|
|
(pcase format
|
|
('symbol element)
|
|
('format-4
|
|
;; Parse named layer with :props and optional :data/:watch/:compute/:transform
|
|
(let* ((layer-suffix (car element))
|
|
(layer-name (intern (format "%s-%s" group-name layer-suffix)))
|
|
(rest (cdr element))
|
|
(props nil)
|
|
(data nil)
|
|
(watch nil)
|
|
(compute nil)
|
|
(transform nil))
|
|
;; Parse keyword arguments
|
|
(while rest
|
|
(pcase (car rest)
|
|
(:props (setq props (cadr rest) rest (cddr rest)))
|
|
(:data (setq data (cadr rest) rest (cddr rest)))
|
|
(:watch (setq watch (cadr rest) rest (cddr rest)))
|
|
(:compute (setq compute (cadr rest) rest (cddr rest)))
|
|
(:transform (setq transform (cadr rest) rest (cddr rest)))
|
|
(unknown
|
|
(error "Unknown keyword %S in layer group element: %S"
|
|
unknown element))))
|
|
(list layer-name :props props :data data :watch watch
|
|
:compute compute :transform transform)))
|
|
('format-3
|
|
(let* ((layer-suffix (car element))
|
|
(layer-name (intern (format "%s-%s" group-name layer-suffix)))
|
|
(props (caddr element)))
|
|
(cons layer-name props)))
|
|
('format-2
|
|
(let* ((layer-suffix (car element))
|
|
(layer-name (intern (format "%s-%s" group-name layer-suffix)))
|
|
(props (cdr element)))
|
|
(cons layer-name props)))
|
|
('format-1
|
|
(let ((layer-name (intern (format "%s-%d" group-name idx))))
|
|
(cons layer-name element)))
|
|
(_ (error "Invalid layer group element: %S" element)))))
|
|
|
|
(defun tp--define-layer-from-parsed (layer-name props data watch compute &optional transform)
|
|
"Internal helper to define a layer from parsed components.
|
|
LAYER-NAME is the symbol name for the layer.
|
|
PROPS is the property list.
|
|
DATA is the list of data variables.
|
|
WATCH is the list of watcher definitions.
|
|
COMPUTE is the list of computed variable definitions.
|
|
TRANSFORM, if non-nil, is registered in `tp-layer-transforms';
|
|
when nil, any previously registered transform for LAYER-NAME is
|
|
removed (mirroring `tp--define-layer-internal')."
|
|
;; Register or unregister transform function
|
|
(if transform
|
|
(if (assoc layer-name tp-layer-transforms)
|
|
(setcdr (assoc layer-name tp-layer-transforms) transform)
|
|
(push (cons layer-name transform) tp-layer-transforms))
|
|
(setq tp-layer-transforms (assq-delete-all layer-name tp-layer-transforms)))
|
|
(let* ((reactive-syms (tp--collect-reactive-symbols props))
|
|
(computed-vars (when compute (mapcar #'car compute)))
|
|
(all-reactive-syms (delete-dups reactive-syms))
|
|
(props-vars (mapcar #'tp--reactive-var-symbol reactive-syms))
|
|
(all-vars-to-define (delete-dups
|
|
(append data
|
|
props-vars
|
|
computed-vars))))
|
|
(if (or all-reactive-syms data compute)
|
|
;; Has reactive features - register dependencies and resolve at runtime
|
|
(progn
|
|
(tp--unregister-reactive-deps layer-name)
|
|
(tp--ensure-reactive-variables all-vars-to-define)
|
|
(when data
|
|
(tp--register-layer-data layer-name data))
|
|
(when compute
|
|
(tp--register-layer-computed layer-name compute)
|
|
(tp--apply-initial-computed compute))
|
|
(tp--register-reactive-deps layer-name all-reactive-syms props)
|
|
(when watch
|
|
(tp--register-layer-watchers layer-name watch))
|
|
(let ((resolved-props (tp--resolve-reactive-symbols props)))
|
|
(tp--set-layer-props layer-name resolved-props))
|
|
(tp--layer-refresh layer-name))
|
|
;; No reactive symbols - use static properties
|
|
(progn
|
|
(tp--unregister-reactive-deps layer-name)
|
|
(tp--set-layer-props layer-name props)
|
|
(tp--layer-refresh layer-name)))
|
|
layer-name))
|
|
|
|
(defun tp--define-layer-internal-group (name &rest elements)
|
|
"Define a layer group named NAME containing multiple layers.
|
|
|
|
This function accepts a list of layer definitions in ELEMENTS.
|
|
Each element in ELEMENTS should be one of:
|
|
|
|
- A symbol: reference to an existing layer
|
|
- A plist: anonymous layer (named as NAME-0, NAME-1, etc.)
|
|
- A cons cell (\"suffix\" . plist): named layer (named as NAME-suffix)
|
|
- A list (\"suffix\" :props plist [:data data] [:watch watch] [:compute compute]):
|
|
named layer with reactive features
|
|
|
|
All property lists should be evaluated (quoted in the call).
|
|
|
|
Example:
|
|
(tp--define-layer-internal-group \\='my-group
|
|
\\='existing-layer
|
|
\\='(face bold)
|
|
\\='(\"named\" . (face italic))
|
|
\\='(\"reactive\" :props (face (:foreground $color))
|
|
:data ((color . \"red\"))))
|
|
|
|
If a layer group with the same NAME already exists, it will be overwritten.
|
|
Individual layers created by the group are stored in `tp-layer-alist',
|
|
and the group itself is stored in `tp-layer-groups'."
|
|
(declare (indent defun))
|
|
(let ((layer-names nil)
|
|
(generated nil)
|
|
(idx 0))
|
|
(dolist (element elements)
|
|
(let ((parsed (tp--parse-layer-group-element name element idx)))
|
|
(cond
|
|
;; Reference to existing layer (symbol)
|
|
((symbolp parsed)
|
|
(push parsed layer-names))
|
|
;; Extended format with :data/:watch/:compute/:transform (format-4)
|
|
((and (listp parsed) (plist-get (cdr parsed) :props))
|
|
(let* ((layer-name (car parsed))
|
|
(props (plist-get (cdr parsed) :props))
|
|
(data (plist-get (cdr parsed) :data))
|
|
(watch (plist-get (cdr parsed) :watch))
|
|
(compute (plist-get (cdr parsed) :compute))
|
|
(transform (plist-get (cdr parsed) :transform)))
|
|
(tp--define-layer-from-parsed layer-name props data watch compute transform)
|
|
(push layer-name layer-names)
|
|
(push layer-name generated)))
|
|
;; Simple format (cons cell of name . props)
|
|
((consp parsed)
|
|
(let* ((layer-name (car parsed))
|
|
(props (cdr parsed)))
|
|
(tp--define-layer-from-parsed layer-name props nil nil nil)
|
|
(push layer-name layer-names)
|
|
(push layer-name generated)
|
|
;; Only increment idx for anonymous (Format 1) elements
|
|
(when (eq (tp--layer-group-element-format element) 'format-1)
|
|
(cl-incf idx)))))))
|
|
(setq layer-names (nreverse layer-names))
|
|
(setq generated (nreverse generated))
|
|
;; Undefine layers generated by a previous definition of this group
|
|
;; that are no longer part of it, so redefinition does not orphan them.
|
|
(let ((old-generated (cdr (assq name tp--group-generated-layers))))
|
|
(dolist (stale (cl-set-difference old-generated generated))
|
|
(tp-undefine-layer stale)))
|
|
(setf (alist-get name tp--group-generated-layers) generated)
|
|
(tp--set-group-layers name layer-names)
|
|
(assoc name tp-layer-groups)))
|
|
|
|
(defun tp--define-layer-group-internal (name arglist elements)
|
|
"Internal function for define-tps with ARGLIST and ELEMENTS.
|
|
NAME is the group name symbol.
|
|
ARGLIST is nil for non-parameterized groups, or a list with one symbol.
|
|
ELEMENTS is the list of layer definitions."
|
|
(if arglist
|
|
;; Parameterized group - store for later evaluation
|
|
(let ((entry (list arglist elements)))
|
|
(if (assoc name tp-layer-groups)
|
|
(setf (cdr (assoc name tp-layer-groups)) entry)
|
|
(push (cons name entry) tp-layer-groups))
|
|
(assoc name tp-layer-groups))
|
|
;; Non-parameterized - define immediately using tp--define-layer-internal-group
|
|
(apply #'tp--define-layer-internal-group name elements)))
|
|
|
|
(defun tp--define-layer-group-unified (name arglist body-form)
|
|
"Define a parameterized layer group NAME with ARGLIST and BODY-FORM.
|
|
Stores the group in `tp-layer-groups' with format:
|
|
\(GROUP-NAME ARGLIST BODY-FORM).
|
|
Layers generated by a previous non-parameterized definition of NAME
|
|
are undefined, since a parameterized group generates none."
|
|
(dolist (stale (cdr (assq name tp--group-generated-layers)))
|
|
(tp-undefine-layer stale))
|
|
(setq tp--group-generated-layers
|
|
(assq-delete-all name tp--group-generated-layers))
|
|
(let ((entry (list arglist body-form)))
|
|
(if (assoc name tp-layer-groups)
|
|
(setf (cdr (assoc name tp-layer-groups)) entry)
|
|
(push (cons name entry) tp-layer-groups)))
|
|
(assoc name tp-layer-groups))
|
|
|
|
;;;###autoload
|
|
(defmacro define-tps (name arglist &rest body)
|
|
"Define a text property group named NAME.
|
|
|
|
This macro defines a group of text properties (layers) that can be
|
|
used together.
|
|
It follows the same format as `define-tp' for consistency.
|
|
|
|
ARGLIST must be either:
|
|
- An empty list () for non-parameterized groups
|
|
- A list of one or more parameter symbols for parameterized groups
|
|
|
|
BODY contains the layer definitions, which should be quoted lists.
|
|
|
|
Format 1 - Non-parameterized (empty arglist):
|
|
(define-tps my-moon-phases ()
|
|
\\='(display \"🌑\")
|
|
\\='(display \"🌕\"))
|
|
|
|
Format 2 - Parameterized (with one or more arguments):
|
|
(define-tps my-status (color)
|
|
\\=`((face (:foreground ,color)))
|
|
\\='(face (:weight bold)))
|
|
|
|
Supported formats for each element in BODY:
|
|
|
|
Format 1 - Existing layer reference:
|
|
\\='existing-layer-name
|
|
|
|
Format 2 - Anonymous layer (named as NAME-0, NAME-1, etc.):
|
|
\\='(display \"🌑\" face (:height 1.0))
|
|
|
|
Format 3 - Named layer with cons-cell (named as NAME-suffix):
|
|
\\='(\"新月\" . (display \"🌑\" face (:height 1.0)))
|
|
|
|
Format 4 - Named layer with :props keyword (named as NAME-suffix):
|
|
\\='(\"新月\" :props (display \"🌑\" face (:height 1.0)))
|
|
|
|
Format 5 - Named layer with :props, :data, :watch, and/or :compute:
|
|
\\='(\"reactive\" :props (face (:foreground $my-color))
|
|
:data ((my-color . \"red\"))
|
|
:watch ((my-color (lambda (new old layer)
|
|
(message \"Changed!\")))))
|
|
|
|
Note: NAME cannot be a built-in Emacs text property name like `face',
|
|
`display', `invisible', etc. See `tp--builtin-text-properties' for the
|
|
complete list of reserved names."
|
|
(declare (indent defun))
|
|
(unless (listp arglist)
|
|
(error "define-tps ARGLIST must be a list"))
|
|
;; Check for built-in text property name conflict
|
|
(when (tp--builtin-text-property-p name)
|
|
(error "define-tps: '%s' is a built-in Emacs text property name and cannot be used as a group name" name))
|
|
(cond
|
|
;; Non-parameterized: empty arglist
|
|
((null arglist)
|
|
`(tp--define-layer-group-internal ',name nil (list ,@body)))
|
|
;; Parameterized: one or more argument symbols
|
|
((cl-every #'symbolp arglist)
|
|
`(tp--define-layer-group-unified ',name ',arglist '(list ,@body)))
|
|
(t
|
|
(error "define-tps ARGLIST must be empty or a list of symbols"))))
|
|
|
|
;; For backward compatibility, keep define-tp-group as an alias
|
|
(defalias 'define-tp-group 'define-tps
|
|
"Alias for `define-tps' for backward compatibility.")
|
|
|
|
;;;###autoload
|
|
(defalias 'tp-define-group 'define-tps
|
|
"Define a text property group named NAME; alias of `define-tps'.
|
|
This is the package-prefix-conforming name for the group definition
|
|
macro, so it is discoverable via the tp- prefix; `define-tps' and
|
|
`define-tp-group' are the historical names and all three are
|
|
permanent - none will be removed. See `define-tps' for the full
|
|
documentation of NAME, ARGLIST and BODY.")
|
|
(function-put 'tp-define-group 'lisp-indent-function 'defun)
|
|
|
|
(defun tp--set-layer-props (layer-name properties)
|
|
"Set PROPERTIES for layer LAYER-NAME in `tp-layer-alist'.
|
|
If the layer already exists, updates its properties; otherwise creates it.
|
|
Stores as (LAYER-NAME . PROPERTIES) for backward compatibility with
|
|
reactive layers.
|
|
This is an internal function used by layer definition macros and
|
|
reactive updates."
|
|
(if (assoc layer-name tp-layer-alist)
|
|
(setf (cdr (assoc layer-name tp-layer-alist)) properties)
|
|
(push (cons layer-name properties) tp-layer-alist)))
|
|
|
|
(defun tp--set-group-layers (group-name layer-names)
|
|
"Set LAYER-NAMES for group GROUP-NAME in `tp-layer-groups'.
|
|
If the group already exists, updates its layer list; otherwise creates it.
|
|
This is an internal function used by group definition macros."
|
|
(if (assoc group-name tp-layer-groups)
|
|
(setf (cdr (assoc group-name tp-layer-groups)) layer-names)
|
|
(push (cons group-name layer-names) tp-layer-groups)))
|
|
|
|
(defun tp-layer-props (layer-name &optional include-tp-name)
|
|
"Return properties for layer LAYER-NAME from `tp-layer-alist'.
|
|
If INCLUDE-TP-NAME is non-nil, appends `tp-name' property to identify
|
|
the layer.
|
|
Also includes tp-name automatically if the layer has reactive
|
|
dependencies registered.
|
|
Handles two storage formats:
|
|
1. Old format (from tp--set-layer-props): (LAYER-NAME . PLIST) - flat plist
|
|
2. Unified format (from define-tp): (LAYER-NAME ARGLIST BODY-FORM)
|
|
For parameterized layers (ARGLIST non-nil), returns nil - use
|
|
`tp-layer-props-with-arg'.
|
|
Recursively expands any nested layer names in the returned plist.
|
|
Signals an error naming the cycle if layer references are cyclic.
|
|
The returned plist is a fresh copy: mutating it does not affect the
|
|
stored layer definition."
|
|
(when-let ((entry (cdr (assoc layer-name tp-layer-alist))))
|
|
(tp--check-layer-cycle layer-name)
|
|
;; Auto-include tp-name for layers with reactive deps
|
|
(let ((tp--layer-expansion-stack (cons layer-name tp--layer-expansion-stack))
|
|
(needs-tp-name (or include-tp-name
|
|
(tp--layer-has-reactive-deps-p layer-name))))
|
|
(copy-tree
|
|
(cond
|
|
;; Unified format: entry is (ARGLIST BODY-FORM) where first elem is nil or a list
|
|
;; Check: exactly 2 elements and first is nil or a list of symbols
|
|
((and (= (length entry) 2)
|
|
(or (null (car entry))
|
|
(and (listp (car entry))
|
|
(cl-every #'symbolp (car entry)))))
|
|
(let ((arglist (car entry))
|
|
(body (cadr entry)))
|
|
(if arglist
|
|
;; Parameterized - needs argument, return nil
|
|
nil
|
|
;; Non-parameterized - evaluate body and return props
|
|
(let ((plist (eval body)))
|
|
(when plist
|
|
;; Recursively expand nested layer names
|
|
(when (tp--plist-has-layer-key-p plist)
|
|
(setq plist (tp--expand-layer-in-plist plist)))
|
|
(if needs-tp-name
|
|
(append plist (list 'tp-name layer-name))
|
|
plist))))))
|
|
;; Old format: entry is just a flat plist
|
|
(t
|
|
(let ((plist entry))
|
|
;; Recursively expand nested layer names
|
|
(when (tp--plist-has-layer-key-p plist)
|
|
(setq plist (tp--expand-layer-in-plist plist)))
|
|
(if needs-tp-name
|
|
(append plist (list 'tp-name layer-name))
|
|
plist))))))))
|
|
|
|
(defun tp-layer-parameterized-p (layer-name)
|
|
"Return non-nil if LAYER-NAME is a parameterized layer.
|
|
Parameterized layers are stored in unified format (LAYER-NAME ARGLIST BODY-FORM)
|
|
where ARGLIST is a non-nil list of argument symbols."
|
|
(when-let ((entry (cdr (assoc layer-name tp-layer-alist))))
|
|
;; Unified format: entry is (ARGLIST BODY-FORM) with exactly 2 elements
|
|
;; and first element is a non-nil list of symbols
|
|
(and (= (length entry) 2)
|
|
(listp (car entry))
|
|
(not (null (car entry)))
|
|
(cl-every #'symbolp (car entry)))))
|
|
|
|
(defun tp-layer-arglist (layer-name)
|
|
"Return the parameter list of parameterized layer LAYER-NAME.
|
|
Returns nil when LAYER-NAME is not a parameterized layer (including
|
|
non-parameterized and undefined layers). The returned list is a copy
|
|
of the ARGLIST given to `define-tp', e.g. (fg bg) for a
|
|
two-parameter layer."
|
|
(when (tp-layer-parameterized-p layer-name)
|
|
(copy-sequence (car (cdr (assoc layer-name tp-layer-alist))))))
|
|
|
|
(defun tp-layer-props-with-args (layer-name args &optional include-tp-name)
|
|
"Return properties for parameterized layer LAYER-NAME with ARGS.
|
|
ARGS is a list of argument values bound positionally (via `cl-progv',
|
|
so dynamically) to the layer's parameters while the stored body form
|
|
is evaluated. Extra values are ignored; passing fewer values than
|
|
the layer has parameters signals a wrong-arity error (since Emacs 27
|
|
`cl-progv' silently binds missing parameters to nil, so the arity is
|
|
checked explicitly here).
|
|
If INCLUDE-TP-NAME is non-nil, appends `tp-name' property to identify
|
|
the layer.
|
|
Recursively expands any nested layer names in the returned plist.
|
|
$-prefixed reactive symbols in the body are resolved to the current
|
|
values of their variables at evaluation time; they do not create
|
|
reactive dependencies (parameterized layers cannot be reactive).
|
|
Signals an error naming the cycle if layer references are cyclic.
|
|
The returned plist is a fresh copy: mutating it does not affect the
|
|
stored layer definition.
|
|
Returns nil when LAYER-NAME is not a parameterized layer.
|
|
|
|
See also `tp-layer-props-with-arg' - note the one-character name
|
|
difference - for the single-argument convenience, and
|
|
`tp-group-props-with-args' for the group counterpart."
|
|
(when (tp-layer-parameterized-p layer-name)
|
|
(let* ((entry (cdr (assoc layer-name tp-layer-alist)))
|
|
(arglist (car entry))
|
|
(body (cadr entry)))
|
|
(when (< (length args) (length arglist))
|
|
(error "tp layer %s takes %d argument(s), got %d"
|
|
layer-name (length arglist) (length args)))
|
|
(tp--check-layer-cycle layer-name)
|
|
(let* ((tp--layer-expansion-stack
|
|
(cons layer-name tp--layer-expansion-stack))
|
|
;; Evaluate the body with all parameters bound. `eval'
|
|
;; without a lexical environment sees the dynamic
|
|
;; bindings established by `cl-progv'.
|
|
(plist (cl-progv arglist args (eval body))))
|
|
(when plist
|
|
;; Recursively expand nested layer names
|
|
(when (tp--plist-has-layer-key-p plist)
|
|
(setq plist (tp--expand-layer-in-plist plist)))
|
|
;; Resolve $-prefixed reactive symbols to their current values
|
|
;; so they never leak literally into the returned props.
|
|
(when (tp--collect-reactive-symbols plist)
|
|
(setq plist (tp--resolve-reactive-symbols plist)))
|
|
(copy-tree
|
|
(if include-tp-name
|
|
(append plist (list 'tp-name layer-name))
|
|
plist)))))))
|
|
|
|
(defun tp-layer-props-with-arg (layer-name arg &optional include-tp-name)
|
|
"Return properties for parameterized layer LAYER-NAME with ARG.
|
|
Evaluates the body form with the argument bound to the parameter.
|
|
This is the single-argument convenience over
|
|
`tp-layer-props-with-args' - note the one-character name difference -
|
|
equivalent to calling it with (list ARG).
|
|
If INCLUDE-TP-NAME is non-nil, appends `tp-name' property to identify
|
|
the layer.
|
|
Recursively expands any nested layer names in the returned plist.
|
|
$-prefixed reactive symbols in the body are resolved to the current
|
|
values of their variables at evaluation time; they do not create
|
|
reactive dependencies (parameterized layers cannot be reactive).
|
|
Signals an error naming the cycle if layer references are cyclic.
|
|
The returned plist is a fresh copy: mutating it does not affect the
|
|
stored layer definition.
|
|
|
|
See also `tp-group-props-with-arg' for the group counterpart."
|
|
(tp-layer-props-with-args layer-name (list arg) include-tp-name))
|
|
|
|
(defun tp--layer-props-for-arg-value (layer-name value &optional include-tp-name)
|
|
"Return props for parameterized LAYER-NAME given a stored VALUE.
|
|
When LAYER-NAME takes more than one parameter and VALUE is a proper
|
|
list, VALUE is treated as the full argument list (as stored by the
|
|
plist-style spec (LAYER-NAME (ARG1 ARG2 ...))); otherwise VALUE is
|
|
the single argument (the single-parameter behavior).
|
|
INCLUDE-TP-NAME is passed through."
|
|
(if (and (proper-list-p value)
|
|
(> (length (tp-layer-arglist layer-name)) 1))
|
|
(tp-layer-props-with-args layer-name value include-tp-name)
|
|
(tp-layer-props-with-arg layer-name value include-tp-name)))
|
|
|
|
(defun tp-group-props (group-name &optional include-tp-name)
|
|
"Return list of properties for all layers in GROUP-NAME.
|
|
If INCLUDE-TP-NAME is non-nil, each layer's props will include tp-name.
|
|
Handles both old format (list of layer names) and new unified format
|
|
from `define-tps` (parameterized groups store ARGLIST and BODY-FORM)."
|
|
(when-let ((entry (cdr (assoc group-name tp-layer-groups))))
|
|
;; Check if it's the unified format from define-tps (ARGLIST BODY-FORM)
|
|
;; Unified format: (ARGLIST BODY-FORM) where ARGLIST is a list of symbols or nil
|
|
;; Old format: (layer1 layer2 ...) where each element is a symbol referring to a layer
|
|
(cond
|
|
;; Unified parameterized format: (ARGLIST BODY-FORM) with non-nil ARGLIST
|
|
((and (= (length entry) 2)
|
|
(listp (car entry))
|
|
(not (null (car entry)))
|
|
(cl-every #'symbolp (car entry)))
|
|
;; Parameterized group - can't get props without argument
|
|
nil)
|
|
;; Old format or non-parameterized define-tps: list of layer names
|
|
(t
|
|
(mapcar (lambda (layer)
|
|
(tp-layer-props layer include-tp-name))
|
|
entry)))))
|
|
|
|
(defun tp-group-parameterized-p (group-name)
|
|
"Return non-nil if GROUP-NAME is a parameterized group.
|
|
Parameterized groups are stored in format (GROUP-NAME ARGLIST BODY-FORM)
|
|
where ARGLIST is a non-nil list of argument symbols."
|
|
(when-let ((entry (cdr (assoc group-name tp-layer-groups))))
|
|
;; Check for unified format: (ARGLIST BODY-FORM) with non-nil ARGLIST
|
|
(and (= (length entry) 2)
|
|
(listp (car entry))
|
|
(not (null (car entry)))
|
|
(cl-every #'symbolp (car entry)))))
|
|
|
|
(defun tp--group-arglist (group-name)
|
|
"Return the parameter list of parameterized group GROUP-NAME.
|
|
Returns nil when GROUP-NAME is not a parameterized group. The
|
|
returned list is a copy of the ARGLIST given to `define-tps'."
|
|
(when (tp-group-parameterized-p group-name)
|
|
(copy-sequence (car (cdr (assoc group-name tp-layer-groups))))))
|
|
|
|
(defun tp--group-anonymous-props (plist)
|
|
"Normalize anonymous-layer PLIST from a parameterized group element.
|
|
Expands nested layer names, resolves $-prefixed reactive symbols to
|
|
their current values, and returns a fresh copy safe for caller
|
|
mutation. Returns nil if PLIST is nil."
|
|
(when plist
|
|
(let ((props plist))
|
|
(when (tp--plist-has-layer-key-p props)
|
|
(setq props (tp--expand-layer-in-plist props)))
|
|
(when (tp--collect-reactive-symbols props)
|
|
(setq props (tp--resolve-reactive-symbols props)))
|
|
(copy-tree props))))
|
|
|
|
(defun tp--group-spec-to-props (spec include-tp-name)
|
|
"Convert one evaluated parameterized-group element SPEC to a props plist.
|
|
SPEC may be:
|
|
- a symbol naming a defined layer;
|
|
- a list (LAYER-NAME ARG ...) whose head is a defined layer or group;
|
|
- a cons (\"NAME\" . PLIST) or a list (\"NAME\" :props PLIST);
|
|
- a raw property list (anonymous layer), optionally wrapped in one
|
|
extra set of parentheses as in the `define-tps' docstring example.
|
|
INCLUDE-TP-NAME is passed through for named layer references;
|
|
anonymous plists have no name, so it does not apply to them.
|
|
Returns nil if SPEC cannot be interpreted."
|
|
(cond
|
|
;; Layer name symbol
|
|
((symbolp spec)
|
|
(tp-layer-props spec include-tp-name))
|
|
((not (consp spec)) nil)
|
|
;; (LAYER-NAME ARG ...) - defined layer at the head
|
|
((and (symbolp (car spec)) (tp--is-layer-name-p (car spec)))
|
|
(let ((layer-name (car spec)))
|
|
(if (tp-layer-parameterized-p layer-name)
|
|
;; Bind as many arguments as the layer has parameters.
|
|
(tp-layer-props-with-args
|
|
layer-name
|
|
(-take (length (tp-layer-arglist layer-name)) (cdr spec))
|
|
include-tp-name)
|
|
;; Non-parameterized layer - arg should be t or ignored
|
|
(tp-layer-props layer-name include-tp-name))))
|
|
;; ("NAME" :props PLIST) or ("NAME" . PLIST) - use the props part
|
|
((stringp (car spec))
|
|
(tp--group-anonymous-props
|
|
(if (eq (cadr spec) :props)
|
|
(caddr spec)
|
|
(cdr spec))))
|
|
;; One extra level of wrapping, e.g. ((face (:foreground "red")))
|
|
((and (consp (car spec)) (null (cdr spec)))
|
|
(tp--group-spec-to-props (car spec) include-tp-name))
|
|
;; Raw plist - anonymous layer
|
|
((symbolp (car spec))
|
|
(tp--group-anonymous-props spec))
|
|
(t nil)))
|
|
|
|
(defun tp--group-props-with-args (group-name args &optional include-tp-name)
|
|
"Return list of properties for parameterized group GROUP-NAME with ARGS.
|
|
ARGS is a list of argument values bound positionally (via `cl-progv',
|
|
so dynamically) to the group's parameters while the stored body form
|
|
is evaluated. Each evaluated element is converted like
|
|
`tp-group-props-with-arg' documents. If INCLUDE-TP-NAME is non-nil,
|
|
named layer references include tp-name.
|
|
Returns nil when GROUP-NAME is not a parameterized group.
|
|
The public entry point delegating here is `tp-group-props-with-args'."
|
|
(when (tp-group-parameterized-p group-name)
|
|
(let* ((entry (cdr (assoc group-name tp-layer-groups)))
|
|
(arglist (car entry))
|
|
(body-form (cadr entry))
|
|
;; Evaluate the body with all parameters bound - returns
|
|
;; list of layer specs.
|
|
(layer-specs (cl-progv arglist args (eval body-form))))
|
|
;; Convert layer specs to property lists
|
|
(mapcar (lambda (spec)
|
|
(tp--group-spec-to-props spec include-tp-name))
|
|
layer-specs))))
|
|
|
|
(defun tp-group-props-with-arg (group-name arg &optional include-tp-name)
|
|
"Return list of properties for parameterized group GROUP-NAME with ARG.
|
|
Evaluates the body form with the argument bound to the parameter.
|
|
This is the single-argument convenience over
|
|
`tp-group-props-with-args' - note the one-character name difference -
|
|
equivalent to calling it with (list ARG).
|
|
Each evaluated element may be a layer name symbol, a (LAYER-NAME ARG)
|
|
reference, a named element (\"NAME\" . PLIST) / (\"NAME\" :props PLIST),
|
|
or a raw property list (anonymous layer) as documented in `define-tps'.
|
|
If INCLUDE-TP-NAME is non-nil, named layer references include tp-name.
|
|
Returns a list of property lists for each layer in the group.
|
|
|
|
See also `tp-layer-props-with-arg' for the single-layer counterpart."
|
|
(tp--group-props-with-args group-name (list arg) include-tp-name))
|
|
|
|
(defun tp-group-props-with-args (group-name args &optional include-tp-name)
|
|
"Return list of properties for parameterized group GROUP-NAME with ARGS.
|
|
ARGS is a list of argument values bound positionally to the group's
|
|
parameters while the stored body form is evaluated - the public
|
|
multi-argument introspection path for groups defined by `define-tps'
|
|
with two or more parameters (which `tp-put-layer' specs like
|
|
\(GROUP-NAME ARG1 ARG2) consume). Each evaluated element is
|
|
converted exactly as `tp-group-props-with-arg' documents. If
|
|
INCLUDE-TP-NAME is non-nil, named layer references include tp-name.
|
|
Returns nil when GROUP-NAME is not a parameterized group.
|
|
|
|
This mirrors `tp-layer-props-with-args' for layers. See also
|
|
`tp-group-props-with-arg' - note the one-character name difference -
|
|
for the single-argument convenience."
|
|
(tp--group-props-with-args group-name args include-tp-name))
|
|
|
|
(defun tp--group-props-for-arg-value (group-name value &optional include-tp-name)
|
|
"Return props list for parameterized GROUP-NAME given a stored VALUE.
|
|
When GROUP-NAME takes more than one parameter and VALUE is a proper
|
|
list, VALUE is treated as the full argument list (as stored by the
|
|
plist-style spec (GROUP-NAME (ARG1 ARG2 ...))); otherwise VALUE is
|
|
the single argument (the single-parameter behavior).
|
|
INCLUDE-TP-NAME is passed through."
|
|
(if (and (proper-list-p value)
|
|
(> (length (tp--group-arglist group-name)) 1))
|
|
(tp--group-props-with-args group-name value include-tp-name)
|
|
(tp-group-props-with-arg group-name value include-tp-name)))
|
|
|
|
(defun tp--is-layer-name-p (sym)
|
|
"Return non-nil if SYM is a defined layer, parameterized layer, or group name."
|
|
(and (symbolp sym)
|
|
(or (assoc sym tp-layer-alist)
|
|
(assoc sym tp-layer-groups))))
|
|
|
|
(defun tp--plist-has-layer-key-p (plist)
|
|
"Return non-nil if PLIST contains any layer names as keys."
|
|
(cl-loop for (key _val) on plist by #'cddr
|
|
thereis (tp--is-layer-name-p key)))
|
|
|
|
(defun tp--expand-layer-in-plist (props)
|
|
"Expand any layer names found in PROPS plist.
|
|
Scans through PROPS treating it as a plist (key value pairs).
|
|
When a key is a layer/group name, expands it with its properties.
|
|
Recursively expands until no more layer names are found in the result.
|
|
Does NOT add tp-name - this is for direct property setting (tp-set/add/reset).
|
|
Returns the expanded plist."
|
|
(let ((result nil)
|
|
(remaining props))
|
|
(while remaining
|
|
(let ((key (car remaining))
|
|
(val (cadr remaining)))
|
|
(cond
|
|
;; Key is a layer/parameterized layer/group name - expand it
|
|
((tp--is-layer-name-p key)
|
|
(let ((layer-props
|
|
(cond
|
|
;; Parameterized layer - evaluate with the argument (val);
|
|
;; for multi-parameter layers a list VAL carries all args
|
|
((tp-layer-parameterized-p key)
|
|
(tp--layer-props-for-arg-value key val nil)) ; no tp-name
|
|
;; Non-parameterized layer - val should be t
|
|
((assoc key tp-layer-alist)
|
|
(tp-layer-props key nil)) ; no tp-name
|
|
;; Parameterized layer group - evaluate with the argument (val);
|
|
;; for multi-parameter groups a list VAL carries all args
|
|
((tp-group-parameterized-p key)
|
|
(when-let ((layer-props-list
|
|
(tp--group-props-for-arg-value key val t)))
|
|
;; Build layered structure: first layer at top, rest in tp-layers
|
|
(tp--build-layer-props layer-props-list)))
|
|
;; Non-parameterized layer group - build layered structure
|
|
((assoc key tp-layer-groups)
|
|
(when-let ((layer-props-list (tp-group-props key t)))
|
|
;; Build layered structure: first layer at top, rest in tp-layers
|
|
(tp--build-layer-props layer-props-list))))))
|
|
(when layer-props
|
|
;; Recursively expand if the layer props contain more layer names
|
|
(when (tp--plist-has-layer-key-p layer-props)
|
|
(setq layer-props (tp--expand-layer-in-plist layer-props)))
|
|
(setq result (append result layer-props)))))
|
|
;; Regular property - keep as-is
|
|
(t
|
|
(setq result (append result (list key val)))))
|
|
(setq remaining (cddr remaining))))
|
|
;; Merge duplicate keys in the expanded result
|
|
;; Use (cdddr result) for O(1) check - need at least 4 elements (2 key-value pairs) for possible duplicates
|
|
(if (cdddr result)
|
|
(tp--merge-duplicate-keys result)
|
|
result)))
|
|
|
|
(defun tp--strip-trailing-plist-nil (plist)
|
|
"Remove a lone trailing nil from odd-length PLIST.
|
|
`tp--merge-duplicate-keys' pads an odd-length property spec (a flat
|
|
\(LAYER ARG1 ARG2 EXTRA-PROP VAL) call for a multi-parameter layer)
|
|
with a trailing nil value; strip it so the extra properties form a
|
|
proper plist again."
|
|
(if (and plist
|
|
(cl-oddp (length plist))
|
|
(null (car (last plist))))
|
|
(butlast plist)
|
|
plist))
|
|
|
|
(defun tp--resolve-props (props)
|
|
"Resolve PROPS to a property list with layer metadata.
|
|
PROPS can be:
|
|
- A symbol (layer name from `tp-layer-alist' or group name from
|
|
`tp-layer-groups')
|
|
- A two-element list (LAYER-NAME ARG) where LAYER-NAME is a defined layer
|
|
and ARG is either `t' for non-parameterized layers or the argument value
|
|
for parameterized layers
|
|
- A list starting with (LAYER-NAME ARG EXTRA-PROPS...) where extra properties
|
|
are merged with the layer properties
|
|
- For multi-parameter layers/groups, (LAYER-NAME ARG1 ARG2 ...
|
|
EXTRA-PROPS...) binds as many leading elements as the layer has
|
|
parameters; alternatively (LAYER-NAME (ARG1 ARG2 ...) EXTRA-PROPS...)
|
|
passes all arguments as one list (recognized when the list's length
|
|
equals the layer's parameter count and the remaining elements form
|
|
an even-length plist)
|
|
- A plist with layer names at any position - they will be expanded inline
|
|
- A plist (handles anonymous layers with reactive variables)
|
|
|
|
If PROPS is a symbol:
|
|
- First checks `tp-layer-alist' and returns the layer properties WITH `tp-name'
|
|
- Then checks `tp-layer-groups' and returns properties WITH `tp-layers'
|
|
|
|
If PROPS is (LAYER-NAME ARG) or (LAYER-NAME ARG EXTRA-PROPS...):
|
|
- For non-parameterized layers: if ARG is t, returns the layer properties
|
|
- For parameterized layers: evaluates the body with the argument(s)
|
|
and returns the result
|
|
- Extra properties after the argument(s) are appended to the layer
|
|
properties
|
|
|
|
If PROPS is a plist with layer names at any position:
|
|
- Layer names are expanded inline with their properties
|
|
- Other properties are preserved in order
|
|
|
|
If PROPS is a plist:
|
|
- If it contains reactive variables ($...), generates a UUID for `tp-name',
|
|
registers reactive dependencies, and returns the resolved props
|
|
with `tp-name'.
|
|
If the plist already has a `tp-name', uses that instead of
|
|
generating a new one.
|
|
- If no reactive variables, returns props as-is (no tp-name added).
|
|
|
|
Returns nil if PROPS is a symbol but no matching layer/group is found.
|
|
|
|
For layer names, includes `tp-name' property for reactive text property support.
|
|
For group names, includes `tp-layers' property with the full layer stack."
|
|
(cond
|
|
;; Already a plist - check for reactive variables and add tp-name
|
|
((listp props)
|
|
(let ((first-elem (car-safe props))
|
|
(second-elem (cadr props)))
|
|
(cond
|
|
;; Handle (layer-name arg ...) format for defined layers at the START
|
|
;; This includes both (layer-name arg) and (layer-name arg extra-prop val ...)
|
|
((and (>= (length props) 2)
|
|
(tp--is-layer-name-p first-elem))
|
|
(let* ((arity (cond ((tp-layer-parameterized-p first-elem)
|
|
(length (tp-layer-arglist first-elem)))
|
|
((tp-group-parameterized-p first-elem)
|
|
(length (tp--group-arglist first-elem)))
|
|
;; Non-parameterized: one slot is consumed
|
|
;; by the conventional `t' argument.
|
|
(t 1)))
|
|
;; Plist-style multi-arg spec (LAYER (ARG1 ... ARGN)
|
|
;; EXTRA...): the element after the name carries all
|
|
;; arguments when it is a list of exactly ARITY values
|
|
;; and the remaining elements form an even-length plist.
|
|
(wrapped-args (and (> arity 1)
|
|
(proper-list-p second-elem)
|
|
(= (length second-elem) arity)
|
|
(cl-evenp (length (cddr props)))))
|
|
(args (if wrapped-args
|
|
second-elem
|
|
(-take arity (cdr props))))
|
|
(extra-props (if wrapped-args
|
|
(cddr props)
|
|
(tp--strip-trailing-plist-nil
|
|
(-drop arity (cdr props)))))
|
|
;; ARG-1: wrong-arity parameterized calls must signal
|
|
;; clearly instead of nil-binding missing parameters or
|
|
;; applying excess positional args as garbage property
|
|
;; keys.
|
|
(kind (cond ((tp-layer-parameterized-p first-elem) "layer")
|
|
((tp-group-parameterized-p first-elem) "group")))
|
|
(_arity-check
|
|
(when kind
|
|
(when (< (length args) arity)
|
|
(error "tp %s %s takes %d argument(s), got %d"
|
|
kind first-elem arity (length args)))
|
|
(when (and (not wrapped-args)
|
|
extra-props
|
|
(not (symbolp (car extra-props))))
|
|
(error "tp %s %s takes %d argument(s); excess argument %S is not a property key"
|
|
kind first-elem arity (car extra-props)))))
|
|
(layer-props
|
|
(cond
|
|
;; Parameterized layer - evaluate with the argument(s)
|
|
((tp-layer-parameterized-p first-elem)
|
|
(tp-layer-props-with-args first-elem args nil)) ; no tp-name
|
|
;; Non-parameterized layer - arg should be t, return the layer props
|
|
;; (silently ignore non-t values for flexibility)
|
|
((assoc first-elem tp-layer-alist)
|
|
(tp-layer-props first-elem nil)) ; no tp-name
|
|
;; Parameterized layer group - evaluate with the argument(s)
|
|
((tp-group-parameterized-p first-elem)
|
|
(when-let ((layer-props-list
|
|
(tp--group-props-with-args first-elem args t)))
|
|
;; Build layered structure: first layer at top, rest in tp-layers
|
|
(tp--build-layer-props layer-props-list)))
|
|
;; Non-parameterized layer group - build layered structure
|
|
((assoc first-elem tp-layer-groups)
|
|
(when-let ((layer-props-list (tp-group-props first-elem t)))
|
|
;; Build layered structure: first layer at top, rest in tp-layers
|
|
(tp--build-layer-props layer-props-list))))))
|
|
;; Recursively resolve extra properties (they may also contain layer names)
|
|
(let ((expanded-props
|
|
(if (and layer-props extra-props)
|
|
(let* ((resolved-extra (tp--expand-layer-in-plist extra-props))
|
|
(combined (append layer-props resolved-extra)))
|
|
;; Merge duplicate keys after combining layer props with extra props
|
|
;; Need at least 4 elements (2 key-value pairs) for possible duplicates
|
|
(if (cdddr combined)
|
|
(tp--merge-duplicate-keys combined)
|
|
combined))
|
|
layer-props)))
|
|
;; After expansion, check for reactive symbols in the merged props
|
|
;; (original props may contain $vars that need reactive tracking)
|
|
(let ((reactive-syms (tp--collect-reactive-symbols props)))
|
|
(if reactive-syms
|
|
;; Has reactive symbols - need anonymous tp-name for reactive tracking
|
|
(let* ((existing-tp-name (plist-get props 'tp-name))
|
|
(layer-name (or existing-tp-name
|
|
(tp--anonymous-layer-name-for props)))
|
|
;; Resolve reactive symbols in expanded props
|
|
(resolved-props (tp--resolve-reactive-symbols expanded-props)))
|
|
;; Register reactive dependencies
|
|
(tp--set-layer-props layer-name resolved-props)
|
|
(tp--register-reactive-deps layer-name reactive-syms props)
|
|
(append resolved-props (list 'tp-name layer-name)))
|
|
;; No reactive symbols - return expanded props as-is (no tp-name)
|
|
expanded-props)))))
|
|
|
|
;; Handle single-element list containing a layer/group name symbol.
|
|
;; This can happen when tp-set is called with string form: (tp-set str 'layer-name)
|
|
;; which produces props = (layer-name) in tp--parse-args.
|
|
((and (= (length props) 1)
|
|
(symbolp first-elem)
|
|
(or (assoc first-elem tp-layer-alist)
|
|
(assoc first-elem tp-layer-groups)))
|
|
;; It's a layer/group name wrapped in a list - recurse with the symbol
|
|
(tp--resolve-props first-elem))
|
|
|
|
;; Check if any key in the plist is a layer name (layer at any position)
|
|
((cl-some #'tp--is-layer-name-p
|
|
(cl-loop for (key _val) on props by #'cddr collect key))
|
|
;; Expand all layer names in the plist
|
|
(let ((expanded-props (tp--expand-layer-in-plist props)))
|
|
;; After expansion, check for reactive symbols in the original props
|
|
;; (they may contain $vars that need reactive tracking)
|
|
(let ((reactive-syms (tp--collect-reactive-symbols props)))
|
|
(if reactive-syms
|
|
;; Has reactive symbols - need anonymous tp-name for reactive tracking
|
|
(let* ((existing-tp-name (plist-get props 'tp-name))
|
|
(layer-name (or existing-tp-name
|
|
(tp--anonymous-layer-name-for props)))
|
|
;; Resolve reactive symbols in expanded props
|
|
(resolved-props (tp--resolve-reactive-symbols expanded-props)))
|
|
;; Register reactive dependencies
|
|
(tp--set-layer-props layer-name resolved-props)
|
|
(tp--register-reactive-deps layer-name reactive-syms props)
|
|
(append resolved-props (list 'tp-name layer-name)))
|
|
;; No reactive symbols - return expanded props as-is (no tp-name)
|
|
expanded-props))))
|
|
|
|
;; Normal plist processing
|
|
(t
|
|
(let* ((existing-tp-name (plist-get props 'tp-name))
|
|
(reactive-syms (tp--collect-reactive-symbols props)))
|
|
(if reactive-syms
|
|
;; Has reactive symbols - need to handle as anonymous reactive layer
|
|
(let* ((layer-name (or existing-tp-name
|
|
(tp--anonymous-layer-name-for props)))
|
|
;; Resolve reactive symbols to get current values
|
|
(resolved-props (tp--resolve-reactive-symbols props)))
|
|
;; Register this anonymous layer in tp-layer-alist with resolved props
|
|
(tp--set-layer-props layer-name resolved-props)
|
|
;; Register reactive dependencies with the original props
|
|
(tp--register-reactive-deps layer-name reactive-syms props)
|
|
;; Return resolved props with tp-name for reactive tracking
|
|
(append resolved-props (list 'tp-name layer-name)))
|
|
;; No reactive symbols - return props as-is (no tp-name needed)
|
|
;; This preserves the native text property behavior for non-reactive plists
|
|
props))))))
|
|
;; Symbol - check if it's a layer or group name
|
|
((symbolp props)
|
|
(cond
|
|
;; Parameterized layer without argument - cannot resolve, return nil
|
|
((tp-layer-parameterized-p props)
|
|
nil)
|
|
;; Check layer - get props without tp-name for direct property setting
|
|
((assoc props tp-layer-alist)
|
|
(tp-layer-props props nil)) ; no tp-name
|
|
;; Check group - build layered structure with tp-layers
|
|
((assoc props tp-layer-groups)
|
|
(when-let ((layer-props-list (tp-group-props props t))) ; include tp-name
|
|
;; Build layered structure: first layer at top, rest in tp-layers
|
|
(tp--build-layer-props layer-props-list)))
|
|
;; Parameterized group without argument - cannot resolve, return nil
|
|
((tp-group-parameterized-p props)
|
|
nil)
|
|
;; Not found - return nil (let caller decide how to handle)
|
|
(t nil)))
|
|
(t nil)))
|
|
|
|
(defun tp--ensure-props (plist)
|
|
"Ensure PLIST is a property list, resolving layer names and
|
|
handling reactive vars.
|
|
If PLIST is a symbol, resolve it via `tp--resolve-props'.
|
|
If PLIST is a plist, also process it via `tp--resolve-props' to handle
|
|
anonymous reactive layers.
|
|
If resolution fails, return PLIST unchanged (for backward compatibility)."
|
|
(or (tp--resolve-props plist) plist))
|
|
|
|
;;;###autoload
|
|
(defun tp-layer-reset ()
|
|
"Reset all layer definitions.
|
|
Clears both `tp-layer-alist' and `tp-layer-groups'.
|
|
Also resets all reactive text property watchers, dependencies, and transforms."
|
|
(interactive)
|
|
(tp-reactive-reset)
|
|
(setq tp-layer-alist nil)
|
|
(setq tp-layer-groups nil)
|
|
(setq tp-layer-transforms nil)
|
|
(setq tp--group-generated-layers nil)
|
|
(setq tp--anonymous-layer-registry nil))
|
|
|
|
(defun tp-undefine-layer (name)
|
|
"Remove layer NAME from `tp-layer-alist'.
|
|
Also unregisters any reactive dependencies and transforms for this layer,
|
|
and drops any anonymous-layer registry entries interned for it."
|
|
(tp--unregister-reactive-deps name)
|
|
(setq tp-layer-alist (assq-delete-all name tp-layer-alist))
|
|
(setq tp-layer-transforms (assq-delete-all name tp-layer-transforms))
|
|
(setq tp--anonymous-layer-registry
|
|
(cl-remove-if (lambda (cell) (eq (cdr cell) name))
|
|
tp--anonymous-layer-registry)))
|
|
|
|
(defun tp-undefine-group (name)
|
|
"Remove layer group NAME from `tp-layer-groups'.
|
|
Also undefines the layers that the group definition itself generated
|
|
(anonymous and named elements), including their reactive dependencies
|
|
and transforms. Layers merely referenced by the group are left
|
|
untouched."
|
|
(dolist (generated (cdr (assq name tp--group-generated-layers)))
|
|
(tp-undefine-layer generated))
|
|
(setq tp--group-generated-layers
|
|
(assq-delete-all name tp--group-generated-layers))
|
|
(setq tp-layer-groups (assq-delete-all name tp-layer-groups)))
|
|
|
|
(defun tp--normalize-layer-spec (layer-spec)
|
|
"Normalize LAYER-SPEC to a plist with tp-name.
|
|
Used by layer stack functions that need tp-name for identification.
|
|
|
|
LAYER-SPEC can be:
|
|
- A symbol (non-parameterized layer name from define-tp or
|
|
tp--define-layer-internal)
|
|
- A list (LAYER-NAME ARG ...) for parameterized layers from
|
|
define-tp, with exactly as many arguments as the layer has
|
|
parameters
|
|
- A plist for inline layer definition
|
|
- A list (NAME &rest PLIST) for named inline layer"
|
|
(cond
|
|
;; Symbol - look up in tp-layer-alist (non-parameterized layer)
|
|
((symbolp layer-spec)
|
|
(cond
|
|
;; Parameterized layer symbol without arg - error
|
|
((tp-layer-parameterized-p layer-spec)
|
|
(error "Parameterized layer %S requires an argument, use '(%S arg)"
|
|
layer-spec layer-spec))
|
|
;; Non-parameterized layer or old-format layer
|
|
((assoc layer-spec tp-layer-alist)
|
|
(or (tp-layer-props layer-spec t) ; include tp-name for layer stack
|
|
(error "Layer %S not found in tp-layer-alist" layer-spec)))
|
|
(t (error "Layer %S not found in tp-layer-alist" layer-spec))))
|
|
|
|
;; List starting with symbol - check if it's a parameterized layer
|
|
((and (listp layer-spec)
|
|
(symbolp (car layer-spec))
|
|
(not (keywordp (car layer-spec))))
|
|
(let ((name (car layer-spec))
|
|
(rest (cdr layer-spec)))
|
|
(cond
|
|
;; Parameterized layer: (LAYER-NAME ARG ...) with exactly as
|
|
;; many arguments as the layer has parameters
|
|
((and (tp-layer-parameterized-p name)
|
|
(= (length rest) (length (tp-layer-arglist name))))
|
|
(or (tp-layer-props-with-args name rest t) ; include tp-name
|
|
(error "Failed to resolve parameterized layer %S with args %S"
|
|
name rest)))
|
|
;; ARG-1: a parameterized layer with the wrong number of
|
|
;; arguments must not fall through to the named-inline branch,
|
|
;; which would build an odd-length plist and die with the
|
|
;; cryptic "Odd length text property list".
|
|
((tp-layer-parameterized-p name)
|
|
(error "tp layer %s expects %d args, got %d"
|
|
name (length (tp-layer-arglist name)) (length rest)))
|
|
;; Named inline layer: (NAME &rest PLIST)
|
|
(rest
|
|
(append rest (list 'tp-name name)))
|
|
;; Just a symbol in a list - treat as non-parameterized layer
|
|
((null rest)
|
|
(or (tp-layer-props name t)
|
|
(error "Layer %S not found in tp-layer-alist" name))))))
|
|
|
|
;; Plist (starts with keyword or property name)
|
|
((and (listp layer-spec) layer-spec)
|
|
layer-spec)
|
|
(t (error "Invalid layer spec: %S" layer-spec))))
|
|
|
|
(defun tp--get-layer-stack (pos object)
|
|
"Get the layer stack at POS in OBJECT as a list.
|
|
Returns (TOP-PROPS . BELOW-PROPS-LIST)."
|
|
(let* ((props (text-properties-at pos object))
|
|
(tp-layers-idx (-elem-index 'tp-layers props))
|
|
(top-props (if tp-layers-idx
|
|
(-remove-at-indices
|
|
(list tp-layers-idx (1+ tp-layers-idx)) props)
|
|
props))
|
|
(below-props (plist-get props 'tp-layers)))
|
|
(cons top-props below-props)))
|
|
|
|
(defun tp--build-layer-props (layer-list)
|
|
"Build text properties from LAYER-LIST.
|
|
First element is top layer, rest are in tp-layers."
|
|
(if (null layer-list)
|
|
nil
|
|
(append (car layer-list)
|
|
(list 'tp-layers (cdr layer-list)))))
|
|
|
|
(defun tp--layer-stack-to-list (top belows)
|
|
"Convert TOP and BELOWS to a flat list of layers."
|
|
(if top
|
|
(cons top belows)
|
|
belows))
|
|
|
|
;;; Layer stack storage codec
|
|
;;
|
|
;; The encoding/decoding of a layer stack into raw text properties
|
|
;; lives here, beside `tp--build-layer-props' / `tp--layer-stack-to-list',
|
|
;; so both the stack operations (tp-stack.el) and the reactive
|
|
;; re-render engine (tp-render.el) can read and write stack storage
|
|
;; without duplicating format knowledge or requiring each other.
|
|
|
|
(defun tp--stack-hidden-p (layer)
|
|
"Return non-nil when the layer plist LAYER is flagged hidden.
|
|
A layer is hidden when its plist carries a non-nil `tp-hidden' entry;
|
|
see `tp-hide-layer'."
|
|
(and (plist-get layer 'tp-hidden) t))
|
|
|
|
(defun tp--stack-props-to-list (props)
|
|
"Return the ordered layer stack stored in raw text properties PROPS.
|
|
The result is a list of layer plists, top layer first, including
|
|
hidden layers (flagged with a non-nil `tp-hidden' entry) at their
|
|
stack position. Returns nil for bare text.
|
|
|
|
This is the inverse of `tp--stack-build-props': when any entry of the
|
|
`tp-layers' bookkeeping property is hidden, that property holds the
|
|
whole ordered stack and the direct properties are only a render cache
|
|
of the topmost non-hidden layer; otherwise the direct properties are
|
|
the top layer and `tp-layers' holds the layers below it. Direct
|
|
property edits made outside the stack API (for example `tp-set') are
|
|
therefore discarded by the next stack operation while any layer is
|
|
hidden."
|
|
(let* ((idx (-elem-index 'tp-layers props))
|
|
(top (if idx
|
|
(-remove-at-indices (list idx (1+ idx)) props)
|
|
props))
|
|
(belows (plist-get props 'tp-layers)))
|
|
(if (seq-some #'tp--stack-hidden-p belows)
|
|
belows
|
|
(tp--layer-stack-to-list top belows))))
|
|
|
|
(defun tp--stack-build-props (layer-list)
|
|
"Build text properties from LAYER-LIST (top layer first).
|
|
Like `tp--build-layer-props', but the `tp-layers' entry is only added
|
|
when there are below-layers, so single-layer stacks do not carry a
|
|
garbage (tp-layers nil) property. Consumers must therefore tolerate
|
|
an absent `tp-layers' property (both `plist-get' and
|
|
`tp--stack-map-region' do).
|
|
|
|
When any layer in LAYER-LIST is hidden (non-nil `tp-hidden' entry,
|
|
see `tp-hide-layer'), the storage switches to full-stack mode: the
|
|
direct properties are those of the topmost non-hidden layer (or no
|
|
layer properties at all when every layer is hidden) and the
|
|
`tp-layers' property holds the complete ordered LAYER-LIST.
|
|
`tp--stack-props-to-list' reverses either representation."
|
|
(cond
|
|
((null layer-list) nil)
|
|
((seq-some #'tp--stack-hidden-p layer-list)
|
|
(append (seq-find (lambda (layer)
|
|
(not (tp--stack-hidden-p layer)))
|
|
layer-list)
|
|
(list 'tp-layers layer-list)))
|
|
((null (cdr layer-list)) (copy-sequence (car layer-list)))
|
|
(t (append (car layer-list)
|
|
(list 'tp-layers (cdr layer-list))))))
|
|
|
|
(defun tp--describe-layer-data (name)
|
|
"Collect description data for layer NAME as a plist.
|
|
Returns nil when NAME is not registered in `tp-layer-alist'.
|
|
The returned plist has these keys:
|
|
:name NAME itself.
|
|
:format Storage format: `parameterized' (unified storage with
|
|
a non-empty arglist), `reactive' (flat storage with
|
|
reactive dependencies registered), `unified' (from
|
|
`define-tp' with an empty arglist) or `flat' (old
|
|
direct plist storage).
|
|
:arglist The parameter list for parameterized layers, else nil.
|
|
:body The raw stored body: the unevaluated BODY-FORM for
|
|
unified/parameterized layers, the stored plist for
|
|
flat/reactive layers.
|
|
:props The expanded properties from `tp-layer-props' (with
|
|
tp-name), or a placeholder string for parameterized
|
|
layers, which need arguments
|
|
\(see `tp-layer-props-with-args').
|
|
:reactive-deps List of reactive variable symbols NAME depends on,
|
|
from tp-reactive's `tp-reactive-deps' registry.
|
|
:transform Non-nil when a transform is registered for NAME in
|
|
`tp-layer-transforms'.
|
|
:group The group that generated NAME (from
|
|
`tp--group-generated-layers'), or nil."
|
|
(when-let ((entry (cdr (assoc name tp-layer-alist))))
|
|
(let* ((parameterized (tp-layer-parameterized-p name))
|
|
(reactive (tp--layer-has-reactive-deps-p name))
|
|
(unified (and (= (length entry) 2)
|
|
(or (null (car entry))
|
|
(and (listp (car entry))
|
|
(cl-every #'symbolp (car entry))))))
|
|
(format (cond (parameterized 'parameterized)
|
|
(reactive 'reactive)
|
|
(unified 'unified)
|
|
(t 'flat)))
|
|
(arglist (when parameterized (tp-layer-arglist name)))
|
|
(body (if unified (cadr entry) entry))
|
|
(props (if parameterized
|
|
"parameterized layer: expand with `tp-layer-props-with-args'"
|
|
(tp-layer-props name t)))
|
|
(deps (cl-loop for dep in tp-reactive-deps
|
|
when (assoc name (cdr dep))
|
|
collect (car dep)))
|
|
(transform (and (assoc name tp-layer-transforms) t))
|
|
(group (cl-loop for (group-name . layers)
|
|
in tp--group-generated-layers
|
|
when (memq name layers)
|
|
return group-name)))
|
|
(list :name name
|
|
:format format
|
|
:arglist arglist
|
|
:body body
|
|
:props props
|
|
:reactive-deps deps
|
|
:transform transform
|
|
:group group))))
|
|
|
|
;;;###autoload
|
|
(defun tp-describe-layer (name)
|
|
"Display a help buffer describing the tp layer NAME.
|
|
NAME is a layer registered in `tp-layer-alist'. Interactively,
|
|
prompt with completion over the registered layers.
|
|
The buffer shows the storage format (flat, unified, parameterized or
|
|
reactive), the raw stored body, the expanded properties (or a
|
|
placeholder for parameterized layers, which need arguments), the
|
|
parameter list, the reactive variables the layer depends on, whether
|
|
a transform is registered, and the group that generated the layer,
|
|
if any."
|
|
(interactive
|
|
(list (intern (completing-read "Describe tp layer: "
|
|
(mapcar #'car tp-layer-alist)
|
|
nil t))))
|
|
(let ((data (tp--describe-layer-data name)))
|
|
(unless data
|
|
(user-error "No tp layer named `%s'" name))
|
|
(with-help-window (help-buffer)
|
|
(princ (format "%s is a tp layer.\n\n" name))
|
|
(princ (format "Storage format: %s\n" (plist-get data :format)))
|
|
(when (plist-get data :arglist)
|
|
(princ (format "Arguments: %S\n" (plist-get data :arglist))))
|
|
(princ (format "Stored body: %S\n" (plist-get data :body)))
|
|
(let ((props (plist-get data :props)))
|
|
(princ (format "Expanded props: %s\n"
|
|
(if (stringp props) props (format "%S" props)))))
|
|
(princ (format "Reactive deps: %s\n"
|
|
(if (plist-get data :reactive-deps)
|
|
(mapconcat #'symbol-name
|
|
(plist-get data :reactive-deps) ", ")
|
|
"none")))
|
|
(princ (format "Transform: %s\n"
|
|
(if (plist-get data :transform) "yes" "no")))
|
|
(when (plist-get data :group)
|
|
(princ (format "Generated by: group %s\n"
|
|
(plist-get data :group)))))))
|
|
|
|
(defun tp--get-layer-by-idx-or-name (layers idx-or-name)
|
|
"Find layer in LAYERS by IDX-OR-NAME.
|
|
Returns (index . layer-props) or nil."
|
|
(cond
|
|
((integerp idx-or-name)
|
|
(let ((actual-idx (if (< idx-or-name 0)
|
|
(+ (length layers) idx-or-name)
|
|
idx-or-name)))
|
|
(when (and (>= actual-idx 0) (< actual-idx (length layers)))
|
|
(cons actual-idx (nth actual-idx layers)))))
|
|
((symbolp idx-or-name)
|
|
(cl-loop for layer in layers
|
|
for i from 0
|
|
when (equal idx-or-name (plist-get layer 'tp-name))
|
|
return (cons i layer)))
|
|
(t nil)))
|
|
|
|
(provide 'tp-layer)
|
|
;;; tp-layer.el ends here
|