[nongnu] elpa/haskell-tng-mode 138aca0 089/385: typelevel lists are harder than I thought...

[ELPA Syncer]

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

    typelevel lists are harder than I thought...
---
 haskell-tng-lexer.el           | 17 +++++++++++++++++
 haskell-tng-rx.el              | 29 ++++++++++++++++++-----------
 haskell-tng-smie.el            | 11 ++++++-----
 haskell-tng-syntax.el          |  8 --------
 test/haskell-tng-lexer-test.el |  8 ++++++--
 test/src/grammar.hs.sexps      |  2 +-
 test/src/layout.hs.lexer       |  2 +-
 test/src/layout.hs.sexps       | 16 ++++++++--------
 test/src/medley.hs.lexer       | 10 +++++-----
 9 files changed, 62 insertions(+), 41 deletions(-)

diff --git a/haskell-tng-lexer.el b/haskell-tng-lexer.el
index e5bf3b2..3fea0e4 100644
--- a/haskell-tng-lexer.el
+++ b/haskell-tng-lexer.el
@@ -93,6 +93,14 @@ the lexer."
             ;; interesting from a grammar point of view so we ignore them.
             (haskell-tng-lexer:last-match nil "")
             (haskell-tng-lexer:forward-token))
+           ((looking-at (rx "'["))
+            ;; DataKinds
+            (null (goto-char (+ (point) 1))))
+           ((looking-at haskell-tng:regexp:kindsym)
+            ;; caveat: doesn't include typelevel lists, see fast-syntax
+            (haskell-tng-lexer:last-match nil "KINDSYM"))
+           ((looking-at haskell-tng:regexp:kindid)
+            (haskell-tng-lexer:last-match nil "KINDID"))
            ((looking-at haskell-tng:regexp:consym)
             (haskell-tng-lexer:last-match nil "CONSYM"))
            ((looking-at haskell-tng:regexp:conid)
@@ -144,6 +152,15 @@ the lexer."
               ((looking-back haskell-tng:regexp:qual lbp 't)
                (haskell-tng-lexer:last-match 'reverse "")
                (haskell-tng-lexer:backward-token))
+              ((and (looking-at (rx "["))
+                    (looking-back (rx "'") (- (point) 1)))
+               ;; non-trivial inversion
+               (goto-char (- (point) 1))
+               (haskell-tng-lexer:backward-token))
+              ((looking-back haskell-tng:regexp:kindsym lbp 't)
+               (haskell-tng-lexer:last-match 'reverse "KINDSYM"))
+              ((looking-back haskell-tng:regexp:kindid lbp 't)
+               (haskell-tng-lexer:last-match 'reverse "KINDID"))
               ((looking-back haskell-tng:regexp:consym lbp 't)
                (haskell-tng-lexer:last-match 'reverse "CONSYM"))
               ((looking-back haskell-tng:regexp:conid lbp 't)
diff --git a/haskell-tng-rx.el b/haskell-tng-rx.el
index eb0a9c3..a9bac83 100644
--- a/haskell-tng-rx.el
+++ b/haskell-tng-rx.el
@@ -12,14 +12,13 @@
 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Here are `rx' patterns that are reused as a very simple form of BNF grammar.
-;; Word/symbol boundaries to help backwards regexp searches to be greedy
-(defconst haskell-tng:rx:consym '(: (or "'" ":") ;; Datakinds
-                                    (+ (syntax symbol))))
-(defconst haskell-tng:rx:conid '(: word-start upper (* word)))
-(defconst haskell-tng:rx:varid '(: word-start (any lower ?_) (* (any word))))
+(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))))
-(defconst haskell-tng:rx:qual `(: symbol-start
-                                  (+ (: ,haskell-tng:rx:conid (char ?.)))))
+(defconst haskell-tng:rx:qual `(+ (: ,haskell-tng:rx:conid (char ?.))))
+(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
   '(|
@@ -30,7 +29,8 @@
           "then" "type" "where" "_")
        word-end)
     (: symbol-start
-       (| ".." ":" "::" "=" "|" "<-" "->" "@" "~" "=>")
+       ;; not including : as it works as a regular consym
+       (| ".." "::" "=" "|" "<-" "->" "@" "~" "=>")
        symbol-end)
     (: symbol-start (char ?\\)))
   "reservedid / reservedop")
@@ -51,16 +51,23 @@
 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Compiled regexps
+;;
+;; 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))
 (defconst haskell-tng:regexp:qual
-  (rx-to-string haskell-tng:rx:qual))
+  (rx-to-string `(: symbol-start ,haskell-tng:rx:qual)))
+(defconst haskell-tng:regexp:kindsym
+  (rx-to-string `(: word-start ,haskell-tng:rx:kindsym)))
+(defconst haskell-tng:regexp:kindid
+  (rx-to-string `(: word-start ,haskell-tng:rx:kindid)))
 (defconst haskell-tng:regexp:consym
   (rx-to-string haskell-tng:rx:consym))
 (defconst haskell-tng:regexp:conid
-  (rx-to-string haskell-tng:rx:conid))
+  (rx-to-string `(: word-start ,haskell-tng:rx:conid)))
 (defconst haskell-tng:regexp:varid
-  (rx-to-string haskell-tng:rx:varid))
+  (rx-to-string `(: word-start ,haskell-tng:rx:varid)))
 (defconst haskell-tng:regexp:symid
   (rx-to-string haskell-tng:rx:symid))
 
diff --git a/haskell-tng-smie.el b/haskell-tng-smie.el
index 816767e..5bb86c5 100644
--- a/haskell-tng-smie.el
+++ b/haskell-tng-smie.el
@@ -48,7 +48,7 @@
       ;; commas only allowed in brackets
       (list
        ("(" list ")")
-       ("[" list "]")
+       ("[" list "]") ;; includes DataKinds
        (list "," list))
 
       ;; operators all have the same precedence
@@ -57,24 +57,25 @@
 
       ;; WLDOs
       (wldo
-       ("where" block)
+       (block "where" block)
        ("let" block "in")
        ("do" block)
        ("case" id "of" block))
       (block
        ("{" block "}")
        (block ";" block)
+       (id "=" id)
        (id "<-" id)
        (id "->" id)
-       (id "=" id))
+       )
 
       (logic
        ("if" id "then" id "else" id))
       )
 
     ;; operator precedences
-    '((assoc ";")
-      (assoc ","))
+    '((assoc ";" ",")
+      )
 
     )))
 
diff --git a/haskell-tng-syntax.el b/haskell-tng-syntax.el
index 1d32423..4946f76 100644
--- a/haskell-tng-syntax.el
+++ b/haskell-tng-syntax.el
@@ -74,7 +74,6 @@
 (defun haskell-tng:syntax-propertize (start end)
   "For some context-sensitive syntax entries."
   (haskell-tng:syntax:char-delims start end)
-  (haskell-tng:syntax:typelevel-lists start end)
   (haskell-tng:syntax:escapes start end))
 
 (defun haskell-tng:syntax:char-delims (start end)
@@ -87,13 +86,6 @@
       (put-text-property open (1+ open) 'syntax-table '(7 . ?\'))
       (put-text-property close (1+ close) 'syntax-table '(7 . ?\')))))
 
-(defun haskell-tng:syntax:typelevel-lists (start end)
-  "Apostrophes should be symbols when used in typelevel lists."
-  (goto-char start)
-  (while (re-search-forward (rx space (char ?') (any ?\[ ?:)) end t)
-    (put-text-property (- (point) 1) (point)
-                       'syntax-table '(3 . ?'))))
-
 (defun haskell-tng:syntax:escapes (start end)
   "Backslash inside String is an escape character."
   (goto-char start)
diff --git a/test/haskell-tng-lexer-test.el b/test/haskell-tng-lexer-test.el
index fba496a..fcc48e0 100644
--- a/test/haskell-tng-lexer-test.el
+++ b/test/haskell-tng-lexer-test.el
@@ -103,7 +103,9 @@
                          (syntax string-delimiter))))
       (forward-sexp 1)
       "§")
-     (t (error "Bumped into unknown token")))))
+     (t (error "Unknown token: '%s' with '%S'"
+               (string (char-after))
+               (syntax-after (point)))))))
 
 ;; same as above, but for `smie-indent-backward-token'
 (defun haskell-tng-lexer-test:indent-backward-token ()
@@ -122,7 +124,9 @@
                     (- (point) 1))
       (backward-sexp 1)
       "§")
-     (t (error "Bumped into unknown token")))))
+     (t (error "Unknown token: '%s' with '%S'"
+               (string (char-before))
+               (syntax-before (point)))))))
 
 (defun haskell-tng-lexer-test:tokens (&optional reverse)
   "Lex the current buffer using SMIE and return the list of lines,
diff --git a/test/src/grammar.hs.sexps b/test/src/grammar.hs.sexps
index 155fe72..1f02b76 100644
--- a/test/src/grammar.hs.sexps
+++ b/test/src/grammar.hs.sexps
@@ -1,5 +1,5 @@
 -- | Tests for grammar rules i.e. sexps, not indentation
-(module) (Foo.(Bar)) (where
+((module) (Foo.(Bar)) (where)
 
 ((calc) (::) (Int) -> (Int)
 ((calc) (a) = (if (a) < ((10)
diff --git a/test/src/layout.hs.lexer b/test/src/layout.hs.lexer
index 1920ad6..ce06291 100644
--- a/test/src/layout.hs.lexer
+++ b/test/src/layout.hs.lexer
@@ -9,7 +9,7 @@ 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 SYMID VARID where { VARID = VARID VARID
+; VARID « CONID VARID VARID » = VARID CONSYM 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 95d7726..2fcfe45 100644
--- a/test/src/layout.hs.sexps
+++ b/test/src/layout.hs.sexps
@@ -1,20 +1,20 @@
 -- Figure 2.1 from the Haskell2010 report
-(module) (AStack)( (Stack), (push), (pop), (top), (size) ) (where
-((data) (Stack) (a) = (Empty)
+((module) (AStack)( (Stack), (push), (pop), (top), (size) ) (where)
+(((data) (Stack) (a) = (Empty)
              (|) (MkStack) (a) ((Stack) (a))
 
 ((push) (::) (a) -> (Stack) (a) -> (Stack) (a))
 ((push) (x) (s) = (MkStack) (x) (s))
 
 ((size) (::) (Stack) (a) -> (Int))
-((size) (s) = (length) ((stkToLst) (s))  (where
-           ((stkToLst)  (Empty)         = ([])
-           ((stkToLst) ((MkStack) (x) (s))  = (x):(xs) (where ((xs) = 
(stkToLst) (s)
+((size) (s) = (length) ((stkToLst) (s)))  (where)
+           (((stkToLst)  (Empty)         = ([])
+           ((stkToLst) ((MkStack) (x) (s))  = (x)(:)(xs)) (where) ((xs) = 
(stkToLst) (s)
 
-))))(pop) (::) (Stack) (a) -> ((a), (Stack) (a))
+)))(pop) (::) (Stack) (a) -> ((a), (Stack) (a))
 ((pop) ((MkStack) (x) (s))
-  = ((x), ((case (s) (of) (r -> (i) (r) (where (i (x) = x))))))) -- pop Empty 
is an error
+  = ((x), ((case (s) (of) ((r -> (i) (r) (where) (i (x) = x))))))) -- pop 
Empty is an error
 
 ((top) (::) (Stack) (a) -> (a))
-((top) ((MkStack) (x) (s)) = (x))))                     -- top Empty is an 
error
+((top) ((MkStack) (x) (s)) = (x)))                     -- top Empty is an error
 ))
\ No newline at end of file
diff --git a/test/src/medley.hs.lexer b/test/src/medley.hs.lexer
index 21bd33d..2ebf636 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 CONSYM VARID » where
+} ; instance CONID VARID « VARID KINDSYM VARID » where
 { VARID « CONID VARID _ » = VARID
 
-} ; instance CONID VARID VARID => CONID VARID « VARID CONSYM VARID » where
+} ; instance CONID VARID VARID => CONID VARID « VARID KINDSYM VARID » where
 { VARID « CONID _ VARID » = VARID VARID
 
 } ; data CONID = CONID
@@ -118,11 +118,11 @@ VARID § » »
 CONSYM CONID § CONID
 CONSYM CONID CONID CONID
 CONSYM CONID
-CONSYM CONID CONSYM CONID » « CONID CONID »
-CONSYM § CONSYM CONID CONSYM CONID » CONID
+CONSYM CONID « CONID » « CONID CONID »
+CONSYM § CONSYM CONID « CONID » CONID
 CONSYM CONID CONID CONID
 CONSYM CONID
-CONSYM CONID CONSYM CONID » « CONID CONID »
+CONSYM CONID « CONID » « CONID CONID »
 
 ; deriving instance CONID CONID
 ; deriving VARID instance CONID CONID