org-element: Implement caching for dynamic parser
authorNicolas Goaziou <n.goaziou@gmail.com>
Sun, 27 Oct 2013 10:09:17 +0000 (27 11:09 +0100)
committerNicolas Goaziou <n.goaziou@gmail.com>
Sun, 3 Nov 2013 12:09:54 +0000 (3 13:09 +0100)
* lisp/org-element.el (org-element-use-cache, org-element--cache,
org-element--cache-sync-idle-time,
org-element--cache-merge-changes-threshold, org-element--cache-status,
org-element--cache-opening-line, org-element--cache-closing-line): New
variables.
(org-element-cache-reset, org-element--cache-pending-changes-p,
org-element--cache-push-change, org-element--cache-cancel-changes,
org-element--cache-get-key, org-element-cache-get,
org-element-cache-put, org-element--shift-positions,
org-element--cache-before-change, org-element--cache-record-change,
org-element--cache-sync): New functions.
(org-element-at-point, org-element-context): Use cache when possible.
* lisp/org.el (org-mode, org-set-modules): Reset cache.
* lisp/org-footnote.el (org-footnote-section): Reset cache.
* testing/lisp/test-org-element.el: Update tests.

This patch gives a boost to `org-element-at-point' and, to a lesser
extent, to `org-element-context'.

lisp/org-element.el
lisp/org-footnote.el
lisp/org.el
testing/lisp/test-org-element.el

index 95b7750..1c617c9 100644 (file)
 ;;
 ;; The library ends by furnishing `org-element-at-point' function, and
 ;; a way to give information about document structure around point
-;; with `org-element-context'.
+;; with `org-element-context'.  A simple cache mechanism is also
+;; provided for these functions.
 
 
 ;;; Code:
@@ -4618,7 +4619,7 @@ indentation is not done with TAB characters."
 ;; The first move is to implement a way to obtain the smallest element
 ;; containing point.  This is the job of `org-element-at-point'.  It
 ;; basically jumps back to the beginning of section containing point
-;; and moves, element after element, with
+;; and proceed, one element after the other, with
 ;; `org-element--current-element' until the container is found.  Note:
 ;; When using `org-element-at-point', secondary values are never
 ;; parsed since the function focuses on elements, not on objects.
