Support full complexity of backtick syntax

Author: gracjan

haskell-font-lock.el

@@ -455,7 +455,21 @@ on an uppercase identifier."
             ("(\\(,*\\|->\\))" 0 'haskell-constructor-face)
             ("\\[\\]" 0 'haskell-constructor-face)
 
-            (,(concat "`" haskell-lexeme-qid-or-qsym "`") 0 'haskell-operator-face)
+            ("`"
+             (0 (unless (or (elt (syntax-ppss) 3) (elt (syntax-ppss) 4))
+                  (when (save-excursion
+                          (goto-char (match-beginning 0))
+                          (haskell-lexeme-looking-at-backtick))
+                    (goto-char (match-end 0))
+                    (unless (text-property-not-all (match-beginning 1) (match-end 1) 'face nil)
+                      (put-text-property (match-beginning 1) (match-end 1) 'face 'haskell-operator-face))
+                    (unless (text-property-not-all (match-beginning 2) (match-end 2) 'face nil)
+                      (put-text-property (match-beginning 2) (match-end 2) 'face 'haskell-operator-face))
+                    (unless (text-property-not-all (match-beginning 4) (match-end 4) 'face nil)
+                      (put-text-property (match-beginning 4) (match-end 4) 'face 'haskell-operator-face))
+                    (add-text-properties
+                     (match-beginning 0) (match-end 0)
+                     '(font-lock-fontified t fontified t font-lock-multiline t))))))
 
             (,haskell-lexeme-idsym-first-char
              (0 (unless (or (elt (syntax-ppss) 3) (elt (syntax-ppss) 4))

haskell-lexeme.el

@@ -130,6 +130,50 @@ the unqualified part (if any)."
                nil nil))
         'qprefix)))))
 
+(defun haskell-lexeme-looking-at-backtick ()
+  "Non-nil when point is just in front of an identifier quoted with backticks.
+
+When match is successful, match-data will contain:
+  (match-text 1) - opening backtick
+  (match-text 2) - whole qualified identifier
+  (match-text 3) - unqualified part of identifier
+  (match-text 4) - closing backtick"
+  (let ((begin (point))
+        (match-data-old (match-data))
+        first-backtick-start
+        last-backtick-start
+        qid-start
+        id-start
+        id-end
+        result)
+    (save-excursion
+      (when (looking-at "`")
+        (setq first-backtick-start (match-beginning 0))
+        (goto-char (match-end 0))
+        (forward-comment (buffer-size))
+        (when (haskell-lexeme-looking-at-qidsym)
+          (setq qid-start (match-beginning 0))
+          (setq id-start (match-beginning 1))
+          (setq id-end (match-end 1))
+          (goto-char (match-end 0))
+          (forward-comment (buffer-size))
+          (when (looking-at "`")
+            (setq last-backtick-start (match-beginning 0))
+            (set-match-data
+             (mapcar
+              (lambda (p)
+                (set-marker (make-marker) p))
+              (list
+               first-backtick-start (1+ last-backtick-start)
+               first-backtick-start (1+ first-backtick-start)
+               qid-start id-end
+               id-start id-end
+               last-backtick-start (1+ last-backtick-start))))
+            (setq result t)))))
+    (unless result
+      (set-match-data match-data-old))
+    result))
+
 (defconst haskell-lexeme-qid
   (rx-to-string `(: (regexp "'*")
                     (regexp ,haskell-lexeme-modid-opt-prefix)

tests/haskell-font-lock-tests.el

@@ -111,6 +111,38 @@
 
      ("<=<" "." haskell-operator-face))))
 
+(ert-deftest haskell-syntactic-test-18 ()
+  "Backtick operators"
+  (check-properties
+   '(" `fmap1`"
+     " ` fmap2 `"
+     " ` {- C1 -} M.fmap3 {- C2 -} `")
+   '(("`" t haskell-operator-face)
+     ("fmap1" t haskell-operator-face)
+     ("`" t haskell-operator-face)
+
+     ("`" t haskell-operator-face)
+     ("fmap2" t haskell-operator-face)
+     ("`" t haskell-operator-face)
+
+     ("`" t haskell-operator-face)
+     ("C1" t font-lock-comment-face)
+     ("fmap3" t haskell-operator-face)
+     ("C2" t font-lock-comment-face)
+     ("`" t haskell-operator-face))))
+
+(ert-deftest haskell-syntactic-test-18a-multiline ()
+  "Backtick operators multiline"
+  ;; strangely thins works in interactive session
+  :expected-result :failed
+  (check-properties
+   '(" `"
+     " fmap "
+     "   `")
+   '(("`" t haskell-operator-face)
+     ("fmap" t haskell-operator-face)
+     ("`" t haskell-operator-face))))
+
 (ert-deftest haskell-syntactic-test-9a ()
   "Syntax for hierarchical modules when on the first line."
   ;; note that quite many things here are not consistent but for now

tests/haskell-lexeme-tests.el

@@ -63,6 +63,16 @@ buffer."
           (insert "\n"))
       (insert lines-or-contents))
 
+    (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
+        (literate-haskell-mode)
+      (haskell-mode))
+
     (font-lock-fontify-buffer)
 
     ;; here we check only if tokenization did not end in exception thrown
@@ -314,7 +324,7 @@ buffer."
   (check-lexemes-nocheck
    (concat "x = " "\""
            (let ((result "\\x01\\&,..\\NUL"))
-             (dotimes (i 17)
+             (dotimes (i 10)
                (setq result (concat result result)))
              result)
            "\"")))
@@ -348,3 +358,12 @@ buffer."
                (setq result (concat result result)))
              result)
            "++")))
+
+(ert-deftest haskell-lexeme-big-09-backticks-long-id()
+  (check-lexemes-nocheck
+   (concat "x = `"
+           (let ((result "xx"))
+             (dotimes (i 20)
+               (setq result (concat result result)))
+             result)
+           "id`")))