[nongnu] elpa/haskell-tng-mode 6e7a24f 083/385: lexer identifies conid / varid

[ELPA Syncer]

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

    lexer identifies conid / varid
---
 haskell-tng-font-lock.el       |  13 ++-
 haskell-tng-lexer.el           |  53 +++++----
 test/haskell-tng-lexer-test.el |   8 +-
 test/src/layout.hs.lexer       |  28 ++---
 test/src/medley.hs.lexer       | 246 ++++++++++++++++++++---------------------
 5 files changed, 182 insertions(+), 166 deletions(-)

diff --git a/haskell-tng-font-lock.el b/haskell-tng-font-lock.el
index 7fe6f56..2a4fb92 100644
--- a/haskell-tng-font-lock.el
+++ b/haskell-tng-font-lock.el
@@ -68,12 +68,14 @@
 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Here are `rx' patterns that are reused as a very simple form of BNF grammar
-(defconst haskell-tng:rx:conid '(: upper (* wordchar)))
+(defconst haskell-tng:rx:conid '(: upper (* word)))
+(defconst haskell-tng:rx:varid '(: (any lower ?_) (* (any word ?_ ?\'))))
 (defconst haskell-tng:rx:qual `(: (+ (: ,haskell-tng:rx:conid (char ?.)))))
 (defconst haskell-tng:rx:consym '(: ":" (+ (syntax symbol))))
 ;; TODO restrictive consym, e.g. no :: , @
 (defconst haskell-tng:rx:toplevel
-  `(: line-start (group (| (: (any lower ?_) (* wordchar))
+  ;; TODO multi-definitions, e.g. Servant's :<|>
+  `(: line-start (group (| ,haskell-tng:rx:varid
                            (: "(" (+? (syntax symbol)) ")")))
       symbol-end))
 ;; note that \n has syntax `comment-end'
@@ -101,6 +103,13 @@
        (: symbol-start (char ?\\))))
   "reservedid / reservedop")
 
+(defconst haskell-tng:regexp:varid
+  (rx-to-string `(: symbol-start (opt ,haskell-tng:rx:qual) 
,haskell-tng:rx:varid symbol-end)))
+(defconst haskell-tng:regexp:conid
+  (rx-to-string `(: symbol-start (opt ,haskell-tng:rx:qual) 
,haskell-tng:rx:conid symbol-end)))
+(defconst haskell-tng:regexp:consym
+  (rx-to-string `(: ,haskell-tng:rx:consym symbol-end)))
+
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Here is the `font-lock-keywords' table of matchers and highlighters.
 (defvar
diff --git a/haskell-tng-lexer.el b/haskell-tng-lexer.el
index ad979ed..f2a5973 100644
--- a/haskell-tng-lexer.el
+++ b/haskell-tng-lexer.el
@@ -81,7 +81,15 @@ the lexer."
            ;; syntax tables (supported by `smie-indent-forward-token')
            ((looking-at haskell-tng-lexer:fast-syntax) nil)
 
-           ;; regexps
+           ;; known identifiers
+           ((looking-at haskell-tng:regexp:reserved)
+            (haskell-tng-lexer:last-match))
+           ((looking-at haskell-tng:regexp:varid)
+            (haskell-tng-lexer:last-match nil "VARID"))
+           ((looking-at haskell-tng:regexp:conid)
+            (haskell-tng-lexer:last-match nil "CONID"))
+           ;; TODO symid
+
            ((or
              ;; known identifiers
              (looking-at haskell-tng:regexp:reserved)
@@ -89,14 +97,6 @@ the lexer."
              (looking-at (rx (+ (| (syntax word) (syntax symbol))))))
             (haskell-tng-lexer:last-match))
 
