[nongnu] elpa/haskell-tng-mode b9bc414 027/385: improve the multiline font macro

[ELPA Syncer]

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

    improve the multiline font macro
---
 haskell-tng-font-lock.el | 119 +++++++++++++++++++++++++----------------------
 haskell-tng-mode.el      |   6 +--
 2 files changed, 65 insertions(+), 60 deletions(-)

diff --git a/haskell-tng-font-lock.el b/haskell-tng-font-lock.el
index 47da66f..1707ffe 100644
--- a/haskell-tng-font-lock.el
+++ b/haskell-tng-font-lock.el
@@ -21,6 +21,7 @@
 ;; TODO: regression tests https://github.com/Lindydancer/faceup
 ;; TODO use levels so users can turn off type fontification
 
+(require 'dash)
 (require 'haskell-tng-util)
 
 (defgroup haskell-tng:faces nil
@@ -172,10 +173,13 @@
   "Print debugging when the font-lock region is extended."
   :type 'boolean)
 
-;; TODO (perf) don't call FIND or extend if there is a multiline property
-;; TODO simplify FIND to use paren-close / indent-close automatically?
-;; TODO option to avoid the initial regexp in -keyword if it overlaps
-(defmacro haskell-tng:font:multiline (name trigger find)
+(defconst haskell-tng:extend-region-functions
+  '(font-lock-extend-region-wholelines)
+  "Used in `font-lock-extend-region-functions'.
+Automatically populated by `haskell-tng:font:multiline'")
+
+;; TODO (perf) don't extend if the TRIGGER has a multiline prop
+(defmacro haskell-tng:font:multiline (name trigger find &rest limiters)
   "Defines `font-lock-keywords' / `font-lock-extend-region-functions' entries.
 
 TRIGGER is a referentially transparent form that produces a regexp.
@@ -184,76 +188,81 @@ FIND is a form that must behave the same as 
`re-search-forward',
 i.e. setting the match groups and placing point after the match.
 The variable `limit' is dynamically bound within this form.
 
-Both TRIGGER and FIND should be optimised as they will be called
-repeatedly as the user is entering text and navigating the code.
-
-The generated `haskell-tng:PREFIX-extend' uses searches
-backwards from the end of the proposed region with TRIGGER. If a
-match is found, then FIND is evaluated with an unlimited limit to
-calculate the end position, which may extend the region.
+The generated `haskell-tng:PREFIX-extend' searches backwards from
+the end of the proposed region for TRIGGER. If a match is found,
+FIND is called with a limit until the end of the buffer, which
+may extend the region.
 
 The generated `haskell-tng:PREFIX-keyword' searches forward for
 TRIGGER within the fontification limit. The point is reset to the
-beginning of the TRIGGER's match and FIND is evaluated."
+beginning of the TRIGGER's match and FIND is evaluated.
+
+The LIMITERS are function names that will be called when the
+TRIGGER succeeds and may return a more restrictive limit than the
+defaults for FIND."
   (declare (indent defun))
   (let* ((sname (concat "haskell-tng:font:" (symbol-name name)))
          (regexp (intern (concat sname ":trigger")))
          (keyword (intern (concat sname ":keyword")))
          (extend (intern (concat sname ":extend"))))
-    `(progn
-       (defconst ,regexp ,trigger)
-       (defun ,keyword (limit)
-         (when (re-search-forward ,regexp limit t)
-           (goto-char (match-beginning 0))
-           ,find))
-       (defun ,extend ()
-         (goto-char font-lock-end)
-         (when (re-search-backward ,regexp font-lock-beg t)
-           (let ((limit (point-max))) ,find)
-           (when (< font-lock-end (point))
-             (when haskell-tng:font:debug-extend
-               (haskell-tng:font:debug-extend (point)))
-             (setq font-lock-end (point))
-             nil))))))
+    (cl-flet
+        ((finder (lim)
+                 `(re-search-forward
+                   ,find
+                   (-min (cons ,lim (-non-nil (-map 'funcall ',limiters))))
+                   t)))
+      `(progn
+         (defconst ,regexp ,trigger)
+         (defun ,extend ()
+           (goto-char font-lock-end)
+           (when (re-search-backward ,regexp font-lock-beg t)
+             ,(finder '(point-max))
+             (when (< font-lock-end (point))
+               (when haskell-tng:font:debug-extend
+                 (haskell-tng:font:debug-extend (point)))
+               (setq font-lock-end (point))
+               nil)))
+         (defun ,keyword (limit)
+           (when (re-search-forward ,regexp limit t)
+             (goto-char (match-beginning 0))
+             ,(finder 'limit)))
+         (add-to-list 'haskell-tng:extend-region-functions ',extend t)))))
 
 (haskell-tng:font:multiline explicit-type
   (rx symbol-start "::" symbol-end)
-  (let ((paren (haskell-tng:paren-close))
-        (indent (haskell-tng:indent-close (- (point) 1))))
-    (re-search-forward
-     (rx symbol-start "::" symbol-end (group (+ anything)))
-     (min limit (or paren limit) (or indent limit)) t)))
+  (rx symbol-start "::" symbol-end (group (+ anything)))
+  haskell-tng:paren-close
+  haskell-tng:font:explicit-type:indent)
+
+(defun haskell-tng:font:explicit-type:indent ()
+  "Indentation closing the previous symbol."
+  (save-excursion
+    (forward-symbol -1)
+    (haskell-tng:indent-close)))
 
 (haskell-tng:font:multiline topdecl
   (rx line-start (| "data" "newtype" "class" "instance") symbol-end)
-  (re-search-forward
-   (rx line-start (| "data" "newtype" "class" "instance") symbol-end
-       (group (+? anything))
-       (| (: line-start symbol-start)
-          (: symbol-start (| "where" "=") symbol-end)))
-   limit t))
+  (rx line-start (| "data" "newtype" "class" "instance") symbol-end
+      (group (+? anything))
+      (| (: line-start symbol-start)
+         (: symbol-start (| "where" "=") symbol-end))))
 
 (haskell-tng:font:multiline type
   (rx line-start "type" symbol-end)
-  (let ((indent (haskell-tng:indent-close)))
-    (re-search-forward
-     (rx line-start "type" symbol-end (+ space) (group (+ anything)))
-     (min limit (or indent limit)))))
-
+  (rx line-start "type" symbol-end (+ space) (group (+ anything)))
+  haskell-tng:indent-close)
+
+;; DeriveAnyClass
+;; DerivingStrategies
+;; GeneralizedNewtypeDeriving
+;; TODO DerivingVia
+;; TODO StandaloneDeriving
 (haskell-tng:font:multiline deriving
   (rx symbol-start "deriving" symbol-end)
-  ;; DeriveAnyClass
-  ;; DerivingStrategies
-  ;; GeneralizedNewtypeDeriving
-  ;; TODO DerivingVia
-  ;; TODO StandaloneDeriving
-  (let ((indent (haskell-tng:indent-close)))
-    (re-search-forward
-     (rx
-      symbol-start "deriving" (+ space)
-      (group (opt (| "anyclass" "stock" "newtype"))) (* space)
-      ?\( (group (* anything)) ?\))
-     (min limit (or indent limit)) t)))
+  (rx symbol-start "deriving" symbol-end
+      (+ space) (group (opt (| "anyclass" "stock" "newtype")))
+      (* space) ?\( (group (* anything)) ?\))
+  haskell-tng:indent-close)
 
 ;; TODO modules
 ;; TODO imports
diff --git a/haskell-tng-mode.el b/haskell-tng-mode.el
index 9fbdec8..bec845f 100644
--- a/haskell-tng-mode.el
+++ b/haskell-tng-mode.el
@@ -49,11 +49,7 @@
 
    font-lock-defaults '(haskell-tng:keywords)
    font-lock-multiline t
-   font-lock-extend-region-functions '(font-lock-extend-region-wholelines
-                                       haskell-tng:font:explicit-type:extend
-                                       haskell-tng:font:topdecl:extend
-                                       haskell-tng:font:type:extend
-                                       haskell-tng:font:deriving:extend)
+   font-lock-extend-region-functions haskell-tng:extend-region-functions
 
    ;; whitespace is meaningful, no electric indentation
    electric-indent-inhibit t)