@@ -4626,8 +4627,417 @@ indentation is not done with TAB characters."
 ;; At a deeper level, `org-element-context' lists all elements and
 ;; objects containing point.
 ;;
-;; `org-element-nested-p' and `org-element-swap-A-B' may be used
-;; internally by navigation and manipulation tools.
+;; Both functions benefit from a simple caching mechanism.  It is
+;; enabled by default, but can be disabled globally with
+;; `org-element-use-cache'.  Also `org-element-cache-reset' clears or
+;; initializes cache for current buffer.  Values are retrieved and put
+;; into cache with respectively, `org-element-cache-get' and
+;; `org-element-cache-put'.  `org-element--cache-sync-idle-time' and
+;; `org-element--cache-merge-changes-threshold' are used internally to
+;; control caching behaviour.
+;;
+;; Eventually `org-element-nested-p' and `org-element-swap-A-B' may be
+;; used internally by navigation and manipulation tools.
+
+(defvar org-element-use-cache t
+  "Non nil when Org parser should cache its results.")
+
+(defvar org-element--cache nil
+  "Hash table used as a cache for parser.
+Key is a buffer position and value is a cons cell with the
+pattern:
+
+  \(ELEMENT . OBJECTS-DATA)
+
+where ELEMENT is the element starting at the key and OBJECTS-DATA
+is an alist where each association is:
+
+  \(POS CANDIDATES . OBJECTS)
+
+where POS is a buffer position, CANDIDATES is the last know list
+of successors (see `org-element--get-next-object-candidates') in
+container starting at POS and OBJECTS is a list of objects known
+to live within that container, from farthest to closest.
+
+In the following example, \\alpha, bold object and \\beta start
+at, respectively, positions 1, 7 and 8,
+
+  \\alpha *\\beta*
+
+If the paragraph is completely parsed, OBJECTS-DATA will be
+
+  \((1 nil BOLD-OBJECT ENTITY-OBJECT)
+   \(8 nil ENTITY-OBJECT))
+
+whereas in a partially parsed paragraph, it could be
+
+  \((1 ((entity . 1) (bold . 7)) ENTITY-OBJECT))
+
+This cache is used in both `org-element-at-point' and
+`org-element-context'.  The former uses ELEMENT only and the
+latter OBJECTS-DATA only.")
+
+(defvar org-element--cache-sync-idle-time 0.5
+  "Number of seconds of idle time wait before syncing buffer cache.
+Syncing also happens when current modification is too distant
+from the stored one (for more information, see
+`org-element--cache-merge-changes-threshold').")
+
+(defvar org-element--cache-merge-changes-threshold 200
+  "Number of characters triggering cache syncing.
+
+The cache mechanism only stores one buffer modification at any
+given time.  When another change happens, it replaces it with
+a change containing both the stored modification and the current
+one.  This is a trade-off, as merging them prevents another
+syncing, but every element between them is then lost.
+
+This variable determines the maximum size, in characters, we
+accept to lose in order to avoid syncing the cache.")
+
+(defvar org-element--cache-status nil
+  "Contains data about cache validity for current buffer.
+
+Value is a vector of seven elements,
+
+  [ACTIVEP BEGIN END OFFSET TIMER PREVIOUS-STATE]
+
+ACTIVEP is a boolean non-nil when changes described in the other
+slots are valid for current buffer.
+
+BEGIN and END are the beginning and ending position of the area
+for which cache cannot be trusted.
+
+OFFSET it an integer specifying the number to add to position of
+elements after that area.
+
+TIMER is a timer used to apply these changes to cache when Emacs
+is idle.
+
+PREVIOUS-STATE is a symbol referring to the state of the buffer
+before a change happens.  It is used to know if sensitive
+areas (block boundaries, headlines) were modified.  It can be set
+to nil, `headline' or `other'.")
+
+;;;###autoload
+(defun org-element-cache-reset (&optional all)
+  "Reset cache in current buffer.
+When optional argument ALL is non-nil, reset cache in all Org
+buffers.  This function will do nothing if
+`org-element-use-cache' is nil."
+  (interactive "P")
+  (when org-element-use-cache
+    (dolist (buffer (if all (buffer-list) (list (current-buffer))))
+      (with-current-buffer buffer
+       (when (derived-mode-p 'org-mode)
+         (if (org-bound-and-true-p org-element--cache)
+             (clrhash org-element--cache)
+           (org-set-local 'org-element--cache
+                          (make-hash-table :size 5003 :test 'eq)))
+         (org-set-local 'org-element--cache-status (make-vector 6 nil))
+         (add-hook 'before-change-functions
+                   'org-element--cache-before-change nil t)
+         (add-hook 'after-change-functions
+                   'org-element--cache-record-change nil t))))))
+
+(defsubst org-element--cache-pending-changes-p ()
+  "Non-nil when changes are not integrated in cache yet."
+  (and org-element--cache-status
+       (aref org-element--cache-status 0)))
+
+(defsubst org-element--cache-push-change (beg end offset)
+  "Push change to current buffer staging area.
+BEG and END and the beginning and ending position of the
+modification area.  OFFSET is the size of the change, as an
+integer."
+  (aset org-element--cache-status 1 beg)
+  (aset org-element--cache-status 2 end)
+  (aset org-element--cache-status 3 offset)
+  (let ((timer (aref org-element--cache-status 4)))
+    (if timer (timer-activate-when-idle timer t)
+      (aset org-element--cache-status 4
+           (run-with-idle-timer org-element--cache-sync-idle-time
+                                nil
+                                #'org-element--cache-sync
+                                (current-buffer)))))
+  (aset org-element--cache-status 0 t))
+
+(defsubst org-element--cache-cancel-changes ()
+  "Remove any cache change set for current buffer."
+  (let ((timer (aref org-element--cache-status 4)))
+    (and timer (cancel-timer timer)))
+  (aset org-element--cache-status 0 nil))
+
+(defsubst org-element--cache-get-key (element)
+  "Return expected key for ELEMENT in cache."
+  (let ((begin (org-element-property :begin element)))
+    (if (and (memq (org-element-type element) '(item table-row))
+            (= (org-element-property :contents-begin
+                                     (org-element-property :parent element))
+               begin))
+       ;; Special key for first item (resp. table-row) in a plain
+       ;; list (resp. table).
+       (1+ begin)
+      begin)))
+
+(defsubst org-element-cache-get (pos &optional type)
+  "Return data stored at key POS in current buffer cache.
+When optional argument TYPE is `element', retrieve the element
+starting at POS.  When it is `objects', return the list of object
+types along with their beginning position within that element.
+Otherwise, return the full data.  In any case, return nil if no
+data is found, or if caching is not allowed."
+  (when (and org-element-use-cache org-element--cache)
+    ;; If there are pending changes, first sync them.
+    (when (org-element--cache-pending-changes-p)
+      (org-element--cache-sync (current-buffer)))
+    (let ((data (gethash pos org-element--cache)))
+      (case type
+       (element (car data))
+       (objects (cdr data))
+       (otherwise data)))))
+
+(defsubst org-element-cache-put (pos data)
+  "Store data in current buffer's cache, if allowed.
+POS is a buffer position, which will be used as a key.  DATA is
+the value to store.  Nothing will be stored if
+`org-element-use-cache' is nil.  Return DATA in any case."
+  (if (not org-element-use-cache) data
+    (unless org-element--cache (org-element-cache-reset))
+    (puthash pos data org-element--cache)))
+
+(defsubst org-element--shift-positions (element offset)
+  "Shift ELEMENT properties relative to buffer positions by OFFSET.
+Properties containing buffer positions are `:begin', `:end',
+`:contents-begin', `:contents-end' and `:structure'.  They are
+modified by side-effect.  Return modified element."
+  (let ((properties (nth 1 element)))
+    ;; Shift :structure property for the first plain list only: it is
+    ;; the only one that really matters and it prevents from shifting
+    ;; it more than once.
+    (when (eq (car element) 'plain-list)
+      (let ((structure (plist-get properties :structure)))
+       (when (<= (plist-get properties :begin) (caar structure))
+         (dolist (item structure)
+           (incf (car item) offset)
+           (incf (nth 6 item) offset)))))
+    (plist-put properties :begin (+ (plist-get properties :begin) offset))
+    (plist-put properties :end (+ (plist-get properties :end) offset))
+    (dolist (key '(:contents-begin :contents-end :post-affiliated))
+      (let ((value (plist-get properties key)))
+       (and value (plist-put properties key (+ offset value))))))
+  element)
+
+(defconst org-element--cache-opening-line
+  (concat "^[ \t]*\\(?:"
+         "#\\+BEGIN[:_]" "\\|"
+         "\\\\begin{[A-Za-z0-9]+\\*?}" "\\|"
+         ":\\S-+:[ \t]*$"
+         "\\)")
+  "Regexp matching an element opening line.
+When such a line is modified, modifications may propagate after
+modified area.  In that situation, every element between that
+area and next section is removed from cache.")
+
+(defconst org-element--cache-closing-line
+  (concat "^[ \t]*\\(?:"
+         "#\\+END\\(?:_\\|:?[ \t]*$\\)" "\\|"
+         "\\\\end{[A-Za-z0-9]+\\*?}[ \t]*$" "\\|"
+         ":END:[ \t]*$"
+         "\\)")
+  "Regexp matching an element closing line.
+When such a line is modified, modifications may propagate before
+modified area.  In that situation, every element between that
+area and previous section is removed from cache.")
+
+(defun org-element--cache-before-change (beg end)
+  "Request extension of area going to be modified if needed.
+BEG and END are the beginning and end of the range of changed
+text.  See `before-change-functions' for more information."
+  (let ((inhibit-quit t))
+    (org-with-wide-buffer
+     (goto-char beg)
+     (beginning-of-line)
+     (let ((top (point))
+          (bottom (save-excursion (goto-char end) (line-end-position)))
+          (sensitive-re
+           ;; A sensitive line is a headline or a block (or drawer,
+           ;; or latex-environment) boundary.  Inserting one can
+           ;; modify buffer drastically both above and below that
+           ;; line, possibly making cache invalid.  Therefore, we
+           ;; need to pay special attention to changes happening to
+           ;; them.
+           (concat
+            "\\(" (org-with-limited-levels org-outline-regexp-bol) "\\)" "\\|"
+            org-element--cache-closing-line "\\|"
+            org-element--cache-opening-line)))
+       (save-match-data
+        (aset org-element--cache-status 5
+              (cond ((not (re-search-forward sensitive-re bottom t)) nil)
+                    ((and (match-beginning 1)
+                          (progn (goto-char bottom)
+                                 (or (not (re-search-backward sensitive-re
+                                                              (match-end 1) t))
+                                     (match-beginning 1))))
+                     'headline)
+                    (t 'other))))))))
+
+(defun org-element--cache-record-change (beg end pre)
+  "Update buffer modifications for current buffer.
+
+BEG and END are the beginning and end of the range of changed
+text, and the length in bytes of the pre-change text replaced by
+that range.  See `after-change-functions' for more information.
+
+If there are already pending changes, try to merge them into
+a bigger change record.  If that's not possible, the function
+will first synchronize cache with previous change and store the
+new one."
+  (let ((inhibit-quit t))
+    (when (and org-element-use-cache org-element--cache)
+      (org-with-wide-buffer
+       (goto-char beg)
+       (beginning-of-line)
+       (let ((top (point))
+            (bottom (save-excursion (goto-char end) (line-end-position))))
+        (org-with-limited-levels
+         (save-match-data
+           ;; Determine if modified area needs to be extended,
+           ;; according to both previous and current state.  We make
+           ;; a special case for headline editing: if a headline is
+           ;; modified but not removed, do not extend.
+           (when (let ((previous-state (aref org-element--cache-status 5))
+                       (sensitive-re
+                        (concat "\\(" org-outline-regexp-bol "\\)" "\\|"
+                                org-element--cache-closing-line "\\|"
+                                org-element--cache-opening-line)))
+                   (cond ((eq previous-state 'other))
+                         ((not (re-search-forward sensitive-re bottom t))
+                          (eq previous-state 'headline))
+                         ((match-beginning 1)
+                          (or (not (eq previous-state 'headline))
+                              (and (progn (goto-char bottom)
+                                          (re-search-backward
+                                           sensitive-re (match-end 1) t))
+                                   (not (match-beginning 1)))))
+                         (t)))
+             ;; Effectively extend modified area.
+             (setq top (progn (goto-char top)
+                              (outline-previous-heading)
+                              ;; Headline above is inclusive.
+                              (point)))
+             (setq bottom (progn (goto-char bottom)
+                                 (outline-next-heading)
+                                 ;; Headline below is exclusive.
+                                 (if (eobp) (point) (1- (point))))))))
+        ;; Store changes.
+        (let ((offset (- end beg pre)))
+          (if (not (org-element--cache-pending-changes-p))
+              ;; No pending changes.  Store the new ones.
+              (org-element--cache-push-change top (- bottom offset) offset)
+            (let* ((current-start (aref org-element--cache-status 1))
+                   (current-end (+ (aref org-element--cache-status 2)
+                                   (aref org-element--cache-status 3)))
+                   (gap (max (- beg current-end) (- current-start end))))
+              (if (> gap org-element--cache-merge-changes-threshold)
+                  ;; If we cannot merge two change sets (i.e. they
+                  ;; modify distinct buffer parts) first apply current
+                  ;; change set and store new one.  This way, there is
+                  ;; never more than one pending change set, which
+                  ;; avoids handling costly merges.
+                  (progn (org-element--cache-sync (current-buffer))
+                         (org-element--cache-push-change
+                          top (- bottom offset) offset))
+                ;; Change sets can be merged.  We can expand the area
+                ;; that requires an update, and postpone the sync.
+                (timer-activate-when-idle (aref org-element--cache-status 4) t)
+                (aset org-element--cache-status 0 t)
+                (aset org-element--cache-status 1 (min top current-start))
+                (aset org-element--cache-status 2
+                      (- (max current-end bottom) offset))
+                (incf (aref org-element--cache-status 3) offset))))))))))
+
+(defun org-element--cache-sync (buffer)
+  "Synchronize cache with recent modification in BUFFER.
+Elements ending before modification area are kept in cache.
+Elements starting after modification area have their position
+shifted by the size of the modification.  Every other element is
+removed from the cache."
+  (when (buffer-live-p buffer)
+    (with-current-buffer buffer
+      (when (org-element--cache-pending-changes-p)
+       (let ((inhibit-quit t)
+             (beg (aref org-element--cache-status 1))
+             (end (aref org-element--cache-status 2))
+             (offset (aref org-element--cache-status 3))
+             new-keys)
+         (maphash
+          #'(lambda (key value)
+              (cond
+               ((memq key new-keys))
+               ((> key end)
+                ;; Shift every element starting after END by OFFSET.
+                ;; We also need to shift keys, since they refer to
+                ;; buffer positions.
+                ;;
+                ;; Upon shifting a key a conflict can occur if the
+                ;; shifted key also refers to some element in the
+                ;; cache.  In this case, we temporarily associate
+                ;; both elements, as a cons cell, to the shifted key,
+                ;; following the pattern (SHIFTED . CURRENT).
+                ;;
+                ;; Such a conflict can only occur if shifted key hash
+                ;; hasn't been processed by `maphash' yet.
+                (unless (zerop offset)
+                  (let* ((conflictp (consp (caar value)))
+                         (value-to-shift (if conflictp (cdr value) value)))
+                    ;; Shift element part.
+                    (org-element--shift-positions (car value-to-shift) offset)
+                    ;; Shift objects part.
+                    (dolist (object-data (cdr value-to-shift))
+                      (incf (car object-data) offset)
+                      (dolist (successor (nth 1 object-data))
+                        (incf (cdr successor) offset))
+                      (dolist (object (cddr object-data))
+                        (org-element--shift-positions object offset)))
+                    ;; Shift key-value pair.
+                    (let* ((new-key (+ key offset))
+                           (new-value (gethash new-key org-element--cache)))
+                      ;; Put new value to shifted key.
+                      ;;
+                      ;; If one already exists, do not overwrite it:
+                      ;; store it as the car of a cons cell instead,
+                      ;; and handle it when `maphash' reaches
+                      ;; NEW-KEY.
+                      ;;
+                      ;; If there is no element stored at NEW-KEY or
+                      ;; if NEW-KEY is going to be removed anyway
+                      ;; (i.e., it is before END), just store new
+                      ;; value there and make sure it will not be
+                      ;; processed again by storing NEW-KEY in
+                      ;; NEW-KEYS.
+                      (puthash new-key
+                               (if (and new-value (> new-key end))
+                                   (cons value-to-shift new-value)
+                                 (push new-key new-keys)
+                                 value-to-shift)
+                               org-element--cache)
+                      ;; If current value contains two elements, car
+                      ;; should be the new value, since cdr has been
+                      ;; shifted already.
+                      (if conflictp
+                          (puthash key (car value) org-element--cache)
+                        (remhash key org-element--cache))))))
+               ;; Remove every element between BEG and END, since
+               ;; this is where changes happened.
+               ((>= key beg) (remhash key org-element--cache))
+               ;; Preserve any element ending before BEG.  If it
+               ;; overlaps the BEG-END area, remove it.
+               (t (or (< (org-element-property :end (car value)) beg)
+                      (remhash key org-element--cache)))))
+          org-element--cache)
+         ;; Signal cache as up-to-date.
+         (org-element--cache-cancel-changes))))))
 
 ;;;###autoload
 (defun org-element-at-point (&optional keep-trail)
@@ -4659,96 +5069,124 @@ first element of current section."
    (if (org-with-limited-levels (org-at-heading-p))
        (progn
         (beginning-of-line)
-        (if (not keep-trail) (org-element-headline-parser (point-max) t)
-          (list (org-element-headline-parser (point-max) t))))
+        (let ((headline
+               (or (org-element-cache-get (point) 'element)
+                   (car (org-element-cache-put
+                         (point)
+                         (list (org-element-headline-parser
+                                (point-max) t)))))))
+          (if keep-trail (list headline) headline)))
      ;; Otherwise move at the beginning of the section containing
      ;; point.
      (catch 'exit
-       (let ((origin (point))
-            (end (save-excursion
-                   (org-with-limited-levels (outline-next-heading)) (point)))
-            element type special-flag trail struct prevs parent)
-        (org-with-limited-levels
-         (if (org-before-first-heading-p)
-             ;; In empty lines at buffer's beginning, return nil.
-             (progn (goto-char (point-min))
-                    (org-skip-whitespace)
-                    (when (or (eobp) (> (line-beginning-position) origin))
-                      (throw 'exit nil)))
-           (org-back-to-heading)
-           (forward-line)
-           (org-skip-whitespace)
-           (when (or (eobp) (> (line-beginning-position) origin))
-             ;; In blank lines just after the headline, point still
-             ;; belongs to the headline.
-             (throw 'exit
-                    (progn (skip-chars-backward " \r\t\n")
-                           (beginning-of-line)
-                           (if (not keep-trail)
-                               (org-element-headline-parser (point-max) t)
-                             (list (org-element-headline-parser
-                                    (point-max) t))))))))
+       (let ((origin (point)))
+        (if (not (org-with-limited-levels (outline-previous-heading)))
+            ;; In empty lines at buffer's beginning, return nil.
+            (progn (goto-char (point-min))
+                   (org-skip-whitespace)
+                   (when (or (eobp) (> (line-beginning-position) origin))
+                     (throw 'exit nil)))
+          (forward-line)
+          (org-skip-whitespace)
+          (when (or (eobp) (> (line-beginning-position) origin))
+            ;; In blank lines just after the headline, point still
+            ;; belongs to the headline.
+            (throw 'exit
+                   (progn
+                     (skip-chars-backward " \r\t\n")
+                     (beginning-of-line)
+                     (let ((headline
+                            (or (org-element-cache-get (point) 'element)
+                                (car (org-element-cache-put
+                                      (point)
+                                      (list (org-element-headline-parser
+                                             (point-max) t)))))))
+                       (if keep-trail (list headline) headline))))))
         (beginning-of-line)
-        ;; Parse successively each element, skipping those ending
-        ;; before original position.
-        (while t
-          (setq element
-                (org-element--current-element end 'element special-flag struct)
-                type (car element))
-          (org-element-put-property element :parent parent)
-          (when keep-trail (push element trail))
-          (cond
-           ;; 1. Skip any element ending before point.  Also skip
-           ;;    element ending at point when we're sure that another
-           ;;    element has started.
-           ((let ((elem-end (org-element-property :end element)))
-              (when (or (< elem-end origin)
-                        (and (= elem-end origin) (/= elem-end end)))
-                (goto-char elem-end))))
-           ;; 2. An element containing point is always the element at
-           ;;    point.
-           ((not (memq type org-element-greater-elements))
-            (throw 'exit (if keep-trail trail element)))
-           ;; 3. At any other greater element type, if point is
-           ;;    within contents, move into it.
-           (t
-            (let ((cbeg (org-element-property :contents-begin element))
-                  (cend (org-element-property :contents-end element)))
-              (if (or (not cbeg) (not cend) (> cbeg origin) (< cend origin)
-                      ;; Create an anchor for tables and plain lists:
-                      ;; when point is at the very beginning of these
-                      ;; elements, ignoring affiliated keywords,
-                      ;; target them instead of their contents.
-                      (and (= cbeg origin) (memq type '(plain-list table)))
-                      ;; When point is at contents end, do not move
-                      ;; into elements with an explicit ending, but
-                      ;; return that element instead.
-                      (and (= cend origin)
-                           (or (memq type
-                                     '(center-block
-                                       drawer dynamic-block inlinetask
-                                       property-drawer quote-block
-                                       special-block))
-                               ;; Corner case: if a list ends at the
-                               ;; end of a buffer without a final new
-                               ;; line, return last element in last
-                               ;; item instead.
-                               (and (memq type '(item plain-list))
-                                    (progn (goto-char cend)
-                                           (or (bolp) (not (eobp))))))))
-                  (throw 'exit (if keep-trail trail element))
-                (setq parent element)
-                (case type
-                  (plain-list
-                   (setq special-flag 'item
-                         struct (org-element-property :structure element)))
-                  (item (setq special-flag nil))
-                  (property-drawer
-                   (setq special-flag 'node-property struct nil))
-                  (table (setq special-flag 'table-row struct nil))
-                  (otherwise (setq special-flag nil struct nil)))
-                (setq end cend)
-                (goto-char cbeg)))))))))))
+        (let ((end (save-excursion
+                     (org-with-limited-levels (outline-next-heading)) (point)))
+              element type special-flag trail struct parent)
+          ;; Parse successively each element, skipping those ending
+          ;; before original position.
+          (while t
+            (setq element
+                  (let* ((pos (if (and (memq special-flag '(item table-row))
+                                       (memq type '(plain-list table)))
+                                  ;; First item (resp. row) in plain
+                                  ;; list (resp. table) gets
+                                  ;; a special key in cache.
+                                  (1+ (point))
+                                (point)))
+                         (cached (org-element-cache-get pos 'element)))
+                    (cond
+                     ((not cached)
+                      (let ((element (org-element--current-element
+                                      end 'element special-flag struct)))
+                        (when (derived-mode-p 'org-mode)
+                          (org-element-cache-put pos (cons element nil)))
+                        element))
+                     ;; When changes happened in the middle of a list,
+                     ;; its structure ends up being invalid.
+                     ;; Therefore, we make sure to use a valid one.
+                     ((and struct (memq (car cached) '(item plain-list)))
+                      (org-element-put-property cached :structure struct))
+                     (t cached))))
+            (setq type (org-element-type element))
+            (org-element-put-property element :parent parent)
+            (when keep-trail (push element trail))
+            (cond
+             ;; 1. Skip any element ending before point.  Also skip
+             ;;    element ending at point when we're sure that
+             ;;    another element has started.
+             ((let ((elem-end (org-element-property :end element)))
+                (when (or (< elem-end origin)
+                          (and (= elem-end origin) (/= elem-end end)))
+                  (goto-char elem-end))))
+             ;; 2. An element containing point is always the element at
+             ;;    point.
+             ((not (memq type org-element-greater-elements))
+              (throw 'exit (if keep-trail trail element)))
+             ;; 3. At any other greater element type, if point is
+             ;;    within contents, move into it.
+             (t
+              (let ((cbeg (org-element-property :contents-begin element))
+                    (cend (org-element-property :contents-end element)))
+                (if (or (not cbeg) (not cend) (> cbeg origin) (< cend origin)
+                        ;; Create an anchor for tables and plain
+                        ;; lists: when point is at the very beginning
+                        ;; of these elements, ignoring affiliated
+                        ;; keywords, target them instead of their
+                        ;; contents.
+                        (and (= cbeg origin) (memq type '(plain-list table)))
+                        ;; When point is at contents end, do not move
+                        ;; into elements with an explicit ending, but
+                        ;; return that element instead.
+                        (and (= cend origin)
+                             (or (memq type
+                                       '(center-block
+                                         drawer dynamic-block inlinetask
+                                         property-drawer quote-block
+                                         special-block))
+                                 ;; Corner case: if a list ends at
+                                 ;; the end of a buffer without
+                                 ;; a final new line, return last
+                                 ;; element in last item instead.
+                                 (and (memq type '(item plain-list))
+                                      (progn (goto-char cend)
+                                             (or (bolp) (not (eobp))))))))
+                    (throw 'exit (if keep-trail trail element))
+                  (setq parent element)
+                  (case type
+                    (plain-list
+                     (setq special-flag 'item
+                           struct (org-element-property :structure element)))
+                    (item (setq special-flag nil))
+                    (property-drawer
+                     (setq special-flag 'node-property struct nil))
+                    (table (setq special-flag 'table-row struct nil))
+                    (otherwise (setq special-flag nil struct nil)))
+                  (setq end cend)
+                  (goto-char cbeg))))))))))))
 
 ;;;###autoload
 (defun org-element-context (&optional element)
@@ -4770,11 +5208,10 @@ Providing it allows for quicker computation."
     (org-with-wide-buffer
      (let* ((origin (point))
             (element (or element (org-element-at-point)))
-            (type (org-element-type element))
-            context)
-       ;; Check if point is inside an element containing objects or at
-       ;; a secondary string.  In that case, narrow buffer to the
-       ;; containing area.  Otherwise, return ELEMENT.
+            (type (org-element-type element)))
+       ;; If point is inside an element containing objects or
+       ;; a secondary string, narrow buffer to the container and
+       ;; proceed with parsing.  Otherwise, return ELEMENT.
        (cond
        ;; At a parsed affiliated keyword, check if we're inside main
        ;; or dual value.
@@ -4804,8 +5241,7 @@ Providing it allows for quicker computation."
             (if (and (>= origin (point)) (< origin (match-end 0)))
                 (narrow-to-region (point) (match-end 0))
               (throw 'objects-forbidden element)))))
-       ;; At an headline or inlinetask, objects are located within
-       ;; their title.
+       ;; At an headline or inlinetask, objects are in title.
        ((memq type '(headline inlinetask))
         (goto-char (org-element-property :begin element))
         (skip-chars-forward "* ")
@@ -4831,44 +5267,92 @@ Providing it allows for quicker computation."
           (if (and (>= origin (point)) (< origin (line-end-position)))
               (narrow-to-region (point) (line-end-position))
             (throw 'objects-forbidden element))))
+       ;; All other locations cannot contain objects: bail out.
        (t (throw 'objects-forbidden element)))
        (goto-char (point-min))
-       (let ((restriction (org-element-restriction type))
-             (parent element)
-             (candidates 'initial))
-         (catch 'exit
-           (while (setq candidates
-                       (org-element--get-next-object-candidates
-                        restriction candidates))
-             (let ((closest-cand (rassq (apply 'min (mapcar 'cdr candidates))
-                                        candidates)))
-               ;; If ORIGIN is before next object in element, there's
-               ;; no point in looking further.
-               (if (> (cdr closest-cand) origin) (throw 'exit parent)
-                 (let* ((object
-                         (progn (goto-char (cdr closest-cand))
-                                (funcall (intern (format "org-element-%s-parser"
-                                                         (car closest-cand))))))
-                        (cbeg (org-element-property :contents-begin object))
-                        (cend (org-element-property :contents-end object))
-                        (obj-end (org-element-property :end object)))
-                   (cond
-                    ;; ORIGIN is after OBJECT, so skip it.
-                    ((<= obj-end origin) (goto-char obj-end))
-                    ;; ORIGIN is within a non-recursive object or at
-                    ;; an object boundaries: Return that object.
-                    ((or (not cbeg) (< origin cbeg) (>= origin cend))
-                     (throw 'exit
-                            (org-element-put-property object :parent parent)))
-                    ;; Otherwise, move within current object and
-                    ;; restrict search to the end of its contents.
-                    (t (goto-char cbeg)
-                       (narrow-to-region (point) cend)
-                       (org-element-put-property object :parent parent)
-                       (setq parent object
-                             restriction (org-element-restriction object)
-                             candidates 'initial)))))))
-           parent))))))
+       (let* ((restriction (org-element-restriction type))
+             (parent element)
+             (candidates 'initial)
+             (cache-key (org-element--cache-get-key element))
+             (cache (org-element-cache-get cache-key 'objects))
+             objects-data next update-cache-flag)
+        (prog1
+            (catch 'exit
+              (while t
+                ;; Get list of next object candidates in CANDIDATES.
+                ;; When entering for the first time PARENT, grab it
+                ;; from cache, if available, or compute it.  Then,
+                ;; for each subsequent iteration in PARENT, always
+                ;; compute it since we're beyond cache anyway.
+                (when (and (not next) org-element-use-cache)
+                  (let ((data (assq (point) cache)))
+                    (if data (setq candidates (nth 1 (setq objects-data data)))
+                      (push (setq objects-data (list (point) 'initial))
+                            cache))))
+                (when (or next (eq 'initial candidates))
+                  (setq candidates
+                        (org-element--get-next-object-candidates
+                         restriction candidates))
+                  (when org-element-use-cache
+                    (setcar (cdr objects-data) candidates)
+                    (or update-cache-flag (setq update-cache-flag t))))
+                ;; Compare ORIGIN with next object starting position,
+                ;; if any.
+                ;;
+                ;; If ORIGIN is lesser or if there is no object
+                ;; following, look for a previous object that might
+                ;; contain it in cache.  If there is no cache, we
+                ;; didn't miss any object so simply return PARENT.
+                ;;
+                ;; If ORIGIN is greater or equal, parse next
+                ;; candidate for further processing.
+                (let ((closest
+                       (and candidates
+                            (rassq (apply #'min (mapcar #'cdr candidates))
+                                   candidates))))
+                  (if (or (not closest) (> (cdr closest) origin))
+                      (catch 'found
+                        (dolist (obj (cddr objects-data) (throw 'exit parent))
+                          (when (<= (org-element-property :begin obj) origin)
+                            (if (<= (org-element-property :end obj) origin)
+                                ;; Object ends before ORIGIN and we
+                                ;; know next one in cache starts
+                                ;; after it: bail out.
+                                (throw 'exit parent)
+                              (throw 'found (setq next obj))))))
+                    (goto-char (cdr closest))
+                    (setq next
+                          (funcall (intern (format "org-element-%s-parser"
+                                                   (car closest)))))
+                    (when org-element-use-cache
+                      (push next (cddr objects-data))
+                      (or update-cache-flag (setq update-cache-flag t)))))
+                ;; Process NEXT to know if we need to skip it, return
+                ;; it or move into it.
+                (let ((cbeg (org-element-property :contents-begin next))
+                      (cend (org-element-property :contents-end next))
+                      (obj-end (org-element-property :end next)))
+                  (cond
+                   ;; ORIGIN is after NEXT, so skip it.
+                   ((<= obj-end origin) (goto-char obj-end))
+                   ;; ORIGIN is within a non-recursive next or
+                   ;; at an object boundaries: Return that object.
+                   ((or (not cbeg) (< origin cbeg) (>= origin cend))
+                    (throw 'exit
+                           (org-element-put-property next :parent parent)))
+                   ;; Otherwise, move into NEXT and reset flags as we
+                   ;; shift parent.
+                   (t (goto-char cbeg)
+                      (narrow-to-region (point) cend)
+                      (org-element-put-property next :parent parent)
+                      (setq parent next
+                            restriction (org-element-restriction next)
+                            next nil
+                            objects-data nil
+                            candidates 'initial))))))
+          ;; Update cache if required.
+          (when (and update-cache-flag (derived-mode-p 'org-mode))
+            (org-element-cache-put cache-key (cons element cache)))))))))
 
 (defun org-element-nested-p (elem-A elem-B)
   "Non-nil when elements ELEM-A and ELEM-B are nested."
index 3c0d97c..c59bd0c 100644 (file)
@@ -106,8 +106,15 @@ the notes.  However, by hand you may place definitions
 *anywhere*.
 
 If this is a string, during export, all subtrees starting with
-this heading will be ignored."
+this heading will be ignored.
+
+If you don't use the customize interface to change this variable,
+you will need to run the following command after the change:
+
+  \\[universal-argument] \\[org-element-cache-reset]"
   :group 'org-footnote
+  :initialize 'custom-initialize-set
+  :set (lambda (var val) (set var val) (org-element-cache-reset 'all))
   :type '(choice
          (string :tag "Collect footnotes under heading")
          (const :tag "Define footnotes locally" nil)))
index ac6f739..15323ba 100644 (file)
@@ -140,6 +140,7 @@ Stars are put in group 1 and the trimmed body in group 2.")
 (declare-function org-element--parse-objects "org-element"
                  (beg end acc restriction))
 (declare-function org-element-at-point "org-element" (&optional keep-trail))
+(declare-function org-element-cache-reset "org-element" (&optional all))
 (declare-function org-element-contents "org-element" (element))
 (declare-function org-element-context "org-element" (&optional element))
 (declare-function org-element-interpret-data "org-element"
@@ -357,7 +358,8 @@ When MESSAGE is non-nil, display a message with the version."
   "Set VAR to VALUE and call `org-load-modules-maybe' with the force flag."
   (set var value)
   (when (featurep 'org)
-    (org-load-modules-maybe 'force)))
+    (org-load-modules-maybe 'force)
+    (org-element-cache-reset 'all)))
 
 (defcustom org-modules '(org-w3m org-bbdb org-bibtex org-docview org-gnus org-info org-irc org-mhe org-rmail)
   "Modules that should always be loaded together with org.el.
@@ -5367,6 +5369,8 @@ The following commands are available:
   (org-setup-filling)
   ;; Comments.
   (org-setup-comments-handling)
+  ;; Initialize cache.
+  (org-element-cache-reset)
   ;; Beginning/end of defun
   (org-set-local 'beginning-of-defun-function 'org-backward-element)
   (org-set-local 'end-of-defun-function 'org-forward-element)
index 3d31ef4..1a46d7e 100644 (file)
@@ -847,25 +847,29 @@ Some other text
 (ert-deftest test-org-element/headline-archive-tag ()
   "Test ARCHIVE tag recognition."
   ;; Reference test.
-  (org-test-with-temp-text "* Headline"
-    (let ((org-archive-tag "ARCHIVE"))
-      (should-not (org-element-property :archivedp (org-element-at-point)))))
+  (should-not
+   (org-test-with-temp-text "* Headline"
+     (let ((org-archive-tag "ARCHIVE"))
+       (org-element-property :archivedp (org-element-at-point)))))
   ;; Single tag.
   (org-test-with-temp-text "* Headline :ARCHIVE:"
     (let ((org-archive-tag "ARCHIVE"))
       (let ((headline (org-element-at-point)))
        (should (org-element-property :archivedp headline))
        ;; Test tag removal.
-       (should-not (org-element-property :tags headline))))
-    (let ((org-archive-tag "Archive"))
-      (should-not (org-element-property :archivedp (org-element-at-point)))))
+       (should-not (org-element-property :tags headline)))))
   ;; Multiple tags.
   (org-test-with-temp-text "* Headline :test:ARCHIVE:"
     (let ((org-archive-tag "ARCHIVE"))
       (let ((headline (org-element-at-point)))
        (should (org-element-property :archivedp headline))
        ;; Test tag removal.
-       (should (equal (org-element-property :tags headline) '("test")))))))
+       (should (equal (org-element-property :tags headline) '("test"))))))
+  ;; Tag is case-sensitive.
+  (should-not
+   (org-test-with-temp-text "* Headline :ARCHIVE:"
+     (let ((org-archive-tag "Archive"))
+       (org-element-property :archivedp (org-element-at-point))))))
 
 (ert-deftest test-org-element/headline-properties ()
   "Test properties from property drawer."