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.

contrib/lisp/org-element.el

@@ -3821,19 +3821,18 @@ first row.
 
 If optional argument KEEP-TRAIL is non-nil, the function returns
 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
    ;; If at an headline, parse it.  It is the sole element that
    ;; doesn't require to know about context.  Be sure to disallow
    ;; secondary string parsing, though.
    (if (org-with-limited-levels (org-at-heading-p))
+       (progn
+	 (beginning-of-line)
 	 (if (not keep-trail) (org-element-headline-parser t)
-	 (list (org-element-headline-parser t)))
+	   (list (org-element-headline-parser t))))
      ;; Otherwise move at the beginning of the section containing
      ;; point.
      (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)))
        (org-skip-whitespace)
        (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
          (while t
            (setq element (org-element-current-element
 			  'element special-flag struct)
                  type (car element))
-	   (when keep-trail (push element trail))
+	   (push element trail)
            (cond
 	    ;; 1. Skip any element ending before point or at point.
 	    ((let ((end (org-element-property :end element)))
 	       (when (<= end origin)
 		 (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
 	    ;;    point.
 	    ((not (memq type org-element-greater-elements))
 	     (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
 	    ;;    that element.
 	    (t
-	     (when (eq type 'item) (setq special-flag nil))
 	     (let ((beg (org-element-property :contents-begin 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)
 		 (goto-char beg)))))))))))
 
@@ -3942,10 +3908,27 @@ in-between, if any, are siblings of the element at point."
 
 (defun org-element-swap-A-B (elem-A 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))
-  (let* ((beg-A (org-element-property :begin elem-A))
+  ;; There are two special cases when an element doesn't start at bol:
+  ;; the first paragraph in an item or in a footnote definition.
+  (let ((specialp (not (bolp))))
+    ;; Only a paragraph without any affiliated keyword can be moved at
+    ;; ELEM-A position in such a situation.  Note that the case of
+    ;; a footnote definition is impossible: it cannot contain two
+    ;; paragraphs in a row because it cannot contain a blank line.
+    (if (and specialp
+	     (or (not (eq (org-element-type elem-B) 'paragraph))
+		 (/= (org-element-property :begin elem-B)
+		     (org-element-property :contents-begin elem-B))))
+	(error "Cannot swap elements"))
+    ;; In a special situation, ELEM-A will have no indentation.  We'll
+    ;; give it ELEM-B's (which will in, in turn, have no indentation).
+    (let* ((ind-B (when specialp
+		    (goto-char (org-element-property :begin elem-B))
+		    (org-get-indentation)))
+	   (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")
@@ -3958,68 +3941,106 @@ Leave point at the end of ELEM-A."
 	   (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))))
+      (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 ()
   "Move backward by one element.
 Move to the previous element at the same level, when possible."
   (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))
-	   (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)
-	(let ((type (org-element-type element)))
       (cond
-	   ;; At an headline: move to previous headline at the same
+       ;; Move to beginning of current element if point isn't there
-	   ;; level, a parent, or BOB.
+       ;; already.
-	   ((eq type 'headline)
+       ((/= (point) beg) (goto-char beg))
-	    (let ((dest (save-excursion (org-backward-same-level 1) (point))))
+       ((not prev-elem) (error "Cannot move further up"))
-	      (if (= (point-min) dest) (error "Cannot move further up")
+       (t (goto-char (org-element-property :begin prev-elem)))))))
-		(goto-char dest))))
+
-	   ;; At an item: try to move to the previous item, if any.
+(defun org-element-up ()
-	   ((and (eq type 'item)
+  "Move to upper element."
-		 (let* ((struct (org-element-property :structure element))
+  (interactive)
-			(prev (org-list-get-prev-item
+  (if (org-with-limited-levels (org-at-heading-p))
-			       beg struct (org-list-prevs-alist struct))))
+      (unless (org-up-heading-safe)
-		   (when prev (goto-char prev)))))
+	(error "No surrounding element"))
-	   ;; In any other case, find the previous element in the
+    (let* ((trail (org-element-at-point 'keep-trail))
-	   ;; trail and move to its beginning.  If no previous element
+	   (elem (pop trail))
-	   ;; can be found, move to headline.
+	   (end (org-element-property :end elem))
-	   (t (let ((prev (nth 1 trail)))
+	   (parent (loop for prev in trail
-		(if prev (goto-char (org-element-property :begin prev))
+			 when (>= (org-element-property :end prev) end)
-		  (org-back-to-heading))))))))))
+			 return prev)))
+      (cond
+       (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 ()
-  "Drag backward element at point."
+  "Move backward element at point."
   (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)))
-      (when (or (org-element-nested-p elem prev-elem)
-		(and (eq (org-element-type elem) 'headline)
-		     (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))))))
+	  (goto-char (+ (org-element-property :begin prev-elem)
+			(- pos (org-element-property :begin elem)))))))))
 
 (defun org-element-drag-forward ()
   "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))
 			    (skip-chars-backward " \r\t\n")
 			    (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)))
 	    (size-blank (- (org-element-property :end elem)
 			   (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)
 	(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 ()
   "Put point at beginning of this element, mark at end.
 
@@ -4127,29 +4113,18 @@ ones already marked."
        (org-element-property :begin elem)
        (org-element-property :end elem))))))
 
-(defun org-transpose-elements ()
+(defun org-element-transpose ()
   "Transpose current and previous elements, keeping blank lines between.
 Point is moved after both elements."
   (interactive)
   (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 ()
   "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."
   (interactive)
   (unless (eq major-mode 'org-mode)
@@ -4159,10 +4134,10 @@ modified."
 	 (unindent-tree
 	  (function
 	   (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-restriction
 		      (narrow-to-region
@@ -4172,57 +4147,6 @@ modified."
 	      (reverse contents))))))
     (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)
 ;;; org-element.el ends here

testing/lisp/test-org-element.el

@@ -1673,7 +1673,22 @@ Paragraph \\alpha."
 
 ;;; 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."
   ;; 1. At EOB: should error.
   (org-test-with-temp-text "Some text\n"
@@ -1753,7 +1768,7 @@ Outside."
     (org-element-forward)
     (should (looking-at "  - sub3"))))
 
-(ert-deftest test-org-element/backward-element ()
+(ert-deftest test-org-element/backward ()
   "Test `org-element-backward' specifications."
   ;; 1. At BOB (modulo some white spaces): should error.
   (org-test-with-temp-text "    \nParagraph."
@@ -1832,7 +1847,7 @@ Outside."
     (org-element-backward)
     (should (looking-at "- item1"))))
 
-(ert-deftest test-org-element/up-element ()
+(ert-deftest test-org-element/up ()
   "Test `org-element-up' specifications."
   ;; 1. At BOB or with no surrounding element: should error.
   (org-test-with-temp-text "Paragraph."
@@ -1883,7 +1898,7 @@ Outside."
     (org-element-up)
     (should (looking-at "\\* Top"))))
 
-(ert-deftest test-org-element/down-element ()
+(ert-deftest test-org-element/down ()
   "Test `org-element-down' specifications."
   ;; 1. Error when the element hasn't got a recursive type.
   (org-test-with-temp-text "Paragraph."