branch: elpa/haskell-tng-mode
commit 97ce717758484e6c1a0519b5702824c65420e344
Author: Tseen She <ts33n....@gmail.com>
Commit: Tseen She <ts33n....@gmail.com>
improve the testing
---
haskell-tng-smie.el | 20 +++++++++++++-------
test/faces/medley.hs | 6 ++++++
test/faces/medley.hs.faceup | 6 ++++++
test/faces/medley.hs.lexer | 12 +++++++++---
test/haskell-tng-font-lock-test.el | 1 +
test/haskell-tng-smie-test.el | 28 +++++++++++++++++++---------
6 files changed, 54 insertions(+), 19 deletions(-)
diff --git a/haskell-tng-smie.el b/haskell-tng-smie.el
index ee080a3..a0c9722 100644
--- a/haskell-tng-smie.el
+++ b/haskell-tng-smie.el
@@ -64,7 +64,6 @@
(t
(let ((done-multi (pop haskell-tng-smie:multi))
(case-fold-search nil)
- (syntax (char-syntax (char-after)))
(offside (car haskell-tng-smie:wldos)))
(cl-flet ((virtual-end () (= (point) (car offside)))
(virtual-semicolon () (= (current-column) (cdr offside))))
@@ -84,8 +83,12 @@
";" haskell-tng-smie:multi)))
(pop haskell-tng-smie:multi))
- ;; parens
- ((member syntax '(?\( ?\) ?\" ?$)) nil)
+ ;; syntax tables (supported by `smie-indent-forward-token')
+ ((looking-at (rx (| (syntax open-parenthesis)
+ (syntax close-parenthesis)
+ (syntax string-quote)
+ (syntax string-delimiter))))
+ nil)
;; layout detection
((looking-at (rx word-start (| "where" "let" "do" "of") word-end))
@@ -102,10 +105,13 @@
;; 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)))))
- (haskell-tng-smie:last-match))))))))
+ (looking-at (rx (+ (| (syntax word) (syntax symbol))))))
+ (haskell-tng-smie:last-match))
+
+ ;; single char
+ (t
+ (forward-char)
+ (string (char-before)))))))))
(defun haskell-tng:layout-of-next-token ()
(save-excursion
diff --git a/test/faces/medley.hs b/test/faces/medley.hs
index f182758..b314e8b 100644
--- a/test/faces/medley.hs
+++ b/test/faces/medley.hs
@@ -125,3 +125,9 @@ type SomeApi =
deriving instance FromJSONKey StateName
deriving anyclass instance FromJSON Base
deriving newtype instance FromJSON Treble
+
+foo = bar
+ where baz = _
+ -- checking that comments are ignored in layout
+ -- and that a starting syntax entry is ok
+ (+) = _
diff --git a/test/faces/medley.hs.faceup b/test/faces/medley.hs.faceup
index 2f33e9a..3192eaa 100644
--- a/test/faces/medley.hs.faceup
+++ b/test/faces/medley.hs.faceup
@@ -125,3 +125,9 @@
«:haskell-tng:keyword:deriving» «:haskell-tng:keyword:instance»
«:haskell-tng:constructor:FromJSONKey» «:haskell-tng:constructor:StateName»
«:haskell-tng:keyword:deriving» anyclass «:haskell-tng:keyword:instance»
«:haskell-tng:constructor:FromJSON» «:haskell-tng:constructor:Base»
«:haskell-tng:keyword:deriving» «:haskell-tng:keyword:newtype»
«:haskell-tng:keyword:instance» «:haskell-tng:constructor:FromJSON»
«:haskell-tng:constructor:Treble»
+
+«:haskell-tng:toplevel:foo» «:haskell-tng:keyword:=» bar
+ «:haskell-tng:keyword:where» baz «:haskell-tng:keyword:=»
«:haskell-tng:keyword:_»
+ «x:-- checking that comments are ignored in layout
+» «x:-- and that a starting syntax entry is ok
+» «:haskell-tng:keyword:(»+«:haskell-tng:keyword:)»
«:haskell-tng:keyword:=» «:haskell-tng:keyword:_»
diff --git a/test/faces/medley.hs.lexer b/test/faces/medley.hs.lexer
index 89748ba..a948522 100644
--- a/test/faces/medley.hs.lexer
+++ b/test/faces/medley.hs.lexer
@@ -55,12 +55,12 @@ _{ optionsReportType :: ReportType
_} deriving _( Eq , Show _)
; class _( Eq a _) => Ord a where
-{ _; < _) , _( <= _) , _( >= _) , _( > _) :: a -> a -> Bool
+{ _( < _) , _( <= _) , _( >= _) , _( > _) :: 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 _)
+; _( Branch l1 r1 _) == _( Branch l2 r2 _) = _( l1==l2 _) && _( r1==r2 _)
; _ == _ = False
} ; data ReportType = Alloc
@@ -90,7 +90,7 @@ Wibble
-> _( Wobble
a b c _)
-; _; foo :: _( Wibble Wobble _) _) foo
+; _( foo :: _( Wibble Wobble _) _) foo
; newtype TestApp
_( logger :: TestLogger _)
@@ -125,4 +125,10 @@ _"thing" :> Capture _"bar" Index :> QueryParam _"wibble"
Text
; deriving instance FromJSONKey StateName
; deriving anyclass instance FromJSON Base
; deriving newtype instance FromJSON Treble
+
+; foo = bar
+where { baz = _
+
+
+; _( + _) = _
}
diff --git a/test/haskell-tng-font-lock-test.el
b/test/haskell-tng-font-lock-test.el
index fe5c739..15157ee 100644
--- a/test/haskell-tng-font-lock-test.el
+++ b/test/haskell-tng-font-lock-test.el
@@ -16,6 +16,7 @@
(eval-when-compile (faceup-this-file-directory)))))
(faceup-defexplainer have-expected-faces)
+;; to generate .faceup files, use faceup-view-buffer
(ert-deftest haskell-tng-font-lock-file-tests ()
(should (have-expected-faces "faces/medley.hs")))
diff --git a/test/haskell-tng-smie-test.el b/test/haskell-tng-smie-test.el
index 82755b1..83e18ab 100644
--- a/test/haskell-tng-smie-test.el
+++ b/test/haskell-tng-smie-test.el
@@ -15,6 +15,23 @@
(file-name-directory load-file-name)
default-directory)))
+;; copy/pasta of `smie-indent-forward-token' but rendering lexed tokens in a
way
+;; more ammenable to regression testing (e.g. syntax table usage)
+(defun haskell-tng-smie:indent-forward-token ()
+ (let ((tok (funcall smie-forward-token-function)))
+ (cond
+ ((< 0 (length tok)) tok)
+ ((looking-at (rx (| (syntax open-parenthesis)
+ (syntax close-parenthesis))))
+ (concat "_" (haskell-tng-smie:last-match)))
+ ((looking-at (rx (| (syntax string-quote)
+ (syntax string-delimiter))))
+ (let ((start (point)))
+ (forward-sexp 1)
+ (concat "_" (buffer-substring-no-properties start (point)))))
+ ((eobp) nil)
+ (t (error "Bumped into unknown token")))))
+
(defun haskell-tng-smie:forward-tokens (&optional display)
"Forward lex the current buffer using SMIE lexer and return the list of
lines,
where each line is a list of tokens.
@@ -26,19 +43,12 @@ When called interactively, shows the tokens in a buffer."
(goto-char (point-min))
(while (not (eobp))
(let* ((start (point))
- (token (funcall smie-forward-token-function)))
- (when (and (not token) (= (point) start))
- (setq token (car (smie-indent-forward-token)))
- (when (= start (point)) (forward-char 1))
- (unless token
- (setq token (buffer-substring-no-properties start (point))))
- ;; differentiate that these tokens come from the syntax table
- (setq token (concat "_" token)))
+ (token (haskell-tng-smie:indent-forward-token)))
(let ((line-diff (- (line-number-at-pos (point))
(line-number-at-pos start))))
(unless (<= line-diff 0)
(setq lines (append (-repeat line-diff nil) lines))))
- (unless (member token '(nil ""))
+ (unless (s-blank? token)
(push token (car lines)))))
(let ((ordered (reverse (--map (reverse it) lines))))
(if display
