From: Nicolas Goaziou <n.goaziou@gmail.com>
To: Org Mode List <emacs-orgmode@gnu.org>
Subject: Re: [RFC] Simple cache mechanism for `org-element-at-point'
Date: Sun, 27 Oct 2013 09:52:46 +0100 [thread overview]
Message-ID: <87k3gzaye9.fsf@gmail.com> (raw)
In-Reply-To: <87wqlu834i.fsf@gmail.com> (Nicolas Goaziou's message of "Thu, 03 Oct 2013 23:18:37 +0200")
[-- Attachment #1: Type: text/plain, Size: 1140 bytes --]
Nicolas Goaziou <n.goaziou@gmail.com> writes:
> The following patches introduce a simple cache mechanism for both
> `org-element-at-point' and `org-element-context'. My goal is to make
> them fast enough to be used in most core commands (excepted
> headlines-only commands).
>
> Since a wrong cache can break Org behaviour badly, I would appreciate if
> it could be tested a bit. You can disable cache at any time by setting
> `org-element-use-cache' to nil and reset it with
> `org-element-cache-reset' function.
>
> It may also be interesting to tweak `org-element--cache-sync-idle-time'
> and `org-element--cache-merge-changes-threshold', although I don't
> expect a regular user to do it. Anyway, it may lead to better default
> values.
>
> Since cache is updated upon buffer modification, visibility status
> cannot be cached properly. Since it is also buggy, the first patch
> removes that data altogether.
I applied the first patch.
Here is a slight change to the second one, which will correctly reset
cache when some variables are customized or when a buffer is refreshed
(C-c C-c on a keyword).
Regards,
--
Nicolas Goaziou
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-org-element-Implement-caching-for-dynamic-parser.patch --]
[-- Type: text/x-diff, Size: 41629 bytes --]
From 6fa0c2908c9cc3c768ec484ce9d7f87a971a4fa5 Mon Sep 17 00:00:00 2001
From: Nicolas Goaziou <n.goaziou@gmail.com>
Date: Thu, 3 Oct 2013 22:12:35 +0200
Subject: [PATCH] org-element: Implement caching for dynamic parser
* 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.
* lisp/org-src.el (org-src-preserve-indentation): 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 | 750 ++++++++++++++++++++++++++++++++-------
| 9 +-
lisp/org-src.el | 25 +-
lisp/org.el | 6 +-
testing/lisp/test-org-element.el | 18 +-
5 files changed, 658 insertions(+), 150 deletions(-)
diff --git a/lisp/org-element.el b/lisp/org-element.el
index 329d00a..cbe0e56 100644
--- a/lisp/org-element.el
+++ b/lisp/org-element.el
@@ -111,7 +111,8 @@
;;
;; 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:
@@ -4646,7 +4647,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.
@@ -4654,8 +4655,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)
@@ -4687,96 +5097,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)
@@ -4798,11 +5236,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.
@@ -4832,8 +5269,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 "* ")
@@ -4859,44 +5295,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."
--git a/lisp/org-footnote.el b/lisp/org-footnote.el
index 3c0d97c..c59bd0c 100644
--- a/lisp/org-footnote.el
+++ b/lisp/org-footnote.el
@@ -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)))
diff --git a/lisp/org-src.el b/lisp/org-src.el
index 6ec3adc..918c1ba 100644
--- a/lisp/org-src.el
+++ b/lisp/org-src.el
@@ -116,15 +116,24 @@ These are the regions where each line starts with a colon."
(function :tag "Other (specify)")))
(defcustom org-src-preserve-indentation nil
- "If non-nil preserve leading whitespace characters on export.
-If non-nil leading whitespace characters in source code blocks
-are preserved on export, and when switching between the org
-buffer and the language mode edit buffer. If this variable is nil
-then, after editing with \\[org-edit-src-code], the
-minimum (across-lines) number of leading whitespace characters
-are removed from all lines, and the code block is uniformly
-indented according to the value of `org-edit-src-content-indentation'."
+ "\\<org-mode-map>If non-nil preserve leading whitespace characters on export.
+
+If non-nil leading whitespace characters in source code blocks are
+preserved on export, and when switching between the org buffer and
+the language mode edit buffer.
+
+If this variable is nil then, after editing with \\[org-edit-src-code],
+or \\[org-edit-special], the minimum (across-lines) number of leading whitespace
+characters are removed from all lines, and the code block is uniformly
+indented according to the value of `org-edit-src-content-indentation'.
+
+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-edit-structure
+ :initialize 'custom-initialize-set
+ :set (lambda (var val) (set var val) (org-element-cache-reset 'all))
:type 'boolean)
(defcustom org-edit-src-content-indentation 2
diff --git a/lisp/org.el b/lisp/org.el
index 0fd531d..e331ace 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -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.
@@ -5391,6 +5393,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)
diff --git a/testing/lisp/test-org-element.el b/testing/lisp/test-org-element.el
index 103ba99..ebf6913 100644
--- a/testing/lisp/test-org-element.el
+++ b/testing/lisp/test-org-element.el
@@ -858,25 +858,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."
--
1.8.4.1
next prev parent reply other threads:[~2013-10-27 8:52 UTC|newest]
Thread overview: 9+ messages / expand[flat|nested] mbox.gz Atom feed top
2013-10-03 21:18 [RFC] Simple cache mechanism for `org-element-at-point' Nicolas Goaziou
2013-10-04 5:43 ` Eric Abrahamsen
2013-10-04 8:53 ` Nicolas Goaziou
2013-10-04 9:13 ` Carsten Dominik
2013-10-04 17:15 ` Nicolas Goaziou
2013-10-27 8:52 ` Nicolas Goaziou [this message]
2013-10-30 10:06 ` Nicolas Goaziou
2013-10-30 12:39 ` Eric Abrahamsen
2013-11-03 12:39 ` Nicolas Goaziou
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.orgmode.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87k3gzaye9.fsf@gmail.com \
--to=n.goaziou@gmail.com \
--cc=emacs-orgmode@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).