branch: elpa/haskell-tng-mode
commit 6e7a24f1b073a69f9d5929384966efa81b410d74
Author: Tseen She <ts33n....@gmail.com>
Commit: Tseen She <ts33n....@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 = _
; _( + _) = _
