[nongnu] elpa/haskell-tng-mode dae43ac 049/385: improvements to the default lexer

[ELPA Syncer]

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

    improvements to the default lexer
---
 haskell-tng-font-lock.el      |  29 +--
 haskell-tng-smie.el           |  38 ++--
 test/faces/medley.hs.lexer    | 397 ++++++++++++++++--------------------------
 test/haskell-tng-smie-test.el |  10 +-
 test/lexer/layout.hs.lexer    |  32 ++--
 5 files changed, 212 insertions(+), 294 deletions(-)

diff --git a/haskell-tng-font-lock.el b/haskell-tng-font-lock.el
index d4daea4..778e6a1 100644
--- a/haskell-tng-font-lock.el
+++ b/haskell-tng-font-lock.el
@@ -86,6 +86,22 @@
   "Newline or line comment.")
 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Here are compiled regexps that are reused
+(defconst haskell-tng:regexp:reserved
+  (rx (|
+       (: 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
+          (| ".." ":" "::" "=" "|" "<-" "->" "@" "~" "=>")
+          symbol-end)
+       (: symbol-start (char ?\\))))
+  "reservedid / reservedop")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Here is the `font-lock-keywords' table of matchers and highlighters.
 (defvar
  haskell-tng:keywords
@@ -98,18 +114,7 @@
        (toplevel haskell-tng:rx:toplevel)
        (bigspace `(| space ,haskell-tng:rx:newline)))
    `(;; reservedid / reservedop
-     (,(rx-to-string
-        '(|
-          (: 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
-             (| ".." ":" "::" "=" "|" "<-" "->" "@" "~" "=>")
-             symbol-end)
-          (: symbol-start (char ?\\))))
+     (,haskell-tng:regexp:reserved
       . 'haskell-tng:keyword)
 
      ;; Some things are not technically keywords but are always special so make
diff --git a/haskell-tng-smie.el b/haskell-tng-smie.el
index ce8d614..4e170df 100644
--- a/haskell-tng-smie.el
+++ b/haskell-tng-smie.el
@@ -27,33 +27,39 @@
 ;;; Code:
 
 (require 'smie)
+(require 'haskell-tng-font-lock)
 
-(defvar haskell-tng-smie:keywords
-  (regexp-opt '("+" "*" "=")))
-
-;; TODO custom Haskell lexer
-;; TODO convert significant whitespace to semicolons
-;;
 ;; Function to scan forward for the next token.
 ;; - Called with no argument should return a token and move to its end.
 ;; - If no token is found, return nil or the empty string.
 ;; - It can return nil when bumping into a parenthesis, which lets SMIE
-;; - use syntax-tables to handle them in efficient C code.
+;;   use syntax-tables to handle them in efficient C code.
 ;;
 ;; https://www.gnu.org/software/emacs/manual/html_mono/elisp.html#SMIE-Lexer
 (defun haskell-tng-smie:forward-token ()
   (interactive) ;; for testing
   (forward-comment (point-max))
-  (cond
-   ((looking-at haskell-tng-smie:keywords)
-    (goto-char (match-end 0))
-    (match-string-no-properties 0))
-   (t (buffer-substring-no-properties
-       (point)
-       (progn (skip-syntax-forward "w_")
-              (point))))))
+  (unless (eobp)
+    (let ((case-fold-search nil)
+          (syntax (char-syntax (char-after))))
+      (cond
+       ;; TODO detect newlines with significant whitespace
+
+       ;; parens
+       ((or (= syntax ?\() (= syntax ?\))) nil)
+
+       ;; TODO match paired delimiters
 
-;; 
+       ;; regexps
+       ((or
+         ;; known identifiers
+         (looking-at haskell-tng:regexp:reserved)
+         ;; symbols
+         (looking-at (rx (+ (| (syntax word) (syntax symbol)))))
+         ;; whatever the current syntax class is
+         (looking-at (rx-to-string `(+ (syntax ,syntax)))))
+        (goto-char (match-end 0))
+        (match-string-no-properties 0))))))
 
 ;; TODO a haskell grammar
 ;; https://www.gnu.org/software/emacs/manual/html_mono/elisp.html#SMIE-Grammar
diff --git a/test/faces/medley.hs.lexer b/test/faces/medley.hs.lexer
index e784f41..598e8a4 100644
--- a/test/faces/medley.hs.lexer
+++ b/test/faces/medley.hs.lexer
@@ -1,83 +1,71 @@
 module
 Foo.Bar.Main
