branch: elpa/tuareg
commit b0a2547c71716c766ab5eac39ea7c3cd22e9713d
Author: Mattias Engdegård <matti...@acm.org>
Commit: Stefan Monnier <monn...@iro.umontreal.ca>
Let declarative `and` begin a defun
Since each `and` hitched to a `type` or declarative `let` produces a
definition, consider them defuns in their own right. Previously, an
entire `let`...`and`... or `type`...`and`... chain was a single defun,
which made movement-by-defun operations less useful.
To get an acceptable interactive latency, we memoise the
calls (smie-forward-sexp "and") and (smie-backward-sexp "and"),
since they are called repeatedly during movement-by-defun.
---
tuareg-tests.el | 89 ++++++++++++++++++++++++++++++++++++++
tuareg.el | 129 ++++++++++++++++++++++++++++++++++++++++----------------
2 files changed, 182 insertions(+), 36 deletions(-)
diff --git a/tuareg-tests.el b/tuareg-tests.el
index 70cb7a4..44dc525 100644
--- a/tuareg-tests.el
+++ b/tuareg-tests.el
@@ -77,4 +77,93 @@
;; case does not seem to be very well-defined.
)))
+(ert-deftest tuareg-chained-defun ()
+ ;; Check motion by defuns that are chained by "and".
+ (with-temp-buffer
+ (tuareg-mode)
+ (let (p0 p1 p2a p2b p3 p4 p5a p5b p6 p7 p8a p8b)
+ (insert "(* *)\n\n")
+ (setq p0 (point))
+ (insert "type t1 =\n"
+ " A\n")
+ (setq p1 (point))
+ (insert "and t2 =\n"
+ " B\n")
+ (setq p2a (point))
+ (insert "\n")
+ (setq p2b (point))
+ (insert "and t3 =\n"
+ " C\n")
+ (setq p3a (point))
+ (insert "\n")
+ (setq p3b (point))
+ (insert "let f1 x =\n"
+ " aa\n")
+ (setq p4 (point))
+ (insert "and f2 x =\n"
+ " bb\n")
+ (setq p5a (point))
+ (insert "\n")
+ (setq p5b (point))
+ (insert "and f3 x =\n"
+ " let ff1 y =\n"
+ " cc\n"
+ " and ff2 y = (\n")
+ (setq p6 (point))
+ (insert " qq ww) + dd\n"
+ " and ff3 y =\n"
+ " for i = 1 to 10 do\n"
+ " ee;\n")
+ (setq p7 (point))
+ (insert " ff;\n"
+ " done\n")
+ (setq p8a (point))
+ (insert "\n")
+ (setq p8b (point))
+ (insert "exception E\n")
+
+ ;; Walk backwards from the end.
+ (goto-char (point-max))
+ (beginning-of-defun)
+ (should (equal (point) p8b))
+ (beginning-of-defun)
+ (should (equal (point) p5b))
+ (beginning-of-defun)
+ (should (equal (point) p4))
+ (beginning-of-defun)
+ (should (equal (point) p3b))
+ (beginning-of-defun)
+ (should (equal (point) p2b))
+ (beginning-of-defun)
+ (should (equal (point) p1))
+ (beginning-of-defun)
+ (should (equal (point) p0))
+ (beginning-of-defun)
+ (should (equal (point) (point-min)))
+
+ ;; Walk forwards from the beginning.
+ (end-of-defun)
+ (should (equal (point) p1))
+ (end-of-defun)
+ (should (equal (point) p2a))
+ (end-of-defun)
+ (should (equal (point) p3a))
+ (end-of-defun)
+ (should (equal (point) p4))
+ (end-of-defun)
+ (should (equal (point) p5a))
+ (end-of-defun)
+ (should (equal (point) p8a))
+ (end-of-defun)
+ (should (equal (point) (point-max)))
+
+ ;; Jumps from inside a defun.
+ (goto-char p7)
+ (beginning-of-defun)
+ (should (equal (point) p5b))
+
+ (goto-char p6)
+ (end-of-defun)
+ (should (equal (point) p8a)))))
+
(provide 'tuareg-tests)
diff --git a/tuareg.el b/tuareg.el
index 341c3de..ad86866 100644
--- a/tuareg.el
+++ b/tuareg.el
@@ -2362,8 +2362,16 @@ Return a non-nil value if a comment was skipped."
(skip-chars-forward " \t;")
(while (tuareg--skip-forward-comment)))
-(defconst tuareg-starters-syms
- '("type" "d-let" "exception" "module" "class" "val" "external" "open"))
+(defvar-local tuareg-smie--forward-and-cache nil
+ "Alist memoising positions from (smie-forward-sexp \"and\").")
+
+(defvar-local tuareg-smie--backward-and-cache nil
+ "Alist memoising results from (smie-backward-sexp \"and\").")
+
+(defvar-local tuareg-smie--and-cache-tick nil
+ "Buffer-modification tick at which and-caches are valid.
+Applies to `tuareg-smie--forward-and-cache'
+and `tuareg-smie--backward-and-cache'.")
(defun tuareg-backward-beginning-of-defun ()
"Move the point backward to the beginning of a definition.
@@ -2375,45 +2383,94 @@ Return the token starting the phrase (`nil' if it is an
expression)."
(or (looking-at (rx symbol-start))
(/= (skip-syntax-forward "w_") 0)
(tuareg--skip-backward-comments-semicolon))))
- (let ((opoint (point))
- (td (smie-backward-sexp ";;"))) ; for expressions
- (cond
- ((and (car td) (member (nth 2 td) tuareg-starters-syms))
- (goto-char (nth 1 td))
- (nth 2 td))
- (t
- (goto-char opoint)
- (let ((tok nil))
- (while (let ((td (smie-backward-sexp 'halfsexp)))
- (cond
- ((and (car td) (member (nth 2 td) tuareg-starters-syms))
- (goto-char (nth 1 td))
- (setq tok (nth 2 td))
- nil)
- ((and (car td) (string= (nth 2 td) ";;"))
- nil)
- ((and (car td) (not (numberp (car td))))
- (unless (bobp)
- (goto-char (nth 1 td))
- ;; Make sure there is not a preceding ;;
- (let ((tok (tuareg-smie-backward-token)))
- (goto-char (nth 1 td))
- (not (string= tok ";;")))))
- (t t))))
- tok)))))
-
-(defun tuareg--skip-double-semicolon ()
- (tuareg-skip-blank-and-comments)
- (when (looking-at ";;[ \t\n]*")
- (goto-char (match-end 0))))
+ ;; We treat each "and" clause belonging to "d-let" or "type" as defuns
+ ;; in the own right since that is how programmers think about it.
+ (let* ((and-pos nil)
+ (ret-tok nil)
+ (tick (buffer-chars-modified-tick))
+ (cache-valid (eql tuareg-smie--and-cache-tick tick)))
+ (while
+ (and (not (bobp))
+ ;; Memoised call to (smie-backward-exp "and")
+ (let* ((cached
+ (and cache-valid
+ (assq (point) tuareg-smie--backward-and-cache)))
+ (td (if cached
+ (cdr cached)
+ (unless cache-valid
+ (setq tuareg-smie--forward-and-cache nil)
+ (setq tuareg-smie--backward-and-cache nil)
+ (setq tuareg-smie--and-cache-tick tick)
+ (setq cache-valid t))
+ (let* ((pt (point))
+ (r (smie-backward-sexp "and")))
+ (push (cons pt r)
+ tuareg-smie--backward-and-cache)
+ r))))
+ (and (nth 0 td)
+ (let ((tpos (nth 1 td))
+ (tok (nth 2 td)))
+ (cond
+ ;; Arrived at a token that always starts a defun.
+ ((member tok '("type" "d-let" "exception" "module"
+ "class" "val" "external" "open"))
+ (if (and and-pos (member tok '("d-let" "type")))
+ ;; Previously found "and" is the start of the
+ ;; defun: return it.
+ (progn
+ (goto-char and-pos)
+ (setq ret-tok "and"))
+ ;; This is the start of the defun.
+ (goto-char tpos)
+ (setq ret-tok tok))
+ nil)
+ ;; Arrived at "and": keep going backwards to find
+ ;; out whether it was the start of a defun.
+ ((equal tok "and")
+ (unless and-pos
+ (setq and-pos tpos))
+ (goto-char tpos)
+ t)
+ ;; Arrived at "let": keep going backwards.
+ ((equal tok "let")
+ ;; Any previous "and" was not the start of a defun.
+ (setq and-pos nil)
+ (goto-char tpos)
+ t)
+ ;; Other tokens not starting a defun: keep going.
+ ((member tok '(";;" "do" "downto" "to"))
+ (goto-char tpos)
+ t)
+ ;; Left bracket or similar: keep going.
+ ((not (numberp (nth 0 td)))
+ (goto-char tpos)
+ t)
+ ;; Something else: stop.
+ (t nil)))))))
+ ret-tok))
+
+(defun tuareg-smie--forward-sexp-and ()
+ "Memoised (smie-forward-sexp \"and\"), point motion only."
+ (let* ((tick (buffer-chars-modified-tick))
+ (cache-valid (eql tuareg-smie--and-cache-tick tick))
+ (cached (and cache-valid
+ (assq (point) tuareg-smie--forward-and-cache))))
+ (if cached
+ (goto-char (cdr cached))
+ (unless cache-valid
+ (setq tuareg-smie--forward-and-cache nil)
+ (setq tuareg-smie--backward-and-cache nil)
+ (setq tuareg-smie--and-cache-tick tick))
+ (let ((pt (point)))
+ (smie-forward-sexp "and")
+ (push (cons pt (point)) tuareg-smie--forward-and-cache)))))
(defun tuareg-end-of-defun ()
"Assuming that we are at the beginning of a definition, move to its end.
See variable `end-of-defun-function'."
(interactive)
- (let ((td (smie-forward-sexp ";;"))) ; for expressions
- (when (member (nth 2 td) tuareg-starters-syms)
- (smie-forward-sexp 'halfsexp)))
+ (tuareg-smie--forward-token) ; Skip the head token.
+ (tuareg-smie--forward-sexp-and)
(tuareg--skip-forward-comments-semicolon))
(defun tuareg-beginning-of-defun (&optional arg)
