branch: elpa/haskell-tng-mode
commit 2a2afee0494acf844584f9575059344bdb9bf793
Author: Tseen She <ts33n....@gmail.com>
Commit: Tseen She <ts33n....@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