-
-(
+SYNTAX_(
 Wibble
-(
+SYNTAX_(
 ..
-)
+SYNTAX_)
 ,
 Wobble
-(
+SYNTAX_(
 Wobb
 ,
-
-(
+SYNTAX_(
 !!!
-)
-)
+SYNTAX_)
+SYNTAX_)
 ,
 Woo
-
 ,
 getFooByBar
 ,
 getWibbleByWobble
-
 ,
 module
 Bloo.Foo
-
-)
+SYNTAX_)
 where
 import
 Control.Applicative
-
-(
+SYNTAX_(
 many
 ,
 optional
 ,
 pure
 ,
-
-(
+SYNTAX_(
 <*>
-)
+SYNTAX_)
 ,
-
-(
+SYNTAX_(
 <|>
-)
-)
+SYNTAX_)
+SYNTAX_)
 import
 Data.Foldable
-
-(
+SYNTAX_(
 traverse_
-)
+SYNTAX_)
 import
 Data.Functor
-
-(
-(
+SYNTAX_(
+SYNTAX_(
 <$>
-)
-)
+SYNTAX_)
+SYNTAX_)
 import
 Data.List
-
-(
+SYNTAX_(
 intercalate
-)
+SYNTAX_)
 import
 Data.Monoid
-
-(
-(
+SYNTAX_(
+SYNTAX_(
 <>
-)
-)
+SYNTAX_)
+SYNTAX_)
 import
 qualified
 Options.Monad
@@ -95,55 +83,49 @@ import
 qualified
 ProfFile.App
 hiding
-
-(
+SYNTAX_(
 as
 ,
 hiding
 ,
 qualified
-)
+SYNTAX_)
 import
 ProfFile.App
-
-(
+SYNTAX_(
 as
 ,
 hiding
 ,
 qualified
-)
+SYNTAX_)
 import
 ProfFile.App
 hiding
-
-(
+SYNTAX_(
 as
 ,
 hiding
 ,
 qualified
-)
+SYNTAX_)
 import
 qualified
 ProfFile.App
-
-(
+SYNTAX_(
 as
 ,
 hiding
 ,
 qualified
-)
+SYNTAX_)
 import
 System.Exit
-
-(
+SYNTAX_(
 ExitCode
-
-(
+SYNTAX_(
 ..
-)
+SYNTAX_)
 ,
 exitFailure
 ,
@@ -154,31 +136,27 @@ Typey
 wibble
 ,
 Wibble
-)
+SYNTAX_)
 import
 System.FilePath
