;;; tp-layer.el --- Named property declaration recipes -*- lexical-binding: t; -*-

;; Copyright (C) 2024-2026 Geekinney
;; SPDX-License-Identifier: GPL-3.0-or-later

;;; Commentary:

;; `define-tp' and `define-tps' register reusable native text-property
;; declaration recipes.  A recipe is definition-time data only: applying it
;; expands to ordinary direct properties and never stamps runtime identity into
;; text.  Live identity and reactivity belong to tp-surface and tp-reactive.

;;; Code:

(require 'cl-lib)
(require 'tp-core)
(require 'tp-style)

(define-error 'tp-unresolved-layer "Unresolved TP declaration recipe")
(define-error 'tp-invalid-layer-definition "Invalid TP declaration recipe")

(defvar tp-layer-alist nil
  "Alist of named declaration recipes.
Each entry has the form (NAME ARGLIST BODY-FORM).")

(defvar tp-layer-groups nil
  "Alist of named declaration group recipes.
Each entry has the form (NAME ARGLIST BODY-FORM).")

(defvar tp--group-generated-layers nil
  "Alist mapping group names to generated static recipe names.")

(defvar tp--compiled-style-layers nil
  "Recipe names currently compiled into TP named direct styles.")

(defvar tp--layer-expansion-stack nil
  "Recipe names currently being expanded, innermost first.")

(defun tp--recipe-entry (name registry)
  "Return NAME's recipe entry from REGISTRY, or nil."
  (cdr (assq name registry)))

(defun tp--validate-recipe-name (name kind)
  "Validate recipe NAME for KIND and return NAME."
  (unless (symbolp name)
    (signal 'tp-invalid-layer-definition (list kind :name name)))
  (when (tp--builtin-text-property-p name)
    (signal 'tp-invalid-layer-definition
            (list kind :reserved-text-property name)))
  name)

(defun tp--validate-recipe-arglist (arglist kind name)
  "Validate ARGLIST for KIND recipe NAME and return a copy."
  (unless (and (listp arglist)
               (cl-every #'symbolp arglist)
               (= (length arglist) (length (delete-dups (copy-sequence arglist)))))
    (signal 'tp-invalid-layer-definition
            (list kind name :arglist arglist)))
  (copy-sequence arglist))

(defun tp--recipe-dollar-symbol-p (value)
  "Return non-nil when VALUE includes a legacy dollar-prefixed symbol."
  (cond
   ((symbolp value) (string-prefix-p "$" (symbol-name value)))
   ((consp value)
    (or (tp--recipe-dollar-symbol-p (car value))
        (tp--recipe-dollar-symbol-p (cdr value))))
   ((vectorp value) (cl-some #'tp--recipe-dollar-symbol-p value))
   (t nil)))

(defun tp--reject-legacy-reactive-syntax (value name)
  "Reject legacy reactive syntax in VALUE from recipe NAME."
  (when (tp--recipe-dollar-symbol-p value)
    (signal 'tp-invalid-layer-definition
            (list name :legacy-reactive-syntax
                  "Use tp-computed with signals or bindings"))))

(defun tp--check-layer-cycle (name)
  "Signal an error when expanding NAME would create a cycle."
  (when (memq name tp--layer-expansion-stack)
    (error "TP: cyclic declaration recipe: %s"
           (mapconcat #'symbol-name
                      (reverse (cons name tp--layer-expansion-stack))
                      " -> "))))

(defun tp--eval-recipe (name arglist body args)
  "Evaluate recipe NAME with ARGLIST, BODY and ARGS."
  (unless (= (length args) (length arglist))
    (error "TP recipe %s takes %d argument(s), got %d"
           name (length arglist) (length args)))
  (let ((value (cl-progv arglist args (eval body))))
    (tp--reject-legacy-reactive-syntax value name)
    value))

(defun tp--merge-property-groups (&rest groups)
  "Merge native property GROUPS using TP's direct property semantics."
  (let ((flat (apply #'append
                     (mapcar #'tp--copy-property-value (delq nil groups)))))
    (if (cddr flat) (tp--merge-duplicate-keys flat) flat)))

(defun tp--recipe-arguments (name arglist values)
  "Split VALUES for recipe NAME with ARGLIST into (ARGS . EXTRA)."
  (let ((arity (length arglist)))
    (cond
     ((zerop arity)
      (cons nil (unless (equal values '(t)) values)))
     ((and (consp values)
           (listp (car values))
           (= (length (car values)) arity)
           (zerop (% (length (cdr values)) 2)))
      (cons (car values) (cdr values)))
     ((>= (length values) arity)
      (cons (cl-subseq values 0 arity) (nthcdr arity values)))
     (t
      (error "TP recipe %s takes %d argument(s), got %d"
             name arity (length values))))))

(defun tp-layer-parameterized-p (name)
  "Return non-nil when layer recipe NAME accepts arguments."
  (when-let* ((entry (tp--recipe-entry name tp-layer-alist)))
    (and (car entry) t)))

(defun tp-layer-arglist (name)
  "Return a defensive copy of layer recipe NAME's argument list."
  (when-let* ((entry (tp--recipe-entry name tp-layer-alist)))
    (copy-sequence (car entry))))

(defun tp-group-parameterized-p (name)
  "Return non-nil when group recipe NAME accepts arguments."
  (when-let* ((entry (tp--recipe-entry name tp-layer-groups)))
    (and (car entry) t)))

(defun tp--group-arglist (name)
  "Return a defensive copy of group recipe NAME's argument list."
  (when-let* ((entry (tp--recipe-entry name tp-layer-groups)))
    (copy-sequence (car entry))))

(defun tp--is-layer-name-p (symbol)
  "Return non-nil when SYMBOL names a layer or group recipe."
  (and (symbolp symbol)
       (or (assq symbol tp-layer-alist)
           (assq symbol tp-layer-groups))))

(defun tp--plist-has-layer-key-p (properties)
  "Return non-nil when PROPERTIES include a recipe as a key."
  (and (listp properties)
       (cl-loop for (key _value) on properties by #'cddr
                thereis (tp--is-layer-name-p key))))

(defun tp--layer-value-args (name value)
  "Return argument list for parameterized recipe NAME from VALUE."
  (let ((arity (length (tp-layer-arglist name))))
    (if (and (> arity 1) (proper-list-p value)) value (list value))))

(defun tp--group-value-args (name value)
  "Return argument list for parameterized group NAME from VALUE."
  (let ((arity (length (tp--group-arglist name))))
    (if (and (> arity 1) (proper-list-p value)) value (list value))))

(defun tp--expand-layer-key (name value)
  "Expand declaration recipe NAME used as a property key with VALUE."
  (cond
   ((assq name tp-layer-alist)
    (if (tp-layer-parameterized-p name)
        (tp-layer-props-with-args name (tp--layer-value-args name value))
      (tp-layer-props name)))
   ((assq name tp-layer-groups)
    (apply #'tp--merge-property-groups
           (if (tp-group-parameterized-p name)
               (tp-group-props-with-args name (tp--group-value-args name value))
             (tp-group-props name))))))

(defun tp--expand-layer-in-plist (properties)
  "Expand recipe keys in native PROPERTIES and return direct properties."
  (unless (and (listp properties) (zerop (% (length properties) 2)))
    (signal 'tp-invalid-layer-definition
            (list :invalid-property-list properties)))
  (let (groups)
    (cl-loop for (key value) on properties by #'cddr
             do (push (if (tp--is-layer-name-p key)
                          (tp--expand-layer-key key value)
                        (list key (tp--copy-property-value value)))
                      groups))
    (apply #'tp--merge-property-groups (nreverse groups))))

(defun tp--layer-properties (name args)
  "Expand layer recipe NAME using ARGS."
  (when-let* ((entry (tp--recipe-entry name tp-layer-alist)))
    (pcase-let ((`(,arglist ,body) entry))
      (tp--check-layer-cycle name)
      (let* ((tp--layer-expansion-stack
              (cons name tp--layer-expansion-stack))
             (properties (tp--eval-recipe name arglist body args)))
        (unless (listp properties)
          (signal 'tp-invalid-layer-definition
                  (list name :properties properties)))
        (tp--expand-layer-in-plist properties)))))

(defun tp-layer-props (name &optional _provenance)
  "Return direct properties for non-parameterized layer recipe NAME.
The result is a defensive copy.  Return nil for an undefined or
parameterized recipe.  PROVENANCE is accepted for source compatibility and
has no effect; runtime identity is never written into text."
  (when (and (assq name tp-layer-alist)
             (not (tp-layer-parameterized-p name)))
    (tp--copy-property-value (tp--layer-properties name nil))))

(defun tp-layer-props-with-args (name args &optional _provenance)
  "Return direct properties for layer recipe NAME evaluated with ARGS.
The result is a defensive copy.  PROVENANCE is accepted for source
  compatibility and has no effect."
  (when (assq name tp-layer-alist)
    (tp--copy-property-value (tp--layer-properties name args))))

(defun tp-layer-props-with-arg (name arg &optional provenance)
  "Return layer recipe NAME evaluated with ARG.
PROVENANCE is accepted for source compatibility and has no effect."
  (tp-layer-props-with-args name (list arg) provenance))

(defun tp--group-element-properties (group-name element)
  "Resolve one ELEMENT produced by GROUP-NAME."
  (cond
   ((symbolp element)
    (or (tp-layer-props element)
        (apply #'tp--merge-property-groups (tp-group-props element))
        (signal 'tp-unresolved-layer (list element))))
   ((and (consp element) (symbolp (car element))
         (tp--is-layer-name-p (car element)))
    (or (tp--resolve-props element)
        (signal 'tp-unresolved-layer (list (car element)))))
   ((and (consp element) (stringp (car element)))
    (let ((properties
           (if (eq (cadr element) :props) (caddr element) (cdr element))))
      (tp--expand-layer-in-plist properties)))
   ((listp element) (tp--expand-layer-in-plist element))
   (t
    (signal 'tp-invalid-layer-definition
            (list group-name :element element)))))

(defun tp--group-properties (name args)
  "Return the ordered direct property groups produced by NAME with ARGS."
  (when-let* ((entry (tp--recipe-entry name tp-layer-groups)))
    (pcase-let ((`(,arglist ,body) entry))
      (tp--check-layer-cycle name)
      (let* ((tp--layer-expansion-stack
              (cons name tp--layer-expansion-stack))
             (elements (tp--eval-recipe name arglist body args)))
        (unless (listp elements)
          (signal 'tp-invalid-layer-definition
                  (list name :elements elements)))
        (mapcar (lambda (element)
                  (tp--group-element-properties name element))
                elements)))))

(defun tp-group-props (name &optional _provenance)
  "Return direct property groups for non-parameterized group recipe NAME.
PROVENANCE is accepted for source compatibility and has no effect."
  (when (and (assq name tp-layer-groups)
             (not (tp-group-parameterized-p name)))
    (tp--copy-property-value (tp--group-properties name nil))))

(defun tp-group-props-with-args (name args &optional _provenance)
  "Return direct property groups for group recipe NAME with ARGS."
  (when (assq name tp-layer-groups)
    (tp--copy-property-value (tp--group-properties name args))))

(defun tp-group-props-with-arg (name arg &optional provenance)
  "Return group recipe NAME evaluated with ARG.
PROVENANCE is accepted for source compatibility and has no effect."
  (tp-group-props-with-args name (list arg) provenance))

(defun tp--resolve-named-call (name values)
  "Resolve recipe NAME applied to VALUES plus optional extra properties."
  (let* ((arglist (if (assq name tp-layer-alist)
                      (tp-layer-arglist name)
                    (tp--group-arglist name)))
         (split (tp--recipe-arguments name arglist values))
         (args (car split))
         (extra (cdr split))
         (base
          (if (assq name tp-layer-alist)
              (tp-layer-props-with-args name args)
            (apply #'tp--merge-property-groups
                   (tp-group-props-with-args name args))))
         (expanded-extra
          (when extra (tp--expand-layer-in-plist extra))))
    (tp--merge-property-groups base expanded-extra)))

(defun tp--resolve-props (properties)
  "Resolve PROPERTIES into ordinary direct Emacs text properties.
PROPERTIES may be a recipe name, a recipe call followed by extra property
pairs, or a native property list containing recipe keys.  Return nil when a
symbol does not name a recipe."
  (cond
   ((symbolp properties)
    (when (tp--is-layer-name-p properties)
      (tp--resolve-named-call properties nil)))
   ((and (consp properties)
         (symbolp (car properties))
         (tp--is-layer-name-p (car properties)))
    (tp--resolve-named-call (car properties) (cdr properties)))
   ((listp properties)
    (tp--expand-layer-in-plist properties))
   (t nil)))

(defun tp--ensure-props (properties)
  "Return direct properties resolved from PROPERTIES.
Signal `tp-unresolved-layer' when a symbol does not name a recipe."
  (or (tp--resolve-props properties)
      (if (symbolp properties)
          (signal 'tp-unresolved-layer (list properties))
        properties)))

(defun tp--compile-layer-style (name)
  "Compile static layer recipe NAME into the named style registry."
  (if (tp-layer-parameterized-p name)
      (progn
        (tp-undefine-style name)
        (setq tp--compiled-style-layers
              (delq name tp--compiled-style-layers)))
    (tp-define-style name (tp-text-declarations (tp-layer-props name)))
    (cl-pushnew name tp--compiled-style-layers))
  name)

(defun tp--candidate-layer-parameterized-p (name layers)
  "Return non-nil when NAME accepts arguments in candidate LAYERS."
  (when-let* ((entry (tp--recipe-entry name layers)))
    (and (car entry) t)))

(defun tp--candidate-layer-properties (name args layers groups)
  "Expand NAME with ARGS against candidate LAYERS and GROUPS."
  (let ((tp-layer-alist layers)
        (tp-layer-groups groups))
    (tp--layer-properties name args)))

(defun tp--candidate-compile-layer-style
    (name layers groups styles compiled)
  "Compile NAME from LAYERS and GROUPS into STYLES; return COMPILED."
  (if (tp--candidate-layer-parameterized-p name layers)
      (progn
        (remhash name styles)
        (delq name compiled))
    (puthash name
             (tp-merge-declarations
              (tp-text-declarations
               (tp--candidate-layer-properties name nil layers groups)))
             styles)
    (cl-pushnew name compiled))
  compiled)

(defun tp--candidate-define-layer-recipe
    (name arglist body layers groups styles compiled)
  "Define NAME with ARGLIST and BODY in candidate registries.
LAYERS, GROUPS, STYLES and COMPILED are the candidate registries.
Return (LAYERS . COMPILED) for the updated candidates."
  (tp--validate-recipe-name name 'layer)
  (setq arglist (tp--validate-recipe-arglist arglist 'layer name))
  (let ((candidate-layers
         (cons (cons name (list arglist (tp--copy-property-value body)))
               (assq-delete-all name layers))))
    (cons candidate-layers
          (tp--candidate-compile-layer-style
           name candidate-layers groups styles compiled))))

(defun tp--candidate-remove-layer (name layers styles compiled)
  "Remove NAME from candidate LAYERS and STYLES; return (LAYERS . COMPILED)."
  (remhash name styles)
  (cons (assq-delete-all name layers)
        (delq name compiled)))

(defun tp--define-layer-recipe (name arglist body)
  "Register layer recipe NAME with ARGLIST and BODY."
  (tp--validate-recipe-name name 'layer)
  (setq arglist (tp--validate-recipe-arglist arglist 'layer name))
  (let ((old-entry (assq name tp-layer-alist)))
    (setq tp-layer-alist
          (cons (cons name (list arglist (tp--copy-property-value body)))
                (assq-delete-all name tp-layer-alist)))
    (condition-case condition
        (progn
          (tp--compile-layer-style name)
          (assq name tp-layer-alist))
      (error
       (setq tp-layer-alist (assq-delete-all name tp-layer-alist))
       (when old-entry (push old-entry tp-layer-alist))
       (signal (car condition) (cdr condition))))))

;;;###autoload
(defmacro define-tp (name arglist &rest body)
  "Define named direct property recipe NAME with ARGLIST and BODY.
BODY must contain exactly one form returning a native text-property plist.
Use `tp-computed' for explicit reactive value sources."
  (declare (indent defun))
  (unless (= (length body) 1)
    (error "Define-tp requires exactly one body form"))
  (if arglist
      `(tp--define-layer-recipe ',name ',arglist ',(car body))
    `(tp--define-layer-recipe
      ',name nil (list 'quote ,(car body)))))

;;;###autoload
(defalias 'tp-define-layer 'define-tp
  "Define a named direct property recipe; alias of `define-tp'.")
(function-put 'tp-define-layer 'lisp-indent-function 'defun)

(defun tp--group-generated-name (group-name suffix)
  "Return a generated recipe name for GROUP-NAME and SUFFIX."
  (intern (format "%s-%s" group-name suffix)))

(defun tp--static-group-generated-specs (name elements)
  "Return validated generated recipe specs for static group NAME ELEMENTS."
  (let (specs)
    (cl-loop for element in elements
             for index from 0
             when (and (consp element) (stringp (car element)))
             do (push (cons (tp--group-generated-name name (car element))
                            (if (eq (cadr element) :props)
                                (caddr element)
                              (cdr element)))
                      specs)
             when (and (listp element)
                       (not (stringp (car-safe element)))
                       (not (symbolp element)))
             do (push (cons (tp--group-generated-name name index) element)
                      specs))
    (dolist (spec specs)
      (tp--validate-recipe-name (car spec) 'group-element)
      (tp-text-declarations (tp--expand-layer-in-plist (cdr spec))))
    (nreverse (tp--copy-property-value specs))))

(defun tp--define-group-recipe (name arglist body)
  "Register group recipe NAME with ARGLIST and BODY."
  (tp--validate-recipe-name name 'group)
  (setq arglist (tp--validate-recipe-arglist arglist 'group name))
  (let* ((elements (unless arglist (tp--eval-recipe name nil body nil)))
         (tp--layer-expansion-stack (cons name tp--layer-expansion-stack))
         (_validated
          (unless arglist
            (mapc (lambda (element)
                    (tp--group-element-properties name element))
                  elements)))
         (specs (unless arglist
                  (tp--static-group-generated-specs name elements))))
    (let ((candidate-layers (tp--copy-property-value tp-layer-alist))
          (candidate-groups (tp--copy-property-value tp-layer-groups))
          (candidate-generated
           (tp--copy-property-value tp--group-generated-layers))
          (candidate-compiled (copy-sequence tp--compiled-style-layers))
          (candidate-styles (copy-hash-table tp--named-styles))
          generated-names)
      (dolist (generated (cdr (assq name candidate-generated)))
        (pcase-let ((`(,layers . ,compiled)
                     (tp--candidate-remove-layer
                      generated candidate-layers
                      candidate-styles candidate-compiled)))
          (setq candidate-layers layers
                candidate-compiled compiled)))
      (setq candidate-generated
            (assq-delete-all name candidate-generated))
      (setf (alist-get name candidate-groups)
            (list arglist (tp--copy-property-value body)))
      (dolist (spec specs)
        (pcase-let ((`(,layers . ,compiled)
                     (tp--candidate-define-layer-recipe
                      (car spec) nil
                      (list 'quote (tp--copy-property-value (cdr spec)))
                      candidate-layers candidate-groups
                      candidate-styles candidate-compiled)))
          (setq candidate-layers layers
                candidate-compiled compiled)
          (push (car spec) generated-names)))
      (when specs
        (setf (alist-get name candidate-generated)
              (nreverse generated-names)))
      (setq tp-layer-alist candidate-layers
            tp-layer-groups candidate-groups
            tp--group-generated-layers candidate-generated
            tp--compiled-style-layers candidate-compiled
            tp--named-styles candidate-styles)))
  (assq name tp-layer-groups))

;;;###autoload
(defmacro define-tps (name arglist &rest body)
  "Define named direct property group recipe NAME with ARGLIST.
Each BODY form evaluates to one layer name, recipe call, native property
  plist, or named element such as (\"label\" . (face bold))."
  (declare (indent defun))
  (if arglist
      `(tp--define-group-recipe ',name ',arglist '(list ,@body))
    `(tp--define-group-recipe
      ',name nil (list 'quote (list ,@body)))))

(defalias 'define-tp-group 'define-tps
  "Define a declaration group; alias of `define-tps'.")

;;;###autoload
(defalias 'tp-define-group 'define-tps
  "Define a declaration group; alias of `define-tps'.")
(function-put 'tp-define-group 'lisp-indent-function 'defun)

;;;###autoload
(defun tp-layer-reset ()
  "Remove every named layer and group declaration recipe."
  (interactive)
  (dolist (name tp--compiled-style-layers)
    (tp-undefine-style name))
  (setq tp-layer-alist nil
        tp-layer-groups nil
        tp--group-generated-layers nil
        tp--compiled-style-layers nil))

(defun tp-undefine-layer (name)
  "Remove named layer declaration recipe NAME."
  (setq tp-layer-alist (assq-delete-all name tp-layer-alist)
        tp--compiled-style-layers (delq name tp--compiled-style-layers))
  (tp-undefine-style name))

(defun tp-undefine-group (name)
  "Remove named declaration group NAME and recipes it generated."
  (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)
        tp-layer-groups (assq-delete-all name tp-layer-groups))
  nil)

(defun tp--describe-layer-data (name)
  "Return declarative registry data for layer recipe NAME."
  (when-let* ((entry (tp--recipe-entry name tp-layer-alist)))
    (list :name name
          :kind 'direct-declaration-recipe
          :arglist (copy-sequence (car entry))
          :body (tp--copy-property-value (cadr entry))
          :props (if (car entry)
                     "parameterized recipe"
                   (tp-layer-props name))
          :group (cl-loop for (group . generated)
                          in tp--group-generated-layers
                          when (memq name generated)
                          return group))))

;;;###autoload
(defun tp-describe-layer (name)
  "Display a help buffer describing declaration recipe NAME."
  (interactive
   (list (intern (completing-read "Describe TP recipe: "
                                  (mapcar #'car tp-layer-alist) nil t))))
  (let ((data (tp--describe-layer-data name)))
    (unless data (user-error "No TP recipe named `%s'" name))
    (with-help-window (help-buffer)
      (princ (format "%s is a TP direct declaration recipe.\n\n" name))
      (princ (format "Arguments: %S\n" (plist-get data :arglist)))
      (princ (format "Stored body: %S\n" (plist-get data :body)))
      (princ (format "Expanded properties: %S\n" (plist-get data :props)))
      (when (plist-get data :group)
        (princ (format "Generated by group: %s\n"
                       (plist-get data :group)))))))

(provide 'tp-layer)
;;; tp-layer.el ends here