tp/tp-ops.el

;;; tp-ops.el --- Direct text property operations -*- lexical-binding: t; -*-

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

;;; Commentary:

;; Stateless string and buffer property operations.  Named declaration
;; recipes are expanded by tp-layer, while live content replacement and
;; reactivity are owned exclusively by tp-surface and tp-reactive.

;;; Code:

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

(defun tp--put-text-property-unless-equal (start end property value object)
  "Set PROPERTY to VALUE on [START, END) in OBJECT only when needed."
  (when (< start end)
    (unless (and (plist-member (text-properties-at start object) property)
                 (equal (get-text-property start property object) value)
                 (>= (or (next-single-property-change
                          start property object end)
                         end)
                     end))
      (put-text-property start end property value object))))

(defun tp--value-after-add (property existing incoming)
  "Return EXISTING after adding INCOMING for PROPERTY."
  (cond
   ((memq property tp-face-properties)
    (tp--prepend-face incoming existing))
   ((and (listp incoming) (keywordp (car-safe incoming))
         (listp existing) (keywordp (car-safe existing)))
    (tp--deep-merge-plist existing incoming))
   (t incoming)))

(defun tp--props-after-add (existing incoming)
  "Return EXISTING with INCOMING applied using `tp-add' semantics."
  (let ((result (copy-tree existing)))
    (cl-loop for (property value) on incoming by #'cddr
             do (setq result
                      (plist-put result property
                                 (tp--value-after-add
                                  property (plist-get result property) value))))
    result))

(defun tp--apply-props-by-operation (start end props object operation)
  "Apply PROPS to [START, END) in OBJECT according to OPERATION."
  (pcase operation
    (:reset (set-text-properties start end props object))
    (:add
     (let ((position start))
       (while (< position end)
         (let* ((next (or (next-property-change position object end) end))
                (merged (tp--props-after-add
                         (text-properties-at position object) props)))
           (set-text-properties position next merged object)
           (setq position next)))))
    (_
     (cl-loop for (property value) on props by #'cddr
              do (tp--put-text-property-unless-equal
                  start end property value object)))))

(defun tp--whole-string-properties (property value rest)
  "Build whole-string properties from PROPERTY, VALUE and REST."
  (cond
   ((and (symbolp property) (tp--is-layer-name-p property))
    (cons property (if (or value rest) (cons value rest) nil)))
   (property (cons property (cons value rest)))
   (t nil)))

(defun tp--parse-region-object (rest)
  "Return the optional region object from REST, rejecting extra values."
  (cond
   ((null rest) nil)
   ((and (null (cdr rest))
         (or (bufferp (car rest)) (stringp (car rest))))
    (car rest))
   (t
    (error "Region form takes one properties plist and an optional object"))))

(defun tp--prepare-direct-properties (specification)
  "Resolve and project direct property SPECIFICATION."
  (tp--project-text-declarations (tp--ensure-props specification)))

(defun tp--parse-args (start-or-string end-or-prop props-or-val rest
                                       &optional operation)
  "Parse a TP mutation call and return a canonical request.

START-OR-STRING and END-OR-PROP are the positional inputs.
PROPS-OR-VAL is the property specification.
REST is optional object or call metadata.
OPERATION is :set, :reset, or :add."
  (let (object start finish properties mutation public-return)
    (if (stringp start-or-string)
        (setq object start-or-string
              start 0
              finish (length start-or-string)
              properties (tp--whole-string-properties
                          end-or-prop props-or-val rest)
              mutation :copy
              public-return :object)
      (unless (numberp start-or-string)
        (error "Invalid first argument: %S" start-or-string))
      (setq start start-or-string
            finish end-or-prop
            properties props-or-val
            object (tp--parse-region-object rest)
            mutation :in-place
            public-return (if (stringp object) :object :range)))
    (when (and (listp properties) (listp (car-safe properties)))
      (setq properties (car properties)))
    (setq properties (tp--prepare-direct-properties properties))
    (let ((range (tp--native-range-from-object object start finish)))
      (tp--make-request
       :operation operation
       :range range
       :props properties
       :mutation mutation
       :public-return public-return))))