-
-(
+SYNTAX_(
 replaceExtension
 ,
 Foo
-(
+SYNTAX_(
 Bar
 ,
-
-(
+SYNTAX_(
 :<
-)
-)
+SYNTAX_)
+SYNTAX_)
 import
 System.IO
-
-(
+SYNTAX_(
 IOMode
-
-(
+SYNTAX_(
 ..
-)
+SYNTAX_)
 ,
 hClose
 ,
@@ -195,52 +173,44 @@ stderr
 stdout
 ,
 MoarTypey
-)
+SYNTAX_)
 import
 System.Process
-
-(
+SYNTAX_(
 CreateProcess
-
-(
+SYNTAX_(
 ..
-)
+SYNTAX_)
 ,
 StdStream
-
-(
+SYNTAX_(
 ..
-)
+SYNTAX_)
 ,
 createProcess
 ,
 proc
 ,
 waitForProcess
-)
-
-'
+SYNTAX_)
+SYNTAX_'
 c
-'
-
-'
-\
+SYNTAX_'
+SYNTAX_'
+SYNTAX_\
 n
+SYNTAX_'
+SYNTAX_'
+SYNTAX_\
 '
-
-'
-\
-'
-'
+SYNTAX_'
 foo
 =
-
 "
 wobble
-
-(
+SYNTAX_(
 wibble
-)
+SYNTAX_)
 "
 class
 Get
@@ -256,44 +226,39 @@ a
 instance
 Get
 a
-
-(
+SYNTAX_(
 a
 ':
 s
-)
+SYNTAX_)
 where
 get
-
-(
+SYNTAX_(
 Ext
 a
 _
-)
+SYNTAX_)
 =
 a
 instance
 Get
 a
 s
-=
->
+=>
 Get
 a
-
-(
+SYNTAX_(
 b
 ':
 s
-)
+SYNTAX_)
 where
 get
-
-(
+SYNTAX_(
 Ext
 _
 xs
-)
+SYNTAX_)
 =
 get
 xs
@@ -301,70 +266,57 @@ data
 Options
 =
 Options
-
-{
+SYNTAX_{
 optionsReportType
 ::
 ReportType
-
 ,
 optionsProfFile
 ::
 Maybe
 FilePath
-
 ,
 optionsOutputFile
 ::
 Maybe
 FilePath
-
 ,
 optionsFlamegraphFlags
 ::
-
-[
+SYNTAX_[
 String
-]
-
-}
+SYNTAX_]
+SYNTAX_}
 deriving
-
-(
+SYNTAX_(
 Eq
 ,
 Show
-)
+SYNTAX_)
 class
-
-(
+SYNTAX_(
 Eq
 a
-)
-=
->
+SYNTAX_)
+=>
 Ord
 a
 where
-
-(
+SYNTAX_(
 <
-)
+SYNTAX_)
 ,
-
-(
+SYNTAX_(
 <=
-)
+SYNTAX_)
 ,
-
-(
+SYNTAX_(
 >=
-)
+SYNTAX_)
 ,
-
-(
+SYNTAX_(
 >
-)
+SYNTAX_)
 ::
 a
 ->
@@ -382,58 +334,47 @@ a
 ->
 a
 instance
-
-(
+SYNTAX_(
 Eq
 a
-)
-=
->
+SYNTAX_)
+=>
 Eq
-
-(
+SYNTAX_(
 Tree
 a
-)
+SYNTAX_)
 where
 Leaf
 a
-=
-=
+==
 Leaf
 b
 =
 a
-=
-=
+==
 b
-
-(
+SYNTAX_(
 Branch
 l1
 r1
-)
-=
-=
-
-(
+SYNTAX_)
+==
+SYNTAX_(
 Branch
 l2
 r2
-)
+SYNTAX_)
 =
-
-(
+SYNTAX_(
 l1==l2
-)
+SYNTAX_)
 &&
-
-(
+SYNTAX_(
 r1==r2
-)
+SYNTAX_)
 _
-=
-=
+==
 _
 =
 False
@@ -450,12 +391,11 @@ Ticks
 |
 Bytes
 deriving
-
-(
+SYNTAX_(
 Eq
 ,
 Show
-)
+SYNTAX_)
 type
 family
 G
@@ -474,34 +414,29 @@ Flobble
 =
 Flobble
 deriving
-
-(
+SYNTAX_(
 Eq
-)
+SYNTAX_)
 via
-
-(
+SYNTAX_(
 NonNegative
-
-(
+SYNTAX_(
 Large
 Int
-)
-)
+SYNTAX_)
+SYNTAX_)
 deriving
 stock
-
-(
+SYNTAX_(
 Floo
-)
+SYNTAX_)
 deriving
 anyclass
-
-(
+SYNTAX_(
 WibblyWoo
 ,
 OtherlyWoo
-)
+SYNTAX_)
 newtype
 Flobby
 =
@@ -516,45 +451,39 @@ Wobble
 ->
 Wobble
 ->
-
-(
+SYNTAX_(
 wob
 ::
 Wobble
-)
+SYNTAX_)
 ->
-
-(
+SYNTAX_(
 Wobble
 a
 b
 c
-)
-
-(
+SYNTAX_)
+SYNTAX_(
 foo
 ::
-
-(
+SYNTAX_(
 Wibble
 Wobble
-)
-)
+SYNTAX_)
+SYNTAX_)
 foo
 newtype
 TestApp
-
-(
+SYNTAX_(
 logger
 ::
 TestLogger
-)
-
-(
+SYNTAX_)
+SYNTAX_(
 scribe
 ::
 TestScribe
-)
+SYNTAX_)
 config
 a
 =
@@ -568,107 +497,89 @@ optionsParser
 =
 Options
 <$>
-
-(
+SYNTAX_(
 Opts.flag'
 Alloc
-
-(
+SYNTAX_(
 Opts.long
-
 "
 alloc
 "
 <>
 Opts.help
-
 "
 wibble
 "
-)
+SYNTAX_)
 <|>
 Opts.flag'
 Entries
-
-(
+SYNTAX_(
 Opts.long
-
 "
 entry
 "
 <>
 Opts.help
-
 "
 wobble
 "
-)
+SYNTAX_)
 <|>
 Opts.flag'
 Bytes
-
-(
+SYNTAX_(
 Opts.long
-
 "
 bytes
 "
 <>
 Opts.help
-
 "
 i'm
 a
 fish
 "
-)
-)
+SYNTAX_)
+SYNTAX_)
 <*>
 optional
-
-(
+SYNTAX_(
 Opts.strArgument
-
-(
+SYNTAX_(
 Opts.metavar
-
 "
 MY-FILE
 "
 <>
 Opts.help
-
 "
 meh
 "
-)
-)
+SYNTAX_)
+SYNTAX_)
 type
 PhantomThing
 type
 SomeApi
 =
-
 "
 thing
 "
 :>
 Capture
-
 "
 bar
 "
 Index
 :>
 QueryParam
-
 "
 wibble
 "
 Text
 :>
 QueryParam
-
 "
 wobble
 "
@@ -682,25 +593,23 @@ ThingHeader
 :>
 Get
 '
-[
+SYNTAX_[
 JSON
-]
-
-(
+SYNTAX_]
+SYNTAX_(
 The
 ReadResult
-)
+SYNTAX_)
 :<|>
-
 "
 thing
 "
 :>
 ReqBody
 '
-[
+SYNTAX_[
 JSON
-]
+SYNTAX_]
 Request
 :>
 Header
@@ -711,14 +620,13 @@ SpecialHeader
 :>
 Post
 '
-[
+SYNTAX_[
 JSON
-]
-
-(
+SYNTAX_]
+SYNTAX_(
 The
 Response
-)
+SYNTAX_)
 deriving
 instance
 FromJSONKey
@@ -733,4 +641,3 @@ newtype
 instance
 FromJSON
 Treble
-
diff --git a/test/haskell-tng-smie-test.el b/test/haskell-tng-smie-test.el
index 005ed0e..649333c 100644
--- a/test/haskell-tng-smie-test.el
+++ b/test/haskell-tng-smie-test.el
@@ -26,12 +26,12 @@
     (while (not (eobp))
       (let* ((start (point))
              (token (apply smie-forward-token-function ())))
-        (when (= (point) start)
-          (unless (or (s-present? token) (eobp))
-            (setq token (char-to-string (char-after (point)))))
+        (when (and (= (point) start) (not token))
+          (setq token (concat "SYNTAX_" (char-to-string (char-after (point)))))
           (forward-char))
-        (with-current-buffer work
-          (insert token "\n"))))
+        (when (s-present? token)
+          (with-current-buffer work
+            (insert token "\n")))))
     (if (called-interactively-p 'interactive)
       (switch-to-buffer work)
       work)))
