Speed up tokenization and font-lock

gracjan · gracjan · commit 262a27a2ad21 · 2016-08-12T16:12:23.000+02:00
diff --git a/haskell-font-lock.el b/haskell-font-lock.el
@@ -314,9 +314,9 @@ like ::, class, instance, data, newtype, type."
     (goto-char end)))
 
 
-(defun haskell-font-lock--put-face-on-type-or-constructor ()
-  "Private function used to put either type or constructor face
-  on an uppercase identifier."
+(defun haskell-font-lock--select-face-on-type-or-constructor ()
+  "Private function used to select either type or constructor face
+on an uppercase identifier."
   (cl-case (haskell-lexeme-classify-by-first-char (char-after (match-beginning 1)))
     (varid (when (member (match-string 0) haskell-font-lock--reverved-ids)
              ;; Note: keywords parse as keywords only when not qualified.
@@ -354,6 +354,15 @@ like ::, class, instance, data, newtype, type."
                 (add-text-properties (match-end 0) (point) '(font-lock-multiline t haskell-type t)))
               'haskell-operator-face))))
 
+(defun haskell-font-lock--put-face-on-type-or-constructor ()
+  "Private function used to put either type or constructor face
+on an uppercase identifier."
+  (let ((face (haskell-font-lock--select-face-on-type-or-constructor)))
+    (when (and face
+               (not (text-property-not-all (match-beginning 0) (match-end 0) 'face nil)))
+      (put-text-property (match-beginning 0) (match-end 0) 'face face))))
+
+
 (defun haskell-font-lock-keywords ()
   ;; this has to be a function because it depends on global value of
   ;; `haskell-font-lock-symbols'
@@ -448,9 +457,15 @@ like ::, class, instance, data, newtype, type."
 
             (,(concat "`" haskell-lexeme-qid-or-qsym "`") 0 'haskell-operator-face)
 
-            (,haskell-lexeme-qid-or-qsym
+            (,haskell-lexeme-idsym-first-char
              (0 (unless (or (elt (syntax-ppss) 3) (elt (syntax-ppss) 4))
-                  (haskell-font-lock--put-face-on-type-or-constructor))))))
+                  (when (save-excursion
+                          (goto-char (match-beginning 0))
+                          (haskell-lexeme-looking-at-qidsym))
+                    (goto-char (match-end 0))
+                    ;; note that we have to put face ourselves here because font-lock
+                    ;; will use match data from the original matcher
+                    (haskell-font-lock--put-face-on-type-or-constructor)))))))
     keywords))
 
 
diff --git a/haskell-lexeme.el b/haskell-lexeme.el
@@ -32,7 +32,7 @@
                (modify-category-entry key ?P))))
    unicode-category-table)
 
-  (dolist (key (string-to-list "!#$%&*+./<=>?@^|~\\-"))
+  (dolist (key (string-to-list "!#$%&*+./<=>?@^|~\\-:"))
     (modify-category-entry key ?P)))
 
 (defconst haskell-lexeme-modid
@@ -43,28 +43,31 @@ Note that GHC accepts Unicode category UppercaseLetter as a first
 character. Following letters are from Unicode categories
 UppercaseLetter, LowercaseLetter, OtherLetter, TitlecaseLetter,
 ModifierLetter, DecimalNumber, OtherNumber, backslash or
-underscore.
-
-Note that this differs from constructor identifier as the latter
-one can have any number of hash character at the end to
-accommodate MagicHash extension.")
+underscore.")
 
 (defconst haskell-lexeme-id
-  "[[:alpha:]_][[:alnum:]'_]*#*"
+  "[[:alpha:]_][[:alnum:]'_]*"
   "Regexp matching a valid Haskell identifier.
 
 GHC accepts a string starting with any alphabetic character or
 underscore followed by any alphanumeric character or underscore
 or apostrophe.")
 
 (defconst haskell-lexeme-sym
-  "\\(:?\\cP\\|:\\)+"
+  "\\cP+"
   "Regexp matching a valid Haskell variable or constructor symbol.
 
 GHC accepts a string of chars from the set
 [:!#$%&*+./<=>?@^|~\\-] or Unicode category Symbol for chars with
 codes larger than 128 only.")
 
+(defconst haskell-lexeme-idsym-first-char
+  "\\(?:[[:alpha:]_]\\|\\cP\\)"
+  "Regexp matching first character of a qualified or unqualified
+identifier or symbol.
+
+Useful for `re-search-forward'.")
+
 (defconst haskell-lexeme-modid-opt-prefix
   (concat "\\(?:" haskell-lexeme-modid "\\.\\)*")
   "Regexp matching a valid Haskell module prefix, potentially empty.
@@ -80,6 +83,53 @@ dot. For path component syntax see `haskell-lexeme-modid'.")
 
 Note that (match-string 1) returns the unqualified part.")
 
+(defun haskell-lexeme-looking-at-qidsym ()
+  "Non-nil when point is just in front of an optionally qualified
+identifier or symbol.
+
+Using this function is more efficient than matching against the
+regexp `haskell-lexeme-qid-or-qsym'.
+
+Returns:
+  'qid - if matched a qualified id: 'Data.Map' or 'Map'
+  'qsym - if matched a qualified id: 'Monad.>>=' or '>>='
+  'qprefix - if matched only modid prefix: 'Data.'
+
+After successful 'qid or 'qsym match (match-string 1) will return
+the unqualified part (if any)."
+  (let ((begin (point))
+        (match-data-old (match-data)))
+    (save-excursion
+      (while (looking-at (concat haskell-lexeme-modid "\\."))
+        (goto-char (match-end 0)))
+      (cond
+       ((looking-at haskell-lexeme-id)
+        (let ((beg (match-beginning 0))
+              (end (match-end 0)))
+
+          ;; check is MagicHash is present at the end of the token
+          (goto-char end)
+          (when (looking-at "#+")
+            (setq end (match-end 0)))
+
+          (set-match-data
+           (list begin end
+                 beg end)))
+        'qid)
+       ((looking-at haskell-lexeme-sym)
+        (set-match-data
+          (list begin (match-end 0)
+                (match-beginning 0) (match-end 0)))
+        'qsym)
+       ((equal begin (point))
+        (set-match-data match-data-old)
+        nil)
+       (t
+        (set-match-data
+         (list begin (point)
+               nil nil))
+        'qprefix)))))
+
 (defconst haskell-lexeme-qid
   (rx-to-string `(: (regexp "'*")
                     (regexp ,haskell-lexeme-modid-opt-prefix)
@@ -148,7 +198,7 @@ strictly only escape sequences defined in Haskell Report.")
          (group (* (| (regexp "\\\\[ \t\n\r\v\f]*\\\\")
                       (regexp "\\\\[ \t\n\r\v\f]+")
                       (regexp "\\\\[^ \t\n\r\v\f]")
-                      (regexp "[^\"\n\\]"))))
+                      (* (regexp "[^\"\n\\]")))))
          (group (| "\"" (regexp "$") (regexp "\\\\?\\'")
                    ))))
   "Regexp matching a string literal lookalike.
@@ -166,30 +216,111 @@ Regexp has subgroup expressions:
  (match-text 3) matches the closing quote, or a closing
                 newline or empty string at the end of the buffer.")
 
-(defconst haskell-lexeme-quasi-quote-literal
-  (rx-to-string `(: "[" (optional "$")
-                    (group (regexp ,haskell-lexeme-id))
-                    (group "|")
-                    (group (* (| (not (any "|"))
-                                 (: "|" (not (any "]"))))
-                              ))
-                    (group (| "|" eos))
-                    (| "]" eos)))
-  "Regexp matching a quasi quote literal.
+(defun haskell-lexeme-looking-at-string-literal ()
+  "Non-nil when point is at a string literal lookalike.
+
+Note that this function matches more than Haskell Report
+specifies because we want to support also code under edit.
+
+String literals end with double quote or unescaped newline or end
+of buffer.
+
+After successful match:
+ (match-text 1) matches the opening doublequote.
+ (match-text 2) matches the inside of the string.
+ (match-text 3) matches the closing quote, or a closing
+                newline or is nil when at the end of the buffer."
+  (when (looking-at "\"")
+    (save-excursion
+      (let ((begin (point)))
+        (goto-char (match-end 0))
+        (let (finish)
+          (while (and (not finish)
+                      (re-search-forward "[\"\n\\]" nil 'goto-eob))
+            (cond
+             ((equal (match-string 0) "\\")
+              (if (looking-at "[ \t\n\r\v\f]+\\\\?")
+                  (goto-char (match-end 0))
+                (goto-char (1+ (point)))))
+
+             ((equal (match-string 0) "\"")
+              (set-match-data
+               (list begin (match-end 0)
+                     begin (1+ begin)
+                     (1+ begin) (match-beginning 0)
+                     (match-beginning 0) (match-end 0)))
+              (setq finish t))
+
+             ((equal (match-string 0) "\n")
+              (set-match-data
+               (list begin (match-beginning 0)
+                     begin (1+ begin)
+                     (1+ begin) (match-beginning 0)
+                     nil nil))
+              (setq finish t))))
+          (unless finish
+            ;; string closed by end of buffer
+            (set-match-data
+             (list begin (point)
+                   begin (1+ begin)
+                   (1+ begin) (point)
+                   nil nil))))))
+    ;; there was a match
+    t))
+
+(defun haskell-lexeme-looking-at-quasi-quote-literal ()
+  "Non-nil when point is just in front of Template Haskell
+quaisquote literal.
 
 Quasi quotes start with '[xxx|' or '[$xxx|' sequence and end with
-'|]'. The 'xxx' is a quoter name. There is no escaping mechanism
+  '|]'. The 'xxx' is a quoter name. There is no escaping mechanism
 provided for the ending sequence.
 
 Regexp has subgroup expressions:
  (match-text 1) matches the quoter name (without $ sign if present).
  (match-text 2) matches the opening vertical bar.
  (match-text 3) matches the inside of the quoted string.
  (match-text 4) matches the closing vertical bar
-                or empty string if at the end of the buffer.
-
-Note that this regexp admits 'e', 't', 'd', 'p' as quoter names
-although template Haskell explicitly rejects those.")
+                or nil if at the end of the buffer.
+
+Note that this function excludes 'e', 't', 'd', 'p' as quoter
+names according to Template Haskell specification."
+  (let ((match-data-old (match-data)))
+    (if (and
+         (looking-at (rx-to-string `(: "[" (optional "$")
+                                       (group (regexp ,haskell-lexeme-id))
+                                       (group "|"))))
+         (equal (haskell-lexeme-classify-by-first-char (char-after (match-beginning 1)))
+                'varid)
+         (not (member (match-string 1) '("e" "t" "d" "p"))))
+      (save-excursion
+        ;; note that quasi quote syntax does not have any escaping
+        ;; mechanism and if not closed it will span til lthe end of buffer
+        (goto-char (match-end 0))
+        (let ((match-data (match-data))
+              (match-data-2 (and (re-search-forward "|]" nil t)
+                                 (match-data))))
+          (if match-data-2
+              (set-match-data
+               (list
+                (nth 0 match-data) (nth 1 match-data-2)          ;; whole match
+                (nth 2 match-data) (nth 3 match-data)            ;; quoter name
+                (nth 4 match-data) (nth 5 match-data)            ;; opening bar
+                (nth 5 match-data) (nth 0 match-data-2)          ;; inner string
+                (nth 0 match-data-2) (1+ (nth 0 match-data-2)))) ;; closing bar
+
+            (set-match-data
+             (list
+              (nth 0 match-data) (point-max)                   ;; whole match
+              (nth 2 match-data) (nth 3 match-data)            ;; quoter name
+              (nth 4 match-data) (nth 5 match-data)            ;; opening bar
+              (nth 5 match-data) (point-max)                   ;; inner string
+              nil nil))                                        ;; closing bar
+            ))
+        t)
+      ;; restore old match data if not matched
+      (set-match-data match-data-old)
+      nil)))
 
 (defun haskell-lexeme-classify-by-first-char (char)
   "Classify token by CHAR.
@@ -258,7 +389,8 @@ See `haskell-lexeme-classify-by-first-char' for details."
        (point (point-marker)))
     (or
      (and
-      (equal (string-to-syntax "<") (syntax-after (point)))
+      (equal (string-to-syntax "<")
+             (get-char-property (point) 'syntax-table))
       (progn
         (set-match-data (list point (set-marker (make-marker) (line-end-position))))
         'literate-comment))
@@ -271,21 +403,13 @@ See `haskell-lexeme-classify-by-first-char' for details."
             'nested-comment))
      (and (looking-at haskell-lexeme-char-literal)
           'char)
-     (and (looking-at haskell-lexeme-string-literal)
+     (and (haskell-lexeme-looking-at-string-literal)
           'string)
      (and (looking-at "[][(){}`,;]")
-          (let ((match-data (match-data)))
-            (if (and (equal "[" (match-string-no-properties 0))
-                     (looking-at haskell-lexeme-quasi-quote-literal))
-                (if (or (member (match-string-no-properties 1) '("e" "d" "p" "t"))
-                        (not (equal (haskell-lexeme-classify-by-first-char (char-after (match-beginning 1)))
-                                    'varid)))
-                    (progn
-                      (set-match-data match-data)
-                      'special)
-                    'template-haskell-quasi-quote)
-              'special)))
-     (and (looking-at haskell-lexeme-qid-or-qsym)
+          (if (haskell-lexeme-looking-at-quasi-quote-literal)
+              'template-haskell-quasi-quote
+            'special))
+     (and (haskell-lexeme-looking-at-qidsym)
           (if (save-match-data
                 (string-match "\\`---*\\'" (match-string-no-properties 0)))
               (progn
diff --git a/haskell-mode.el b/haskell-mode.el
@@ -567,13 +567,14 @@ be set to the preferred literate style."
               ;; when a generic delimiter is not closed so in case
               ;; string ends at the end of the buffer we will use
               ;; plain string
-              (when (and (equal (match-beginning 3) (match-end 3))
-                         (not (equal (match-beginning 3) (point-max))))
+              (when (and (not (match-beginning 3))
+                         (not (equal (match-end 2) (point-max))))
                 (put-text-property (match-beginning 1) (match-end 1) 'syntax-table (string-to-syntax "|"))
-                (put-text-property (match-beginning 3) (1+ (match-end 3)) 'syntax-table (string-to-syntax "|")))))
+                (put-text-property (match-end 2 ) (1+ (match-end 2)) 'syntax-table (string-to-syntax "|")))))
            ((equal token-kind 'template-haskell-quasi-quote)
             (put-text-property (match-beginning 2) (match-end 2) 'syntax-table (string-to-syntax "\""))
-            (put-text-property (match-beginning 4) (match-end 4) 'syntax-table (string-to-syntax "\""))
+            (when (match-beginning 4)
+              (put-text-property (match-beginning 4) (match-end 4) 'syntax-table (string-to-syntax "\"")))
             (save-excursion
               (goto-char (match-beginning 3))
               (let ((limit (match-end 3)))
diff --git a/tests/haskell-c2hs-tests.el b/tests/haskell-c2hs-tests.el
@@ -16,7 +16,7 @@
 (ert-deftest haskell-c2hs-qualified-import-hook ()
   "C2HS qualified import hook"
   (check-properties
-    '("{#import qualified Foo#}")
+    '("{#import qualified Foo #}")
     '(("{#" t haskell-c2hs-hook-pair-face)
       ("import" "w" haskell-c2hs-hook-name-face)
       ("qualified" "w" haskell-c2hs-hook-name-face)
@@ -284,7 +284,7 @@
 (ert-deftest haskell-c2hs-const-hook ()
   "C2HS const hook"
   (check-properties
-    '("{#const FOO_BAR#}")
+    '("{#const FOO_BAR #}")
     '(("{#" t haskell-c2hs-hook-pair-face)
       ("const" "w" haskell-c2hs-hook-name-face)
       ("#}" t haskell-c2hs-hook-pair-face))
diff --git a/tests/haskell-lexeme-tests.el b/tests/haskell-lexeme-tests.el

-Original file line number
+Diff line change
   (save-current-buffer
     (set-buffer (get-buffer-create "*haskell-mode-buffer*"))
 +    (when (fboundp 'jit-lock-debug-mode)
 +      ;; to see stack traces from inside font-lock
 +      (jit-lock-debug-mode))
++
     ;; Note that all of this should work both in haskell-mode and
     ;; outside of it. Currently we test only haskell-mode setup.
     (if literate
         (goto-char (match-end 0)))
       (should (equal nil left-lexemes)))))
 +(defun check-lexemes-nocheck (lines-or-contents &optional literate)
 +  "Checks if tokenization works as expected.
++
 +LINES is a list of strings that will be inserted to a new
 +buffer."
 +  (when (get-buffer "*haskell-mode-buffer*")
 +    (kill-buffer "*haskell-mode-buffer*"))
 +  (save-current-buffer
 +    (set-buffer (get-buffer-create "*haskell-mode-buffer*"))
++
 +    (if (consp lines-or-contents)
 +        (dolist (line lines-or-contents)
 +          (insert line)
 +          (insert "\n"))
 +      (insert lines-or-contents))
++
 +    (font-lock-fontify-buffer)
++
 +    ;; here we check only if tokenization did not end in exception thrown
 +    (goto-char (point-min))
 +    (while (haskell-lexeme-looking-at-token)
 +      (goto-char (match-end 0)))))
++
 (ert-deftest haskell-lexeme-classify-chars-1 ()
   (should (equal 'varsym (haskell-lexeme-classify-by-first-char ?=)))
   (should (equal 'conid (haskell-lexeme-classify-by-first-char ?L)))
      "code"
      "no code")
    'literate))
++
 +(ert-deftest haskell-lexeme-big-01-quasi-literal ()
 +  (check-lexemes-nocheck
 +   (concat "x = " "[th|"
 +           (make-string (* 10 1000 1000) ? )
 +           "|]")))
++
 +(ert-deftest haskell-lexeme-big-02-string ()
 +  (check-lexemes-nocheck
 +   (concat "x = " "\""
 +           (make-string (* 10 1000 1000) ? )
 +           "\"")))
++
 +(ert-deftest haskell-lexeme-big-03-string-with-escapes ()
 +  (check-lexemes-nocheck
 +   (concat "x = " "\""
 +           (let ((result "\\x01\\&,..\\NUL"))
 +             (dotimes (i 17)
 +               (setq result (concat result result)))
 +             result)
 +           "\"")))
++
 +(ert-deftest haskell-lexeme-big-04-long-id ()
 +  (check-lexemes-nocheck
 +   (concat "x = " (make-string 1000000 ?x))))
++
 +(ert-deftest haskell-lexeme-big-05-long-sym()
 +  (check-lexemes-nocheck
 +   (concat "x = " (make-string 1000000 ?+))))
++
 +(ert-deftest haskell-lexeme-big-06-long-module-name()
 +  (check-lexemes-nocheck
 +   (concat "x = " (make-string 10000000 ?M) ".x")))
++
 +(ert-deftest haskell-lexeme-big-07-many-modules-id()
 +  (check-lexemes-nocheck
 +   (concat "x = "
 +           (let ((result "M."))
 +             (dotimes (i 20)
 +               (setq result (concat result result)))
 +             result)
 +           "x")))
++
 +(ert-deftest haskell-lexeme-big-08-many-modules-sym()
 +  (check-lexemes-nocheck
 +   (concat "x = "
 +           (let ((result "M."))
 +             (dotimes (i 20)
 +               (setq result (concat result result)))
 +             result)
 +           "++")))