org-mode/lisp/org-element-ast.el

;;; org-element-ast.el --- Abstract syntax tree for Org  -*- lexical-binding: t; -*-

;; Copyright (C) 2023  Ihor Radchenko

;; Author: Ihor Radchenko <yantar92@posteo.net>
;; Keywords: data, lisp

;; 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.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; This file implements Org abstract syntax tree (AST) data structure.
;;
;; Only the most generic aspect of the syntax tree are considered
;; below.  The fine details of Org syntax are implemented elsewhere.
;;
;; Org AST is composed of nested syntax nodes.
;; Within actual Org syntax, the nodes can be either headings,
;; elements, or objects.  However, historically, we often call syntax
;; nodes simply "elements", unless the context requires clarification
;; about the node type.  In particular, many functions below will have
;; naming pattern `org-element-X', implying `org-element-node-X' --
;; they will apply to all the node types, not just to elements.
;;
;; 1. Syntax nodes
;; ------------------
;; Each Org syntax node can be represented as a string or list.
;;
;; The main node representation follows the pattern
;; (TYPE PROPERTIES CONTENTS), where
;;   TYPE is a symbol describing the node type.
;;   PROPERTIES is the property list attached to it.
;;   CONTENTS is a list of child syntax nodes contained within the
;;            current node, when applicable.
;;
;;; For example, "*bold text*  " node can be represented as
;;
;;    (bold (:begin 1 :end 14 :post-blank 2 ...) "bold text")
;;
;; TYPE can be any symbol, including symbol not explicitly defined by
;; Org syntax.  If TYPE is not a part of the syntax, the syntax
;; node is called "pseudo element/object", but otherwise considered a
;; valid part of Org syntax tree.  Search "Pseudo objects and
;; elements" in lisp/ox-latex.el for an example of using pseudo
;; elements.
;;
;; PROPERTIES is a property list (:property1 value1 :property2 value2 ...)
;; holding properties and value.
;;
;; `:standard-properties', `:parent', `:deferred', and `:secondary'
;; properties are treated specially in the code below.
;;
;; `:standard-properties' holds an array with
;; `org-element--standard-properties' values, in the same order.  The
;; values in the array have priority over the same properties
;; specified in the property list.  You should not rely on the value
;; of `org-element--standard-propreties' in the code.
;; `:standard-properties' may or may not be actually present in
;; PROPERTIES.  It is mostly used to speed up property access in
;; performance-critical code, as most of the code requesting property
;; values by constant name is inlined.
;;
;; The previous example can also be presented in more compact form as:
;;
;;    (bold (:standard-properties [1 10 ... 2 ...]) "bold text")
;;
;; Using an array allows faster access to frequently used properties.
;;
;; `:parent' holds the containing node, for a child node within the
;; AST.  It may or may not be present in PROPERTIES.
;;
;; `:secondary' holds a list of properties that may contain extra AST
;; nodes, in addition to the node contents.
;;
;; `deferred' property describes how to update not-yet-calculated
;; properties on request.
;;
;;
;; Syntax node can also be represented by a string.  Strings always
;; represent syntax node of `plain-text' type with contents being nil
;; and properties represented as string properties at position 0.
;; `:standard-properties' are not considered for `plain-text' nodes as
;; `plain-text' nodes tend to hold much fewer properties.
;;
;; In the above example, `plain-text' node "bold text" is more
;; accurately represented as
;;
;;    #("bold text" 0 9 (:parent (bold ...)))
;;
;; with :parent property value pointing back to the containing `bold'
;; node.
;;
;; `anonymous' syntax node is represented as a list with `car'
;; containing another syntax node.  Such node has nil type, does not
;; have properties, and its contents is a list of the contained syntax
;; node.  `:parent' property of the contained nodes point back to the
;; list itself, except when `anonymous' node holds secondary value
;; (see below), in which case the `:parent' property is set to be the
;; containing node in the AST.
;;
;; Any node representation other then described above is not
;; considered as Org syntax node.
;;
;; 2. Deferred values
;; ------------------
;; Sometimes, it is computationally expensive or even not possible to
;; calculate property values when creating an AST node.  The value
;; calculation can be deferred to the time the value is requested.
;;
;; Property values and contained nodes may have a special value of
;; `org-element-deferred' type.  Such values are computed dynamically.
;; Either every time the property value is requested or just the first
;; time.  In the latter case, the `org-element-deferred' property
;; value is auto-replaced with the dynamically computed result.
;;
;; Sometimes, even property names (not just property values) cannot, or
;; should not be computed in advance.  If a special property
;; `:deferred' has the value of `org-element-deferred-type', it is
;; first resolved for side effects of setting the missing properties.
;; The resolved value is re-assigned to the `:deferred' property.
;;
;; Note that `org-element-copy' unconditionally resolves deferred
;; properties.  This is useful to generate pure (in functional sense)
;; AST.
;;
;; The properties listed in `org-element--standard-properties', except
;; `:deferred' and `:parent' are never considered to have deferred value.
;; This constraint makes org-element API significantly faster.
;;
;; 3. Org document representation
;; ------------------------------
;; Document AST is represented by nested Org syntax nodes.
;;
;; Each node in the AST can hold the contained node in its CONTENTS or
;; as values of properties.
;;
;; For example, (bold (...) "bold text") `bold' node contains
;; `plain-text' node in CONTENTS.
;;
;; The containing node is called "parent node".
;;
;; The contained nodes held inside CONTENTS are called "child nodes".
;; They must have their `:parent' property set to the containing
;; parent node.
;;
;; The contained nodes can also be held as property values.  Such
;; nodes are called "secondary nodes".  Only certain properties
;; can contribute to AST - the property names listed as the value of
;; special property `:secondary'
;;
;; For example,
;;
;;   (headline ((:secondary (:title)
;;               :title (#("text" 0 4 (:parent (headline ...)))))))
;;
;; is a parent headline node containing "text" secondary string node
;; inside `:title' property.  Note that `:title' is listed in
;; `:secondary' value.
;;
;; The following example illustrates an example AST for Org document:
;;
;; ---- Org document --------
;; * Heading with *bold* text
;; Paragraph.
;; ---- end -----------------
;;
;; (org-data (...) ; `org-data' node.
;;   (headline
;;     (
;;      ;; `:secondary' property lists property names that contain other
;;      ;; syntax tree nodes.
;;
;;      :secondary (:title)
;;
;;      ;; `:title' property is set to anonymous node containing:
;;      ;; `plain-text', `bold', `plain-text'.
;;
;;      :title ("Heading with " (bold (:post-blank 1 ...) "bold") "text"))
;;
;;      ;; `headline' contents
;;     (section (...)
;;       (paragraph
;;         ;; `:parent' property set to the containing section.
;;         (:parent (section ...))
;;         ;; paragraph contents is a `plain-text' node.
;;         "Paragraph1."))))
;;
;; Try calling M-: (org-element-parse-buffer) on the above example Org
;; document to explore a more complete version of Org AST.

;;; Code:

(require 'org-macs)
(require 'inline) ; load indentation rules

;;;; Syntax node type

(defun org-element-type (node &optional anonymous)
  "Return type of NODE.

The function returns the type of the node provided.
It can also return the following special value:
  `plain-text'       for a string
  nil                in any other case.

When optional argument ANONYMOUS is non-nil, return symbol `anonymous'
when NODE is an anonymous node."
  (declare (pure t))
  (cond
   ((stringp node) 'plain-text)
   ((null node) nil)
   ((not (consp node)) nil)
   ((symbolp (car node)) (car node))
   ((and anonymous (car node) (org-element-type (car node) t))
    'anonymous)
   (t nil)))

(define-inline org-element-type-p (node types)
  "Return non-nil when NODE type is one of TYPES.
TYPES can be a type symbol or a list of symbols."
  (if (inline-const-p types)
      (if (listp (inline-const-val types))
          (inline-quote (memq (org-element-type ,node t) ,types))
        (inline-quote (eq (org-element-type ,node t) ,types)))
    (inline-letevals (node types)
      (inline-quote
       (if (listp ,types)
           (memq (org-element-type ,node t) ,types)
         (eq (org-element-type ,node t) ,types))))))

(defun org-element-secondary-p (node)
  "Non-nil when NODE directly belongs to a secondary node.
Return value is the containing property name, as a keyword, or nil."
  (declare (pure t))
  (let* ((parent (org-element-property :parent node))
	 (properties (org-element-property :secondary parent))
         val)
    (catch 'exit
      (dolist (p properties)
        (setq val (org-element-property-1 p parent))
	(when (or (eq node val) (memq node val))
	  (throw 'exit p))))))

;;;; Deferred values

(cl-defstruct (org-element-deferred
               (:constructor nil)
               (:constructor org-element-deferred-create
                             ( auto-undefer-p function &rest arg-value
                               &aux (args arg-value)))
               (:constructor org-element-deferred-create-alias
                             ( keyword &optional auto-undefer-p
                               &aux
                               (function #'org-element-property-2)
                               (args (list keyword))))
               (:constructor org-element-deferred-create-list
                             ( args &optional auto-undefer-p
                               &aux
                               (function #'org-element--deferred-resolve-list)))
               (:type vector) :named)
  "Dynamically computed value.

The value can be obtained by calling FUNCTION with containing syntax
node as first argument and ARGS list as remainting arguments.

If the function throws `:org-element-deferred-retry' signal, assume
that the syntax node has been modified by side effect and retry
retrieving the value that was previously deferred.

AUTO-UNDEFER slot flags if the property value should be replaced upon
resolution.  Some functions may ignore this flag."
  function args auto-undefer-p)

(defsubst org-element--deferred-resolve-once (deferred-value &optional node)
  "Resolve DEFERRED-VALUE for NODE.
Throw `:org-element-deferred-retry' if NODE has been modified and we
need to re-read the value again."
  (apply (org-element-deferred-function deferred-value)
         node
         (org-element-deferred-args deferred-value)))

(defsubst org-element--deferred-resolve (value &optional node force-undefer)
  "Resolve VALUE for NODE recursively.
Return a cons cell of the resolved value and the value to store.
When no value should be stored, return `org-element-ast--nil' as cdr.
When FORCE-UNDEFER is non-nil, resolve all the deferred values, ignoring
their `auto-undefer-p' slot.

Throw `:org-element-deferred-retry' if NODE has been modified and we
need to re-read the value again."
  (let ((value-to-store 'org-element-ast--nil) undefer)
    (while (org-element-deferred-p value)
      (setq undefer (or force-undefer (org-element-deferred-auto-undefer-p value))
            value (org-element--deferred-resolve-once value node))
      (when undefer (setq value-to-store value)))
    (cons value value-to-store)))

(defsubst org-element--deferred-resolve-force (value &optional node)
  "Resolve VALUE for NODE recursively, ignoring `auto-undefer-p'.
Return the resolved value.

Throw `:org-element-deferred-retry' if NODE has been modified and we
need to re-read the value again."
  (car (org-element--deferred-resolve value node 'force)))

(defsubst org-element--deferred-resolve-list (node &rest list)
  "Unconditionally resolve all the deferred values in LIST for NODE.
Return a new list with all the values resolved.

Throw `:org-element-deferred-retry' if NODE has been modified and we
need to re-read the value again."
  (mapcar
   (lambda (value)
     (if (org-element-deferred-p value)
         (org-element--deferred-resolve-force value node)
       value))
   list))

;;;; Object properties

(eval-and-compile ; make available during inline expansion

  (defconst org-element--standard-properties
    '( :begin :end :contents-begin :contents-end
       :post-blank :post-affiliated :secondary
       :cached :org-element--cache-sync-key
       :robust-begin :robust-end
       :mode :granularity :true-level
       :parent :deferred :structure :buffer)
    "Standard properties stored in every syntax node structure.
These properties are stored in an array pre-allocated every time a new
object is created.  Two exceptions are `anonymous' and `plain-text'
node types.")

  (defconst org-element--standard-properties-idxs
    (let (plist)
      (seq-do-indexed
       (lambda (property idx)
         (setq plist (plist-put plist property idx)))
       org-element--standard-properties)
      plist)
    "Property list holding standard indexes for `org-element--standard-properties'."))

(define-inline org-element--property-idx (property)
  "Return standard property index or nil."
  (declare (pure t))
  (if (inline-const-p property)
      (plist-get
       org-element--standard-properties-idxs
       (inline-const-val property))
    (inline-quote (plist-get
                   org-element--standard-properties-idxs
                   ,property))))

(define-inline org-element--parray (node)
  "Return standard property array for NODE."
  (declare (pure t))
  (inline-letevals (node)
    (inline-quote
     (pcase (org-element-type ,node)
       (`nil nil)
       ;; Do not use property array for strings - they usually hold
       ;; `:parent' property and nothing more.
       (`plain-text nil)
       (_
        ;; (type (:standard-properties val ...) ...)
        (if (eq :standard-properties (car (nth 1 ,node)))
            (cadr (nth 1 ,node))
          ;; Non-standard order.  Go long way.
          (plist-get (nth 1 ,node) :standard-properties)))))))

(define-inline org-element--plist-property (property node &optional dflt)
  "Extract the value for PROPERTY from NODE's property list.
Ignore standard property array."
  (declare (pure t))
  (inline-letevals (property node dflt)
    (inline-quote
     (pcase (org-element-type ,node)
       (`nil ,dflt)
       (`plain-text
        (or (get-text-property 0 ,property ,node)
            (when ,dflt
              (if (plist-member (text-properties-at 0 ,node) ,property)
                  nil ,dflt))))
       (_
        (or (plist-get (nth 1 ,node) ,property)
            (when ,dflt
              (if (plist-member (nth 1 ,node) ,property)
                  nil ,dflt))))))))

(define-inline org-element-property-1 (property node &optional dflt)
  "Extract the value for PROPERTY of an NODE.
Do not resolve deferred values.
If PROPERTY is not present, return DFLT."
  (declare (pure t))
  (let ((idx (and (inline-const-p property)
                  (org-element--property-idx property))))
    (if idx
        (inline-letevals (node)
          (inline-quote
           (if-let ((parray (org-element--parray ,node)))
               (pcase (aref parray ,idx)
                 (`org-element-ast--nil ,dflt)
                 (val val))
             ;; No property array exists.  Fall back to `plist-get'.
             (org-element--plist-property ,property ,node ,dflt))))
      (inline-letevals (node property)
        (inline-quote
         (let ((idx (org-element--property-idx ,property)))
           (if-let ((parray (and idx (org-element--parray ,node))))
               (pcase (aref parray idx)
                 (`org-element-ast--nil ,dflt)
                 (val val))
             ;; No property array exists.  Fall back to `plist-get'.
             (org-element--plist-property ,property ,node ,dflt))))))))

(define-inline org-element--put-parray (node &optional parray)
  "Initialize standard property array in NODE.
Return the array or nil when NODE is `plain-text'."
  (inline-letevals (node parray)
    (inline-quote
     (let ((parray ,parray))
       (unless (or parray (memq (org-element-type ,node) '(plain-text nil)))
         (setq parray (make-vector ,(length org-element--standard-properties) nil))
         ;; Copy plist standard properties back to parray.
         (let ((stdplist org-element--standard-properties-idxs))
           (while stdplist
             (aset parray (cadr stdplist)
                   (org-element--plist-property (car stdplist) ,node))
             (setq stdplist (cddr stdplist))))
         (setcar (cdr ,node)
                 (nconc (list :standard-properties parray)
                        (cadr ,node)))
         parray)))))

(define-inline org-element-put-property (node property value)
  "In NODE, set PROPERTY to VALUE.
Return modified NODE."
  (let ((idx (and (inline-const-p property)
                  (org-element--property-idx property))))
    (if idx
        (inline-letevals (node value)
          (inline-quote
           (if (org-element-type-p ,node 'plain-text)
               ;; Special case: Do not use parray for plain-text.
               (org-add-props ,node nil ,property ,value)
             (let ((parray
                    (or (org-element--parray ,node)
                        (org-element--put-parray ,node))))
               (when parray (aset parray ,idx ,value))
               ,node))))
      (inline-letevals (node property value)
        (inline-quote
         (let ((idx (org-element--property-idx ,property)))
           (if (and idx (not (org-element-type-p ,node 'plain-text)))
               (when-let
                   ((parray
                     (or (org-element--parray ,node)
                         (org-element--put-parray ,node))))
                 (aset parray idx ,value))
             (pcase (org-element-type ,node)
               (`nil nil)
               (`plain-text
                (org-add-props ,node nil ,property ,value))
               (_
                ;; Note that `plist-put' adds new elements at the end,
                ;; thus keeping `:standard-properties' as the first element.
                (setcar (cdr ,node) (plist-put (nth 1 ,node) ,property ,value)))))
           ,node))))))

(define-inline org-element-put-property-2 (property value node)
  "Like `org-element-put-property', but NODE is the last argument.
See `org-element-put-property' for the meaning of PROPERTY and VALUE."
  (inline-quote (org-element-put-property ,node ,property ,value)))

(defun org-element--property (property node &optional dflt force-undefer)
  "Extract the value from the PROPERTY of a NODE.
Return DFLT when PROPERTY is not present.
When FORCE-UNDEFER is non-nil, unconditionally resolve deferred
properties, replacing their values in NODE."
  (let ((value (org-element-property-1 property node 'org-element-ast--nil)))
    ;; PROPERTY not present.
    (when (and (eq 'org-element-ast--nil value)
               (org-element-deferred-p
                (org-element-property-1 :deferred node)))
      ;; If :deferred has `org-element-deferred' type, resolve it for
      ;; side-effects, and re-assign the new value.
      (org-element--property :deferred node nil 'force-undefer)
      ;; Try to retrieve the value again.
      (setq value (org-element-property-1 property node dflt)))
    ;; Deferred property.  Resolve it recursively.
    (when (org-element-deferred-p value)
      (let ((retry t) (firstiter t))
        (while retry
          (if firstiter (setq firstiter nil) ; avoid extra call to `org-element-property-1'.
            (setq value (org-element-property-1 property node 'org-element-ast--nil)))
          (catch :org-element-deferred-retry
            (pcase-let
                ((`(,resolved . ,value-to-store)
                  (org-element--deferred-resolve value node force-undefer)))
              (setq value resolved)
              ;; Store the resolved property value, if needed.
              (unless (eq value-to-store 'org-element-ast--nil)
                (org-element-put-property node property value-to-store)))
            ;; Finished resolving.
            (setq retry nil)))))
    ;; Return the resolved value.
    (if (eq value 'org-element-ast--nil) dflt value)))

(define-inline org-element-property (property node &optional dflt force-undefer)
  "Extract the value from the PROPERTY of a NODE.
Return DFLT when PROPERTY is not present.
When FORCE-UNDEFER is non-nil, unconditionally resolve deferred
properties, replacing their values in NODE.

Note: The properties listed in `org-element--standard-properties',
except `:deferred', may not be resolved."
  (if (and (inline-const-p property)
           (not (memq (inline-const-val property) '(:deferred :parent)))
           (org-element--property-idx (inline-const-val property)))
      ;; This is an important optimization, making common org-element
      ;; API calls much faster.
      (inline-quote (org-element-property-1 ,property ,node ,dflt))
    (inline-quote (org-element--property ,property ,node ,dflt ,force-undefer))))

(define-inline org-element-property-2 (node property &optional dflt force-undefer)
  "Like `org-element-property', but reverse the order of NODE and PROPERTY."
  (inline-quote (org-element-property ,property ,node ,dflt ,force-undefer)))

(defsubst org-element-parent (node)
  "Return `:parent' property of NODE."
  (org-element-property :parent node))

(gv-define-setter org-element-parent (value node)
  `(org-element-put-property ,node :parent ,value))

(gv-define-setter org-element-property (value property node &optional _)
  `(org-element-put-property ,node ,property ,value))

(gv-define-setter org-element-property-1 (value property node &optional _)
  `(org-element-put-property ,node ,property ,value))

(defun org-element--properties-mapc (fun node &optional collect no-standard)
  "Apply FUN for each property of NODE.
FUN will be called with three arguments: property name, property
value, and node.  If FUN accepts only 2 arguments, it will be called
with two arguments: property name and property value.  If FUN accepts
only a single argument, it will be called with a single argument -
property value.

Do not resolve deferred values, except `:deferred'.
`:standard-properties' internal property will be skipped.

When NO-STANDARD is non-nil, do no map over
`org-element--standard-properties'.

When COLLECT is symbol `set', set the property values to the return
values (except the values equal to `org-element-ast--nil') and finally
return nil.  When COLLECT is non-nil and not symbol `set', collect the
return values into a list and return it.
Otherwise, return nil."
  (let ( acc rtn (fun-arity (cdr (func-arity fun)))
         (type (org-element-type node)))
    (when type
      ;; Compute missing properties.
      (org-element-property :deferred node)
      ;; Map over parray.
      (unless no-standard
        (let ((standard-idxs
               org-element--standard-properties-idxs)
              (parray (org-element--parray node)))
          (when parray
            (while standard-idxs
              (setq
               rtn
               (pcase fun-arity
                 (1 (funcall fun (aref parray (cadr standard-idxs))))
                 (2 (funcall
                     fun
                     (car standard-idxs)
                     (aref parray (cadr standard-idxs))))
                 (_ (funcall
                     fun
                     (car standard-idxs)
                     (aref parray (cadr standard-idxs))
                     node))))
              (when collect
                (unless (eq rtn (aref parray (cadr standard-idxs)))
                  (if (and (eq collect 'set) (not eq rtn 'org-element-ast--nil))
                      (setf (aref parray (cadr standard-idxs)) rtn)
                    (push rtn acc))))
              (setq standard-idxs (cddr standard-idxs))))))
      ;; Map over plist.
      (let ((props
             (if (eq type 'plain-text)
                 (text-properties-at 0 node)
               (nth 1 node))))
        (while props
          (unless (eq :standard-properties (car props))
            (setq rtn
                  (pcase fun-arity
                    (1 (funcall fun (cadr props)))
                    (2 (funcall fun (car props) (cadr props)))
                    (_ (funcall fun (car props) (cadr props) node))))
            (when collect
              (if (and (eq collect 'set)
                       (not (eq rtn 'org-element-ast--nil)))
                  (unless (eq rtn (cadr props))
                    (if (eq type 'plain-text)
                        (org-add-props node nil (car props) rtn)
                      (setf (cadr props) rtn)))
                (push rtn acc))))
          (setq props (cddr props)))))
    ;; Return.
    (when collect (nreverse acc))))

(defun org-element--deferred-resolve-force-rec (property val node)
  "Resolve deferred PROPERTY VAL in NODE recursively.  Force undefer."
  (catch :found
    (catch :org-element-deferred-retry
      (throw :found (org-element--deferred-resolve-force val node)))
    ;; Caught `:org-element-deferred-retry'.  Go long way.
    (org-element-property property node nil t)))

(defun org-element--deferred-resolve-rec (property val node)
  "Resolve deferred PROPERTY VAL in NODE recursively.
Return the value to be stored."
  (catch :found
    (catch :org-element-deferred-retry
      (throw :found (cdr (org-element--deferred-resolve val node))))
    ;; Caught `:org-element-deferred-retry'.  Go long way.
    (org-element-property property node)))

(defsubst org-element-properties-resolve (node &optional force-undefer)
  "Resolve all the deferred properties in NODE, modifying the NODE.
When FORCE-UNDEFER is non-nil, resolve unconditionally.
Return the modified NODE."
  ;; Compute all the available properties.
  (org-element-property :deferred node nil force-undefer)
  (org-element--properties-mapc
   (if force-undefer
       #'org-element--deferred-resolve-force-rec
     #'org-element--deferred-resolve-rec)
   node 'set 'no-standard)
  node)

(defsubst org-element-properties-mapc (fun node &optional undefer)
  "Apply FUN for each property of NODE for side effect.
FUN will be called with three arguments: property name, property
value, and node.  If FUN accepts only 2 arguments, it will be called
with two arguments: property name and property value.  If FUN accepts
only a single argument, it will be called with a single argument -
property value.

When UNDEFER is non-nil, undefer deferred properties.
When UNDEFER is symbol `force', unconditionally replace the property
values with undeferred values.

Return nil."
  (when undefer
    (org-element-properties-resolve node (eq 'force undefer)))
  (org-element--properties-mapc fun node))

(defsubst org-element-properties-map (fun node &optional undefer)
  "Apply FUN for each property of NODE and return a list of the results.
FUN will be called with three arguments: property name, property
value, and node.  If FUN accepts only 2 arguments, it will be called
with two arguments: property name and property value.  If FUN accepts
only a single argument, it will be called with a single argument -
property value.

When UNDEFER is non-nil, undefer deferred properties unconditionally.
When UNDEFER is symbol `force', unconditionally replace the property
values with undeferred values."
  (when undefer
    (org-element-properties-resolve node (eq 'force undefer)))
  (org-element--properties-mapc fun node 'collect))

;;;; Node contents.

(defsubst org-element-contents (node)
  "Extract contents from NODE.
Do not resolve deferred values."
  (declare (pure t))
  (cond ((not (consp node)) nil)
	((symbolp (car node)) (nthcdr 2 node))
	(t node)))

(defsubst org-element-set-contents (node &rest contents)
  "Set NODE's contents to CONTENTS.
Return modified NODE.
If NODE cannot have contents, return CONTENTS."
  (pcase (org-element-type node t)
    (`plain-text contents)
    ((guard (null node)) contents)
    ;; Anonymous node.
    (`anonymous
     (setcar node (car contents))
     (setcdr node (cdr contents))
     node)
    ;; Node with type.
    (_ (setf (cddr node) contents)
       node)))

(defalias 'org-element-resolve-deferred #'org-element-properties-resolve)

;;;; Constructor and copier

(defun org-element-create (type &optional props &rest children)
  "Create a new syntax node of TYPE.
Optional argument PROPS, when non-nil, is a plist defining the
properties of the node.  CHILDREN can be elements, objects or
strings.

When CHILDREN is a single anonymous node, use its contents as children
nodes.  This way,
   (org-element-create \\='section nil (org-element-contents node))
will yield expected results with contents of another node adopted into
a newly created one.

When TYPE is `plain-text', CHILDREN must contain a single node -
string.  Alternatively, TYPE can be a string.  When TYPE is nil or
`anonymous', PROPS must be nil."
  (cl-assert
   ;; FIXME: Just use `plistp' from Emacs 29 when available.
   (let ((len (proper-list-p props)))
     (and len (zerop (% len 2)))))
  ;; Assign parray.
  (when (and props (not (stringp type)) (not (eq type 'plain-text)))
    (let ((node (list 'dummy props)))
      (org-element--put-parray node)
      (setq props (nth 1 node))
      ;; Remove standard properties from PROPS plist by side effect.
      (let ((ptail props))
        (while ptail
          (if (not (and (keywordp (car ptail))
                        (org-element--property-idx (car ptail))))
              (setq ptail (cddr ptail))
            (if (null (cddr ptail)) ; last property
                (setq props (nbutlast props 2)
                      ptail nil)
              (setcar ptail (nth 2 ptail))
              (setcdr ptail (seq-drop ptail 3))))))))
  (pcase type
    ((or `nil `anonymous)
     (cl-assert (null props))
     (apply #'org-element-adopt nil children))
    (`plain-text
     (cl-assert (length= children 1))
     (org-add-props (car children) props))
    ((pred stringp)
     (if props (org-add-props type props) type))
    (_
     (if (and (= 1 (length children))
              (org-element-type-p (car children) 'anonymous))
         (apply #'org-element-adopt (list type props) (car children))
       (apply #'org-element-adopt (list type props) children)))))

(defun org-element-copy (datum &optional keep-contents)
  "Return a copy of DATUM.
DATUM is an element, object, string or nil.  `:parent' property
is cleared and contents are removed in the process.
Secondary objects are also copied and their `:parent' is re-assigned.

When optional argument KEEP-CONTENTS is non-nil, do not remove the
contents.  Instead, copy the children recursively, updating their
`:parent' property.

As a special case, `anonymous' nodes do not have their contents
removed.  The contained children are copied recursively, updating
their `:parent' property to the copied `anonymous' node.

When DATUM is `plain-text', all the properties are removed."
  (pcase (org-element-type datum t)
    ((guard (null datum)) nil)
    (`plain-text (substring-no-properties datum))
    (`nil (error "Not an Org syntax node: %S" datum))
    (`anonymous
     (let* ((node-copy (copy-sequence datum))
            (tail node-copy))
       (while tail
         (setcar tail (org-element-copy (car tail) t))
         (org-element-put-property (car tail) :parent node-copy)
         (setq tail (cdr tail)))
       node-copy))
    (_
     (let ((node-copy (copy-sequence datum)))
       ;; Copy `:standard-properties'
       (when-let ((parray (org-element-property-1 :standard-properties node-copy)))
         (org-element-put-property node-copy :standard-properties (copy-sequence parray)))
       ;; Clear `:parent'.
       (org-element-put-property node-copy :parent nil)
       ;; We cannot simply return the copied property list.  When
       ;; DATUM is i.e. a headline, it's property list `:title' can
       ;; contain parsed objects.  The objects will contain
       ;; `:parent' property set to the DATUM itself.  When copied,
       ;; these inner `:parent' property values will contain
       ;; incorrect object decoupled from DATUM.  Changes to the
       ;; DATUM copy will no longer be reflected in the `:parent'
       ;; properties.  So, we need to reassign inner `:parent'
       ;; properties to the DATUM copy explicitly.
       (dolist (secondary-prop (org-element-property :secondary node-copy))
         (when-let ((secondary-value (org-element-property secondary-prop node-copy)))
           (setq secondary-value (org-element-copy secondary-value t))
           (if (org-element-type secondary-value)
               (org-element-put-property secondary-value :parent node-copy)
             (dolist (el secondary-value)
               (org-element-put-property el :parent node-copy)))
           (org-element-put-property node-copy secondary-prop secondary-value)))
       (when keep-contents
         (let ((contents (org-element-contents node-copy)))
           (while contents
             (setcar contents (org-element-copy (car contents) t))
             (setq contents (cdr contents)))))
       node-copy))))

;;;; AST queries

(defun org-element-ast-map
    ( data types fun
      &optional
      ignore first-match no-recursion
      with-properties no-secondary no-undefer)
  "Map a function on selected syntax nodes.

DATA is a syntax tree.  TYPES is a symbol or list of symbols of
node types.  FUN is the function called on the matching nodes.
It has to accept one argument: the node itself.

When TYPES is t, call FUN for all the node types.

FUN can also be a Lisp form.  The form will be evaluated as function
with symbol `node' bound to the current node.

When optional argument IGNORE is non-nil, it should be a list holding
nodes to be skipped.  In that case, the listed nodes and their
contents will be skipped.

When optional argument FIRST-MATCH is non-nil, stop at the first
match for which FUN doesn't return nil, and return that value.

Optional argument NO-RECURSION is a symbol or a list of symbols
representing node types.  `org-element-map' won't enter any recursive
element or object whose type belongs to that list.  Though, FUN can
still be applied on them.

When optional argument WITH-PROPERTIES is non-nil, it should hold a list
of property names.  These properties will be treated as additional
secondary properties.

When optional argument NO-SECONDARY is non-nil, do not recurse into
secondary strings.

When optional argument NO-UNDEFER is non-nil, do not resolve deferred
values.

FUN may also throw `:org-element-skip' signal.  Then,
`org-element-ast-map' will not recurse into the current node.

Nil values returned from FUN do not appear in the results."
  (declare (indent 2))
  ;; Ensure TYPES and NO-RECURSION are a list, even of one node.
  (when types
    (let* ((types (pcase types
                    ((pred listp) types)
                    (`t t)
                    (_ (list types))))
	   (no-recursion (if (listp no-recursion) no-recursion
			   (list no-recursion)))
           (fun (if (functionp fun) fun `(lambda (node) ,fun)))
	   --acc)
      (letrec ((--walk-tree
	        (lambda (--data)
		  ;; Recursively walk DATA.  INFO, if non-nil, is a plist
		  ;; holding contextual information.
		  (let ((--type (org-element-type --data t))
                        recurse)
		    (cond
		     ((not --data))
                     ((not --type))
		     ;; Ignored node in an export context.
		     ((and ignore (memq --data ignore)))
		     ;; List of elements or objects.
		     ((eq --type 'anonymous)
                      (mapc --walk-tree (org-element-contents --data)))
		     (t
		      ;; Check if TYPE is matching among TYPES.  If so,
		      ;; apply FUN to --DATA and accumulate return value
		      ;; into --ACC (or exit if FIRST-MATCH is non-nil).
                      (setq recurse t)
		      (when (or (eq types t) (memq --type types))
		        (let ((result
                               (catch :org-element-skip
                                 (setq recurse nil)
                                 (prog1 (funcall fun --data)
                                   (setq recurse t)))))
			  (cond ((not result))
			        (first-match (throw :--map-first-match result))
			        (t (push result --acc)))))
		      ;; Determine if a recursion into --DATA is possible.
		      (cond
                       ;; No recursion requested.
                       ((not recurse))
		       ;; --TYPE is explicitly removed from recursion.
		       ((memq --type no-recursion))
		       ;; In any other case, map secondary, affiliated, and contents.
		       (t
		        (when with-properties
		          (dolist (p with-properties)
                            (funcall
                             --walk-tree
                             (if no-undefer
                                 (org-element-property-1 p --data)
                               (org-element-property p --data)))))
                        (unless no-secondary
		          (dolist (p (org-element-property :secondary --data))
			    (funcall
                             --walk-tree
                             (if no-undefer
                                 (org-element-property-1 p --data)
                               (org-element-property p --data)))))
                        (mapc --walk-tree (org-element-contents --data))))))))))
        (catch :--map-first-match
	  (funcall --walk-tree data)
	  ;; Return value in a proper order.
	  (nreverse --acc))))))

(defun org-element-lineage (datum &optional types with-self)
  "List all ancestors of a given element or object.

DATUM is an object or element.

Return ancestors from the closest to the farthest.  When optional
argument TYPES is a symbol or a list of symbols, return the first
element or object in the lineage whose type equals or belongs to that
list instead.

When optional argument WITH-SELF is non-nil, lineage includes
DATUM itself as the first element, and TYPES, if provided, also
apply to it.

When DATUM is obtained through `org-element-context' or
`org-element-at-point', and org-element-cache is disabled, only
ancestors from its section can be found.  There is no such limitation
when DATUM belongs to a full parse tree."
  (when (and types (not (listp types))) (setq types (list types)))
  (let ((up (if with-self datum (org-element-parent datum)))
	ancestors)
    (while (and up (not (org-element-type-p up types)))
      (unless types (push up ancestors))
      (setq up (org-element-parent up)))
    (if types up (nreverse ancestors))))

(defun org-element-lineage-map (datum fun &optional types with-self first-match)
  "Map FUN across ancestors of DATUM, from closest to furthest.
Return a list of results.  Nil values returned from FUN do not appear
in the results.

DATUM is an object or element.

FUN is a function accepting a single argument: syntax node.
FUN can also be a Lisp form.  The form will be evaluated as function
with symbol `node' bound to the current node.

When optional argument TYPES is a list of symbols, only map across
nodes with the listed types.

When optional argument WITH-SELF is non-nil, lineage includes
DATUM itself as the first element, and TYPES, if provided, also
apply to it.

When optional argument FIRST-MATCH is non-nil, stop at the first
match for which FUN doesn't return nil, and return that value."
  (declare (indent 2))
  (setq fun (if (functionp fun) fun `(lambda (node) ,fun)))
  (let ((up (if with-self datum (org-element-parent datum)))
	acc rtn)
    (catch :--first-match
      (while up
        (when (or (not types) (org-element-type-p up types))
          (setq rtn (funcall fun up))
          (if (and first-match rtn)
              (throw :--first-match rtn)
            (when rtn (push rtn acc))))
        (setq up (org-element-parent up)))
      (nreverse acc))))

(defun org-element-property-inherited (property node &optional with-self accumulate literal-nil include-nil)
  "Extract non-nil value from the PROPERTY of a NODE and/or its parents.

PROPERTY is a single property or a list of properties to be considered.

When WITH-SELF is non-nil, consider PROPERTY in the NODE itself.
Otherwise, only start from the immediate parent.

When optional argument ACCUMULATE is nil, return the first non-nil value
\(properties when PROPERTY is a list are considered one by one).
When ACCUMULATE is non-nil, extract all the values, starting from the
outermost ancestor and accumulate them into a single list.  The values
that are lists are appended.

When LITERAL-NIL is non-nil, treat property values \"nil\" and nil.

When INCLUDE-NIL is non-nil, do not skip properties with value nil.  The
properties that are missing from the property list will still be
skipped."
  (setq property (ensure-list property))
  (let (acc local val)
    (catch :found
      (unless with-self (setq node (org-element-parent node)))
      (while node
        (setq local nil)
        (dolist (prop property)
          (setq val (org-element-property prop node 'org-element-ast--nil))
          (unless (eq val 'org-element-ast--nil) ; not present
            (when literal-nil (setq val (org-not-nil val)))
            (when (and (not accumulate) (or val include-nil))
              (throw :found val))
            ;; Append to the end.
            (if (and include-nil (not val))
                (setq local (append local '(nil)))
              (setq local (append local (ensure-list val))))))
        ;; Append parent to front.
        (setq acc (append local acc))
        (setq node (org-element-parent node)))
      acc)))

;;;; AST modification

(defalias 'org-element-adopt-elements #'org-element-adopt)
(defun org-element-adopt (parent &rest children)
  "Append CHILDREN to the contents of PARENT.

PARENT is a syntax node.  CHILDREN can be elements, objects, or
strings.

If PARENT is nil, create a new anonymous node containing CHILDREN.

The function takes care of setting `:parent' property for each child.
Return the modified PARENT."
  (declare (indent 1))
  (if (not children) parent
    ;; Link every child to PARENT. If PARENT is nil, it is a secondary
    ;; string: parent is the list itself.
    (dolist (child children)
      (when child
        (org-element-put-property child :parent (or parent children))))
    ;; Add CHILDREN at the end of PARENT contents.
    (when parent
      (apply #'org-element-set-contents
	     parent
	     (nconc (org-element-contents parent) children)))
    ;; Return modified PARENT element.
    (or parent children)))

(defalias 'org-element-extract-element #'org-element-extract)
(defun org-element-extract (node)
  "Extract NODE from parse tree.
Remove NODE from the parse tree by side-effect, and return it
with its `:parent' property stripped out."
  (let ((parent (org-element-parent node))
	(secondary (org-element-secondary-p node)))
    (if secondary
        (org-element-put-property
	 parent secondary
	 (delq node (org-element-property secondary parent)))
      (apply #'org-element-set-contents
	     parent
	     (delq node (org-element-contents parent))))
    ;; Return NODE with its :parent removed.
    (org-element-put-property node :parent nil)))

(defun org-element-insert-before (node location)
  "Insert NODE before LOCATION in parse tree.
LOCATION is an element, object or string within the parse tree.
Parse tree is modified by side effect."
  (let* ((parent (org-element-parent location))
	 (property (org-element-secondary-p location))
	 (siblings (if property (org-element-property property parent)
		     (org-element-contents parent)))
	 ;; Special case: LOCATION is the first element of an
	 ;; independent secondary string (e.g. :title property).  Add
	 ;; NODE in-place.
	 (specialp (and (not property)
			(eq siblings parent)
			(eq (car parent) location))))
    ;; Install NODE at the appropriate LOCATION within SIBLINGS.
    (cond (specialp)
	  ((or (null siblings) (eq (car siblings) location))
	   (push node siblings))
	  ((null location) (nconc siblings (list node)))
	  (t
	   (let ((index (cl-position location siblings)))
	     (unless index (error "No location found to insert node"))
	     (push node (cdr (nthcdr (1- index) siblings))))))
    ;; Store SIBLINGS at appropriate place in parse tree.
    (cond
     (specialp (setcdr parent (copy-sequence parent)) (setcar parent node))
     (property (org-element-put-property parent property siblings))
     (t (apply #'org-element-set-contents parent siblings)))
    ;; Set appropriate :parent property.
    (org-element-put-property node :parent parent)))

(defalias 'org-element-set-element #'org-element-set)
(defun org-element-set (old new &optional keep-props)
  "Replace element or object OLD with element or object NEW.
When KEEP-PROPS is non-nil, keep OLD values of the listed property
names.

Return the modified element.

The function takes care of setting `:parent' property for NEW."
  ;; Ensure OLD and NEW have the same parent.
  (org-element-put-property new :parent (org-element-property :parent old))
  ;; Handle KEEP-PROPS.
  (dolist (p keep-props)
    (org-element-put-property new p (org-element-property p old)))
  (let ((old-type (org-element-type old))
        (new-type (org-element-type new)))
    (if (or (eq old-type 'plain-text)
	    (eq new-type 'plain-text))
        ;; We cannot replace OLD with NEW since strings are not mutable.
        ;; We take the long path.
        (progn (org-element-insert-before new old)
	       (org-element-extract old))
      ;; Since OLD is going to be changed into NEW by side-effect, first
      ;; make sure that every element or object within NEW has OLD as
      ;; parent.
      (dolist (blob (org-element-contents new))
        (org-element-put-property blob :parent old))
      ;; Both OLD and NEW are lists.
      (setcar old (car new))
      (setcdr old (cdr new))))
  old)

(provide 'org-element-ast)
;;; org-element-ast.el ends here