branch: elpa/tuareg
commit 75c1ffc1cf07657d274a11a1f43be9e98106bd05
Author: Mattias Engdegård <matti...@acm.org>
Commit: Stefan Monnier <monn...@iro.umontreal.ca>
Make beginning-of-defun (C-M-a) repeatable
Ensure that `tuareg-beginning-of-defun` right at the beginning of a
defun moves point to the beginning of the previous defun rather than
being a no-op (issue #236). Also make the return value is correct for
a `beginning-of-defun-function`, as well as the semantics for negative
arguments.
Add tests, which are run automatically as part of Travis CI, or
manually by `make check-ert` or M-x ert.
---
.travis.yml | 1 +
Makefile | 6 +++-
tuareg-tests.el | 80 +++++++++++++++++++++++++++++++++++++++++++++++
tuareg.el | 96 +++++++++++++++++++++++++++++++++------------------------
4 files changed, 141 insertions(+), 42 deletions(-)
diff --git a/.travis.yml b/.travis.yml
index 4eac1ef..491b08b 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -19,6 +19,7 @@ before_install:
script:
- emacs --version
- make elc
+ - make check-ert
- make indent-test
notifications:
diff --git a/Makefile b/Makefile
index eb0393c..7e23a23 100644
--- a/Makefile
+++ b/Makefile
@@ -65,7 +65,11 @@ uninstall :
.PHONY: refresh
refresh:
-check : sample.ml.test
+check : sample.ml.test check-ert
+
+.PHONY: check-ert
+check-ert:
+ $(EMACS) -batch -Q -L . -l tuareg-tests -f ert-run-tests-batch-and-exit
%.test: % $(ELC) refresh
@echo ====Indent $*====
diff --git a/tuareg-tests.el b/tuareg-tests.el
new file mode 100644
index 0000000..70cb7a4
--- /dev/null
+++ b/tuareg-tests.el
@@ -0,0 +1,80 @@
+;;; tests for tuareg.el -*- lexical-binding: t -*-
+
+(require 'tuareg)
+(require 'ert)
+
+(ert-deftest tuareg-beginning-of-defun ()
+ ;; Check that `beginning-of-defun' works as expected: move backwards
+ ;; to the beginning of the current top-level definition (defun), or
+ ;; the previous one if already at the beginning; return t if one was
+ ;; found, nil if none.
+ (with-temp-buffer
+ (tuareg-mode)
+ (let (p1 p2 p3 p4)
+ (insert "(* first line *)\n\n")
+ (setq p1 (point))
+ (insert "type ty =\n"
+ " | Goo\n"
+ " | Baa of int\n\n")
+ (setq p2 (point))
+ (insert "let a = ho hum\n"
+ ";;\n\n")
+ (setq p3 (point))
+ (insert "let g u =\n"
+ " while mo ma do\n"
+ " we wo;\n")
+ (setq p4 (point))
+ (insert " ze zo\n"
+ " done\n")
+
+ ;; Check without argument.
+ (goto-char p4)
+ (should (equal (beginning-of-defun) t))
+ (should (equal (point) p3))
+ (should (equal (beginning-of-defun) t))
+ (should (equal (point) p2))
+ (should (equal (beginning-of-defun) t))
+ (should (equal (point) p1))
+ (should (equal (beginning-of-defun) nil))
+ (should (equal (point) (point-min)))
+
+ ;; Check with positive argument.
+ (goto-char p4)
+ (should (equal (beginning-of-defun 1) t))
+ (should (equal (point) p3))
+ (goto-char p4)
+ (should (equal (beginning-of-defun 2) t))
+ (should (equal (point) p2))
+ (goto-char p4)
+ (should (equal (beginning-of-defun 3) t))
+ (should (equal (point) p1))
+ (goto-char p4)
+ (should (equal (beginning-of-defun 4) nil))
+ (should (equal (point) (point-min)))
+
+ ;; Check with negative argument.
+ (goto-char (point-min))
+ (should (equal (beginning-of-defun -1) t))
+ (should (equal (point) p1))
+ (should (equal (beginning-of-defun -1) t))
+ (should (equal (point) p2))
+ (should (equal (beginning-of-defun -1) t))
+ (should (equal (point) p3))
+ (should (equal (beginning-of-defun -1) nil))
+ (should (equal (point) (point-max)))
+
+ (goto-char (point-min))
+ (should (equal (beginning-of-defun -2) t))
+ (should (equal (point) p2))
+ (goto-char (point-min))
+ (should (equal (beginning-of-defun -3) t))
+ (should (equal (point) p3))
+ (goto-char (point-min))
+ (should (equal (beginning-of-defun -4) nil))
+ (should (equal (point) (point-max)))
+
+ ;; We don't test with a zero argument as the behaviour for that
+ ;; case does not seem to be very well-defined.
+ )))
+
+(provide 'tuareg-tests)
diff --git a/tuareg.el b/tuareg.el
index 9448b7e..341c3de 100644
--- a/tuareg.el
+++ b/tuareg.el
@@ -1908,7 +1908,7 @@ Return values can be
(t t)))))))
(defun tuareg-smie-backward-token ()
- "Move point to the beginning of the next token and return its SMIE name."
+ "Move point to the beginning of the previous token and return its SMIE name."
(let ((tok (tuareg-smie--backward-token)))
(cond
;; Distinguish a let expression from a let declaration.
@@ -2371,38 +2371,36 @@ Return the token starting the phrase (`nil' if it is an
expression)."
(let ((state (syntax-ppss)))
(if (nth 3 state); in a string
(goto-char (nth 8 state))
- ;; If on a word (e.g., "let" or "end"), move to the end of it.
- ;; In particular, even if at the beginning of the "let" of a
- ;; definition, one will not jump to the previous one.
- (or (/= (skip-syntax-forward "w_") 0)
+ ;; If inside a word (e.g., "let" or "end"), move to the end of it.
+ (or (looking-at (rx symbol-start))
+ (/= (skip-syntax-forward "w_") 0)
(tuareg--skip-backward-comments-semicolon))))
- (let (td tok
- (opoint (point)))
- (setq td (smie-backward-sexp ";;")); for expressions
+ (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)) (setq tok (nth 2 td)))
- ((and (car td) (string= (nth 2 td) ";;")))
+ (goto-char (nth 1 td))
+ (nth 2 td))
(t
(goto-char opoint)
- (while (progn
- (setq 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)
+ (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))
- ;; Make sure there is not a preceding ;;
- (setq opoint (point))
- (let ((tok (tuareg-smie-backward-token)))
- (goto-char opoint)
- (not (string= tok ";;")))))
- (t t))))))
- tok))
+ (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)
@@ -2423,20 +2421,36 @@ See variable `end-of-defun-function'."
See variable `beginning-of-defun-function'."
(interactive "^P")
(unless arg (setq arg 1))
- (cond
- ((> arg 0)
- (while (and (> arg 0) (not (bobp)))
- (tuareg-backward-beginning-of-defun)
- (cl-decf arg)))
- (t
- (tuareg-backward-beginning-of-defun)
- (unless (bobp) (tuareg-end-of-defun))
- (while (and (< arg 0) (not (eobp)))
- (tuareg--skip-double-semicolon)
- (smie-forward-sexp 'halfsexp)
- (cl-incf arg))
- (tuareg-backward-beginning-of-defun)))
- t); whether an experssion or a def, we found something.
+ (let ((ret t))
+ (cond
+ ((>= arg 0)
+ (while (and (> arg 0) ret)
+ (unless (tuareg-backward-beginning-of-defun)
+ (setq ret nil))
+ (cl-decf arg)))
+ (t
+ (while (and (< arg 0) ret)
+ (let ((start (point)))
+ (tuareg-end-of-defun)
+ (skip-chars-forward " \t\n")
+ (tuareg--skip-forward-comments-semicolon)
+ (let ((end (point)))
+ (tuareg-backward-beginning-of-defun)
+ ;; Did we make forward progress?
+ (when (<= (point) start)
+ ;; No, try again.
+ (goto-char end)
+ (tuareg-end-of-defun)
+ (skip-chars-forward " \t\n")
+ (tuareg--skip-forward-comments-semicolon)
+ (tuareg-backward-beginning-of-defun)
+ ;; This time?
+ (when (<= (point) start)
+ ;; No, no more defuns.
+ (goto-char (point-max))
+ (setq ret nil)))))
+ (cl-incf arg))))
+ ret))
(defun tuareg-skip-siblings ()
(while (and (not (bobp))
