[nongnu] elpa/haskell-tng-mode 387aa18 203/385: more efficient layout algorithm

[ELPA Syncer]

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

    more efficient layout algorithm
---
 haskell-tng-layout.el           | 177 +++++++++++++++++++++++++++-------------
 haskell-tng-lexer.el            |   5 --
 test/haskell-tng-layout-test.el |  43 ++++++++--
 3 files changed, 153 insertions(+), 72 deletions(-)

diff --git a/haskell-tng-layout.el b/haskell-tng-layout.el
index 08fe7ce..1f49b78 100644
--- a/haskell-tng-layout.el
+++ b/haskell-tng-layout.el
@@ -19,26 +19,25 @@
 
 ;; Notes on caching
 ;;
-;; Small brain is to parse the entire buffer, invalidated on any change.
+;; Small brain parses the entire buffer, invalidated by any change.
 ;;
-;; Big brain would store a record of the region that has been edited and 
reparse
-;; only the layouts that have changed. The invalidation may be a simple case of
-;; dismissing everything (including CLOSE parts) after any point that has been
-;; edited or trying to track insertions.
+;; Big brain parses toplevel regions of interest, invalidated by any changes.
+;; This is what we do.
 ;;
 ;; Galaxy brain caching would use properties and put dirty markers on inserted
