[nongnu] elpa/raku-mode 024ef71927 064/253: Highlight type constraints

[ELPA Syncer]

branch: elpa/raku-mode
commit 024ef71927186c29fdc5f040528c3a88accedc10
Author: Hinrik Örn Sigurðsson <hinrik.sig@gmail.com>
Commit: Hinrik Örn Sigurðsson <hinrik.sig@gmail.com>

    Highlight type constraints
    
    I ran into the issue that the highlighting goes haywire if
    perl6-font-lock-keywords refers to an optional match group.
    
    I.e. if I put a regex like "\\(foo\\)\\(?: bar \\(baz\\)\\)?"
    in there and reference match group 2 (the one matching "baz"), the
    highlighting gets messed up. So I wrote a function to apply the 'face
    property directly, which seems to work without issue.
---
 perl6-font-lock.el | 75 ++++++++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 73 insertions(+), 2 deletions(-)

diff --git a/perl6-font-lock.el b/perl6-font-lock.el
index 34500ae3e3..74cf7e0787 100644
--- a/perl6-font-lock.el
+++ b/perl6-font-lock.el
@@ -66,10 +66,14 @@
   "Face for pragmas in Perl 6."
   :group 'perl6-faces)
 
-(defface perl6-type-constraint '((t :inherit font-lock-keyword-face))
+(defface perl6-type-constraint '((t :inherit font-lock-preprocessor-face))
   "Face for type constraint keywords in Perl 6."
   :group 'perl6-faces)
 
+(defface perl6-type-property '((t :inherit font-lock-builtin-face))
+  "Face for type constraint properties in Perl 6."
+  :group 'perl6-faces)
+
 (defface perl6-sigil '((t :inherit font-lock-variable-name-face))
   "Face for variable sigils in Perl 6."
   :group 'perl6-faces)
@@ -120,6 +124,14 @@
                          "END" "CATCH" "CONTROL" "TEMP")))
       (exception . ,(rx (or "die" "fail" "try" "warn")))
       (pragma . ,(rx (or "oo" "fatal")))
+      (type-constraint . ,(rx (or "does" "as" "but" "trusts" "of" "returns"
+                                  "handles" "where" "augment" "supersede")))
+      (type-property . ,(rx (or "signature" "context" "also" "shape" "prec"
+                                "irs" "ofs" "ors" "export" "deep" "binary"
+                                "unary" "reparsed" "rw" "parsed" "cached"
+                                "readonly" "defequiv" "will" "ref" "copy"
+                                "inline" "tighter" "looser" "equiv" "assoc"
+                                "required")))
       (operator-word . ,(rx (or "div" "xx" "x" "mod" "also" "leg" "cmp"
                            "before" "after" "eq" "ne" "le" "lt" "not"
                            "gt" "eqv" "ff" "fff" "and" "andthen" "or"
@@ -306,10 +318,64 @@ Takes STATE, the parse state."
      (in-string 'perl6-string)
      (in-comment 'perl6-comment))))
 
+(defun perl6-search-when (regex condition limit)
+  "Search forward for REGEX if the match satisfies CONDITION.
+
+CONDITION should be a lambda that will be called after REGEX
+matches.  If CONDITION returns non-nil, this function will set the
+match data, then move point forward and return its position, like
+`re-search-forward' would.
+
+If CONDITION returns nil, further searches for REGEX will be
+performed until CONDITION returns non-nil or REGEX fails to
+match.
+
+LIMIT can be used to bound the search."
+  (let ((limit (or limit (point-max)))
+        (keep-searching t)
+        (new-match-data))
+    (save-excursion
+      (save-match-data
+        (while keep-searching
+          (if (re-search-forward regex limit t)
+              (when (save-excursion (save-match-data (funcall condition)))
+                (setq new-match-data (match-data)
+                      keep-searching nil))
+            (setq keep-searching nil)))))
+    (when new-match-data
+      (set-match-data new-match-data)
+      (goto-char (match-end 0)))))
+
+(defun perl6-match-type-constraint (limit)
+  (perl6-search-when
+   (perl6-rx (or (group (symbol type-constraint))
+                 (and (group (symbol "is"))
+                      (1+ space)
+                      (opt (group (symbol type-property))))))
+   (lambda ()
+     (goto-char (match-beginning 0))
+     (not (looking-back (rx (or (char ".^")
+                                (and line-start (0+ space)))))))
+   limit))
+
+(defun perl6-fontify (groups)
+  "Fontify the current match.
+
+GROUPS should be a list, each element being a list containing the number
+of a match group and the name of a face.
+
+GROUPS is allowed to reference optional match groups."
+  (dolist (group groups)
+    (let ((group-num (car group))
+          (group-face (cdr group)))
+      (when (match-string group-num)
+        (put-text-property (match-beginning group-num) (match-end group-num)
+                           'face group-face)))))
+
 (defconst perl6-font-lock-keywords
   `(
     (,(perl6-rx (group (any "@$%&")) (0+ space)
-                (or (any ",\)\}")(symbol "where")))
+                (or (any ",\)\}") (symbol "where")))
      1 'perl6-sigil)
     (,(perl6-rx (group (1+ (char "@$%&")))
                 (group (opt (char ".^*?=!~")))
@@ -321,6 +387,11 @@ Takes STATE, the parse state."
      (3 'perl6-var-package)
      (4 'perl6-var-name))
     (,(perl6-rx symbol-start version) 0 'perl6-version)
+    (perl6-match-type-constraint
+     0 (ignore (perl6-fontify
+               '((1 . perl6-type-constraint)
+                 (2 . perl6-type-constraint)
+                 (3 . perl6-type-property)))))
     (,(perl6-rx (group (any ".^")) (group identifier symbol-end))
      (1 'perl6-operator)
      (2 'perl6-identifier))