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

1140 lines
46 KiB
EmacsLisp

;;; 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))))
(pcase (org-element-type node)
(`nil nil)
(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)
;;;; 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-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)
(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-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 (plistp props))
;; 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))))
(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 list of symbols, return the first element or
object in the lineage whose type 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."
(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)))
(provide 'org-element-ast)
;;; org-element-ast.el ends here