-;; or deleted regions. Also this could give lightning fast lookup at point on
-;; cache hits.
-;;
-;; Anything more complicated that small brain needs improved testing.
+;; or deleted regions. Would give fast lookup at point.
 
 (require 'dash)
 
 (require 'haskell-tng-util)
 
-;; Easiest cache... full buffer parse with full invalidation on any insertion.
+;; A alist of lists of (OPEN . (CLOSE . SEPS)) positions, keyed by (START . 
END)
+;;
+;; Regions are exclusive of START and inclusive of END, and do not overlap. 
This
+;; is because START would only ever contain CLOSE or SEP, not OPEN.
 ;;
-;; A list of (OPEN . (CLOSE . SEPS)) positions, one per inferred block.
+;; Instead of a list, may also be t, indicating that there is no relevant 
layout
+;; in a region.
 (defvar-local haskell-tng--layout-cache nil)
 
 (defun haskell-tng--layout-cache-invalidation (_beg _end _pre-length)
@@ -56,61 +55,124 @@ the layout engine."
 Haskell2010 Layout rules.
 
 Designed to be called repeatedly, managing its own caching."
-  (unless haskell-tng--layout-cache
-    (haskell-tng--layout-rebuild-cache-full))
-
-  (let ((pos (point))
-        opens breaks closes)
-    (dolist (block haskell-tng--layout-cache)
-      (let ((open (car block))
-            (close (cadr block))
-            (lines (cddr block)))
-        (when (and (<= open pos) (<= pos close))
-          (when (= open pos)
-            (push "{" opens))
-          (when (= close pos)
-            (push "}" closes))
-          (dolist (line lines)
-            (when (= line pos)
-              (push ";" breaks))))))
-    (append opens closes breaks)))
+  (when-let (cache (haskell-tng--layout-at-point))
+    (let ((pos (point))
+          opens breaks closes)
+      (dolist (block cache)
+        (pcase block
+          (`(,open . (,close . ,seps))
+           (when (and open (= open pos))
+             (push "{" opens))
+           (when (and close (= close pos))
+             (push "}" closes))
+           (dolist (sep seps)
+             (when (= sep pos)
+               (push ";" breaks))))))
+      (append opens closes breaks))))
 
 (defun haskell-tng--layout-has-virtual-at-point ()
   "t if there is a virtual at POINT"
   ;; avoids a measured performance hit (append indentation)
-  (unless haskell-tng--layout-cache
-    (haskell-tng--layout-rebuild-cache-full))
-  (--any (member (point) it)
-         haskell-tng--layout-cache))
-
-(defun haskell-tng--layout-rebuild-cache-full ()
-  (let (case-fold-search
-        cache)
-    (save-excursion
-      (goto-char 0)
-      (while (not (eobp))
-        (when-let (wldo (haskell-tng--layout-next-wldo))
-          (push wldo cache))))
-    (setq haskell-tng--layout-cache (reverse cache))))
-
-(defun haskell-tng--layout-next-wldo ()
+  (when-let (cache (haskell-tng--layout-at-point))
+    (--any (member (point) it) cache)))
+
+(defun haskell-tng--layout-at-point ()
+  "Returns the relevant virtual tokens for the current point,
+using a cache if available."
+  (when-let
+      (layout (or
+               (cdr (--find
+                     (and (<  (caar it) (point))
+                          (<= (point) (cdar it)))
+                     haskell-tng--layout-cache))
+               (haskell-tng--layout-rebuild-cache-at-point)))
+    (unless (eq layout t) layout)))
+
+(defun haskell-tng--layout-rebuild-cache-at-point ()
+  (let ((toplevel (rx bol (or word-start "("))))
+    (if (and (looking-at toplevel) (not (bobp)))
+        ;; min is exclusive, so go back one.
+        (save-excursion
+          (forward-char -1)
+          (haskell-tng--layout-rebuild-cache-at-point))
+     (let* ((min
+          (save-excursion
+            (end-of-line 1)
+            (or (re-search-backward toplevel nil t) 0)))
+         (max
+          (save-excursion
+            (end-of-line 1)
+            (or (and (re-search-forward toplevel nil t)
+                     (match-beginning 0))
+                (point-max))))
+         (module
+          (save-excursion
+            (goto-char min)
+            (looking-at (rx word-start "module" word-end))))
+         (before-module
+          (save-excursion
+            (goto-char max)
+            (looking-at (rx word-start "module" word-end))))
+         case-fold-search
+         cache)
+
+    ;; `module ... where { ... }' special cases:
+    ;;
+    ;; 1. before module, nothing
+    ;; 2. after module, only an open
+    ;; 3. eob, extra close
+    ;; 4. everywhere else, extra sep
+    (when module
+      (push `(,max nil) cache))
+    (when (not (or module before-module))
+      (if (eq max (point-max))
+          (push `(nil ,max) cache)
+        (push `(nil nil ,max) cache))
+      (save-excursion
+        (goto-char min)
+        (while (< (point) max)
+          (when-let (wldo (haskell-tng--layout-next-wldo max))
+            (push wldo cache)))))
+
+    ;; TODO remove this sanity check when we are happy
+    ;; a sanity check that all points are within the bounds
+    (cl-flet ((good (type p)
+                    (when (and p (or (<= p min) (< max p)))
+                      (message "BUG: LAYOUT %S at %S" type p))))
+      (dolist (block cache)
+        (pcase block
+          (`(,open . (,close . ,seps))
+           (good 'OPEN open)
+           (good 'CLOSE close)
+           (dolist (sep seps)
+             (good 'SEP sep))))))
+
+    (let ((key (cons min max))
+          (value (or (reverse cache) t)))
+      (push (cons key value) haskell-tng--layout-cache)
+      value)))))
+
+(defun haskell-tng--layout-next-wldo (limit)
   (catch 'wldo
-    (while (not (eobp))
-      (forward-comment (point-max))
+    (while (< (point) limit)
+      (forward-comment limit)
       (cond
        ((looking-at (rx symbol-start
                         (| "\\case" ;; LambdaCase
                            "where" "let" "do" "of")
                         word-end))
         (goto-char (match-end 0))
-        (forward-comment (point-max))
+        (forward-comment limit)
         (when (not (looking-at "{"))
-          (throw 'wldo (haskell-tng--layout-wldo))))
+          (throw 'wldo (haskell-tng--layout-wldo
+                        (min (or (haskell-tng--util-paren-close) (point-max))
+                             limit)))))
 
        (t (skip-syntax-forward "^-"))))))
 
-(defun haskell-tng--layout-wldo ()
-  "A list holding virtual `{', then `}', then virtual `;' in order.
+(defun haskell-tng--layout-wldo (limit)
+  "A list holding virtual `{', then `}', then virtual `;' in
+order between point and LIMIT.
 
 Assumes that point is at the beginning of the first token after a
 WLDO that is using the offside rule."
@@ -118,21 +180,20 @@ WLDO that is using the offside rule."
     (let* ((open (point))
            seps
            (level (current-column))
-           (limit (or (haskell-tng--util-paren-close) (point-max)))
            (close (catch 'closed
-                    (while (not (eobp))
+                    (while (< (point) limit)
                       (forward-line)
-                      (forward-comment (point-max))
-                      (when (and (= (current-column) level)
-                                 (not (eobp))
+                      (forward-comment limit)
+                      (when (and (< (point) limit)
+                                 (= (current-column) level)
                                  (not (looking-at
                                        (rx bol (or "," ")" "]" "}")))))
                         (push (point) seps))
-                      (when (< limit (point))
+                      (when (<= limit (point))
                         (throw 'closed limit))
                       (when (< (current-column) level)
                         (throw 'closed (point))))
-                    (point-max))))
+                    limit)))
       `(,open . (,close . ,(reverse seps))))))
 
 (provide 'haskell-tng-layout)
diff --git a/haskell-tng-lexer.el b/haskell-tng-lexer.el
index d21701a..5f6eda0 100644
--- a/haskell-tng-lexer.el
+++ b/haskell-tng-lexer.el
@@ -84,9 +84,6 @@ the lexer."
 
           (forward-comment (point-max))
 
-          ;; TODO: performance. Only request virtuals when they make sense...
-          ;; e.g. on newlines, or following a WLDO (assuming a comment-aware
-          ;; lookback is fast).
           (setq haskell-tng--lexer-state
                 (unless haskell-tng--lexer-state
                   (haskell-tng--layout-virtuals-at-point)))
@@ -159,8 +156,6 @@ the lexer."
 
           (setq haskell-tng--lexer-state
                 (unless haskell-tng--lexer-state
-                  ;; TODO semicolon cannot be used as a separator and a line 
end
-                  ;; in the grammar rules, so should we emit multiple tokens?
                   (haskell-tng--layout-virtuals-at-point)))
 
           (if haskell-tng--lexer-state
diff --git a/test/haskell-tng-layout-test.el b/test/haskell-tng-layout-test.el
index 7c6f485..c1a94a3 100644
--- a/test/haskell-tng-layout-test.el
+++ b/test/haskell-tng-layout-test.el
@@ -13,28 +13,34 @@
 
 (ert-deftest haskell-tng-layout-file-tests:layout ()
   ;; the Haskell2010 test case
-  (should (have-expected-layout (testdata "src/layout.hs"))))
+  (should (have-expected-layout (testdata "src/layout.hs")))
+  (should (have-expected-layout-reverse (testdata "src/layout.hs"))))
 
 (ert-deftest haskell-tng-layout-file-tests:indentation ()
-  (should (have-expected-layout (testdata "src/indentation.hs"))))
+  (should (have-expected-layout (testdata "src/indentation.hs")))
+  (should (have-expected-layout-reverse (testdata "src/indentation.hs"))))
 
 (ert-deftest haskell-tng-layout-file-tests:medley ()
-  (should (have-expected-layout (testdata "src/medley.hs"))))
+  (should (have-expected-layout (testdata "src/medley.hs")))
+  (should (have-expected-layout-reverse (testdata "src/medley.hs"))))
 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Testing utilities
 
-(defun haskell-tng--layout-test-parse-to-string ()
-  (goto-char 0)
+(defun haskell-tng--layout-test-parse-to-string (&optional reverse)
+  (if reverse
+      (goto-char (point-max))
+    (goto-char 0))
   (let (tokens exit)
     (while (not exit)
       (when-let (virtuals (haskell-tng--layout-virtuals-at-point))
         (push (s-join "" virtuals) tokens))
-      (if (eobp)
+      (if (or (and (not reverse) (eobp))
+              (and reverse (bobp)))
           (setq exit t)
-        (push (string (char-after)) tokens)
-        (forward-char)))
-    (s-join "" (reverse tokens))))
+        (push (string (if reverse (char-before) (char-after))) tokens)
+        (forward-char (if reverse -1 1))))
+    (s-join "" (if reverse tokens (reverse tokens)))))
 
 (defun have-expected-layout (file)
   (haskell-tng--testutils-assert-file-contents
@@ -42,6 +48,25 @@
    #'haskell-tng-mode
    #'haskell-tng--layout-test-parse-to-string
    "layout"))
+(defun have-expected-layout-reverse (file)
+  (haskell-tng--testutils-assert-file-contents
+   file
+   #'haskell-tng-mode
+   (lambda () (haskell-tng--layout-test-parse-to-string t))
+   "layout"))
+
+(ert-deftest haskell-tng-layout-cache-ordering-tests ()
+  (with-temp-buffer
+    (insert-file-contents (testdata "src/layout.hs"))
+    (haskell-tng-mode)
+
+    ;; Differs from the regular layout test because the cache is empty. We 
could
+    ;; do a more intensive version of this by randomly sampling the points.
+    (goto-char 94)
+    (should
+     (equal
+      (haskell-tng--layout-virtuals-at-point)
+      '("{")))))
 
 (ert-deftest haskell-tng-layout-cache-invalidation-tests ()
   (with-temp-buffer