[nongnu] elpa/haskell-tng-mode 067e8a7 280/385: bugfix fontification of erroneous matches inside strings

[ELPA Syncer]

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

    bugfix fontification of erroneous matches inside strings
---
 haskell-tng-font-lock.el  | 22 +++++++++++++++++++---
 test/src/medley.hs        |  2 ++
 test/src/medley.hs.faceup |  2 ++
 test/src/medley.hs.imenu  | 10 +++++-----
 test/src/medley.hs.layout |  2 ++
 test/src/medley.hs.lexer  |  2 ++
 test/src/medley.hs.syntax |  2 ++
 7 files changed, 34 insertions(+), 8 deletions(-)

diff --git a/haskell-tng-font-lock.el b/haskell-tng-font-lock.el
index cfa17c6..bd923d7 100644
--- a/haskell-tng-font-lock.el
+++ b/haskell-tng-font-lock.el
@@ -274,13 +274,28 @@ succeeds and may further restrict the FIND search limit."
          (defconst ,regexp-2 ,find)
          (defun ,extend ()
            (goto-char font-lock-end)
-           (when (re-search-backward ,regexp-1 font-lock-beg t)
+           (when (and
+                  ;; lots of conservative checks to make sure we never extend
+                  ;; from, or into, a comment or string.
+                  (not (nth 8 (syntax-ppss)))
+                  (re-search-backward ,regexp-1 font-lock-beg t)
+                  (not (nth 8 (syntax-ppss))))
              ,(finder '(point-max))
-             (when (< font-lock-end (point))
+             (when (and
+                    (not (nth 8 (syntax-ppss)))
+                    (< font-lock-end (point)))
                (setq font-lock-end (point))
                nil)))
          (defun ,keyword (limit)
-           (when (re-search-forward ,regexp-1 limit t)
+           (when (and
+                  (re-search-forward ,regexp-1 limit t)
+                  ;; TODO if the last search got us into a string or comment. 
We
+                  ;; should recurse, otherwise we miss valid matches in the
+                  ;; region. This hack just tries once more.
+                  (or
+                   (not (nth 8 (syntax-ppss)))
+                   (re-search-forward ,regexp-1 limit t))
+                  (not (nth 8 (syntax-ppss))))
              (goto-char (match-beginning 0))
              ,(finder 'limit)))
          ;; TODO is this needed since we use multiline?
@@ -294,6 +309,7 @@ succeeds and may further restrict the FIND search limit."
                             haskell-tng--util-indent-close-previous
                             haskell-tng--util-type-ender)
 ;; TODO commas end a type signature in a record of functions (but can be used 
in tuples, so complex)
+;; TODO since there is no way to exit based on context, we will match :: 
inside strings and comments
 
 (haskell-tng--font-lock-multiline topdecl
                             (rx line-start (| "data" "newtype" "class" 
"instance") word-end)
diff --git a/test/src/medley.hs b/test/src/medley.hs
index 72c503f..2426e67 100644
--- a/test/src/medley.hs
+++ b/test/src/medley.hs
@@ -52,6 +52,8 @@ lambdas1 = \a -> a
 lambdas2 = \ a -> a
 lambdas3 = \(a) -> a
 
+bar = "blah :: " <> foo
+
 class Get a s where
   get :: Set s -> a
 
diff --git a/test/src/medley.hs.faceup b/test/src/medley.hs.faceup
index 17b02be..871e877 100644
--- a/test/src/medley.hs.faceup
+++ b/test/src/medley.hs.faceup
@@ -52,6 +52,8 @@ lambdas1 «:haskell-tng-keyword-face:=» 
«:haskell-tng-keyword-face:\»a «:has
 lambdas2 «:haskell-tng-keyword-face:=» «:haskell-tng-keyword-face:\» a 
«:haskell-tng-keyword-face:->» a
 lambdas3 «:haskell-tng-keyword-face:=» 
«:haskell-tng-keyword-face:\(»a«:haskell-tng-keyword-face:)» 
«:haskell-tng-keyword-face:->» a
 
+bar «:haskell-tng-keyword-face:=» «s:"blah :: "» <> foo
+
 «:haskell-tng-keyword-face:class»«:haskell-tng-type-face: Get a s 
»«:haskell-tng-keyword-face:where»
   get «:haskell-tng-keyword-face:::»«:haskell-tng-type-face: Set s 
»«:haskell-tng-keyword-face:->»«:haskell-tng-type-face: a
 »
diff --git a/test/src/medley.hs.imenu b/test/src/medley.hs.imenu
index 5ee08d2..a0164dc 100644
--- a/test/src/medley.hs.imenu
+++ b/test/src/medley.hs.imenu
@@ -10,8 +10,8 @@
  ("lambdas1" . 1852)
  ("lambdas2" . 1871)
  ("lambdas3" . 1891)
- ("optionsParser" . 3464)
- ("getUsers" . 4439)
- ("test" . 4808)
- ("cases" . 4831)
- ("bar" . 4903))
+ ("bar" . 1913)
+ ("optionsParser" . 3489)
+ ("getUsers" . 4464)
+ ("test" . 4833)
+ ("cases" . 4856))
diff --git a/test/src/medley.hs.layout b/test/src/medley.hs.layout
index 3e660c5..0992e1a 100644
--- a/test/src/medley.hs.layout
+++ b/test/src/medley.hs.layout
@@ -52,6 +52,8 @@ module Foo.Bar.Main
 ;lambdas2 = \ a -> a
 ;lambdas3 = \(a) -> a
 
+;bar = "blah :: " <> foo
+
 ;class Get a s where
   {get :: Set s -> a
 
diff --git a/test/src/medley.hs.lexer b/test/src/medley.hs.lexer
index 55ff768..d3c0b81 100644
--- a/test/src/medley.hs.lexer
+++ b/test/src/medley.hs.lexer
@@ -52,6 +52,8 @@ VARID , VARID , VARID »
 ; VARID = \ VARID -> VARID
 ; VARID = \ « VARID » -> VARID
 
+; VARID = § SYMID VARID
+
 ; class CONID VARID VARID where
 { VARID :: CONID VARID => VARID
 
diff --git a/test/src/medley.hs.syntax b/test/src/medley.hs.syntax
index 2dd3546..e08111d 100644
--- a/test/src/medley.hs.syntax
+++ b/test/src/medley.hs.syntax
@@ -52,6 +52,8 @@ wwwwwwww _ _w __ w>
 wwwwwwww _ _ w __ w>
 wwwwwwww _ _(w) __ w>
 >
+www _ "wwww __ " __ www>
+>
 wwwww www w w wwwww>
   www __ www w __ w>
 >