;;; tp-query.el --- Native query and policy helpers for tp -*- lexical-binding: t -*-

;; Copyright (C) 2024-2026 Geekinney

;; Author: Geekinney (kinneyzhang666@gmail.com)

;;; Commentary:

;; Explicit native text-property query boundaries and mutation policy.

;;; Code:

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

(cl-defstruct (tp-lookup-result
               (:constructor tp--make-lookup-result
                             (&key property value present-p source mode
                                   object position overlay)))
  "Normalized text or character property lookup result.
PRESENT-P distinguishes an explicit nil value from absence.  SOURCE
identifies the winning text source or `:overlay'; OVERLAY is non-nil
only when that overlay supplied the winning character-property value."
  property value present-p source mode object position overlay)

(defun tp--lookup-direct (position property object mode)
  "Return direct text lookup result for PROPERTY at POSITION in OBJECT.

POSITION, PROPERTY, and OBJECT identify the lookup target; MODE is
returned in the result."
  (let* ((obj (or object (current-buffer)))
         (cell (plist-member (text-properties-at position object) property)))
    (tp--make-lookup-result
     :property property :value (cadr cell) :present-p (and cell t)
     :source (if cell :text-direct :absent) :mode mode
     :object obj :position position)))

(defun tp--lookup-effective (position property object mode)
  "Return effective text lookup result for PROPERTY at POSITION in OBJECT.

POSITION, PROPERTY, and OBJECT identify the lookup target; MODE is
returned in the result."
  (let* ((value (get-text-property position property object))
         (source-cell (tp--lookup-source-cell position property object))
         (present-p (nth 2 source-cell)))
    (tp--make-lookup-result
     :property property :value value :present-p present-p
     :source (if present-p (car source-cell) :absent) :mode mode
     :object (or object (current-buffer)) :position position)))

(defun tp--lookup-char (position property object mode)
  "Return overlay-aware lookup for PROPERTY at POSITION in OBJECT.
MODE is recorded in the returned `tp-lookup-result'."
  (let* ((native (get-char-property-and-overlay position property object))
         (overlay (cdr native))
         (text-object (if (windowp object) (window-buffer object) object))
         (text-source (tp--lookup-source-cell
                       position property text-object))
         (present-p (or overlay (nth 2 text-source)))
         (source (if overlay :overlay (car text-source))))
    (tp--make-lookup-result
     :property property :value (car native) :present-p (and present-p t)
     :source source :mode mode :object (or object (current-buffer))
     :position position :overlay overlay)))

