[nongnu] elpa/tuareg 75c1ffc 1/7: Make beginning-of-defun (C-M-a) repeatable

[ELPA Syncer]

branch: elpa/tuareg
commit 75c1ffc1cf07657d274a11a1f43be9e98106bd05
Author: Mattias Engdegård <mattiase@acm.org>
Commit: Stefan Monnier <monnier@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))