From 74a7980758b929c991e317ea281b7cd4a097fdff Mon Sep 17 00:00:00 2001 From: Theodor Thornhill Date: Sun, 25 Dec 2022 20:11:59 +0100 Subject: [PATCH] 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. --- lisp/simple.el | 106 +++++++++++++++++++++++++++++------------------- lisp/treesit.el | 28 ++++++++++++- 2 files changed, 91 insertions(+), 43 deletions(-) diff --git a/lisp/simple.el b/lisp/simple.el index 4551b749d5..99dbfaea9f 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -8438,6 +8438,21 @@ transpose-words (interactive "*p") (transpose-subr 'forward-word arg)) +(defvar-local transpose-sexps-function nil + "If non-nil, `transpose-sexps' delegates to this function. + +This function takes one argument ARG, a number as provided +through running `transpose-sexps'. It supports the following two +return values: + +1. A cons (REGION . REGION), where REGION is (BEG . END) and BEG +and END are buffer positions. + +2. A cons (BEG . END), where BEG and END are buffer positions. + +If the second return value is chosen for this function, it is +expected to behave similarly to `forward-sexp' and friends.") + (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 @@ -8454,36 +8469,37 @@ transpose-sexps (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))))) + (if transpose-sexps-function 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)))))) arg 'special))) (defun transpose-lines (arg) @@ -8509,19 +8525,23 @@ transpose-lines ;; 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." - (let ((aux (if special mover - (lambda (x) - (cons (progn (funcall mover x) (point)) - (progn (funcall mover (- x)) (point)))))) - pos1 pos2) +Works for lines, sentences, paragraphs, etc. MOVER is either a +function that moves forward by units of the given +object (e.g. `forward-sentence', `forward-paragraph'), or a +function that calculates a cons of two position-pairs. 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)) + (progn (funcall mover (- x)) (point)))))) + (pos1 (save-excursion (funcall aux arg))) + pos2) (cond + ((and (consp (car pos1)) (consp (cdr pos1))) + (transpose-subr-1 (car pos1) (cdr pos1))) ((= arg 0) (save-excursion (setq pos1 (funcall aux 1)) @@ -8542,6 +8562,8 @@ transpose-subr (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 cefbed1a16..2bd7f71f2f 100644 --- a/lisp/treesit.el +++ b/lisp/treesit.el @@ -1582,6 +1582,31 @@ treesit-search-forward-goto (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-child + parent (+ arg (treesit-node-index child t)) + t))) + (when (and prev next) + (if (< (point) (treesit-node-end next)) + (cons (cons (treesit-node-start prev) + (treesit-node-end prev)) + (cons (treesit-node-start next) + (treesit-node-end next))) + (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 +2136,8 @@ treesit-major-mode-setup ;; 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 -- 2.34.1