(defun tp--apply-props-to-string (string start end props &optional operation)
  "Return a copy of STRING with PROPS applied to [START, END)."
  (let ((result (copy-sequence string)))
    (tp--apply-props-by-operation
     (max 0 start) (min end (length result)) props result operation)
    result))

(defun tp--mutate-request (request)
  "Execute canonical mutation REQUEST and return its public result."
  (let* ((range (tp--request-range request))
         (original (tp--native-range-object range))
         (object (if (eq (tp--request-mutation request) :copy)
                     (copy-sequence original)
                   original))
         (start (tp--native-range-start range))
         (end (tp--native-range-end range)))
    (tp--apply-props-by-operation
     start end (tp--request-props request) object
     (tp--request-operation request))
    (if (eq (tp--request-public-return request) :object)
        object
      (cons start end))))

;;;###autoload
(defun tp-propertize (string declarations)
  "Return a copy of STRING styled by native DECLARATIONS.
Declarations pass through TP's direct property policy and projection core."
  (unless (stringp string)
    (signal 'wrong-type-argument (list 'stringp string)))
  (tp--apply-props-to-string
   string 0 (length string) (tp--project-text-declarations declarations)))

;;;###autoload
(defun tp-apply (buffer start end declarations)
  "Apply native DECLARATIONS once to BUFFER from START to END.
Preserve text and direct properties not named by DECLARATIONS, then return the
committed range as a START . END cons."
  (let ((target (get-buffer buffer)))
    (tp--validate-buffer-range target start end)
    (tp--apply-props-by-operation
     start end (tp--project-text-declarations declarations) target nil)
    (cons start end)))

;;;###autoload
(defun tp-set (start-or-string &optional end-or-prop props-or-val &rest rest)
  "Set direct text properties on a string or buffer range.
String whole-object calls return a new string.  Explicit string ranges and
buffer ranges mutate their target in place.  Named recipes expand to ordinary
properties and do not create live identity.

START-OR-STRING, END-OR-PROP, PROPS-OR-VAL and REST are parsed by
`tp--parse-args` and then committed by `tp--mutate-request`."
  (tp--mutate-request
   (tp--parse-args start-or-string end-or-prop props-or-val rest :set)))

;;;###autoload
(defun tp-reset (start-or-string &optional end-or-prop props-or-val &rest rest)
  "Replace all text properties on a string or buffer range.

START-OR-STRING, END-OR-PROP, PROPS-OR-VAL and REST are passed through
`tp--parse-args` as in `tp-set`."
  (tp--mutate-request
   (tp--parse-args start-or-string end-or-prop props-or-val rest :reset)))

;;;###autoload
(defun tp-add (start-or-string &optional end-or-prop props-or-val &rest rest)
  "Merge direct text properties into a string or buffer range.
Face-family properties compose and nested plist values merge recursively.

START-OR-STRING, END-OR-PROP, PROPS-OR-VAL and REST are passed through
`tp--parse-args` as in `tp-set` and `tp-reset`."
  (tp--mutate-request
   (tp--parse-args start-or-string end-or-prop props-or-val rest :add)))

(defun tp--property-intervals (object start end property path)
  "Return PROPERTY intervals in OBJECT between START and END using PATH."
  (let ((position start) intervals)
    (while (< position end)
      (let* ((props (text-properties-at position object))
             (member (plist-member props property))
             (next (or (next-single-property-change
                        position property object end)
                       end)))
        (when member
          (push (list position next
                      (if path
                          (tp--get-nested (cadr member) path)
                        (cadr member)))
                intervals))
        (setq position next)))
    (nreverse intervals)))

(defun tp--all-property-intervals (object start end)
  "Return all nonempty property intervals in OBJECT from START to END."
  (let ((position start) intervals)
    (while (< position end)
      (let* ((props (text-properties-at position object))
             (next (or (next-property-change position object end) end)))
        (when props (push (list position next props) intervals))
        (setq position next)))
    (nreverse intervals)))

