[nongnu] elpa/haskell-tng-mode 2a2afee 064/385: cache invalidation and tests for layout invalidation

[ELPA Syncer]

branch: elpa/haskell-tng-mode
commit 2a2afee0494acf844584f9575059344bdb9bf793
Author: Tseen She <ts33n.sh3@gmail.com>
Commit: Tseen She <ts33n.sh3@gmail.com>

    cache invalidation and tests for layout invalidation
---
 haskell-tng-layout.el              |   7 ++-
 haskell-tng-smie.el                | 102 +++++++++++++++++++++++--------------
 test/haskell-tng-font-lock-test.el |   4 +-
 test/haskell-tng-layout-test.el    |  21 +++++++-
 test/haskell-tng-smie-test.el      |  10 ++--
 test/haskell-tng-testutils.el      |  13 ++---
 6 files changed, 105 insertions(+), 52 deletions(-)

diff --git a/haskell-tng-layout.el b/haskell-tng-layout.el
index f1f9672..0fb8480 100644
--- a/haskell-tng-layout.el
+++ b/haskell-tng-layout.el
@@ -37,7 +37,12 @@
 ;; Easiest cache... full buffer parse with full invalidation on any insertion.
 (defvar-local haskell-tng-layout:cache nil)
 
-;; TODO invalidate the cache on change
+(defun haskell-tng-layout:cache-invalidation (_beg _end _pre-length)
+  "For use in `after-change-functions' to invalidate the state of
+the layout engine."
+  (when haskell-tng-layout:cache
+    (message "INVALIDATING LAYOUT CACHE")
+    (setq haskell-tng-layout:cache nil)))
 
 ;; TODO a visual debugging option would be great, showing virtuals as overlays
 
