tp/tp-style.el

;;; tp-style.el --- Native text property policies -*- lexical-binding: t; -*-

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

;;; Commentary:

;; Native Emacs text-property policies, named direct declarations, and
;; explicit computed value sources.  This module does not implement selectors,
;; stylesheets, CSS precedence, inheritance, or custom properties.

;;; Code:

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

(define-error 'tp-property-error "TP property error")
(define-error 'tp-invalid-property-policy
  "Invalid TP property policy" 'tp-property-error)
(define-error 'tp-invalid-declaration
  "Invalid TP direct declaration" 'tp-property-error)

(cl-defstruct (tp-property-policy
               (:constructor tp--make-property-policy))
  "Policy governing one namespaced direct text property."
  id normalizer validator equality merge projector)

(cl-defstruct (tp--computed-source (:constructor tp--make-computed-source))
  function)

(cl-defstruct (tp-paint-slot (:constructor tp--make-paint-slot))
  "Stable named-face address for one mutable paint contribution."
  face spec installed-p)

(defvar tp--paint-slot-counter 0
  "Monotonic id source for private paint-slot faces.")

(defconst tp--property-policy-option-keys
  '(:normalizer :validator :equality :merge :projector)
  "Accepted property policy option keys.")

(defvar tp--property-policies (make-hash-table :test #'eq)
  "Registered property policies by namespaced id.")

(defvar tp--property-policy-order nil
  "Property ids in stable registration order.")

(defvar tp--named-styles (make-hash-table :test #'eq)
  "Named direct declaration sets.")

(defun tp--paint-slot-face-spec (spec)
  "Return validated face SPEC for a paint slot."
  (unless (and (listp spec) (zerop (% (length spec) 2))
               (cl-loop for key in spec by #'cddr always (keywordp key)))
    (signal 'tp-invalid-declaration (list :paint-slot spec)))
  (copy-tree spec))

;;;###autoload
(defun tp-paint-slot-create (spec)
  "Create a stable paint slot initialized from anonymous face SPEC."
  (let* ((face (intern (format "tp-paint-slot-%d"
                               (cl-incf tp--paint-slot-counter))))
         (slot (tp--make-paint-slot
                :face face :spec (tp--paint-slot-face-spec spec)
                :installed-p nil)))
    (make-face face)
    slot))

;;;###autoload
(defun tp-paint-slot-update (slot spec)
  "Update SLOT to anonymous face SPEC without changing its address."
  (unless (tp-paint-slot-p slot)
    (signal 'wrong-type-argument (list 'tp-paint-slot-p slot)))
  (let* ((face (tp-paint-slot-face slot))
         (next (tp--paint-slot-face-spec spec))
         (previous (tp-paint-slot-spec slot)))
    (condition-case err
        (progn
          (face-spec-reset-face face)
          (when next
            (face-spec-set face `((t ,next))))
          (setf (tp-paint-slot-spec slot) next))
      (error
       (face-spec-reset-face face)
       (when previous
         (face-spec-set face `((t ,previous))))
       (signal (car err) (cdr err))))
    slot))

(defun tp-paint-slot-apply-updates (buffer updates)
  "Apply `(SLOT . SPEC)' UPDATES to BUFFER in one face-remap swap.
Return a rollback journal containing the previous buffer map and slot specs."
  (unless (buffer-live-p buffer)
    (signal 'wrong-type-argument (list 'buffer-live-p buffer)))
  (let ((normalized
         (mapcar
          (lambda (entry)
            (unless (tp-paint-slot-p (car entry))
              (signal 'wrong-type-argument
                      (list 'tp-paint-slot-p (car entry))))
            (cons (car entry) (tp--paint-slot-face-spec (cdr entry))))
          updates))
        slot-journal next)
    (with-current-buffer buffer
      (setq next (copy-tree face-remapping-alist))
      (dolist (entry normalized)
        (let* ((slot (car entry))
               (spec (cdr entry))
               (face (tp-paint-slot-face slot)))
          (push (list slot (copy-tree (tp-paint-slot-spec slot))
                      (tp-paint-slot-installed-p slot))
                slot-journal)
          (setq next (assq-delete-all face next))
          (when spec
            (push (list face spec) next))
          (setf (tp-paint-slot-spec slot) spec
                (tp-paint-slot-installed-p slot) t)))
      (prog1
          (list :buffer buffer
                :face-remapping-alist (copy-tree face-remapping-alist)
                :slot-specs (nreverse slot-journal))
        (setq-local face-remapping-alist next)))))

(defun tp-paint-slot-rollback-updates (journal)
  "Restore paint slots from reverse-safe JOURNAL."
  (when-let ((buffer (plist-get journal :buffer)))
    (when (buffer-live-p buffer)
      (with-current-buffer buffer
        (setq-local face-remapping-alist
                    (copy-tree
                     (plist-get journal :face-remapping-alist))))))
  (dolist (entry (reverse (plist-get journal :slot-specs)))
    (setf (tp-paint-slot-spec (nth 0 entry)) (copy-tree (nth 1 entry))
          (tp-paint-slot-installed-p (nth 0 entry)) (nth 2 entry)))
  nil)

(defun tp--canonical-property-id-p (id)
  "Return non-nil when ID is a namespaced property symbol."
  (and (symbolp id)
       (let ((name (symbol-name id)))
         (and (string-match-p "/" name)
              (not (string-prefix-p "/" name))
              (not (string-suffix-p "/" name))))))

(defun tp--declaration-list-p (declarations)
  "Return non-nil when DECLARATIONS is an even property/value list."
  (and (listp declarations) (zerop (% (length declarations) 2))))

(defun tp--policy-options-valid-p (options)
  "Return non-nil when OPTIONS is a supported property policy plist."
  (and (listp options)
       (zerop (% (length options) 2))
       (cl-loop for key in options by #'cddr
                always (memq key tp--property-policy-option-keys))))

(defun tp--policy-option (options key fallback)
  "Return KEY from OPTIONS when present, otherwise FALLBACK."
  (if (plist-member options key) (plist-get options key) fallback))

(defun tp--validate-policy-functions (options)
  "Validate callable property policy fields in OPTIONS."
  (dolist (key tp--property-policy-option-keys)
    (let ((value (plist-get options key)))
      (unless (or (null value) (functionp value))
        (signal 'tp-invalid-property-policy (list key value))))))

(defun tp--build-property-policy (id options)
  "Build and validate a property policy for ID from OPTIONS."
  (unless (and (tp--canonical-property-id-p id)
               (tp--policy-options-valid-p options))
    (signal 'tp-invalid-property-policy (list :property id options)))
  (tp--validate-policy-functions options)
  (tp--make-property-policy
   :id id
   :normalizer (tp--policy-option options :normalizer #'identity)
   :validator (tp--policy-option options :validator (lambda (_value) t))
   :equality (tp--policy-option options :equality #'equal)
   :merge (tp--policy-option options :merge (lambda (_old new) new))
   :projector (plist-get options :projector)))

;;;###autoload
(defun tp-define-property-policy (id &rest options)
  "Atomically register namespaced property ID using policy OPTIONS.
OPTIONS support :normalizer, :validator, :equality, :merge, and :projector."
  (let ((policy (tp--build-property-policy id options)))
    (unless (gethash id tp--property-policies)
      (setq tp--property-policy-order
            (append tp--property-policy-order (list id))))
    (puthash id policy tp--property-policies)
    policy))

(defun tp-property-policy (id)
  "Return the registered property policy for ID, or nil."
  (gethash id tp--property-policies))

(defun tp-text-property-id (property)
  "Return the canonical `text/' policy id for Emacs PROPERTY."
  (unless (symbolp property)
    (signal 'wrong-type-argument (list 'symbolp property)))
  (intern (format "text/%s" property)))

(defun tp--text-property-merge-function (property)
  "Return the contribution merge function for Emacs PROPERTY."
  (if (memq property tp-face-properties)
      #'tp--merge-face-values
    (lambda (_old new) new)))

(defun tp-register-text-property (property)
  "Register and return a direct policy for Emacs PROPERTY."
  (let ((id (tp-text-property-id property)))
    (or (tp-property-policy id)
        (tp-define-property-policy
         id :equality #'equal
         :merge (tp--text-property-merge-function property)
         :projector (lambda (value) (list property value))))))

(defun tp--register-default-text-properties ()
  "Register policies for TP's known native Emacs properties."
  (dolist (property tp--builtin-text-properties)
    (tp-register-text-property property)))

(defun tp-text-declarations (properties)
  "Convert raw Emacs PROPERTIES to namespaced direct declarations."
  (unless (tp--declaration-list-p properties)
    (signal 'tp-invalid-declaration (list :text-properties properties)))
  (cl-loop for (property value) on properties by #'cddr
           append (list (tp-property-policy-id
                         (tp-register-text-property property))
                        (tp--copy-property-value value))))

;;;###autoload
(defun tp-computed (function)
  "Return an explicit computed value source wrapping FUNCTION."
  (unless (functionp function)
    (signal 'wrong-type-argument (list 'functionp function)))
  (tp--make-computed-source :function function))

(defun tp-computed-p (value)
  "Return non-nil when VALUE is an explicit computed source."
  (tp--computed-source-p value))

;;;###autoload
(defun tp-resolve-value (value &optional _property _subject)
  "Resolve VALUE only when it is an explicit `tp-computed' source.
Ordinary function values remain literal.  PROPERTY and SUBJECT are accepted
so this function can be passed directly as a consumer value resolver."
  (if (tp--computed-source-p value)
      (funcall (tp--computed-source-function value))
    value))

(defun tp--validate-direct-property (property)
  "Return PROPERTY when it has a registered direct policy."
  (unless (tp-property-policy property)
    (signal 'tp-invalid-declaration (list :unknown-property property)))
  property)

(defun tp--copy-direct-declarations (declarations)
  "Validate and defensively copy direct DECLARATIONS."
  (unless (tp--declaration-list-p declarations)
    (signal 'tp-invalid-declaration (list :declarations declarations)))
  (cl-loop for (property value) on declarations by #'cddr
           do (tp--validate-direct-property property)
           append (list property (tp--copy-property-value value))))

;;;###autoload
(defun tp-merge-declarations (&rest declaration-groups)
  "Merge direct DECLARATION-GROUPS without CSS interpretation.
Later values replace earlier values for the same registered property.  An
explicit nil remains present and is distinct from an absent declaration."
  (let (result)
    (dolist (declarations declaration-groups result)
      (cl-loop for (property value)
               on (tp--copy-direct-declarations declarations) by #'cddr
               do (setq result (plist-put result property value))))))

;;;###autoload
(defun tp-define-style (name declarations)
  "Define named direct style NAME from DECLARATIONS and return NAME."
  (unless (symbolp name)
    (signal 'tp-invalid-declaration (list :style-name name)))
  (puthash name (tp-merge-declarations declarations) tp--named-styles)
  name)

(defun tp-style-declarations (name)
  "Return a defensive copy of named direct style NAME declarations."
  (when-let ((declarations (gethash name tp--named-styles)))
    (tp--copy-property-value declarations)))

(defun tp-undefine-style (name)
  "Remove named direct style NAME and return nil."
  (remhash name tp--named-styles)
  nil)

(defun tp--normalized-policy-value (policy value)
  "Resolve, normalize, and validate VALUE using POLICY."
  (let ((normalized
         (funcall (tp-property-policy-normalizer policy)
                  (tp-resolve-value value (tp-property-policy-id policy)))))
    (unless (funcall (tp-property-policy-validator policy) normalized)
      (signal 'tp-invalid-declaration
              (list :property (tp-property-policy-id policy)
                    :value normalized)))
    normalized))

(defun tp--project-policy-value (policy value)
  "Project VALUE through POLICY into direct Emacs text properties."
  (when-let ((projector (tp-property-policy-projector policy)))
    (let ((projected (funcall projector value)))
      (unless (tp--declaration-list-p projected)
        (signal 'tp-invalid-declaration
                (list :projection (tp-property-policy-id policy) projected)))
      projected)))

(defun tp--project-declarations (declarations)
  "Project namespaced direct DECLARATIONS into Emacs text properties."
  (let (result)
    (cl-loop for (property source)
             on (tp--copy-direct-declarations declarations) by #'cddr
             for policy = (tp-property-policy property)
             for value = (tp--normalized-policy-value policy source)
             for projected = (tp--project-policy-value policy value)
             when projected
             do (setq result (tp--deep-merge-plist result projected)))
    result))

(defun tp--project-text-declarations (declarations)
  "Project native text property DECLARATIONS through direct policies."
  (tp--project-declarations (tp-text-declarations declarations)))

(tp--register-default-text-properties)

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