branch: elpa/haskell-tng-mode
commit dae43acc79cc29c351d13da7f9ce2e41f5612953
Author: Tseen She <ts33n....@gmail.com>
Commit: Tseen She <ts33n....@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
}