(defun tp--lookup-alias-cell (position property object)
  "Return the first non-nil alias value for PROPERTY at POSITION."
  (catch 'found
    (dolist (alias (cdr (assq property char-property-alias-alist)))
      (when-let ((value (get-text-property position alias object)))
        (throw 'found (list alias value))))))

(defun tp--lookup-source-cell (position property object)
  "Return (SOURCE VALUE PRESENT-P) for PROPERTY at POSITION in OBJECT."
  (let* ((props (text-properties-at position object))
         (direct (plist-member props property))
         (category (plist-get props 'category))
         (cat-cell (and category (plist-member (symbol-plist category) property)))
         (alias-cell (tp--lookup-alias-cell position property object))
         (default-cell (plist-member default-text-properties property)))
    (cond
     (direct (list :text-direct (cadr direct) t))
     (cat-cell (list :category (cadr cat-cell) t))
     (alias-cell (list :alias (cadr alias-cell) t))
     (default-cell (list :default (cadr default-cell) t))
     (t (list :absent nil nil)))))

;;;###autoload
(cl-defun tp-lookup (position property &key object (mode :text-effective))
  "Look up PROPERTY at POSITION in OBJECT according to MODE.

POSITION, PROPERTY, OBJECT, and MODE are lookup parameters.

MODE is one of `:text-direct', `:text-effective', `:text-source',
`:char', or `:char-source'.  Text modes ignore overlays.  Character
modes delegate overlay precedence to `get-char-property-and-overlay';
when an overlay supplies the winning value, the result records both
source `:overlay' and the winning overlay object.

Always return a `tp-lookup-result'.  Its `present-p' field separates
absence from a direct property whose value is nil."
  (pcase mode
    (:text-direct (tp--lookup-direct position property object mode))
    (:text-effective (tp--lookup-effective position property object mode))
    (:text-source
     (pcase-let ((`(,source ,value ,present-p)
                  (tp--lookup-source-cell position property object)))
       (tp--make-lookup-result
        :property property :value value :present-p present-p
        :source source :mode mode :object (or object (current-buffer))
        :position position)))
    ((or :char :char-source)
     (tp--lookup-char position property object mode))
    (_ (error "TP-LOOKUP: unknown mode %S" mode))))

;;;###autoload
(cl-defun tp-property-change
    (position &key property object limit (direction :next))
  "Return a native property change position from POSITION.
With PROPERTY, delegate to the single-property change primitives;
with nil PROPERTY, observe changes to any property.  DIRECTION is
`:next' or `:previous'.  OBJECT and LIMIT retain their native Emacs
meanings.  Return the changed position or nil."
  (pcase direction
    (:next
     (if property
         (next-single-property-change position property object limit)
       (next-property-change position object limit)))
    (:previous
     (if property
         (previous-single-property-change position property object limit)
       (previous-property-change position object limit)))
    (_ (error "TP-PROPERTY-CHANGE: unknown direction %S" direction))))

;;;###autoload
(defun tp-property-any (start end property value &optional object)
  "Return first position in [START, END) where PROPERTY is VALUE.

START and END are search bounds.
PROPERTY and VALUE are matched directly.
OBJECT is a string, a buffer, or nil for the current buffer."
  (text-property-any start end property value object))

;;;###autoload
(defun tp-property-not-all (start end property value &optional object)
  "Return first position in [START, END) where PROPERTY is not VALUE.

START and END are search bounds.
PROPERTY and VALUE are matched directly.
OBJECT is a string, a buffer, or nil for the current buffer."
  (text-property-not-all start end property value object))

(defun tp--mutation-policy-modes (policy)
  "Return normalized (MODIFIED READ-ONLY) modes for POLICY.

POLICY is a property list with keys `:modified' and `:read-only'."
  (unless (and (proper-list-p policy) (cl-evenp (length policy)))
    (error "TP-WITH-MUTATION-POLICY: POLICY must be a plist"))
  (cl-loop for (key _value) on policy by #'cddr
           unless (memq key '(:modified :read-only))
           do (error "TP-WITH-MUTATION-POLICY: unknown key %S" key))
  (let ((modified (if (plist-member policy :modified)
                      (plist-get policy :modified)
                    :ordinary))
        (read-only (if (plist-member policy :read-only)
                       (plist-get policy :read-only)
                     :respect)))
    (unless (memq modified '(:ordinary :silent))
      (error "TP-WITH-MUTATION-POLICY: unknown :modified %S" modified))
    (unless (memq read-only '(:respect :inhibit))
      (error "TP-WITH-MUTATION-POLICY: unknown :read-only %S" read-only))
    (when (and (eq modified :silent) (eq read-only :respect))
      (error "TP-WITH-MUTATION-POLICY: :silent requires :read-only :inhibit"))
    (list modified read-only)))

;;;###autoload
(defmacro tp-with-mutation-policy (policy &rest body)
  "Run BODY with explicit mutation POLICY.
POLICY accepts `:modified' (`:ordinary' or `:silent') and
`:read-only' (`:respect' or `:inhibit').  The supported combinations
are ordinary/respect, ordinary/inhibit, and silent/inhibit.
Silent/respect is rejected because native `with-silent-modifications'
itself inhibits read-only text."
  (declare (indent 1) (debug (form body)))
  `(pcase (tp--mutation-policy-modes ,policy)
     ('(:ordinary :respect) ,@body)
     ('(:ordinary :inhibit)
      (let ((inhibit-read-only t)) ,@body))
     ('(:silent :inhibit)
      (let ((inhibit-read-only t))
        (with-silent-modifications ,@body)))))

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