[nongnu] elpa/haskell-tng-mode 77d6ec5 019/385: cleaned up multiline explicit types

[ELPA Syncer]

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

    cleaned up multiline explicit types
---
 haskell-tng-font-lock.el | 252 +++++++++++++++++++----------------------------
 haskell-tng-mode.el      |  11 +--
 2 files changed, 103 insertions(+), 160 deletions(-)

diff --git a/haskell-tng-font-lock.el b/haskell-tng-font-lock.el
index 600059c..a7e2ba7 100644
--- a/haskell-tng-font-lock.el
+++ b/haskell-tng-font-lock.el
@@ -18,6 +18,16 @@
 ;;
 ;;; Code:
 
+;; TODO: regression tests https://github.com/Lindydancer/faceup
+;;
+;; TODO: pragmas
+;;
+;; TODO: numeric / char primitives?
+;;
+;; TODO: haddock, different face vs line comments, and some markup.
+;;
+;; TODO use levels so users can turn off type fontification
+
 (require 'subr-x)
 
 (defgroup haskell-tng:faces nil
@@ -49,14 +59,8 @@
   "Haskell top level declarations."
   :group 'haskell-tng:faces)
 
-;; TODO: regression tests https://github.com/Lindydancer/faceup
-;;
-;; TODO: pragmas
-;;
-;; TODO: numeric / char primitives?
-;;
-;; TODO: haddock, different face vs line comments, and some markup.
-
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Here are `rx' patterns that are reused as a very simple form of BNF grammar
 (defconst haskell-tng:conid '(: upper (* wordchar)))
 (defconst haskell-tng:qual `(: (+ (: ,haskell-tng:conid (char ?.)))))
 (defconst haskell-tng:consym '(: ":" (+ (syntax symbol)))) ;; TODO exclude ::, 
limited symbol set
@@ -72,19 +76,9 @@
          (+ (not (syntax comment-end)))
          (+ (syntax comment-end))))
   "Newline or line comment.")
