ndwarshuis
/
org-mode
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

org-element: Refactor navigation tools 

* contrib/lisp/org-element.el (org-element-at-point,
  org-element-backward, org-element-up, org-element-down,
  org-element-drag-backward): Refactor.
(org-element-swap-A-B): Handle the case of the first paragraph in an
item.
(org-element-transpose): New function.
(org-transpose-elements): Removed function.
(org-element-unindent-buffer): Correctly un-indent contents of
headlines.
* testing/lisp/test-org-element.el: Add tests.
This commit is contained in:
Nicolas Goaziou 2012-05-05 09:14:39 +02:00
parent b137cdb296
commit ed9a748057
2 changed files with 183 additions and 244 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

404
contrib/lisp/org-element.el
View File

@ -3821,19 +3821,18 @@ first row.
If optional argument KEEP-TRAIL is non-nil, the function returns If optional argument KEEP-TRAIL is non-nil, the function returns
a list of of elements leading to element at point. The list's a list of of elements leading to element at point. The list's
CAR is always the element at point. Its last item will be the CAR is always the element at point. Following positions contain
element's parent, unless element was either the first in its element's siblings, then parents, siblings of parents, until the
section (in which case the last item in the list is the first first element of current section."
element of section) or an headline (in which case the list
contains that headline as its single element). Elements
in-between, if any, are siblings of the element at point."
(org-with-wide-buffer (org-with-wide-buffer
;; If at an headline, parse it. It is the sole element that ;; If at an headline, parse it. It is the sole element that
;; doesn't require to know about context. Be sure to disallow ;; doesn't require to know about context. Be sure to disallow
;; secondary string parsing, though. ;; secondary string parsing, though.
(if (org-with-limited-levels (org-at-heading-p)) (if (org-with-limited-levels (org-at-heading-p))
(if (not keep-trail) (org-element-headline-parser t) (progn
(list (org-element-headline-parser t))) (beginning-of-line)
(if (not keep-trail) (org-element-headline-parser t)
(list (org-element-headline-parser t))))
;; Otherwise move at the beginning of the section containing ;; Otherwise move at the beginning of the section containing
;; point. ;; point.
(let ((origin (point)) element type special-flag trail struct prevs) (let ((origin (point)) element type special-flag trail struct prevs)
@ -3843,72 +3842,39 @@ in-between, if any, are siblings of the element at point."
(forward-line))) (forward-line)))
(org-skip-whitespace) (org-skip-whitespace)
(beginning-of-line) (beginning-of-line)
;; Starting parsing successively each element with ;; Parse successively each element, skipping those ending
;; `org-element-current-element'. Skip those ending before ;; before original position.
;; original position.
(catch 'exit (catch 'exit
(while t (while t
(setq element (org-element-current-element (setq element (org-element-current-element
'element special-flag struct) 'element special-flag struct)
type (car element)) type (car element))
(when keep-trail (push element trail)) (push element trail)
(cond (cond
;; 1. Skip any element ending before point or at point. ;; 1. Skip any element ending before point or at point.
((let ((end (org-element-property :end element))) ((let ((end (org-element-property :end element)))
(when (<= end origin) (when (<= end origin)
(if (> (point-max) end) (goto-char end) (if (> (point-max) end) (goto-char end)
(throw 'exit (or trail element)))))) (throw 'exit (if keep-trail trail element))))))
;; 2. An element containing point is always the element at ;; 2. An element containing point is always the element at
;; point. ;; point.
((not (memq type org-element-greater-elements)) ((not (memq type org-element-greater-elements))
(throw 'exit (if keep-trail trail element))) (throw 'exit (if keep-trail trail element)))
;; 3. At a plain list. ;; 3. At any other greater element type, if point is
((eq type 'plain-list)
(setq struct (org-element-property :structure element)
prevs (or prevs (org-list-prevs-alist struct)))
(let ((beg (org-element-property :contents-begin element)))
(if (<= origin beg) (throw 'exit (or trail element))
;; Find the item at this level containing ORIGIN.
(let ((items (org-list-get-all-items beg struct prevs))
parent)
(catch 'local
(mapc
(lambda (pos)
(cond
;; Item ends before point: skip it.
((<= (org-list-get-item-end pos struct) origin))
;; Item contains point: store is in PARENT.
((<= pos origin) (setq parent pos))
;; We went too far: return PARENT.
(t (throw 'local nil)))) items))
;; No parent: no item contained point, though the
;; plain list does. Point is in the blank lines
;; after the list: return plain list.
(if (not parent) (throw 'exit (or trail element))
(setq special-flag 'item)
(goto-char parent))))))
;; 4. At a table.
((eq type 'table)
(if (eq (org-element-property :type element) 'table.el)
(throw 'exit (or trail element))
(let ((beg (org-element-property :contents-begin element))
(end (org-element-property :contents-end element)))
(if (or (<= origin beg) (>= origin end))
(throw 'exit (or trail element))
(when keep-trail (setq trail (list element)))
(setq special-flag 'table-row)
(narrow-to-region beg end)))))
;; 4. At any other greater element type, if point is
;; within contents, move into it. Otherwise, return ;; within contents, move into it. Otherwise, return
;; that element. ;; that element.
(t (t
(when (eq type 'item) (setq special-flag nil))
(let ((beg (org-element-property :contents-begin element)) (let ((beg (org-element-property :contents-begin element))
(end (org-element-property :contents-end element))) (end (org-element-property :contents-end element)))
(if (or (not beg) (not end) (> beg origin) (< end origin)) (if (or (not beg) (not end) (> beg origin) (<= end origin)
(throw 'exit (or trail element)) (and (= beg origin) (memq type '(plain-list table))))
;; Reset trail, since we found a parent. (throw 'exit (if keep-trail trail element))
(when keep-trail (setq trail (list element))) (case type
(plain-list
(setq special-flag 'item
struct (org-element-property :structure element)))
(table (setq special-flag 'table-row))
(otherwise (setq special-flag nil)))
(narrow-to-region beg end) (narrow-to-region beg end)
(goto-char beg))))))))))) (goto-char beg)))))))))))
@ -3942,84 +3908,139 @@ in-between, if any, are siblings of the element at point."
(defun org-element-swap-A-B (elem-A elem-B) (defun org-element-swap-A-B (elem-A elem-B)
"Swap elements ELEM-A and ELEM-B. "Swap elements ELEM-A and ELEM-B.
Assume ELEM-B is after ELEM-A in the buffer. Leave point at the
Leave point at the end of ELEM-A." end of ELEM-A."
(goto-char (org-element-property :begin elem-A)) (goto-char (org-element-property :begin elem-A))
(let* ((beg-A (org-element-property :begin elem-A)) ;; There are two special cases when an element doesn't start at bol:
(end-A (save-excursion ;; the first paragraph in an item or in a footnote definition.
(goto-char (org-element-property :end elem-A)) (let ((specialp (not (bolp))))
(skip-chars-backward " \r\t\n") ;; Only a paragraph without any affiliated keyword can be moved at
(point-at-eol))) ;; ELEM-A position in such a situation. Note that the case of
(beg-B (org-element-property :begin elem-B)) ;; a footnote definition is impossible: it cannot contain two
(end-B (save-excursion ;; paragraphs in a row because it cannot contain a blank line.
(goto-char (org-element-property :end elem-B)) (if (and specialp
(skip-chars-backward " \r\t\n") (or (not (eq (org-element-type elem-B) 'paragraph))
(point-at-eol))) (/= (org-element-property :begin elem-B)
(body-A (buffer-substring beg-A end-A)) (org-element-property :contents-begin elem-B))))
(body-B (delete-and-extract-region beg-B end-B))) (error "Cannot swap elements"))
(goto-char beg-B) ;; In a special situation, ELEM-A will have no indentation. We'll
(insert body-A) ;; give it ELEM-B's (which will in, in turn, have no indentation).
(goto-char beg-A) (let* ((ind-B (when specialp
(delete-region beg-A end-A) (goto-char (org-element-property :begin elem-B))
(insert body-B) (org-get-indentation)))
(goto-char (org-element-property :end elem-B)))) (beg-A (org-element-property :begin elem-A))
(end-A (save-excursion
(goto-char (org-element-property :end elem-A))
(skip-chars-backward " \r\t\n")
(point-at-eol)))
(beg-B (org-element-property :begin elem-B))
(end-B (save-excursion
(goto-char (org-element-property :end elem-B))
(skip-chars-backward " \r\t\n")
(point-at-eol)))
(body-A (buffer-substring beg-A end-A))
(body-B (delete-and-extract-region beg-B end-B)))
(goto-char beg-B)
(when specialp
(setq body-B (replace-regexp-in-string "\\`[ \t]*" "" body-B))
(org-indent-to-column ind-B))
(insert body-A)
(goto-char beg-A)
(delete-region beg-A end-A)
(insert body-B)
(goto-char (org-element-property :end elem-B)))))
(defun org-element-forward ()
"Move forward by one element.
Move to the next element at the same level, when possible."
(interactive)
(if (org-with-limited-levels (org-at-heading-p))
(let ((origin (point)))
(org-forward-same-level 1)
(unless (org-with-limited-levels (org-at-heading-p))
(goto-char origin)
(error "Cannot move further down")))
(let* ((trail (org-element-at-point 'keep-trail))
(elem (pop trail))
(end (org-element-property :end elem))
(parent (loop for prev in trail
when (>= (org-element-property :end prev) end)
return prev)))
(cond
((eobp) (error "Cannot move further down"))
((and parent (= (org-element-property :contents-end parent) end))
(goto-char (org-element-property :end parent)))
(t (goto-char end))))))
(defun org-element-backward () (defun org-element-backward ()
"Move backward by one element. "Move backward by one element.
Move to the previous element at the same level, when possible." Move to the previous element at the same level, when possible."
(interactive) (interactive)
(if (save-excursion (skip-chars-backward " \r\t\n") (bobp)) (if (org-with-limited-levels (org-at-heading-p))
(error "Cannot move further up") ;; At an headline, move to the previous one, if any, or stay
;; here.
(let ((origin (point)))
(org-backward-same-level 1)
(unless (org-with-limited-levels (org-at-heading-p))
(goto-char origin)
(error "Cannot move further up")))
(let* ((trail (org-element-at-point 'keep-trail)) (let* ((trail (org-element-at-point 'keep-trail))
(element (car trail)) (elem (car trail))
(beg (org-element-property :begin element))) (prev-elem (nth 1 trail))
;; Move to beginning of current element if point isn't there. (beg (org-element-property :begin elem)))
(if (/= (point) beg) (goto-char beg) (cond
(let ((type (org-element-type element))) ;; Move to beginning of current element if point isn't there
(cond ;; already.
;; At an headline: move to previous headline at the same ((/= (point) beg) (goto-char beg))
;; level, a parent, or BOB. ((not prev-elem) (error "Cannot move further up"))
((eq type 'headline) (t (goto-char (org-element-property :begin prev-elem)))))))
(let ((dest (save-excursion (org-backward-same-level 1) (point))))
(if (= (point-min) dest) (error "Cannot move further up") (defun org-element-up ()
(goto-char dest)))) "Move to upper element."
;; At an item: try to move to the previous item, if any. (interactive)
((and (eq type 'item) (if (org-with-limited-levels (org-at-heading-p))
(let* ((struct (org-element-property :structure element)) (unless (org-up-heading-safe)
(prev (org-list-get-prev-item (error "No surrounding element"))
beg struct (org-list-prevs-alist struct)))) (let* ((trail (org-element-at-point 'keep-trail))
(when prev (goto-char prev))))) (elem (pop trail))
;; In any other case, find the previous element in the (end (org-element-property :end elem))
;; trail and move to its beginning. If no previous element (parent (loop for prev in trail
;; can be found, move to headline. when (>= (org-element-property :end prev) end)
(t (let ((prev (nth 1 trail))) return prev)))
(if prev (goto-char (org-element-property :begin prev)) (cond
(org-back-to-heading)))))))))) (parent (goto-char (org-element-property :begin parent)))
((org-before-first-heading-p) (error "No surrounding element"))
(t (org-back-to-heading))))))
(defun org-element-down ()
"Move to inner element."
(interactive)
(let ((element (org-element-at-point)))
(cond
((memq (org-element-type element) '(plain-list table))
(goto-char (org-element-property :contents-begin element))
(forward-char))
((memq (org-element-type element) org-element-greater-elements)
;; If contents are hidden, first disclose them.
(when (org-element-property :hiddenp element) (org-cycle))
(goto-char (org-element-property :contents-begin element)))
(t (error "No inner element")))))
(defun org-element-drag-backward () (defun org-element-drag-backward ()
"Drag backward element at point." "Move backward element at point."
(interactive) (interactive)
(let* ((pos (point)) (if (org-with-limited-levels (org-at-heading-p)) (org-move-subtree-up)
(elem (org-element-at-point))) (let* ((trail (org-element-at-point 'keep-trail))
(when (= (progn (goto-char (point-min)) (elem (car trail))
(org-skip-whitespace) (prev-elem (nth 1 trail)))
(point-at-bol)) ;; Error out if no previous element or previous element is
(org-element-property :end elem)) ;; a parent of the current one.
(error "Cannot drag element backward")) (if (or (not prev-elem) (org-element-nested-p elem prev-elem))
(goto-char (org-element-property :begin elem)) (error "Cannot drag element backward")
(org-element-backward) (let ((pos (point)))
(let ((prev-elem (org-element-at-point))) (org-element-swap-A-B prev-elem elem)
(when (or (org-element-nested-p elem prev-elem) (goto-char (+ (org-element-property :begin prev-elem)
(and (eq (org-element-type elem) 'headline) (- pos (org-element-property :begin elem)))))))))
(not (eq (org-element-type prev-elem) 'headline))))
(goto-char pos)
(error "Cannot drag element backward"))
;; Compute new position of point: it's shifted by PREV-ELEM
;; body's length.
(let ((size-prev (- (org-element-property :end prev-elem)
(org-element-property :begin prev-elem))))
(org-element-swap-A-B prev-elem elem)
(goto-char (- pos size-prev))))))
(defun org-element-drag-forward () (defun org-element-drag-forward ()
"Move forward element at point." "Move forward element at point."
@ -4042,7 +4063,9 @@ Move to the previous element at the same level, when possible."
(goto-char (org-element-property :end next-elem)) (goto-char (org-element-property :end next-elem))
(skip-chars-backward " \r\t\n") (skip-chars-backward " \r\t\n")
(forward-line) (forward-line)
(point)) ;; Small correction if buffer doesn't end
;; with a newline character.
(if (and (eolp) (not (bolp))) (1+ (point)) (point)))
(org-element-property :begin next-elem))) (org-element-property :begin next-elem)))
(size-blank (- (org-element-property :end elem) (size-blank (- (org-element-property :end elem)
(save-excursion (save-excursion
@ -4053,43 +4076,6 @@ Move to the previous element at the same level, when possible."
(org-element-swap-A-B elem next-elem) (org-element-swap-A-B elem next-elem)
(goto-char (+ pos size-next size-blank)))))) (goto-char (+ pos size-next size-blank))))))
(defun org-element-forward ()
"Move forward by one element.
Move to the next element at the same level, when possible."
(interactive)
(if (eobp) (error "Cannot move further down")
(let* ((trail (org-element-at-point 'keep-trail))
(element (car trail))
(type (org-element-type element))
(end (org-element-property :end element)))
(cond
;; At an headline, move to next headline at the same level.
((eq type 'headline) (goto-char end))
;; At an item. Move to the next item, if possible.
((and (eq type 'item)
(let* ((struct (org-element-property :structure element))
(prevs (org-list-prevs-alist struct))
(beg (org-element-property :begin element))
(next-item (org-list-get-next-item beg struct prevs)))
(when next-item (goto-char next-item)))))
;; In any other case, move to element's end, unless this
;; position is also the end of its parent's contents, in which
;; case, directly jump to parent's end.
(t
(let ((parent
;; Determine if TRAIL contains the real parent of ELEMENT.
(and (> (length trail) 1)
(let* ((parent-candidate (car (last trail))))
(and (memq (org-element-type parent-candidate)
org-element-greater-elements)
(>= (org-element-property
:contents-end parent-candidate) end)
parent-candidate)))))
(cond ((not parent) (goto-char end))
((= (org-element-property :contents-end parent) end)
(goto-char (org-element-property :end parent)))
(t (goto-char end)))))))))
(defun org-element-mark-element () (defun org-element-mark-element ()
"Put point at beginning of this element, mark at end. "Put point at beginning of this element, mark at end.
@ -4127,102 +4113,40 @@ ones already marked."
(org-element-property :begin elem) (org-element-property :begin elem)
(org-element-property :end elem)))))) (org-element-property :end elem))))))
(defun org-transpose-elements () (defun org-element-transpose ()
"Transpose current and previous elements, keeping blank lines between. "Transpose current and previous elements, keeping blank lines between.
Point is moved after both elements." Point is moved after both elements."
(interactive) (interactive)
(org-skip-whitespace) (org-skip-whitespace)
(let ((pos (point)) (let ((end (org-element-property :end (org-element-at-point))))
(cur (org-element-at-point))) (org-element-drag-backward)
(when (= (save-excursion (goto-char (point-min)) (goto-char end)))
(org-skip-whitespace)
(point-at-bol))
(org-element-property :begin cur))
(error "No previous element"))
(goto-char (org-element-property :begin cur))
(forward-line -1)
(let ((prev (org-element-at-point)))
(when (org-element-nested-p cur prev)
(goto-char pos)
(error "Cannot transpose nested elements"))
(org-element-swap-A-B prev cur))))
(defun org-element-unindent-buffer () (defun org-element-unindent-buffer ()
"Un-indent the visible part of the buffer. "Un-indent the visible part of the buffer.
Relative indentation \(between items, inside blocks, etc.\) isn't Relative indentation (between items, inside blocks, etc.) isn't
modified." modified."
(interactive) (interactive)
(unless (eq major-mode 'org-mode) (unless (eq major-mode 'org-mode)
(error "Cannot un-indent a buffer not in Org mode")) (error "Cannot un-indent a buffer not in Org mode"))
(let* ((parse-tree (org-element-parse-buffer 'greater-element)) (let* ((parse-tree (org-element-parse-buffer 'greater-element))
unindent-tree ; For byte-compiler. unindent-tree ; For byte-compiler.
(unindent-tree (unindent-tree
(function (function
(lambda (contents) (lambda (contents)
(mapc (lambda (element) (mapc
(if (eq (org-element-type element) 'headline) (lambda (element)
(funcall unindent-tree (if (memq (org-element-type element) '(headline section))
(org-element-contents element)) (funcall unindent-tree (org-element-contents element))
(save-excursion (save-excursion
(save-restriction (save-restriction
(narrow-to-region (narrow-to-region
(org-element-property :begin element) (org-element-property :begin element)
(org-element-property :end element)) (org-element-property :end element))
(org-do-remove-indentation))))) (org-do-remove-indentation)))))
(reverse contents)))))) (reverse contents))))))
(funcall unindent-tree (org-element-contents parse-tree)))) (funcall unindent-tree (org-element-contents parse-tree))))
(defun org-element-up ()
"Move to upper element."
(interactive)
(cond
((bobp) (error "No surrounding element"))
((org-with-limited-levels (org-at-heading-p))
(or (org-up-heading-safe) (error "No surronding element")))
(t
(let* ((trail (org-element-at-point 'keep-trail))
(element (car trail))
(type (org-element-type element)))
(cond
;; At an item, with a parent in the list: move to that parent.
((and (eq type 'item)
(let* ((beg (org-element-property :begin element))
(struct (org-element-property :structure element))
(parents (org-list-parents-alist struct))
(parentp (org-list-get-parent beg struct parents)))
(and parentp (goto-char parentp)))))
;; Determine parent in the trail.
(t
(let ((parent
(and (> (length trail) 1)
(let ((parentp (car (last trail))))
(and (memq (org-element-type parentp)
org-element-greater-elements)
(>= (org-element-property :contents-end parentp)
(org-element-property :end element))
parentp)))))
(cond
;; When parent is found move to its beginning.
(parent (goto-char (org-element-property :begin parent)))
;; If no parent was found, move to headline above, if any
;; or return an error.
((org-before-first-heading-p) (error "No surrounding element"))
(t (org-back-to-heading))))))))))
(defun org-element-down ()
"Move to inner element."
(interactive)
(let ((element (org-element-at-point)))
(cond
((memq (org-element-type element) '(plain-list table))
(goto-char (org-element-property :contents-begin element))
(forward-char))
((memq (org-element-type element) org-element-greater-elements)
;; If contents are hidden, first disclose them.
(when (org-element-property :hiddenp element) (org-cycle))
(goto-char (org-element-property :contents-begin element)))
(t (error "No inner element")))))
(provide 'org-element) (provide 'org-element)
;;; org-element.el ends here ;;; org-element.el ends here

23
testing/lisp/test-org-element.el
View File

@ -1673,7 +1673,22 @@ Paragraph \\alpha."
;;; Test Navigation Tools. ;;; Test Navigation Tools.
(ert-deftest test-org-element/forward-element () (ert-deftest test-org-element/at-point ()
"Test `org-element-at-point' specifications."
;; Special case: at the very beginning of a table, return `table'
;; object instead of `table-row'.
(should
(eq 'table
(org-test-with-temp-text "| a | b |"
(org-element-type (org-element-at-point)))))
;; Special case: at the very beginning of a list or sub-list, return
;; `plain-list' object instead of `item'.
(should
(eq 'plain-list
(org-test-with-temp-text "- item"
(org-element-type (org-element-at-point))))))
(ert-deftest test-org-element/forward ()
"Test `org-element-forward' specifications." "Test `org-element-forward' specifications."
;; 1. At EOB: should error. ;; 1. At EOB: should error.
(org-test-with-temp-text "Some text\n" (org-test-with-temp-text "Some text\n"
@ -1753,7 +1768,7 @@ Outside."
(org-element-forward) (org-element-forward)
(should (looking-at " - sub3")))) (should (looking-at " - sub3"))))
(ert-deftest test-org-element/backward-element () (ert-deftest test-org-element/backward ()
"Test `org-element-backward' specifications." "Test `org-element-backward' specifications."
;; 1. At BOB (modulo some white spaces): should error. ;; 1. At BOB (modulo some white spaces): should error.
(org-test-with-temp-text " \nParagraph." (org-test-with-temp-text " \nParagraph."
@ -1832,7 +1847,7 @@ Outside."
(org-element-backward) (org-element-backward)
(should (looking-at "- item1")))) (should (looking-at "- item1"))))
(ert-deftest test-org-element/up-element () (ert-deftest test-org-element/up ()
"Test `org-element-up' specifications." "Test `org-element-up' specifications."
;; 1. At BOB or with no surrounding element: should error. ;; 1. At BOB or with no surrounding element: should error.
(org-test-with-temp-text "Paragraph." (org-test-with-temp-text "Paragraph."
@ -1883,7 +1898,7 @@ Outside."
(org-element-up) (org-element-up)
(should (looking-at "\\* Top")))) (should (looking-at "\\* Top"))))
(ert-deftest test-org-element/down-element () (ert-deftest test-org-element/down ()
"Test `org-element-down' specifications." "Test `org-element-down' specifications."
;; 1. Error when the element hasn't got a recursive type. ;; 1. Error when the element hasn't got a recursive type.
(org-test-with-temp-text "Paragraph." (org-test-with-temp-text "Paragraph."