branch: elpa/haskell-tng-mode
commit 3e53f56c2af65ab2127dfec053975acb90c9968e
Author: Tseen She <ts33n....@gmail.com>
Commit: Tseen She <ts33n....@gmail.com>
cleaner lexer test output
---
test/faces/medley.hs.lexer | 736 +++++++-----------------------------------
test/haskell-tng-smie-test.el | 36 ++-
test/lexer/layout.hs.lexer | 160 ++-------
3 files changed, 163 insertions(+), 769 deletions(-)
diff --git a/test/faces/medley.hs.lexer b/test/faces/medley.hs.lexer
index a1aeae1..42da296 100644
--- a/test/faces/medley.hs.lexer
+++ b/test/faces/medley.hs.lexer
@@ -1,615 +1,127 @@
-module
-Foo.Bar.Main
-SYNTAX_(
+
+
+
+
+module Foo.Bar.Main
+_( Wibble _( .. _) , Wobble _( Wobb , _( !!! _) _) , Woo
+
+, getFooByBar , getWibbleByWobble
+, module Bloo.Foo
+_) 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 _)
+
+
+_'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
-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
-import
-qualified
-Options.Applicative
-as
-Opts
-import
-qualified
-Options.Divisible
-as
-Div
-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
-,
-qualified
-,
-Typey
-,
-wibble
-,
-Wibble
-SYNTAX_)
-import
-System.FilePath
-SYNTAX_(
-replaceExtension
-,
-Foo
-SYNTAX_(
-Bar
-,
-SYNTAX_(
-:<
-SYNTAX_)
-SYNTAX_)
-import
-System.IO
-SYNTAX_(
-IOMode
-SYNTAX_(
-..
-SYNTAX_)
-,
-hClose
-,
-hGetContents
-,
-hPutStr
-,
-hPutStrLn
-,
-openFile
-,
-stderr
-,
-stdout
-,
-MoarTypey
-SYNTAX_)
-import
-System.Process
-SYNTAX_(
-CreateProcess
-SYNTAX_(
-..
-SYNTAX_)
-,
-StdStream
-SYNTAX_(
-..
-SYNTAX_)
-,
-createProcess
-,
-proc
-,
-waitForProcess
-SYNTAX_)
-SYNTAX_'c'
-SYNTAX_'\n'
-SYNTAX_'\''
-foo
-=
-SYNTAX_"wobble (wibble)"
-class
-Get
-a
-s
-where
-{
-get
-::
-Set
-s
-->
-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
-}
-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
-->
-a
-->
-Bool
-max
-@Foo
-,
-min
-::
-a
-->
-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
-}
-data
-ReportType
-=
-Alloc
-|
-Entries
-|
-Time
-|
-Ticks
-|
-Bytes
-deriving
-SYNTAX_(
-Eq
-,
-Show
-SYNTAX_)
-type
-family
-G
-a
-where
-{
-G
-Int
-=
-Bool
-G
-a
-=
-Char
-}
-data
-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
-=
-Flobby
-foo
-::
-Wibble
-->
-Wobble
-->
-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_)
+-> 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
-<$>
-SYNTAX_(
-Opts.flag'
-Alloc
-SYNTAX_(
-Opts.long
-SYNTAX_"alloc"
-<>
-Opts.help
-SYNTAX_"wibble"
-SYNTAX_)
-<|>
-Opts.flag'
-Entries
-SYNTAX_(
-Opts.long
-SYNTAX_"entry"
-<>
-Opts.help
-SYNTAX_"wobble"
-SYNTAX_)
-<|>
-Opts.flag'
-Bytes
-SYNTAX_(
-Opts.long
-SYNTAX_"bytes"
-<>
-Opts.help
-SYNTAX_"i'm a fish"
-SYNTAX_)
-SYNTAX_)
-<*>
-optional
-SYNTAX_(
-Opts.strArgument
-SYNTAX_(
-Opts.metavar
-SYNTAX_"MY-FILE"
-<>
-Opts.help
-SYNTAX_"meh"
-SYNTAX_)
-SYNTAX_)
-type
-PhantomThing
-type
-SomeApi
-=
-SYNTAX_"thing"
-:>
-Capture
-SYNTAX_"bar"
-Index
-:>
-QueryParam
-SYNTAX_"wibble"
-Text
-:>
-QueryParam
-SYNTAX_"wobble"
-Natural
-:>
-Header
-TracingHeader
-TracingId
-:>
-ThingHeader
-:>
-Get
-'
-SYNTAX_[
-JSON
-SYNTAX_]
-SYNTAX_(
-The
-ReadResult
-SYNTAX_)
-:<|>
-SYNTAX_"thing"
-:>
-ReqBody
-'
-SYNTAX_[
-JSON
-SYNTAX_]
-Request
-:>
-Header
-TracingHeader
-TracingId
-:>
-SpecialHeader
-:>
-Post
-'
-SYNTAX_[
-JSON
-SYNTAX_]
-SYNTAX_(
-The
-Response
-SYNTAX_)
-deriving
-instance
-FromJSONKey
-StateName
-deriving
-anyclass
-instance
-FromJSON
-Base
-deriving
-newtype
-instance
-FromJSON
-Treble
+= 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
diff --git a/test/haskell-tng-smie-test.el b/test/haskell-tng-smie-test.el
index ae889fd..b2cd085 100644
--- a/test/haskell-tng-smie-test.el
+++ b/test/haskell-tng-smie-test.el
@@ -5,6 +5,7 @@
(require 'haskell-tng-mode)
+(require 'dash)
(require 'ert)
(require 's)
@@ -14,15 +15,14 @@
(file-name-directory load-file-name)
default-directory)))
-;; FIXME return a list of lines, each a list of tokens. It produces a much
-;; cleaner output for regression testing.
(defun haskell-tng-smie:forward-tokens (&optional display)
- "Forward lex the current buffer using SMIE lexer and return the list of
tokens.
+ "Forward lex the current buffer using SMIE lexer and return the list of
lines,
+where each line is a list of tokens.
When called interactively, shows the tokens in a buffer."
(interactive '(t))
(defvar smie-forward-token-function)
- (let* ((tokens '()))
+ (let* ((lines '(())))
(goto-char (point-min))
(while (not (eobp))
(let* ((start (point))
@@ -33,19 +33,24 @@ When called interactively, shows the tokens in a buffer."
(unless token
(setq token (buffer-substring-no-properties start (point))))
;; differentiate that these tokens come from the syntax table
- (setq token (concat "SYNTAX_" token)))
+ (setq token (concat "_" 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 ""))
- (push token tokens))))
- (if display
- (haskell-tng-smie:display-tokens tokens)
- (nreverse tokens))))
+ (push token (car lines)))))
+ (let ((ordered (reverse (--map (reverse it) lines))))
+ (if display
+ (haskell-tng-smie:display-tokens ordered)
+ ordered))))
-(defun haskell-tng-smie:tokens-to-string (tokens)
- (concat (mapconcat #'identity tokens "\n") "\n"))
+(defun haskell-tng-smie:tokens-to-string (lines)
+ (s-join "\n" (--map (s-join " " it) lines)))
-(defun haskell-tng-smie:display-tokens (tokens)
+(defun haskell-tng-smie:display-tokens (lines)
(with-current-buffer (get-buffer-create "*Haskell-TNG-SMIE-test*")
- (insert (haskell-tng-smie:tokens-to-string tokens))
+ (insert (haskell-tng-smie:tokens-to-string lines))
(pop-to-buffer (current-buffer))))
(defun have-expected-forward-lex (file)
@@ -64,7 +69,7 @@ When called interactively, shows the tokens in a buffer."
(haskell-tng-smie:forward-tokens)))
(got (haskell-tng-smie:tokens-to-string lexed)))
(or (equal got expected)
- ;; TODO make this a parameter
+ ;; TODO make this a setting
;; writes out the new version on failure
(progn
(write-region got nil golden)
@@ -74,8 +79,7 @@ When called interactively, shows the tokens in a buffer."
(ert-deftest haskell-tng-smie-file-tests ()
(should (have-expected-forward-lex "faces/medley.hs"))
- ;; FIXME this is the real test
- ;;(should (have-expected-forward-lex "lexer/layout.hs"))
+ (should (have-expected-forward-lex "lexer/layout.hs"))
)
;; ideas for an indentation tester
diff --git a/test/lexer/layout.hs.lexer b/test/lexer/layout.hs.lexer
index f76687b..63343e7 100644
--- a/test/lexer/layout.hs.lexer
+++ b/test/lexer/layout.hs.lexer
@@ -1,142 +1,20 @@
-module
-AStack
-SYNTAX_(
-Stack
-,
-;
-push
-,
-pop
-,
-top
-,
-size
-SYNTAX_)
-where
-{
-data
-Stack
-a
-=
-Empty
-|
-MkStack
-a
-SYNTAX_(
-Stack
-a
-SYNTAX_)
-;
-push
-::
-a
-->
-Stack
-a
-->
-Stack
-a
-push
-x
-s
-=
-MkStack
-x
-s
-;
-size
-::
-Stack
-a
-->
-Int
-;
-size
-s
-=
-length
-SYNTAX_(
-stkToLst
-s
-SYNTAX_)
-where
-{
-stkToLst
-Empty
-=
-SYNTAX_[
-SYNTAX_]
-;
-stkToLst
-SYNTAX_(
-MkStack
-x
-s
-SYNTAX_)
-=
-x:xs
-where
-{
-xs
-=
-stkToLst
-s
-}
-}
-;
-pop
-::
-Stack
-a
-->
-SYNTAX_(
-a
-,
-Stack
-a
-SYNTAX_)
-;
-pop
-SYNTAX_(
-MkStack
-x
-s
-SYNTAX_)
-=
-SYNTAX_(
-x
-,
-case
-s
-of
-{
-r
-->
-i
-r
-where
-{
-i
-x
-=
-x
-}
-}
-SYNTAX_)
-;
-top
-::
-Stack
-a
-->
-a
-;
-top
-SYNTAX_(
-MkStack
-x
-s
-SYNTAX_)
-=
-x
+
+module AStack _( Stack , push , pop , top , size _) where
+{ data Stack a = Empty
+| MkStack a _( Stack a _)
+
+; push :: a -> Stack a -> Stack a
+; push x s = MkStack x s
+
+; size :: Stack a -> Int
+; size s = length _( stkToLst s _) where
+{ stkToLst Empty = _[ _]
+; stkToLst _( MkStack x s _) = x:xs where { xs = stkToLst s
+
+} } ; pop :: Stack a -> _( a , Stack a _)
+; pop _( MkStack x s _)
+= _( x , case s of { r -> i r where { i x = x } } _)
+
+; top :: Stack a -> a
+; top _( MkStack x s _) = x
}