diff --git a/test/lexer/layout.hs.lexer b/test/lexer/layout.hs.lexer
index 10ac6b0..d048eb2 100644
--- a/test/lexer/layout.hs.lexer
+++ b/test/lexer/layout.hs.lexer
@@ -1,6 +1,6 @@
 module
 AStack
-(
+SYNTAX_(
 Stack
 ,
 ;
@@ -11,7 +11,7 @@ pop
 top
 ,
 size
-)
+SYNTAX_)
 where
 {
 data
@@ -22,10 +22,10 @@ Empty
 |
 MkStack
 a
-(
+SYNTAX_(
 Stack
 a
-)
+SYNTAX_)
 ;
 push
 ::
@@ -55,10 +55,10 @@ size
 s
 =
 length
-(
+SYNTAX_(
 stkToLst
 s
-)
+SYNTAX_)
 where
 {
 stkToLst
@@ -68,11 +68,11 @@ Empty
 ]
 ;
 stkToLst
-(
+SYNTAX_(
 MkStack
 x
 s
-)
+SYNTAX_)
 =
 x:xs
 where
@@ -89,21 +89,21 @@ pop
 Stack
 a
 ->
-(
+SYNTAX_(
 a
 ,
 Stack
 a
-)
+SYNTAX_)
 ;
 pop
-(
+SYNTAX_(
 MkStack
 x
 s
-)
+SYNTAX_)
 =
-(
+SYNTAX_(
 x
 ,
 case
@@ -122,7 +122,7 @@ x
 x
 }
 }
-)
+SYNTAX_)
 ;
 top
 ::
@@ -132,11 +132,11 @@ a
 a
 ;
 top
-(
+SYNTAX_(
 MkStack
 x
 s
-)
+SYNTAX_)
 =
 x
 }