-           ;; TODO infix operators should be converted to a virtual token
-           ;; (with some important ones allowed through for fixity)
-
-           ;; TODO virtual paren tokens for top level blocks, depend on imenu
-
-           ;; TODO virtual tokens for pattern matches. Would be even better if
-           ;; it was in the syntax table so fontification could benefit.
-
            ;; single char
            (t
             (forward-char)
@@ -117,23 +117,30 @@ the lexer."
 
           (setq haskell-tng-lexer:state
                 (unless haskell-tng-lexer:state
+                  ;; TODO semicolon cannot be used as a separator and a line 
end
+                  ;; in the grammar rules, so should we emit multiple tokens?
                   (haskell-tng-layout:virtuals-at-point)))
 
           (if haskell-tng-lexer:state
               (haskell-tng-lexer:replay-virtual 'reverse)
 
             (forward-comment (- (point)))
-            (cond
-             ((bobp) nil)
-             ((looking-back haskell-tng-lexer:fast-syntax (- (point) 1)) nil)
-             ((or
-               (looking-back haskell-tng:regexp:reserved (- (point) 8))
-               (looking-back (rx (+ (| (syntax word) (syntax symbol))))
-                             (line-beginning-position) 't))
-              (haskell-tng-lexer:last-match 'reverse))
-             (t
-              (forward-char -1)
-              (string (char-after)))))))
+            (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))
+               (haskell-tng-lexer:last-match 'reverse))
+              ((looking-back haskell-tng:regexp:varid lbp 't)
+               (haskell-tng-lexer:last-match 'reverse "VARID"))
+              ((looking-back haskell-tng:regexp:conid lbp 't)
+               (haskell-tng-lexer:last-match 'reverse "CONID"))
+              ((looking-back (rx (+ (| (syntax word) (syntax symbol)))) lbp 't)
+               (haskell-tng-lexer:last-match 'reverse))
+              (t
+               (forward-char -1)
+               (string (char-after))))))))
 
     (haskell-tng-lexer:set-last 'backward)))
 
@@ -146,7 +153,7 @@ the lexer."
     (setq haskell-tng-lexer:state nil)))
 
 (defun haskell-tng-lexer:replay-virtual (&optional reverse)
-  ";; read a virtual token from state, set 't when all done"
+  "read a virtual token from state, set 't when all done"
   (unwind-protect
       (if reverse
           (unwind-protect
@@ -157,9 +164,9 @@ the lexer."
     (unless haskell-tng-lexer:state
       (setq haskell-tng-lexer:state 't))))
 
-(defun haskell-tng-lexer:last-match (&optional reverse)
+(defun haskell-tng-lexer:last-match (&optional reverse alt)
   (goto-char (if reverse (match-beginning 0) (match-end 0)))
-  (match-string-no-properties 0))
+  (or alt (match-string-no-properties 0)))
 
 (provide 'haskell-tng-lexer)
 ;;; haskell-tng-lexer.el ends here
diff --git a/test/haskell-tng-lexer-test.el b/test/haskell-tng-lexer-test.el
index 5559888..1128761 100644
--- a/test/haskell-tng-lexer-test.el
+++ b/test/haskell-tng-lexer-test.el
@@ -28,7 +28,7 @@
     ;; token, then move the point for another token.
     (goto-char 317)
     (should (equal (haskell-tng-lexer-test:indent-forward-token) ";"))
-    (should (equal (haskell-tng-lexer-test:indent-forward-token) "stkToLst"))
+    (should (equal (haskell-tng-lexer-test:indent-forward-token) "VARID"))
     (should (equal (haskell-tng-lexer-test:indent-forward-token) "_("))
 
     ;; repeating the above, but with a user edit, should reset the state
@@ -38,17 +38,17 @@
       (goto-char (point-max))
       (insert " "))
     (should (equal (haskell-tng-lexer-test:indent-forward-token) ";"))
-    (should (equal (haskell-tng-lexer-test:indent-forward-token) "stkToLst"))
+    (should (equal (haskell-tng-lexer-test:indent-forward-token) "VARID"))
     (should (equal (haskell-tng-lexer-test:indent-forward-token) "_("))
 
     ;; repeating again, but jumping the lexer, should reset the state
     (goto-char 317)
     (should (equal (haskell-tng-lexer-test:indent-forward-token) ";"))
     (goto-char 327)
-    (should (equal (haskell-tng-lexer-test:indent-forward-token) "MkStack"))
+    (should (equal (haskell-tng-lexer-test:indent-forward-token) "CONID"))
     (goto-char 317)
     (should (equal (haskell-tng-lexer-test:indent-forward-token) ";"))
-    (should (equal (haskell-tng-lexer-test:indent-forward-token) "stkToLst"))
+    (should (equal (haskell-tng-lexer-test:indent-forward-token) "VARID"))
     (should (equal (haskell-tng-lexer-test:indent-forward-token) "_("))
 
     ;; repeating those tests, but for the backward lexer
diff --git a/test/src/layout.hs.lexer b/test/src/layout.hs.lexer
index 63343e7..96ba575 100644
--- a/test/src/layout.hs.lexer
+++ b/test/src/layout.hs.lexer
@@ -1,20 +1,20 @@
 
-module AStack _( Stack , push , pop , top , size _) where
-{ data Stack a = Empty
-| MkStack a _( Stack a _)
+module CONID _( CONID , VARID , VARID , VARID , VARID _) where
+{ data CONID VARID = CONID
+| CONID VARID _( CONID VARID _)
 
-; push :: a -> Stack a -> Stack a
-; push x s = MkStack x s
+; VARID :: VARID -> CONID VARID -> CONID VARID
+; VARID VARID VARID = CONID VARID VARID
 
-; size :: Stack a -> Int
-; size s = length _( stkToLst s _) where
-{ stkToLst Empty = _[ _]
-; stkToLst _( MkStack x s _) = x:xs where { xs = stkToLst s
+; VARID :: CONID VARID -> CONID
+; VARID VARID = VARID _( VARID VARID _) where
+{ VARID CONID = _[ _]
+; VARID _( CONID VARID VARID _) = x:xs where { VARID = VARID VARID
 
-} } ; pop :: Stack a -> _( a , Stack a _)
-; pop _( MkStack x s _)
-= _( x , case s of { r -> i r where { i x = x } } _)
+} } ; VARID :: CONID VARID -> _( VARID , CONID VARID _)
+; VARID _( CONID VARID VARID _)
+= _( VARID , case VARID of { VARID -> VARID VARID where { VARID VARID = VARID 
} } _)
 
-; top :: Stack a -> a
-; top _( MkStack x s _) = x
+; VARID :: CONID VARID -> VARID
+; VARID _( CONID VARID VARID _) = VARID
 }
diff --git a/test/src/medley.hs.lexer b/test/src/medley.hs.lexer
index c2ee1a8..647ab47 100644
--- a/test/src/medley.hs.lexer
+++ b/test/src/medley.hs.lexer
@@ -2,132 +2,132 @@
 
 
 
-module Foo.Bar.Main
-_( Wibble _( .. _) , Wobble _( Wobb , _( !!! _) _) , Woo
+module CONID
+_( CONID _( .. _) , CONID _( CONID , _( !!! _) _) , CONID
 
-, getFooByBar , getWibbleByWobble
-, module Bloo.Foo
+, VARID , VARID
+, module CONID
 _) where
 
-{ import Control.Applicative _( many , optional , pure , _( <*> _) , _( <|> _) 
_)
-; import Data.Foldable _( traverse_ _)
-; import Data.Functor _( _( <$> _) _)
-; import Data.List _( intercalate _)
-; import Data.Monoid _( _( <> _) _)
-; import qualified Options.Monad
-; import qualified Options.Applicative as Opts
-; import qualified Options.Divisible
-as Div
-; import qualified ProfFile.App hiding _( as , hiding , qualified _)
-; import ProfFile.App _( as , hiding , qualified _)
-; import ProfFile.App hiding _( as , hiding , qualified _)
-; import qualified ProfFile.App _( as , hiding , qualified _)
-; import System.Exit _( ExitCode _( .. _) , exitFailure , qualified ,
-Typey ,
-wibble ,
-Wibble _)
-; import System.FilePath _( replaceExtension , Foo _( Bar , _( :< _) _)
-; import System.IO _( IOMode _( .. _) , hClose , hGetContents ,
-hPutStr , hPutStrLn , openFile , stderr ,
-stdout , MoarTypey _)
-; import System.Process _( CreateProcess _( .. _) , StdStream _( .. _) ,
-createProcess , proc , waitForProcess _)
-
-
-; chars = _[ _'c' , _'\n' , _'\'' _]
-
-; foo = _"wobble (wibble)"
-
-; class Get a s where
-{ get :: Set s -> a
-
-} ; instance Get a _( a ': s _) where
-{ get _( Ext a _ _) = a
-
-} ; instance Get a s => Get a _( b ': s _) where
-{ get _( Ext _ xs _) = get xs
-
-} ; data Options = Options
-_{ optionsReportType :: ReportType
-, optionsProfFile :: Maybe FilePath
-, optionsOutputFile :: Maybe FilePath
-, optionsFlamegraphFlags :: _[ String _]
-_} deriving _( Eq , Show _)
-
-; class _( Eq a _) => Ord a where
-{ _( < _) , _( <= _) , _( >= _) , _( > _) :: a -> a -> Bool
-; max @Foo , min :: a -> a -> a
-
-} ; instance _( Eq a _) => Eq _( Tree a _) where
-{ Leaf a == Leaf b = a == b
-; _( Branch l1 r1 _) == _( Branch l2 r2 _) = _( l1==l2 _) && _( r1==r2 _)
-; _ == _ = False
-
-} ; data ReportType = Alloc
-| Entries
-| Time
-| Ticks
-| Bytes
-deriving _( Eq , Show _)
-
-; type family G a where
-{ G Int = Bool
-; G a = Char
-
-} ; data Flobble = Flobble
-deriving _( Eq _) via _( NonNegative _( Large Int _) _)
-deriving stock _( Floo _)
-deriving anyclass _( WibblyWoo , OtherlyWoo _)
-
-; newtype Flobby = Flobby
-
-; foo ::
-Wibble
--> Wobble
--> Wobble
--> Wobble
--> _( wob :: Wobble _)
--> _( Wobble
-a b c _)
-
-; _( foo :: _( Wibble Wobble _) _) foo
-
-; newtype TestApp
-_( logger :: TestLogger _)
-_( scribe :: TestScribe _)
-config
-a
-= TestApp a
-
-; optionsParser :: Opts.Parser Options
-; optionsParser = Options
-<$> _( Opts.flag' Alloc _( Opts.long _"alloc" <> Opts.help _"wibble" _)
-<|> Opts.flag' Entries _( Opts.long _"entry" <> Opts.help _"wobble" _)
-<|> Opts.flag' Bytes _( Opts.long _"bytes" <> Opts.help _"i'm a fish" _) _)
-<*> optional
-_( Opts.strArgument
-_( Opts.metavar _"MY-FILE" <>
-Opts.help _"meh" _) _)
-
-; type PhantomThing
-
-; type SomeApi =
-_"thing" :> Capture _"bar" Index :> QueryParam _"wibble" Text
-:> QueryParam _"wobble" Natural
-:> Header TracingHeader TracingId
-:> ThingHeader
-:> Get ' _[ JSON _] _( The ReadResult _)
-:<|> _"thing" :> ReqBody ' _[ JSON _] Request
-:> Header TracingHeader TracingId
-:> SpecialHeader
-:> Post ' _[ JSON _] _( The Response _)
-
-; deriving instance FromJSONKey StateName
-; deriving anyclass instance FromJSON Base
-; deriving newtype instance FromJSON Treble
-
-; foo = bar
-where { baz = _
+{ import CONID _( VARID , VARID , VARID , _( <*> _) , _( <|> _) _)
+; import CONID _( VARID _)
+; import CONID _( _( <$> _) _)
+; import CONID _( VARID _)
+; import CONID _( _( <> _) _)
+; import VARID CONID
+; import VARID CONID VARID CONID
+; import VARID CONID
+VARID CONID
+; import VARID CONID VARID _( VARID , VARID , VARID _)
+; import CONID _( VARID , VARID , VARID _)
+; import CONID VARID _( VARID , VARID , VARID _)
+; import VARID CONID _( VARID , VARID , VARID _)
+; import CONID _( CONID _( .. _) , VARID , VARID ,
+CONID ,
+VARID ,
+CONID _)
+; import CONID _( VARID , CONID _( CONID , _( :< _) _)
+; import CONID _( CONID _( .. _) , VARID , VARID ,
+VARID , VARID , VARID , VARID ,
+VARID , CONID _)
+; import CONID _( CONID _( .. _) , CONID _( .. _) ,
+VARID , VARID , VARID _)
+
+
+; VARID = _[ _'c' , _'\n' , _'\'' _]
+
+; VARID = _"wobble (wibble)"
+
+; class CONID VARID VARID where
+{ VARID :: CONID VARID -> VARID
+
+} ; instance CONID VARID _( VARID ': VARID _) where
+{ VARID _( CONID VARID _ _) = VARID
+
+} ; instance CONID VARID VARID => CONID VARID _( VARID ': VARID _) where
+{ VARID _( CONID _ VARID _) = VARID VARID
+
+} ; data CONID = CONID
+_{ VARID :: CONID
+, VARID :: CONID CONID
+, VARID :: CONID CONID
+, VARID :: _[ CONID _]
+_} deriving _( CONID , CONID _)
+
+; class _( CONID VARID _) => CONID VARID where
+{ _( < _) , _( <= _) , _( >= _) , _( > _) :: VARID -> VARID -> CONID
+; VARID @Foo , VARID :: VARID -> VARID -> VARID
+
+} ; instance _( CONID VARID _) => CONID _( CONID VARID _) where
+{ CONID VARID == CONID VARID = VARID == VARID
+; _( CONID VARID VARID _) == _( CONID VARID VARID _) = _( l1==l2 _) && _( 
r1==r2 _)
+; _ == _ = CONID
+
+} ; data CONID = CONID
+| CONID
+| CONID
+| CONID
+| CONID
+deriving _( CONID , CONID _)
+
+; type VARID CONID VARID where
+{ CONID CONID = CONID
+; CONID VARID = CONID
+
+} ; data CONID = CONID
+deriving _( CONID _) VARID _( CONID _( CONID CONID _) _)
+deriving VARID _( CONID _)
+deriving VARID _( CONID , CONID _)
+
+; newtype CONID = CONID
+
+; VARID ::
+CONID
+-> CONID
+-> CONID
+-> CONID
+-> _( VARID :: CONID _)
+-> _( CONID
+VARID VARID VARID _)
+
+; _( VARID :: _( CONID CONID _) _) VARID
+
+; newtype CONID
+_( VARID :: CONID _)
+_( VARID :: CONID _)
+VARID
+VARID
+= CONID VARID
+
+; VARID :: CONID CONID
+; VARID = CONID
+<$> _( VARID CONID _( VARID _"alloc" <> VARID _"wibble" _)
+<|> VARID CONID _( VARID _"entry" <> VARID _"wobble" _)
+<|> VARID CONID _( VARID _"bytes" <> VARID _"i'm a fish" _) _)
+<*> VARID
+_( VARID
+_( VARID _"MY-FILE" <>
+VARID _"meh" _) _)
+
+; type CONID
+
+; type CONID =
+_"thing" :> CONID _"bar" CONID :> CONID _"wibble" CONID
+:> CONID _"wobble" CONID
+:> CONID CONID CONID
+:> CONID
+:> CONID ' _[ CONID _] _( CONID CONID _)
+:<|> _"thing" :> CONID ' _[ CONID _] CONID
+:> CONID CONID CONID
+:> CONID
+:> CONID ' _[ CONID _] _( CONID CONID _)
+
+; deriving instance CONID CONID
+; deriving VARID instance CONID CONID
+; deriving newtype instance CONID CONID
+
+; VARID = VARID
+where { VARID = _
 
 
 ; _( + _) = _