[nongnu] elpa/haskell-tng-mode cb801b4 015/385: moar multiline type search

[ELPA Syncer]

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

    moar multiline type search
---
 haskell-tng-font-lock.el | 135 ++++++++++++++++++++++++++---------------------
 1 file changed, 75 insertions(+), 60 deletions(-)

diff --git a/haskell-tng-font-lock.el b/haskell-tng-font-lock.el
index 9f1fe88..8b48c34 100644
--- a/haskell-tng-font-lock.el
+++ b/haskell-tng-font-lock.el
@@ -72,9 +72,28 @@
   `(: line-start (group (| (: (any lower ?_) (* wordchar))
                            (: "(" (+? (syntax symbol)) ")")))
       symbol-end))
+;; note that \n has syntax `comment-end'
+(defconst haskell-tng:newline
+  '(| (syntax comment-end)
+      (: symbol-start
+         "--"
+         (+ (not (syntax comment-end)))
+         (+ (syntax comment-end))))
+  "Newline or line comment.")
+;; note that type matching must be bounded for inline occurences
+(defconst haskell-tng:type
+  ;; TODO literal types and generic lists ... eek!
+  (let ((typepart `(| (+ (any ?\( ?\)))
+                      (+ (any lower ?_))
+                      (: (opt ,haskell-tng:qual)
+                         (| "::" ,haskell-tng:conid ,haskell-tng:consym)))))
+    `(: (opt ,haskell-tng:newline) (+ (| space ,typepart))
+        (* (opt ,haskell-tng:newline (+ space)) "->" (+ (| space ,typepart)))))
+  "An explicit type")
 
 ;; TODO a macro that wraps these consts with short-form names
 
+;; TODO use the levels support so users can turn off type fontification
 (setq
  haskell-tng:keywords
  ;; These regexps use the `rx' library so we can reuse common subpatterns. It
@@ -159,8 +178,14 @@
 
      )))
 
-;; TODO: consider previous/next symbol instead of the default whole line
-;; detection in font-lock-extend-region-functions for super duper hyper perf.
+(defvar haskell-tng:explicit-type-regex
+  (rx-to-string `(: point "::" (* space) ,haskell-tng:type))
+  "Cache of a regex internal to `haskell-tng:explicit-type'")
+(defun haskell-tng:explicit-type ()
+  "Matches an explicit type at point, bounded by a closing paren."
+  (re-search-forward
+   haskell-tng:explicit-type-regex
+   (or (haskell-tng:paren-close) (point-max)) t))
 
 (eval-when-compile
   ;; available inside font-lock-extend-region-functions procedures.
@@ -168,16 +193,17 @@
   (defvar font-lock-beg)
   (defvar font-lock-end))
 
-;; TODO optimise extend-parens-* to module / import / types
+;; TODO optimise extend-parens-* to just module / import / types
 (defun haskell-tng:extend-parens-open ()
   "For use in `font-lock-extend-region-functions'.
 Expand the region to include the opening parenthesis.
 The caller loops until everything is opened."
   (goto-char font-lock-beg)
   ;; TODO: exit early if in comment
+  ;; TODO: use a bounded search-backward to exclude non-package characters
   (when-let (open (nth 1 (syntax-ppss)))
-    (when (and (goto-char open)
-               (looking-at "("))
+    (goto-char open)
+    (when (looking-at "(")
       ;;(haskell-tng:debug-extend (point))
       (setq font-lock-beg (point)))))
 
@@ -187,69 +213,54 @@ Expand the region to include a closing parenthesis.
 The caller loops until everything is closed."
   (goto-char font-lock-end)
   ;; TODO: exit early if in comment
-  (when-let (open (nth 1 (syntax-ppss)))
-    (when (and (goto-char open)
-               (looking-at "(")
-               (goto-char font-lock-end)
-               (re-search-forward ")" (point-max) t))
-      ;;(haskell-tng:debug-extend (point))
-      (setq font-lock-end (point)))))
+  ;; TODO: use a bounded search-forward to exclude non-package characters
+  (when-let (close (haskell-tng:paren-close))
+    ;;(haskell-tng:debug-extend (point))
+    (setq font-lock-end (+ 1 close))))
+
+(defun haskell-tng:paren-close ()
+  "Return the position of the next `)', if it closes the current paren depth."
+  (interactive) ;; TODO for manual testing
+  (save-excursion
+    (when-let (close (ignore-errors (scan-lists (point) 1 1)))
+      (goto-char (- close 1))
+      (when (looking-at ")")
+        (point)))))
 
 (defun haskell-tng:extend-type-open ()
   "For use in `font-lock-extend-region-functions'.
 Ensures that multiline type signatures are opened."
   (goto-char font-lock-beg)
   ;; TODO: exit early if in comment
-  (when (and (re-search-forward
-              (rx symbol-start "->" symbol-end)
-              font-lock-end t)
-             (re-search-backward
-              (rx symbol-start "::" symbol-end)
-              (point-min) t))
-    (goto-char (match-beginning 0))
-    (let ((beg (point)))
-      (haskell-tng:type-end)
-      (when (< font-lock-beg (point))
-        (haskell-tng:debug-extend beg)
-        (setq font-lock-beg beg)
-        (when (< font-lock-end (point))
-          (haskell-tng:debug-extend (point))
-          (setq font-lock-end (point))))))
-  nil
-  )
-
-;; note that \n has syntax `comment-end'
-(defconst haskell-tng:newline
-  '(| (syntax comment-end)
-      (: symbol-start
-         "--"
-         (+ (not (syntax comment-end)))
-         (+ (syntax comment-end))))
-  "Newline or line comment.")
-
-;; TODO literal types and generic lists ... eek!
-(defconst haskell-tng:type
-  (let ((typepart `(| (+ (| ?\( ?\)))
-                      (+ (| lower ?_))
-                      (: (opt ,haskell-tng:qual)
-                         (| "::" ,haskell-tng:conid ,haskell-tng:consym)))))
-    `(: (opt ,haskell-tng:newline) (+ (| space ,typepart))
-        (* (opt ,haskell-tng:newline (+ space)) "->" (+ (| space ,typepart)))))
-  "An explicit type")
-
-(defun haskell-tng:type-end ()
-  "Move to the end of this type signature."
-  (interactive)
-  (let* ((case-fold-search nil))
-    (re-search-forward
-     (rx-to-string `(: point "::" (* space) ,haskell-tng:type))
-     (point-max) t)))
-
-;; also consider multiline data / newtype / type definitions to the equals sign
+  (when (re-search-backward
+         ;; TODO: replace \ with a larger list of non-type chars
+         (rx symbol-start "::" symbol-end (*? (not (any ?\\))) point)
+         (point-min) t)
+    (let ((beg (match-beginning 0)))
+      (when (< beg font-lock-beg)
+        (goto-char beg)
+        ;; validate that it's actually a type
+        (haskell-tng:explicit-type) ;; is this needed if we trust the 
non-lambda backscan?
+        (when (< font-lock-beg (point))
+          (haskell-tng:debug-extend beg)
+          (setq font-lock-beg beg)))))
+  nil)
 
 (defun haskell-tng:extend-type-close ()
   "For use in `font-lock-extend-region-functions'.
 Ensures that multiline type signatures are closed."
+  (goto-char font-lock-end)
+  ;; TODO: exit early if in comment
+  (when (re-search-backward
+         ;; TODO: replace \ with a larger list of non-type chars
+         (rx symbol-start "::" symbol-end (*? (not (any ?\\))) point)
+         font-lock-beg t)
+    (let ((beg (match-beginning 0)))
+      (goto-char beg)
+      (haskell-tng:explicit-type)
+      (when (< font-lock-end (point))
+        (haskell-tng:debug-extend (point))
+        (setq font-lock-beg (point)))))
   nil)
 
 (defun haskell-tng:extend-module-open ()
@@ -272,12 +283,16 @@ Ensures that multiline `import' definitions are opened."
 Ensures that multiline `import' definitions are closed."
   nil)
 
+;; TODO multiline data / newtype / type definitions
+
 (defun haskell-tng:debug-extend (to)
   (message "extending `%s' to include `%s'!"
            (buffer-substring-no-properties font-lock-beg font-lock-end)
-           (if (< to font-lock-beg)
+           (if (<= to font-lock-beg)
                (buffer-substring-no-properties to font-lock-beg)
-             (buffer-substring-no-properties font-lock-end to))))
+             (if (<= font-lock-end to)
+                 (buffer-substring-no-properties font-lock-end to)
+               "BADNESS! Reduced the region"))))
 
 (defun haskell-tng:mark-block ()
   ;; TODO: this is kinda obscure, replace with mark-defun when it is defined