(defun tp--get-string (string selector args)
  "Implement the whole-string `tp-get' form for STRING, SELECTOR and ARGS.

STRING is searched from 0 to its full length.  SELECTOR and ARGS mirror
the normal `tp-get' arguments for a whole-string query."
  (cond
   ((null selector)
    (tp--all-property-intervals string 0 (length string)))
   ((numberp selector)
    (let ((end (car args)))
      (unless (numberp end)
        (error "TP-GET string range requires a numeric END"))
      (apply #'tp-get selector end (append (cdr args) (list string)))))
   ((listp selector)
    (tp--property-intervals
     string 0 (length string) (car selector) (cdr selector)))
   ((symbolp selector)
    (tp--property-intervals string 0 (length string) selector args))
   (t (error "Invalid tp-get selector: %S" selector))))

(defun tp--get-region-options (args)
  "Parse region-form `tp-get' ARGS into (PROPERTY PATH OBJECT)."
  (let (property path object)
    (when args
      (cond
       ((listp (car args))
        (setq property (caar args)
              path (cdar args)
              object (cadr args)))
       ((symbolp (car args))
        (setq property (pop args))
        (when (and args (or (bufferp (car (last args)))
                            (stringp (car (last args)))))
          (setq object (car (last args))
                args (butlast args)))
        (setq path args))
       ((or (bufferp (car args)) (stringp (car args)))
        (setq object (car args)))))
    (list property path object)))

;;;###autoload
(defun tp-get (start-or-string &optional end-or-property &rest args)
  "Return property intervals from a string or buffer range.

START-OR-STRING and END-OR-PROPERTY are the query range.
ARGS are passed to region parsing and property expansion logic.

Use `tp-at' for a single position.  Explicit nil values remain distinguishable
from absent properties because intervals are emitted only for present keys."
  (if (stringp start-or-string)
      (tp--get-string start-or-string end-or-property args)
    (unless (and (numberp start-or-string) (numberp end-or-property))
      (error "Invalid arguments to tp-get"))
    (pcase-let* ((`(,property ,path ,object) (tp--get-region-options args))
                 (target (or object (current-buffer))))
      (if property
          (tp--property-intervals
           target start-or-string end-or-property property path)
        (tp--all-property-intervals
         target start-or-string end-or-property)))))

;;;###autoload
(defun tp-at (position &optional property-or-object object)
  "Return text properties at POSITION in OBJECT.
PROPERTY-OR-OBJECT may be a property symbol, a nested property path, or the
target string/buffer itself."
  (let (property path target)
    (cond
     ((null property-or-object))
     ((or (bufferp property-or-object) (stringp property-or-object))
      (setq target property-or-object))
     ((symbolp property-or-object)
      (setq property property-or-object target object))
     ((listp property-or-object)
      (setq property (car property-or-object)
            path (cdr property-or-object)
            target object))
     (t (error "Invalid property or object: %S" property-or-object)))
    (if property
        (let ((value (get-text-property position property target)))
          (if path (tp--get-nested value path) value))
      (text-properties-at position target))))

;;;###autoload
(defun tp-member (position property &optional object)
  "Return (PROPERTY VALUE) when PROPERTY is present at POSITION in OBJECT."
  (when-let* ((member (plist-member
                      (text-properties-at position object) property)))
    (list (car member) (cadr member))))

(defun tp--value-after-sub-removal (value sub-property)
  "Return VALUE after removing SUB-PROPERTY, or nil when empty."
  (tp--remove-sub-from-face-value value sub-property))

(defun tp--remove-sub (start end property sub-property object)
  "Remove SUB-PROPERTY from PROPERTY on [START, END) in OBJECT."
  (let ((position start))
    (while (< position end)
      (let* ((next (or (next-single-property-change
                        position property object end)
                       end))
             (value (get-text-property position property object))
             (updated (tp--value-after-sub-removal value sub-property)))
        (if updated
            (put-text-property position next property updated object)
          (remove-text-properties position next (list property nil) object))
        (setq position next)))))

(defun tp--remove-nested-keys (plist keys)
  "Return PLIST without KEYS, or nil when nothing remains."
  (let ((result (copy-tree plist)))
    (dolist (key keys) (cl-remf result key))
    result))

