branch: elpa/haskell-tng-mode
commit 6c520bc30d4fd0f65844308da05488d0c5ed9189
Author: Tseen She <ts33n....@gmail.com>
Commit: Tseen She <ts33n....@gmail.com>
fixes for type level lists
---
haskell-tng-lexer.el | 19 +++++++++++--------
haskell-tng-rx.el | 38 ++++++++++++++++++++++++++++----------
haskell-tng-smie.el | 2 ++
test/haskell-tng-lexer-test.el | 9 +++------
test/src/layout.hs.faceup | 2 +-
test/src/layout.hs.lexer | 4 ++--
test/src/layout.hs.sexps | 2 +-
test/src/medley.hs.faceup | 6 +++---
test/src/medley.hs.lexer | 6 +++---
9 files changed, 54 insertions(+), 34 deletions(-)
diff --git a/haskell-tng-lexer.el b/haskell-tng-lexer.el
index 5d106ea..c0c252c 100644
--- a/haskell-tng-lexer.el
+++ b/haskell-tng-lexer.el
@@ -90,15 +90,16 @@ the lexer."
((eobp) nil)
+ ;; reserved keywords take precedence
+ ((looking-at haskell-tng:regexp:reserved-hack)
+ (haskell-tng-lexer:last-match))
+
;; syntax tables (supported by `smie-indent-forward-token')
((looking-at haskell-tng-lexer:fast-syntax) nil)
- ;; If this ordering is changed, things will break, since many
regexps
- ;; match more than they should.
-
;; known identifiers
- ((looking-at haskell-tng:regexp:reserved)
- (haskell-tng-lexer:last-match))
+ ;;
+ ;; Ordering is important because regexps are greedy.
((looking-at haskell-tng:regexp:qual)
;; Matches qualifiers separately from identifiers because the
;; backwards lexer is not greedy enough. Qualifiers are not
@@ -157,10 +158,12 @@ the lexer."
(let ((lbp (min (point) (line-beginning-position))))
(cond
((bobp) nil)
- ((looking-back haskell-tng-lexer:fast-syntax (- (point) 1)) nil)
- ;; known identifiers
- ((looking-back haskell-tng:regexp:reserved (- (point) 8))
+ ((looking-back haskell-tng:regexp:reserved-hack
+ (max lbp (- (point) 8)) 't)
(haskell-tng-lexer:last-match 'reverse))
+ ((looking-back haskell-tng-lexer:fast-syntax
+ (max lbp (- (point) 1)))
+ nil)
((looking-back haskell-tng:regexp:qual lbp 't)
(haskell-tng-lexer:last-match 'reverse "")
(haskell-tng-lexer:backward-token))
diff --git a/haskell-tng-rx.el b/haskell-tng-rx.el
index a9bac83..ad7fcd0 100644
--- a/haskell-tng-rx.el
+++ b/haskell-tng-rx.el
@@ -12,7 +12,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Here are `rx' patterns that are reused as a very simple form of BNF grammar.
-(defconst haskell-tng:rx:consym '(: ":" (* (syntax symbol))))
+(defconst haskell-tng:rx:consym '(: ":" (+ (syntax symbol))))
(defconst haskell-tng:rx:conid '(: upper (* word)))
(defconst haskell-tng:rx:varid '(: (any lower ?_) (* (any word))))
(defconst haskell-tng:rx:symid '(: (+ (syntax symbol))))
@@ -20,20 +20,36 @@
(defconst haskell-tng:rx:kindsym `(: "'" ,haskell-tng:rx:consym)) ;; DataKinds
(defconst haskell-tng:rx:kindid `(: "'" ,haskell-tng:rx:conid)) ;; DataKinds
-(defconst haskell-tng:rx:reserved
- '(|
+(defun haskell-tng:rx:reserved (hack)
+ "reservedid / reservedop.
+
+This is a function, not a constant, because the lexer needs a
+hack that would break fontification.
+
+WORKAROUND https://debbugs.gnu.org/cgi/bugreport.cgi?bug=35119
+
+TL;DR: regexps don't see some non-capture boundaries outside the
+limit, so use POINT as a hint during lexing. If used in
+fontification, a carefully positioned point in e.g. <--> would
+give false positives." `(|
(: word-start
(| "case" "class" "data" "default" "deriving" "do" "else"
"foreign" "if" "import" "in" "infix" "infixl"
"infixr" "instance" "let" "module" "newtype" "of"
"then" "type" "where" "_")
word-end)
- (: symbol-start
- ;; not including : as it works as a regular consym
- (| ".." "::" "=" "|" "<-" "->" "@" "~" "=>")
- symbol-end)
- (: symbol-start (char ?\\)))
- "reservedid / reservedop")
+ (: "{..}") ;; RecordWildCards
+ (: word-start "':" symbol-end) ;; DataKinds (consider foo':bar)
+ (: ,(if hack
+ '(| symbol-start word-end point)
+ '(| symbol-start word-end))
+ (| ".." "::" ":" "=" "|" "<-" "->" "@" "~" "=>")
+ ,(if hack
+ '(| symbol-end word-start point)
+ '(| symbol-end word-start))
+ )
+ (| "[]" "()") ;; empty list / void
+ (: symbol-start (char ?\\))))
(defconst haskell-tng:rx:toplevel
;; TODO multi-definitions, e.g. Servant's :<|>
@@ -55,7 +71,9 @@
;; Word/symbol boundaries to help backwards regexp searches to be greedy and
;; are not in the BNF form as it breaks composability.
(defconst haskell-tng:regexp:reserved
- (rx-to-string haskell-tng:rx:reserved))
+ (rx-to-string (haskell-tng:rx:reserved nil)))
+(defconst haskell-tng:regexp:reserved-hack
+ (rx-to-string (haskell-tng:rx:reserved t)))
(defconst haskell-tng:regexp:qual
(rx-to-string `(: symbol-start ,haskell-tng:rx:qual)))
(defconst haskell-tng:regexp:kindsym
diff --git a/haskell-tng-smie.el b/haskell-tng-smie.el
index ebbef4f..42fb3ad 100644
--- a/haskell-tng-smie.el
+++ b/haskell-tng-smie.el
@@ -55,6 +55,8 @@
;; operators all have the same precedence
(infixexp
+ (id ":" infixexp) ;; keyword infix
+ (id "':" infixexp) ;; DataKinds
(id "SYMID" infixexp))
;; WLDOs
diff --git a/test/haskell-tng-lexer-test.el b/test/haskell-tng-lexer-test.el
index 1e8044b..a7724a6 100644
--- a/test/haskell-tng-lexer-test.el
+++ b/test/haskell-tng-lexer-test.el
@@ -54,8 +54,7 @@
;; repeating those tests, but for the backward lexer
(goto-char 317)
(should (equal (haskell-tng-lexer-test:indent-backward-token) ";"))
- (should (equal (haskell-tng-lexer-test:indent-backward-token) "»"))
- (should (equal (haskell-tng-lexer-test:indent-backward-token) "«"))
+ (should (equal (haskell-tng-lexer-test:indent-backward-token) "[]"))
(goto-char 317)
(should (equal (haskell-tng-lexer-test:indent-backward-token) ";"))
@@ -63,8 +62,7 @@
(goto-char (point-max))
(insert " "))
(should (equal (haskell-tng-lexer-test:indent-backward-token) ";"))
- (should (equal (haskell-tng-lexer-test:indent-backward-token) "»"))
- (should (equal (haskell-tng-lexer-test:indent-backward-token) "«"))
+ (should (equal (haskell-tng-lexer-test:indent-backward-token) "[]"))
(goto-char 317)
(should (equal (haskell-tng-lexer-test:indent-backward-token) ";"))
@@ -72,8 +70,7 @@
(should (equal (haskell-tng-lexer-test:indent-backward-token) "«"))
(goto-char 317)
(should (equal (haskell-tng-lexer-test:indent-backward-token) ";"))
- (should (equal (haskell-tng-lexer-test:indent-backward-token) "»"))
- (should (equal (haskell-tng-lexer-test:indent-backward-token) "«"))
+ (should (equal (haskell-tng-lexer-test:indent-backward-token) "[]"))
;; jumping between forward and backward at point should reset state
(goto-char 317)
diff --git a/test/src/layout.hs.faceup b/test/src/layout.hs.faceup
index 083a704..1f56b22 100644
--- a/test/src/layout.hs.faceup
+++ b/test/src/layout.hs.faceup
@@ -9,7 +9,7 @@
«:haskell-tng:toplevel:size» «:haskell-tng:keyword:::»«:haskell-tng:type:
Stack a »«:haskell-tng:keyword:->»«:haskell-tng:type: Int
»«:haskell-tng:toplevel:size» s «:haskell-tng:keyword:=» length
«:haskell-tng:keyword:(»stkToLst s«:haskell-tng:keyword:)»
«:haskell-tng:keyword:where»
stkToLst «:haskell-tng:constructor:Empty»
«:haskell-tng:keyword:=» «:haskell-tng:keyword:[]»
- stkToLst «:haskell-tng:keyword:(»«:haskell-tng:constructor:MkStack»
x s«:haskell-tng:keyword:)» «:haskell-tng:keyword:=» x:xs
«:haskell-tng:keyword:where» xs «:haskell-tng:keyword:=» stkToLst s
+ stkToLst «:haskell-tng:keyword:(»«:haskell-tng:constructor:MkStack»
x s«:haskell-tng:keyword:)» «:haskell-tng:keyword:=»
x«:haskell-tng:keyword::»xs «:haskell-tng:keyword:where» xs
«:haskell-tng:keyword:=» stkToLst s
«:haskell-tng:toplevel:pop» «:haskell-tng:keyword:::»«:haskell-tng:type: Stack
a »«:haskell-tng:keyword:->»«:haskell-tng:type:
»«:haskell-tng:keyword:(»«:haskell-tng:type:a»«:haskell-tng:keyword:,»«:haskell-tng:type:
Stack a»«:haskell-tng:keyword:)»«:haskell-tng:type:
»«:haskell-tng:toplevel:pop»
«:haskell-tng:keyword:(»«:haskell-tng:constructor:MkStack» x
s«:haskell-tng:keyword:)»
diff --git a/test/src/layout.hs.lexer b/test/src/layout.hs.lexer
index ce06291..4128c01 100644
--- a/test/src/layout.hs.lexer
+++ b/test/src/layout.hs.lexer
@@ -8,8 +8,8 @@ module CONID « CONID , VARID , VARID , VARID , VARID » where
; VARID :: CONID VARID -> CONID
; VARID VARID = VARID « VARID VARID » where
-{ VARID CONID = « »
-; VARID « CONID VARID VARID » = VARID CONSYM VARID where { VARID = VARID VARID
+{ VARID CONID = []
+; VARID « CONID VARID VARID » = VARID : VARID where { VARID = VARID VARID
} } ; VARID :: CONID VARID -> « VARID , CONID VARID »
; VARID « CONID VARID VARID »
diff --git a/test/src/layout.hs.sexps b/test/src/layout.hs.sexps
index 2fcfe45..d5a45a1 100644
--- a/test/src/layout.hs.sexps
+++ b/test/src/layout.hs.sexps
@@ -9,7 +9,7 @@
((size) (::) (Stack) (a) -> (Int))
((size) (s) = (length) ((stkToLst) (s))) (where)
(((stkToLst) (Empty) = ([])
- ((stkToLst) ((MkStack) (x) (s)) = (x)(:)(xs)) (where) ((xs) =
(stkToLst) (s)
+ ((stkToLst) ((MkStack) (x) (s)) = (x):(xs)) (where) ((xs) =
(stkToLst) (s)
)))(pop) (::) (Stack) (a) -> ((a), (Stack) (a))
((pop) ((MkStack) (x) (s))
diff --git a/test/src/medley.hs.faceup b/test/src/medley.hs.faceup
index 26359eb..818934a 100644
--- a/test/src/medley.hs.faceup
+++ b/test/src/medley.hs.faceup
@@ -43,10 +43,10 @@
«:haskell-tng:keyword:class»«:haskell-tng:type: Get a s
»«:haskell-tng:keyword:where»
get «:haskell-tng:keyword:::»«:haskell-tng:type: Set s
»«:haskell-tng:keyword:->»«:haskell-tng:type: a
»
-«:haskell-tng:keyword:instance»«:haskell-tng:type: »«x:{-# OVERLAPS
#-}»«:haskell-tng:type: Get a »«:haskell-tng:keyword:(»«:haskell-tng:type:a ':
s»«:haskell-tng:keyword:)»«:haskell-tng:type: »«:haskell-tng:keyword:where»
+«:haskell-tng:keyword:instance»«:haskell-tng:type: »«x:{-# OVERLAPS
#-}»«:haskell-tng:type: Get a »«:haskell-tng:keyword:(»«:haskell-tng:type:a
»«:haskell-tng:keyword:':»«:haskell-tng:type:
s»«:haskell-tng:keyword:)»«:haskell-tng:type: »«:haskell-tng:keyword:where»
get «:haskell-tng:keyword:(»«:haskell-tng:constructor:Ext» a
«:haskell-tng:keyword:_)» «:haskell-tng:keyword:=» a
-«:haskell-tng:keyword:instance»«:haskell-tng:type: »«x:{-# OVERLAPPABLE
#-}»«:haskell-tng:type: Get a s »«:haskell-tng:keyword:=>»«:haskell-tng:type:
Get a »«:haskell-tng:keyword:(»«:haskell-tng:type:b ':
s»«:haskell-tng:keyword:)»«:haskell-tng:type: »«:haskell-tng:keyword:where»
+«:haskell-tng:keyword:instance»«:haskell-tng:type: »«x:{-# OVERLAPPABLE
#-}»«:haskell-tng:type: Get a s »«:haskell-tng:keyword:=>»«:haskell-tng:type:
Get a »«:haskell-tng:keyword:(»«:haskell-tng:type:b
»«:haskell-tng:keyword:':»«:haskell-tng:type:
s»«:haskell-tng:keyword:)»«:haskell-tng:type: »«:haskell-tng:keyword:where»
get «:haskell-tng:keyword:(»«:haskell-tng:constructor:Ext»
«:haskell-tng:keyword:_» xs«:haskell-tng:keyword:)» «:haskell-tng:keyword:=»
get xs
«:haskell-tng:keyword:data»«:haskell-tng:type: Options
»«:haskell-tng:keyword:=» «:haskell-tng:constructor:Options»
@@ -58,7 +58,7 @@
«:haskell-tng:keyword:class»«:haskell-tng:type:
»«:haskell-tng:keyword:(»«:haskell-tng:type:Eq
a»«:haskell-tng:keyword:)»«:haskell-tng:type:
»«:haskell-tng:keyword:=>»«:haskell-tng:type: Ord a
»«:haskell-tng:keyword:where»
«:haskell-tng:keyword:(»<«:haskell-tng:keyword:),»
«:haskell-tng:keyword:(»<=«:haskell-tng:keyword:),»
«:haskell-tng:keyword:(»>=«:haskell-tng:keyword:),»
«:haskell-tng:keyword:(»>«:haskell-tng:keyword:)»
«:haskell-tng:keyword:::»«:haskell-tng:type: a
»«:haskell-tng:keyword:->»«:haskell-tng:type: a
»«:haskell-tng:keyword:->»«:haskell-tng:type: Bool
-» max @Foo«:haskell-tng:keyword:,» min
«:haskell-tng:keyword:::»«:haskell-tng:type: a
»«:haskell-tng:keyword:->»«:haskell-tng:type: a
»«:haskell-tng:keyword:->»«:haskell-tng:type: a
+» max «:haskell-tng:keyword:@»Foo«:haskell-tng:keyword:,» min
«:haskell-tng:keyword:::»«:haskell-tng:type: a
»«:haskell-tng:keyword:->»«:haskell-tng:type: a
»«:haskell-tng:keyword:->»«:haskell-tng:type: a
»
«:haskell-tng:keyword:instance»«:haskell-tng:type:
»«:haskell-tng:keyword:(»«:haskell-tng:type:Eq
a»«:haskell-tng:keyword:)»«:haskell-tng:type:
»«:haskell-tng:keyword:=>»«:haskell-tng:type: Eq
»«:haskell-tng:keyword:(»«:haskell-tng:type:Tree
a»«:haskell-tng:keyword:)»«:haskell-tng:type: »«:haskell-tng:keyword:where»
«:haskell-tng:constructor:Leaf» a == «:haskell-tng:constructor:Leaf»
b «:haskell-tng:keyword:=» a == b
diff --git a/test/src/medley.hs.lexer b/test/src/medley.hs.lexer
index 2ebf636..e13d30d 100644
--- a/test/src/medley.hs.lexer
+++ b/test/src/medley.hs.lexer
@@ -43,10 +43,10 @@ VARID , VARID , VARID »
; class CONID VARID VARID where
{ VARID :: CONID VARID -> VARID
-} ; instance CONID VARID « VARID KINDSYM VARID » where
+} ; instance CONID VARID « VARID ': VARID » where
{ VARID « CONID VARID _ » = VARID
-} ; instance CONID VARID VARID => CONID VARID « VARID KINDSYM VARID » where
+} ; instance CONID VARID VARID => CONID VARID « VARID ': VARID » where
{ VARID « CONID _ VARID » = VARID VARID
} ; data CONID = CONID
@@ -58,7 +58,7 @@ VARID , VARID , VARID »
; class « CONID VARID » => CONID VARID where
{ « SYMID » , « SYMID » , « SYMID » , « SYMID » :: VARID -> VARID -> CONID
-; VARID SYMID CONID , VARID :: VARID -> VARID -> VARID
+; VARID @ CONID , VARID :: VARID -> VARID -> VARID
} ; instance « CONID VARID » => CONID « CONID VARID » where
{ CONID VARID SYMID CONID VARID = VARID SYMID VARID