-(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
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Here is the `font-lock-keywords' table of matchers and highlighters.
 (setq
  haskell-tng:keywords
  ;; These regexps use the `rx' library so we can reuse common subpatterns. It
@@ -110,46 +104,46 @@
       . 'haskell-tng:keyword)
 
      ;; types
-     (haskell-tng:explicit-type-paint
+     (haskell-tng:explicit-type
       (0 'haskell-tng:type keep))
-     ;; TODO multiline data/newtype/class/instance types
-     (,(rx-to-string `(: line-start "data" (+ space)
-                         (group (| ,conid ,consym))))
-      (1 'haskell-tng:type))
-     (,(rx-to-string `(: line-start (| "class" "instance") (+ space)
-                         (group (+? anything))
-                         (+ space) "where"))
-      (1 'haskell-tng:type keep))
-     ;; TypeApplications
-     (,(rx-to-string `(: symbol-start "@" (* space)
-                         ;; TODO: more liberal type application
-                         (group (opt ,qual) (| ,conid ,consym))))
-      (1 'haskell-tng:type))
+     ;; ;; TODO multiline data/newtype/class/instance types
+     ;; (,(rx-to-string `(: line-start "data" (+ space)
+     ;;                     (group (| ,conid ,consym))))
+     ;;  (1 'haskell-tng:type))
+     ;; (,(rx-to-string `(: line-start (| "class" "instance") (+ space)
+     ;;                     (group (+? anything))
+     ;;                     (+ space) "where"))
+     ;;  (1 'haskell-tng:type keep))
+     ;; ;; TypeApplications
+     ;; (,(rx-to-string `(: symbol-start "@" (* space)
+     ;;                     ;; TODO: more liberal type application
+     ;;                     (group (opt ,qual) (| ,conid ,consym))))
+     ;;  (1 'haskell-tng:type))
 
      ;; TODO: multiline module / import sections
 
      ;; modules
-     (,(rx-to-string `(: symbol-start "module" symbol-end (+ space)
-                         symbol-start (group (opt ,qual) ,conid) symbol-end))
-      1 'haskell-tng:module)
+     ;; (,(rx-to-string `(: symbol-start "module" symbol-end (+ space)
+     ;;                     symbol-start (group (opt ,qual) ,conid) 
symbol-end))
+     ;;  1 'haskell-tng:module)
 
      ;; imports
-     (,(rx-to-string '(: word-start "import" word-end)) ;; anchor matcher
-      (,(rx-to-string `(: point (+ space) (group word-start "qualified" 
word-end)))
-       nil nil (1 'haskell-tng:keyword))
-      (,(rx-to-string `(: point
-                          (opt (+ space) word-start "qualified" word-end)
-                          (+ space) word-start (group (opt ,qual) ,conid) 
word-end))
-       nil nil (1 'haskell-tng:module))
-      (,(rx-to-string `(: point (+? (not (any ?\()))
-                          word-start (group (| "hiding" "as")) word-end
-                          (opt (+ space) word-start (group ,conid) word-end)))
-       nil nil (1 'haskell-tng:keyword) (2 'haskell-tng:module nil t))
-      (,(rx-to-string `(: symbol-start (group (| ,conid ,consym)) symbol-end
-                          (* space) "(..)"))
-       nil nil (1 'haskell-tng:constructor))
-      (,(rx-to-string `(: symbol-start (group (| ,conid ,consym)) symbol-end))
-       nil nil (1 'haskell-tng:type)))
+     ;; (,(rx-to-string '(: word-start "import" word-end)) ;; anchor matcher
+     ;;  (,(rx-to-string `(: point (+ space) (group word-start "qualified" 
word-end)))
+     ;;   nil nil (1 'haskell-tng:keyword))
+     ;;  (,(rx-to-string `(: point
+     ;;                      (opt (+ space) word-start "qualified" word-end)
+     ;;                      (+ space) word-start (group (opt ,qual) ,conid) 
word-end))
+     ;;   nil nil (1 'haskell-tng:module))
+     ;;  (,(rx-to-string `(: point (+? (not (any ?\()))
+     ;;                      word-start (group (| "hiding" "as")) word-end
+     ;;                      (opt (+ space) word-start (group ,conid) 
word-end)))
+     ;;   nil nil (1 'haskell-tng:keyword) (2 'haskell-tng:module nil t))
+     ;;  (,(rx-to-string `(: symbol-start (group (| ,conid ,consym)) symbol-end
+     ;;                      (* space) "(..)"))
+     ;;   nil nil (1 'haskell-tng:constructor))
+     ;;  (,(rx-to-string `(: symbol-start (group (| ,conid ,consym)) 
symbol-end))
+     ;;   nil nil (1 'haskell-tng:type)))
 
      ;; top-level
      (,(rx-to-string toplevel)
@@ -165,135 +159,73 @@
 
      )))
 
-(defvar haskell-tng:explicit-type-regex
-  (rx-to-string `(: point "::" (* space) ,haskell-tng:type))
-  "Cache of a regex internal to `haskell-tng:explicit-type'")
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Here are `function' matchers for use in `font-lock-keywords', and reusable 
in
+;; the `font-lock-extend-region-functions' below. These set the match region 
and
+;; return nil if there is not match in the limited search.
+;;
+;; Avoid compiling any regexes (i.e. `rx-to-string'), prefer `defconst' caches.
+(defconst haskell-tng:explicit-type-regex
+  ;; TODO literal types and generic lists ... eek!
+  (let ((newline haskell-tng:newline)
+        (typepart `(| (+ (any ?\( ?\) ?\[ ?\]))
+                      (+ (any lower ?_))
+                      (: (opt ,haskell-tng:qual)
+                         (| "::" ,haskell-tng:conid ,haskell-tng:consym)))))
+    (rx-to-string
+     `(: symbol-start "::" (* space) (opt ,newline) (+ (| space ,typepart))
+         (* (opt ,newline (+ space)) "->" (+ (| space ,typepart)))))))
 (defun haskell-tng:explicit-type (limit)
-  "Matches an explicit type at point, bounded by a closing paren."
-  (let ((end (min limit (or (haskell-tng:paren-close) limit))))
-    (re-search-forward haskell-tng:explicit-type-regex end t)))
-(defun haskell-tng:explicit-type-paint (limit)
-  ;; ideally we would use an anchored `haskell-tng:explicit-type' with a `::'
-  ;; trigger, but there is a bug in GNU Emacs where anchored functions receive 
a
-  ;; much smaller `limit' than `font-lock-end' requested
-  ;; https://lists.gnu.org/archive/html/emacs-devel/2018-11/msg00136.html
-  "Matches an explicit type at point, bounded by a closing paren."
+  "Matches an explicit type, bounded by a closing paren."
   (when (re-search-forward (rx symbol-start "::" symbol-end) limit t)
     (goto-char (match-beginning 0))
-    (haskell-tng:explicit-type limit)))
+    (when-let (bounded (haskell-tng:paren-close))
+      (setq limit (min limit (+ 1 bounded))))
+    (re-search-forward haskell-tng:explicit-type-regex limit t)))
 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Below are `font-lock-extend-region-functions' procedures for extending the
+;; Here are `font-lock-extend-region-functions' procedures for extending the
 ;; region. Note that because we are using `font-lock-multiline' then multiline
 ;; patterns will always be rehighlighted as a group.
+;;
+;; Avoid compiling any regexes (i.e. `rx-to-string'), prefer `defconst' caches.
 (eval-when-compile
   ;; NOTE: font-lock-end is non-inclusive.
   (defvar font-lock-beg)
   (defvar font-lock-end))
 
-(defconst haskell-tng:non-import
-  ;; TODO: exclude more non-import/export characters. ideas: dots that aren't
-  ;; (..) or part of a symbolic import, symbolic operators that are not
-  ;; surrounded by parens.
-  (rx (| ?\" ?\\))
-  "Matches that should never exist in the parens of an import or export")
-(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
-  (when-let (open (nth 1 (syntax-ppss)))
-    (goto-char open)
-    (when (looking-at "(")
-      (unless (re-search-forward haskell-tng:non-import font-lock-beg t)
-        ;;(haskell-tng:debug-extend open)
-        (setq font-lock-beg open)))))
-
-(defun haskell-tng:extend-parens-close ()
-  "For use in `font-lock-extend-region-functions'.
-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 (close (haskell-tng:paren-close))
-    (let ((end (+ 1 close)))
-      (goto-char end)
-      (unless (re-search-backward haskell-tng:non-import font-lock-end t)
-        ;;(haskell-tng:debug-extend end)
-        (setq font-lock-end end)))))
-
-(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)))))
-
-(setq
-  haskell-tng:beg-type
-  ;; TODO: more restrictive search, add more like \ and =
-  (rx symbol-start "::" symbol-end (* (not (any ?\\ ?=)))))
-(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
-  ;; TODO: maximum lookback for a type
-  (when (re-search-backward haskell-tng:beg-type (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 (point-max)) ;; would not be needed if 
backscan was more reliable
-        (when (<= font-lock-beg (match-end 0))
-          ;;(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."
+(defun haskell-tng:extend-explicit-type ()
+  "Multiline explicit type signatures are considered."
   (goto-char font-lock-end)
-  ;; TODO: exit early if in comment
-  (when (re-search-backward haskell-tng:beg-type font-lock-beg t)
+  (when (re-search-backward
+         ;; TODO: more restrictive back scan
+         (rx symbol-start "::" symbol-end (*? (not (any ?\\ ?=))))
+         font-lock-beg t)
     (let ((beg (match-beginning 0)))
       (goto-char beg)
       (haskell-tng:explicit-type (point-max))
-      (let ((end (match-end 0)))
-        (when (< font-lock-end end)
-          ;;(haskell-tng:debug-extend end)
-          (setq font-lock-beg end)
-          nil)))))
+      (when (< font-lock-end (point))
+        (haskell-tng:debug-extend (point))
+        (setq font-lock-end (point))
+        nil))))
 
 (defun haskell-tng:extend-defns ()
-  "Extends data, type, class and instance definitons to include their full 
type part."
+  "Multiline data, type, newtype, class and instance definitions."
   nil
   )
 
-(defun haskell-tng:extend-module-open ()
+(defun haskell-tng:extend-module ()
   "For use in `font-lock-extend-region-functions'.
 Ensures that multiline `module' definitions are opened."
   nil)
 
-(defun haskell-tng:extend-module-close ()
-  "For use in `font-lock-extend-region-functions'.
-Ensures that multiline `module' definitions are closed."
-  nil)
-
-(defun haskell-tng:extend-import-open ()
+(defun haskell-tng:extend-import ()
   "For use in `font-lock-extend-region-functions'.
 Ensures that multiline `import' definitions are opened."
   nil)
 
-(defun haskell-tng:extend-import-close ()
-  "For use in `font-lock-extend-region-functions'.
-Ensures that multiline `import' definitions are closed."
-  nil)
-
 ;; TODO multiline data / newtype / type definitions
+;; TODO delete the paren and type extender and rely on growing from a seed
 
 (defun haskell-tng:debug-extend (to)
   (message "extending `%s' to include `%s'!"
@@ -304,5 +236,21 @@ Ensures that multiline `import' definitions are closed."
                  (buffer-substring-no-properties font-lock-end to)
                "BADNESS! Reduced the region"))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Helpers
+(defun haskell-tng:paren-close ()
+  "Return the position of the next `)', if it closes the current paren depth."
+  (save-excursion
+    (when-let (close (ignore-errors (scan-lists (point) 1 1)))
+      (goto-char (- close 1))
+      (when (looking-at ")")
+        (point)))))
+
+;; FIXME
+(defun debug-goto-close ()
+  (interactive)
+  (when-let (p (haskell-tng:paren-close))
+    (goto-char p)))
+
 (provide 'haskell-tng-font-lock)
 ;;; haskell-tng-font-lock.el ends here
diff --git a/haskell-tng-mode.el b/haskell-tng-mode.el
index d162cc9..5577d39 100644
--- a/haskell-tng-mode.el
+++ b/haskell-tng-mode.el
@@ -50,15 +50,10 @@
    font-lock-defaults '(haskell-tng:keywords)
    font-lock-multiline t
    font-lock-extend-region-functions '(font-lock-extend-region-wholelines
-                                       haskell-tng:extend-parens-open
-                                       haskell-tng:extend-parens-close
-                                       haskell-tng:extend-type-open
-                                       haskell-tng:extend-type-close
+                                       haskell-tng:extend-explicit-type
                                        haskell-tng:extend-defns
-                                       haskell-tng:extend-module-open
-                                       haskell-tng:extend-module-close
-                                       haskell-tng:extend-import-open
-                                       haskell-tng:extend-import-close)
+                                       haskell-tng:extend-module
+                                       haskell-tng:extend-import)
 
    ;; whitespace is meaningful, no electric indentation
    electric-indent-inhibit t)