(defun tp--remove-nested-sub-keys (plist sub-key nested-keys)
  "Remove NESTED-KEYS from SUB-KEY within PLIST."
  (let* ((result (copy-tree plist))
         (sub-value (plist-get result sub-key))
         (updated (when (listp sub-value)
                    (tp--remove-nested-keys
                     sub-value
                     (if (listp nested-keys) nested-keys
                       (list nested-keys))))))
    (if updated
        (plist-put result sub-key updated)
      (cl-remf result sub-key))
    result))

(defun tp--remove-nested-property (start end property sub-key nested object)
  "Remove NESTED keys below PROPERTY and SUB-KEY from START to END in OBJECT."
  (let ((position start))
    (while (< position end)
      (let* ((next (or (next-single-property-change
                        position property object end)
                       end))
             (value (get-text-property position property object)))
        (when (listp value)
          (let ((updated (tp--remove-nested-sub-keys value sub-key nested)))
            (if updated
                (put-text-property position next property updated object)
              (remove-text-properties
               position next (list property nil) object))))
        (setq position next)))))

(defun tp--remove-property (start end property object)
  "Remove PROPERTY specification from [START, END) in OBJECT."
  (cond
   ((symbolp property)
    (remove-text-properties start end (list property nil) object))
   ((and (listp property) (symbolp (car property)))
    (pcase-let ((`(,name ,sub-key ,nested) property))
      (cond
       (nested (tp--remove-nested-property
                start end name sub-key nested object))
       (sub-key (tp--remove-sub start end name sub-key object))
       (t (remove-text-properties start end (list name nil) object)))))
   (t (error "Invalid property removal spec: %S" property))))

(defun tp--remove-properties-from-string (string properties)
  "Return a copy of STRING without top-level PROPERTIES."
  (let ((result (copy-sequence string)))
    (dolist (property properties)
      (tp--remove-property 0 (length result) property result))
    result))

(defun tp--remove-property-from-string (string start end property)
  "Return a copy of STRING with PROPERTY removed from [START, END)."
  (let ((result (copy-sequence string)))
    (tp--remove-property start end property result)
    result))

(defun tp--remove-sub-from-string (string start end property sub-key)
  "Return a copy of STRING without PROPERTY's SUB-KEY from START to END."
  (tp--remove-property-from-string
   string start end (list property sub-key)))

;;;###autoload
(defun tp-remove (start-or-string end-or-prop &optional prop-or-sub &rest rest)
  "Remove direct properties from a string or buffer range.

START-OR-STRING and END-OR-PROP mirror `tp-get`-style range arguments.
PROP-OR-SUB selects the property or nested-key form and REST carries
optional flags/object."
  (if (stringp start-or-string)
      (cond
       ((and (symbolp end-or-prop) (keywordp prop-or-sub) rest)
        (tp--remove-property-from-string
         start-or-string 0 (length start-or-string)
         (list end-or-prop prop-or-sub (car rest))))
       ((and (symbolp end-or-prop) (keywordp prop-or-sub))
        (tp--remove-sub-from-string
         start-or-string 0 (length start-or-string)
         end-or-prop prop-or-sub))
       ((listp end-or-prop)
        (tp--remove-property-from-string
         start-or-string 0 (length start-or-string) end-or-prop))
       (t
        (tp--remove-properties-from-string
         start-or-string
         (delq nil (cons end-or-prop (cons prop-or-sub rest))))))
    (unless (and (numberp start-or-string) (numberp end-or-prop))
      (error "Invalid arguments to tp-remove"))
    (tp--remove-property
     start-or-string end-or-prop prop-or-sub (car rest))
    nil))

(defun tp--reset-apply (start end props object)
  "Replace properties on OBJECT from START to END with PROPS."
  (if (stringp object)
      (tp--apply-props-to-string object start end props :reset)
    (set-text-properties start end props object)
    object))

(defun tp--deep-merge-apply (start end props object)
  "Merge PROPS into OBJECT from START to END."
  (if (stringp object)
      (tp--apply-props-to-string object start end props :add)
    (tp--apply-props-by-operation start end props object :add)
    object))

;;;###autoload
(defun tp-clear (&optional start end object)
  "Clear all text properties from START to END in OBJECT."
  (interactive)
  (pcase-let ((`(,minimum . ,maximum) (tp--object-bounds object)))
    (set-text-properties (or start minimum) (or end maximum) nil object))
  nil)

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