diff --git a/haskell-tng-smie.el b/haskell-tng-smie.el
index 32591bc..f42afbc 100644
--- a/haskell-tng-smie.el
+++ b/haskell-tng-smie.el
@@ -27,10 +27,20 @@
 ;; The list of virtual tokens that must be played back at point, or `t' to
 ;; indicate that virtual tokens have already been played back at point and
 ;; normal lexing may continue.
-;;
-;; TODO: invalidate this state when the lexer jumps around or the user edits
 (defvar-local haskell-tng-smie:virtuals nil)
 
+;; A cons cell of the last known direction and point when forward or backward
+;; lexing was called. Used to invalidate `haskell-tng-smie:virtuals' during
+;; read-only navigation.
+(defvar-local haskell-tng-smie:last nil)
+
+(defun haskell-tng-smie:virtuals-invalidation (_beg _end _pre-length)
+  "For use in `after-change-functions' to invalidate the state of
+the lexer."
+  (when haskell-tng-smie:virtuals
+    (message "INVALIDATING SMIE VIRTUALS")
+    (setq haskell-tng-smie:virtuals nil)))
+
 ;; Implementation of `smie-forward-token' for Haskell, i.e.
 ;;
 ;; - Called with no argument should return a token and move to its end.
@@ -44,41 +54,51 @@
 ;; virtual tokens at a single point. This lexer could be made stateless if SMIE
 ;; were to support a 4th return type: a list of any of the above.
 (defun haskell-tng-smie:forward-token ()
-  (let (case-fold-search)
-    (if (consp haskell-tng-smie:virtuals)
-        ;; continue replaying virtual tokens
-        (haskell-tng-smie:replay-virtual)
-
-      (forward-comment (point-max))
-      ;; TODO: performance. Only request virtuals when they make sense... e.g.
-      ;; on newlines, or following a WLDO (assuming a lookback is faster).
-      (setq haskell-tng-smie:virtuals
-            (and (not haskell-tng-smie:virtuals)
-                 (haskell-tng-layout:virtuals-at-point)))
-      (cond
-       ;; new virtual tokens
-       (haskell-tng-smie:virtuals
-        (haskell-tng-smie:replay-virtual))
-
-       ;; syntax tables (supported by `smie-indent-forward-token')
-       ((looking-at (rx (| (syntax open-parenthesis)
-                           (syntax close-parenthesis)
-                           (syntax string-quote)
-                           (syntax string-delimiter))))
-        nil)
-
-       ;; regexps
-       ((or
-         ;; known identifiers
-         (looking-at haskell-tng:regexp:reserved)
-         ;; symbols
-         (looking-at (rx (+ (| (syntax word) (syntax symbol))))))
-        (haskell-tng-smie:last-match))
-
-       ;; single char
-       (t
-        (forward-char)
-        (string (char-before)))))))
+  (unwind-protect
+      (let (case-fold-search)
+        (when (and haskell-tng-smie:virtuals
+                   (not (equal haskell-tng-smie:last `(forward . ,(point)))))
+          (message "INVALIDATING SMIE VIRTUALS DUE TO JUMP")
+          (setq haskell-tng-smie:virtuals nil))
+
+        (if (consp haskell-tng-smie:virtuals)
+            ;; continue replaying virtual tokens
+            (haskell-tng-smie:replay-virtual)
+
+          (forward-comment (point-max))
+          ;; TODO: performance. Only request virtuals when they make sense...
+          ;; e.g. on newlines, or following a WLDO (assuming a lookback is
+          ;; faster).
+          (setq haskell-tng-smie:virtuals
+                (and (not haskell-tng-smie:virtuals)
+                     (haskell-tng-layout:virtuals-at-point)))
+          (cond
+           ;; new virtual tokens
+           (haskell-tng-smie:virtuals
+            (haskell-tng-smie:replay-virtual))
+
+           ;; syntax tables (supported by `smie-indent-forward-token')
+           ((looking-at (rx (| (syntax open-parenthesis)
+                               (syntax close-parenthesis)
+                               (syntax string-quote)
+                               (syntax string-delimiter))))
+            nil)
+
+           ;; regexps
+           ((or
+             ;; known identifiers
+             (looking-at haskell-tng:regexp:reserved)
+             ;; symbols
+             (looking-at (rx (+ (| (syntax word) (syntax symbol))))))
+            (haskell-tng-smie:last-match))
+
+           ;; single char
+           (t
+            (forward-char)
+            (string (char-before))))))
+
+    ;; save the state
+    (setq haskell-tng-smie:last `(forward . ,(point)))))
 
 (defun haskell-tng-smie:replay-virtual ()
   ";; read a virtual token from state, set 't when all done"
@@ -116,6 +136,14 @@
 (defvar haskell-tng-smie:rules nil)
 
 (defun haskell-tng-smie:setup ()
+  (add-to-list
+   'after-change-functions
+   #'haskell-tng-layout:cache-invalidation)
+
+  (add-to-list
+   'after-change-functions
+   #'haskell-tng-smie:virtuals-invalidation)
+
   (smie-setup
    haskell-tng-smie:grammar
    haskell-tng-smie:rules
diff --git a/test/haskell-tng-font-lock-test.el 
b/test/haskell-tng-font-lock-test.el
index 059fbd6..e4af4b9 100644
--- a/test/haskell-tng-font-lock-test.el
+++ b/test/haskell-tng-font-lock-test.el
@@ -24,9 +24,9 @@
 
 ;; to generate .faceup files, use faceup-view-buffer
 (ert-deftest haskell-tng-font-lock-file-tests ()
-  (should (have-expected-faces "src/medley.hs"))
+  (should (have-expected-faces (testdata "src/medley.hs")))
 
-  (should (have-expected-faces "src/layout.hs"))
+  (should (have-expected-faces (testdata "src/layout.hs")))
   )
 
 ;;; haskell-tng-font-lock-test.el ends here
diff --git a/test/haskell-tng-layout-test.el b/test/haskell-tng-layout-test.el
index 2217e1f..47ef63d 100644
--- a/test/haskell-tng-layout-test.el
+++ b/test/haskell-tng-layout-test.el
@@ -32,9 +32,26 @@
 
 (ert-deftest haskell-tng-layout-file-tests ()
   ;; the Haskell2010 test case
-  (should (have-expected-layout "src/layout.hs"))
+  (should (have-expected-layout (testdata "src/layout.hs")))
 
-  (should (have-expected-layout "src/medley.hs"))
+  (should (have-expected-layout (testdata "src/medley.hs")))
   )
 
+(ert-deftest haskell-tng-layout-cache-invalidation-tests ()
+  (with-temp-buffer
+    (insert-file-contents (testdata "src/layout.hs"))
+    (haskell-tng-mode)
+
+    (goto-char 317)
+    (should
+     (equal
+      (haskell-tng-layout:virtuals-at-point)
+      '(";")))
+
+    (insert " ")
+    (goto-char 317)
+    (should
+     (not
+      (haskell-tng-layout:virtuals-at-point)))))
+
 ;;; haskell-tng-layout-test.el ends here
diff --git a/test/haskell-tng-smie-test.el b/test/haskell-tng-smie-test.el
index 59a537d..faffc41 100644
--- a/test/haskell-tng-smie-test.el
+++ b/test/haskell-tng-smie-test.el
@@ -61,13 +61,15 @@ When called interactively, shows the tokens in a buffer."
    #'haskell-tng-smie-test:parse-to-string
    "lexer"))
 
-;; TODO the backwards test should simply assert consistency
-
 (ert-deftest haskell-tng-smie-file-tests ()
-  (should (have-expected-forward-lex "src/medley.hs"))
-  (should (have-expected-forward-lex "src/layout.hs"))
+  (should (have-expected-forward-lex (testdata "src/medley.hs")))
+  (should (have-expected-forward-lex (testdata "src/layout.hs")))
   )
 
+;; TODO the backwards test should assert consistency with forward
+
+;; FIXME test for cache invalidation
+
 ;; ideas for an indentation tester
 ;; 
https://github.com/elixir-editors/emacs-elixir/blob/master/test/test-helper.el#L52-L63
 
diff --git a/test/haskell-tng-testutils.el b/test/haskell-tng-testutils.el
index cacf54f..86c9f0a 100644
--- a/test/haskell-tng-testutils.el
+++ b/test/haskell-tng-testutils.el
@@ -20,16 +20,12 @@
   "For FILE, enable MODE and run TO-STRING and compare with the golden data in 
FILE.SUFFIX.
 
 Will fail and write out the expected version to FILE.SUFFIX."
-  (let* ((backup-inhibited t)
-         (filename (expand-file-name
-                    file
-                    (haskell-tng-testutils:this-lisp-directory)))
-         (golden (concat filename "." suffix))
+  (let* ((golden (concat file "." suffix))
          (expected (with-temp-buffer
                      (insert-file-contents golden)
                      (buffer-string)))
          (got (with-temp-buffer
-                  (insert-file-contents filename)
+                  (insert-file-contents file)
                   (funcall mode)
                   (funcall to-string))))
     (or (equal got expected)
@@ -38,5 +34,10 @@ Will fail and write out the expected version to FILE.SUFFIX."
           (write-region got nil golden)
           nil))))
 
+(defun testdata (file)
+  (expand-file-name
+   file
+   (haskell-tng-testutils:this-lisp-directory)))
+
 (provide 'haskell-tng-testutils)
 ;;; haskell-tng-testutils.el ends here