Add treesit-transpose-sexps (bug#60128)

We don't really need to rely on forward-sexp to define what to
transpose.  In tree-sitter we can consider siblings as "balanced
expressions", and swap them without doing any movement to calculate
where the siblings in question are.

* lisp/simple.el (transpose-sexps-function): New defvar-local.
(transpose-sexps): Use the new defvar-local if available.
(transpose-subr): Check whether the mover function returns a cons of
conses, then run transpose-subr-1 on the position-pairs.
* lisp/treesit.el (treesit-transpose-sexps): New function.

3 files changed, 86 insertions, 40 deletions

diff --git a/etc/NEWS b/etc/NEWS
index d17e1f1f89f..83aa81eb4b8 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -44,6 +44,15 @@ example, as part of preview for iconified frames.
 
 * Editing Changes in Emacs 30.1
 
+** New helper 'transpose-sexps-function'
+Emacs now can set this defvar to customize the behavior of the
+'transpose-sexps' function.
+
+** New function 'treesit-transpose-sexps'
+treesit.el now unconditionally sets 'transpose-sexps-function' for all
+Tree-sitter modes.  This functionality utilizes the new
+'transpose-sexps-function'.
+
 
 * Changes in Specialized Modes and Packages in Emacs 30.1
 ---
diff --git a/lisp/simple.el b/lisp/simple.el
index 4551b749d56..cf0845853a2 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -8438,6 +8438,43 @@ are interchanged."
   (interactive "*p")
   (transpose-subr 'forward-word arg))
 
+(defvar transpose-sexps-function
+  (lambda (arg)
+    ;; Here we should try to simulate the behavior of
+    ;; (cons (progn (forward-sexp x) (point))
+    ;;       (progn (forward-sexp (- x)) (point)))
+    ;; Except that we don't want to rely on the second forward-sexp
+    ;; putting us back to where we want to be, since forward-sexp-function
+    ;; might do funny things like infix-precedence.
+    (if (if (> arg 0)
+            (looking-at "\\sw\\|\\s_")
+          (and (not (bobp))
+               (save-excursion
+                 (forward-char -1)
+                 (looking-at "\\sw\\|\\s_"))))
+        ;; Jumping over a symbol.  We might be inside it, mind you.
+        (progn (funcall (if (> arg 0)
+                            #'skip-syntax-backward #'skip-syntax-forward)
+                        "w_")
+               (cons (save-excursion (forward-sexp arg) (point)) (point)))
+      ;; Otherwise, we're between sexps.  Take a step back before jumping
+      ;; to make sure we'll obey the same precedence no matter which
+      ;; direction we're going.
+      (funcall (if (> arg 0) #'skip-syntax-backward #'skip-syntax-forward)
+               " .")
+      (cons (save-excursion (forward-sexp arg) (point))
+            (progn (while (or (forward-comment (if (> arg 0) 1 -1))
+                              (not (zerop (funcall (if (> arg 0)
+                                                       #'skip-syntax-forward
+                                                     #'skip-syntax-backward)
+                                                   ".")))))
+                   (point)))))
+  "If non-nil, `transpose-sexps' delegates to this function.
+
+This function takes one argument ARG, a number.  Its expected
+return value is a position pair, which is a cons (BEG . END),
+where BEG and END are buffer positions.")
+
 (defun transpose-sexps (arg &optional interactive)
   "Like \\[transpose-chars] (`transpose-chars'), but applies to sexps.
 Unlike `transpose-words', point must be between the two sexps and not
@@ -8453,38 +8490,7 @@ report errors as appropriate for this kind of usage."
       (condition-case nil
           (transpose-sexps arg nil)
         (scan-error (user-error "Not between two complete sexps")))
-    (transpose-subr
-     (lambda (arg)
-       ;; Here we should try to simulate the behavior of
-       ;; (cons (progn (forward-sexp x) (point))
-       ;;       (progn (forward-sexp (- x)) (point)))
-       ;; Except that we don't want to rely on the second forward-sexp
-       ;; putting us back to where we want to be, since forward-sexp-function
-       ;; might do funny things like infix-precedence.
-       (if (if (> arg 0)
-               (looking-at "\\sw\\|\\s_")
-             (and (not (bobp))
-                  (save-excursion
-                    (forward-char -1)
-                    (looking-at "\\sw\\|\\s_"))))
-           ;; Jumping over a symbol.  We might be inside it, mind you.
-           (progn (funcall (if (> arg 0)
-                               'skip-syntax-backward 'skip-syntax-forward)
-                           "w_")
-                  (cons (save-excursion (forward-sexp arg) (point)) (point)))
-         ;; Otherwise, we're between sexps.  Take a step back before jumping
-         ;; to make sure we'll obey the same precedence no matter which
-         ;; direction we're going.
-         (funcall (if (> arg 0) 'skip-syntax-backward 'skip-syntax-forward)
-                  " .")
-         (cons (save-excursion (forward-sexp arg) (point))
-               (progn (while (or (forward-comment (if (> arg 0) 1 -1))
-                                 (not (zerop (funcall (if (> arg 0)
-                                                          'skip-syntax-forward
-                                                        'skip-syntax-backward)
-                                                      ".")))))
-                      (point)))))
-     arg 'special)))
+    (transpose-subr transpose-sexps-function arg 'special)))
 
 (defun transpose-lines (arg)
   "Exchange current line and previous line, leaving point after both.
@@ -8509,13 +8515,15 @@ With argument 0, interchanges line point is in with line mark is in."
 ;; FIXME document SPECIAL.
 (defun transpose-subr (mover arg &optional special)
   "Subroutine to do the work of transposing objects.
-Works for lines, sentences, paragraphs, etc.  MOVER is a function that
-moves forward by units of the given object (e.g. `forward-sentence',
-`forward-paragraph').  If ARG is zero, exchanges the current object
-with the one containing mark.  If ARG is an integer, moves the
-current object past ARG following (if ARG is positive) or
-preceding (if ARG is negative) objects, leaving point after the
-current object."
+Works for lines, sentences, paragraphs, etc.  MOVER is a function
+that moves forward by units of the given
+object (e.g. `forward-sentence', `forward-paragraph'), or a
+function calculating a cons of buffer positions.
+
+  If ARG is zero, exchanges the current object with the one
+containing mark.  If ARG is an integer, moves the current object
+past ARG following (if ARG is positive) or preceding (if ARG is
+negative) objects, leaving point after the current object."
   (let ((aux (if special mover
                (lambda (x)
                  (cons (progn (funcall mover x) (point))
@@ -8542,6 +8550,8 @@ current object."
       (goto-char (+ (car pos2) (- (cdr pos1) (car pos1))))))))
 
 (defun transpose-subr-1 (pos1 pos2)
+  (unless (and pos1 pos2)
+    (error "Don't have two things to transpose"))
   (when (> (car pos1) (cdr pos1)) (setq pos1 (cons (cdr pos1) (car pos1))))
   (when (> (car pos2) (cdr pos2)) (setq pos2 (cons (cdr pos2) (car pos2))))
   (when (> (car pos1) (car pos2))
diff --git a/lisp/treesit.el b/lisp/treesit.el
index cefbed1a168..203a724fe7a 100644
--- a/lisp/treesit.el
+++ b/lisp/treesit.el
@@ -1582,6 +1582,32 @@ BACKWARD and ALL are the same as in `treesit-search-forward'."
       (goto-char current-pos)))
     node))
 
+(defun treesit-transpose-sexps (&optional arg)
+  "Tree-sitter `transpose-sexps' function.
+Arg is the same as in `transpose-sexps'.
+
+Locate the node closest to POINT, and transpose that node with
+its sibling node ARG nodes away.
+
+Return a pair of positions as described by
+`transpose-sexps-function' for use in `transpose-subr' and
+friends."
+  (let* ((parent (treesit-node-parent (treesit-node-at (point))))
+         (child (treesit-node-child parent 0 t)))
+    (named-let loop ((prev child)
+                     (next (treesit-node-next-sibling child t)))
+      (when (and prev next)
+        (if (< (point) (treesit-node-end next))
+            (if (= arg -1)
+                (cons (treesit-node-start prev)
+                      (treesit-node-end prev))
+              (when-let ((n (treesit-node-child
+                             parent (+ arg (treesit-node-index prev t)) t)))
+                (cons (treesit-node-end n)
+                      (treesit-node-start n))))
+          (loop (treesit-node-next-sibling prev t)
+                (treesit-node-next-sibling next t)))))))
+
 ;;; Navigation, defun, things
 ;;
 ;; Emacs lets you define "things" by a regexp that matches the type of
@@ -2111,7 +2137,8 @@ before calling this function."
   ;; Defun name.
   (when treesit-defun-name-function
     (setq-local add-log-current-defun-function
-                #'treesit-add-log-current-defun)))
+                #'treesit-add-log-current-defun))
+  (setq-local transpose-sexps-function #'treesit-transpose-sexps))
 
 ;;; Debugging