fast-tags-2.0.1: tests/MainTest.hs
----------------------------------------------------------------------------
-- |
-- Module : MainTest
-- Copyright : (c) Sergey Vinokurov 2019
----------------------------------------------------------------------------
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
module MainTest where
import Control.Arrow (first)
import qualified Data.List as List
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Void (Void)
import qualified Test.Tasty as Tasty
import Test.Tasty (TestTree, testGroup)
import qualified Test.Tasty.HUnit as HUnit
import qualified FastTags.Emacs as Emacs
import qualified FastTags.Lexer as Lexer
import FastTags.LexerTypes (LitMode(..))
import qualified FastTags.Tag as Tag
import FastTags.Tag hiding (process)
import FastTags.Token
import qualified FastTags.Vim as Vim
main :: IO ()
main = Tasty.defaultMain tests
tests :: TestTree
tests = testGroup "tests"
[ testTokenize
, testTokenizeWithNewlines
, testStripComments
, testBreakBlocks
, testWhereBlock
, testEmacs
, testVim
, testProcess
]
class ExtendedEq a where
(===) :: a -> a -> Bool
default (===) :: Eq a => a -> a -> Bool
(===) = (==)
instance (ExtendedEq a) => ExtendedEq [a] where
(===) xs ys = length xs == length ys && and (zipWith (===) xs ys)
instance (ExtendedEq a, ExtendedEq b) => ExtendedEq (a, b) where
(===) (a, b) (c, d) = a === c && b === d
instance ExtendedEq TagVal where
TagVal name t parent === TagVal name' t' parent' =
name == name' && t == t' && parent == parent'
instance (ExtendedEq a) => ExtendedEq (Pos a) where
(===) (Pos x y) (Pos x' y') = x === x' && y === y'
instance ExtendedEq a => ExtendedEq (Maybe a) where
(===) Nothing Nothing = True
(===) (Just x) (Just y) = x === y
(===) _ _ = False
instance (ExtendedEq a, ExtendedEq b, ExtendedEq c) => ExtendedEq (a, b, c)
where
(a, b, c) === (a', b', c') = a === a' && b === b' && c === c'
instance ExtendedEq Int
instance ExtendedEq Char
instance ExtendedEq Text
instance ExtendedEq TokenVal
instance ExtendedEq SrcPos
instance ExtendedEq Vim.Parsed
testTokenize :: TestTree
testTokenize = testGroup "tokenize"
[ "xyz -- abc" ==> [T "xyz", Newline 0]
, "xyz --- abc" ==> [T "xyz", Newline 0]
, " {- foo -}" ==> [Newline 0]
, " {- foo \n\
\\n\
\-}" ==> [Newline 0]
, " {- foo {- bar-} -}" ==> [Newline 0]
, " {-# INLINE #-}" ==> [Newline 0]
, "a::b->c" ==>
[T "a", DoubleColon, T "b", Arrow, T "c", Newline 0]
, "a∷b→c" ==>
[T "a", DoubleColon, T "b", Arrow, T "c", Newline 0]
, "x{-\n bc#-}\n" ==> [T "x", Newline 0, Newline 0]
, "X.Y" ==> [T "X.Y", Newline 0]
, "a=>b" ==> [T "a", Implies, T "b", Newline 0]
, "a ⇒ b" ==> [T "a", Implies, T "b", Newline 0]
, "x9" ==> [T "x9", Newline 0]
-- , "9x" ==> ["nl 0", "9", "x"]
, "x :+: y" ==> [T "x", T ":+:", T "y", Newline 0]
, "(#$)" ==> [LParen, T "#$", RParen, Newline 0]
, "Data.Map.map" ==> [T "Data.Map.map", Newline 0]
, "Map.map" ==> [T "Map.map", Newline 0]
, "forall a. f a" ==> [T "forall", T "a", Dot, T "f", T "a", Newline 0]
, "forall a . Foo" ==> [T "forall", T "a", Dot, T "Foo", Newline 0]
, "forall a. Foo" ==> [T "forall", T "a", Dot, T "Foo", Newline 0]
, "forall a .Foo" ==> [T "forall", T "a", Dot, T "Foo", Newline 0]
, "forall a.Foo" ==> [T "forall", T "a", Dot, T "Foo", Newline 0]
, "$#-- hi" ==> [T "$#--", T "hi", Newline 0]
, "(*), (-)" ==>
[LParen, T "*", RParen, Comma, LParen, T "-", RParen, Newline 0]
, "(.::)" ==> [LParen, T ".::", RParen, Newline 0]
-- we rely on this behavior
, "data (:+) a b" ==>
[KWData, LParen, T ":+", RParen, T "a", T "b", Newline 0]
, "data (.::+::) a b" ==>
[KWData, LParen, T ".::+::", RParen, T "a", T "b", Newline 0]
-- string tokenization
, "foo \"bar\" baz" ==> [T "foo", String, T "baz", Newline 0]
-- multiline string
, "foo \"bar\\\n\
\ \\bar\" baz" ==> [T "foo", String, T "baz", Newline 0]
-- multiline string with \r
, "foo \"bar\\\r\n\
\ \\bar\" baz" ==> [T "foo", String, T "baz", Newline 0]
-- multiline string with zero indentation
, "foo \"bar\\\r\n\
\\\bar\" baz" ==> [T "foo", String, T "baz", Newline 0]
, "(\\err -> case err of Foo -> True; _ -> False)" ==>
[ LParen, LambdaBackslash, T "err", Arrow, KWCase, T "err", KWOf, T "Foo"
, Arrow, T "True", Semicolon, T "_", Arrow, T "False", RParen, Newline 0
]
, "foo = \"foo\\n\\\r\n\
\ \\\" bar" ==> [T "foo", Equals, String, T "bar", Newline 0]
, "foo = \"foo\\n\\\n\
\ \\x\" bar" ==>
[ T "foo", Equals, String, T "bar", Newline 0]
, "{- ___ -}import Data.Char;main=putStr$do{c<-\"/1 AA A A;9+ )11929 )1191A 2C9A \";e\r\n\
\ {- {- | -} -} {- {- || -} -}{- {- || -} -}{- {- || -} -} {--}.(`divMod`8).(+(-32)).ord$c};f(0,0)=\"\\n\";f(m,n)=m?\" \"++n?\"_/\"\r\n\
\{- {- | -} -}n?x=do{[1..n];x} --- obfuscated\r\n\
\{-\\_/ on Fairbairn, with apologies to Chris Brown. Above is / Haskell 98 -}"
==>
[ KWImport, T "Data.Char", Semicolon
, T "main", Equals , T "putStr", T "$", KWDo, LBrace, T "c", T "<-"
, String, Semicolon, T "e", Newline 4
, Dot, LParen, Backtick, T "divMod", Backtick, Number, RParen, Dot
, LParen, T "+", LParen, Number, RParen, RParen, Dot
, T "ord", T "$", T "c", RBrace, Semicolon
, T "f", LParen, Number, Comma, Number, RParen, Equals, String, Semicolon
, T "f", LParen, T "m", Comma, T "n", RParen, Equals, T "m", T "?"
, String, T "++", T "n", T "?", String, Newline 0
, T "n", T "?", T "x", Equals, KWDo, LBrace, LBracket, Number
, T "..", T "n", RBracket, Semicolon, T "x", RBrace, Newline 0
, Newline 0
]
, "one_hash, two_hash :: text_type\n\
\hash_prec :: Int -> Int\n\
\one_hash = from_char '#'\n\
\two_hash = from_string \"##\"\n\
\hash_prec = const 0"
==>
[ T "one_hash", Comma, T "two_hash", DoubleColon, T "text_type", Newline 0
, T "hash_prec", DoubleColon, T "Int", Arrow, T "Int", Newline 0
, T "one_hash", Equals, T "from_char", Character, Newline 0
, T "two_hash", Equals, T "from_string", String, Newline 0
, T "hash_prec", Equals, T "const", Number, Newline 0
]
, "showComplexFloat x 0.0 = showFFloat Nothing x \"\""
==>
[ T "showComplexFloat", T "x", Number, Equals
, T "showFFloat", T "Nothing", T "x", String, Newline 0
]
, "deriveJSON defaultOptions ''CI.CI"
==>
[T "deriveJSON", T "defaultOptions", T "''CI.CI", Newline 0]
, "--:+: :+: :+:"
==>
[T "--:+:", T ":+:", T ":+:", Newline 0]
, "\\x -> y" ==> [LambdaBackslash, T "x", Arrow, T "y", Newline 0]
, "f :: G -> N -> R\n\
\f g = \n\
\\\n -> case lookup n info' of\n\
\\tNothing -> []\n\
\\tJust c -> c\n\
\ where"
==>
[ T "f", DoubleColon, T "G", Arrow, T "N", Arrow, T "R", Newline 0
, T "f", T "g", Equals, Newline 0
, LambdaBackslash, T "n", Arrow
, KWCase, T "lookup", T "n", T "info'", KWOf, Newline 1
, T "Nothing", Arrow, LBracket, RBracket, Newline 1
, T "Just", T "c", Arrow, T "c", Newline 2
, KWWhere, Newline 0
]
, tokenizeSplices
, "import Foo hiding (Bar)" ==>
[KWImport, T "Foo", T "hiding", LParen, T "Bar", RParen, Newline 0]
, "foo\n\
\#{enum Bar, Baz }\n\
\quux" ==>
[ T "foo", Newline 0, HSCEnum, T "Bar", Comma, T "Baz", RBrace, Newline 0
, T "quux", Newline 0
]
, "newtype ControlOp' = ControlOp' CInt\n\
\\n\
\#{enum ControlOp, ControlOp\n\
\ , controlOpAdd = EPOLL_CTL_ADD\n\
\ , controlOpModify = EPOLL_CTL_MOD\n\
\ , controlOpDelete = EPOLL_CTL_DEL\n\
\ }" ==>
[ KWNewtype, T "ControlOp'", Equals, T "ControlOp'", T "CInt", Newline 0
, Newline 0
, HSCEnum, T "ControlOp", Comma, T "ControlOp", Newline 1
, Comma, T "controlOpAdd", Equals, T "EPOLL_CTL_ADD", Newline 1
, Comma, T "controlOpModify", Equals, T "EPOLL_CTL_MOD", Newline 1
, Comma, T "controlOpDelete", Equals, T "EPOLL_CTL_DEL", Newline 1
, RBrace, Newline 0
]
, "a # b = apply a b" ==>
[T "a", T "#", T "b", Equals, T "apply", T "a", T "b", Newline 0]
, "\"\"" ==> [String, Newline 0]
, "\"a\"" ==> [String, Newline 0]
, "\"abc\"" ==> [String, Newline 0]
, "\"abc\\n\"" ==> [String, Newline 0]
, "\"abc\\d\"" ==> [String, Newline 0]
, "\"abc\\\\d\"" ==> [String, Newline 0]
, "\"\\\\d\"" ==> [String, Newline 0]
, "\"\\\\\"" ==> [String, Newline 0]
, "\"a\" ++ \"b\"" ==> [String, T "++", String, Newline 0]
, "\"\\\\\" ++ \"b\"" ==> [String, T "++", String, Newline 0]
, "'a'" ==> [Character, Newline 0]
, "'\\''" ==> [Character, Newline 0]
, "'\"'" ==> [Character, Newline 0]
, "'\\\\'" ==> [Character, Newline 0]
, "foo' bar'" ==> [T "foo'", T "bar'", Newline 0]
, "'\\n'" ==> [Character, Newline 0]
, "argsOf s = map (init . (drop $ 2 + length s)) . filter ((\"\\\\\" ++ s ++ \"{\") `isPrefixOf`)"
==>
[ T "argsOf", T "s", Equals, T "map", LParen, T "init", Dot
, LParen, T "drop", T "$", Number, T "+"
, T "length", T "s", RParen, RParen , Dot, T "filter"
, LParen, LParen, String, T "++", T "s", T "++", String, RParen
, Backtick, T "isPrefixOf", Backtick, RParen, Newline 0
]
, "foo\n\
\# 17 \"/usr/include/stdc-predef.h\" 3 4\n\
\bar"
==>
[ T "foo", Newline 0
, Newline 0
, T "bar", Newline 0
]
, "foo\n\
\#{get_area \"Queue.T\"}\n\
\bar"
==>
[ T "foo", Newline 0
, Newline 0
, T "bar", Newline 0
]
, "foo\n\
\#ccall apr_atomic_init, Ptr <apr_pool_t> -> IO <apr_status_t>\n\
\bar"
==>
[ T "foo", Newline 0
, Newline 0
, T "bar", Newline 0
]
]
where
(==>) = test f
f :: Text -> [TokenVal]
f = tail -- strip uninteresting initial newline
. map valOf
. unstrippedTokensOf
. tokenize
tokenizeSplices = testGroup "tokenize splices"
[ "$(foo)" ==>
[SpliceStart, T "foo", RParen, Newline 0]
, "$(foo [| baz |])" ==>
[ SpliceStart, T "foo", QuasiquoterStart, QuasiquoterEnd, RParen
, Newline 0
]
, "$(foo ⟦ baz ⟧)" ==>
[ SpliceStart, T "foo", QuasiquoterStart, QuasiquoterEnd, RParen
, Newline 0
]
, "$(foo [bar| baz |])" ==>
[ SpliceStart, T "foo", QuasiquoterStart, QuasiquoterEnd, RParen
, Newline 0
]
, "$(foo [Foo.bar| baz ⟧)" ==>
[ SpliceStart, T "foo", QuasiquoterStart, QuasiquoterEnd, RParen
, Newline 0
]
, "$(foo [$bar| baz |])" ==>
[ SpliceStart, T "foo", QuasiquoterStart, QuasiquoterEnd, RParen
, Newline 0
]
, "$(foo [$Foo.bar| baz ⟧)" ==>
[ SpliceStart, T "foo", QuasiquoterStart, QuasiquoterEnd, RParen
, Newline 0
]
, "$(foo [bar| bar!\nbaz!\n $(baz) |])" ==>
[ SpliceStart, T "foo", QuasiquoterStart, SpliceStart, T "baz"
, RParen, QuasiquoterEnd, RParen, Newline 0
]
, "$(foo [Foo.bar| bar!\nbaz!\n $(baz) ⟧)" ==>
[ SpliceStart, T "foo", QuasiquoterStart, SpliceStart, T "baz"
, RParen, QuasiquoterEnd, RParen, Newline 0
]
, "$(foo [$bar| bar!\nbaz!\n $(baz) |])" ==>
[ SpliceStart, T "foo", QuasiquoterStart, SpliceStart, T "baz"
, RParen, QuasiquoterEnd, RParen, Newline 0
]
, "$(foo [$Foo.bar| bar!\nbaz!\n $(baz) ⟧)" ==>
[ SpliceStart, T "foo", QuasiquoterStart, SpliceStart, T "baz"
, RParen, QuasiquoterEnd, RParen, Newline 0
]
, "foo [$bar| baz |]" ==>
[ T "foo", QuasiquoterStart, QuasiquoterEnd, Newline 0 ]
, "foo [$bar|\n\
\ baz |]" ==>
[ T "foo", QuasiquoterStart, QuasiquoterEnd, Newline 0 ]
, "foo [$bar|\n\
\ baz \n\
\|]" ==>
[ T "foo", QuasiquoterStart, QuasiquoterEnd, Newline 0 ]
, "foo\n\
\$bar\n\
\baz" ==>
[ T "foo", Newline 0
, ToplevelSplice, Newline 0
, T "baz", Newline 0
]
, "foo\nf $ x = f x\nbaz" ==>
[ T "foo", Newline 0
, T "f", T "$", T "x", Equals, T "f", T "x", Newline 0
, T "baz", Newline 0
]
]
testTokenizeWithNewlines :: TestTree
testTokenizeWithNewlines = testGroup "tokenize with newlines"
[ testGroup "vanilla"
[ "x\ny\n"
==> [Newline 0, T "x", Newline 0, T "y", Newline 0, Newline 0]
, " xx\n yy\n"
==> [Newline 1, T "xx", Newline 1, T "yy", Newline 0, Newline 0]
, "\n\
\class (X x) => C a b where\n\
\\tm :: a->b\n\
\\tn :: c\n"
==>
[ Newline 0
, Newline 0
, KWClass, LParen, T "X", T "x", RParen, Implies
, T "C", T "a", T "b", KWWhere, Newline 1
, T "m", DoubleColon, T "a", Arrow, T "b", Newline 1
, T "n", DoubleColon, T "c"
, Newline 0
, Newline 0
]
]
, testGroup "literate"
[ "foo bar baz"
|=>
[]
, "foo bar baz\nquux fizz buzz"
|=>
[]
, "> foo = 1"
|=>
[Newline 1, T "foo", Equals, Number, Newline 0]
, "This is a factorial function\n\
\\n\
\> f :: Integer -> Integer\n\
\> f 0 = 1\n\
\> f n = \n\
\> n * (f $ n - 1)\n\
\\n\
\And that's it !"
|=>
[ Newline 1
, T "f", DoubleColon, T "Integer", Arrow, T "Integer", Newline 1
, T "f", Number, Equals, Number, Newline 1
, T "f", T "n", Equals, Newline 3
, T "n", T "*", LParen, T "f", T "$"
, T "n", T "-", Number, RParen, Newline 0
]
, "This is a factorial function\n\
\\n\
\> f :: Integer -> Integer\n\
\> f 0 = 1\n\
\> f n = \n\
\> n * (f $ n - 1)\n\
\\n\
\And another function:\n\
\\n\
\> foo :: a -> a\n\
\> foo x = x"
|=>
[ Newline 1
, T "f", DoubleColon, T "Integer", Arrow, T "Integer", Newline 1
, T "f", Number, Equals, Number, Newline 1
, T "f", T "n", Equals, Newline 3
, T "n", T "*", LParen, T "f", T "$"
, T "n", T "-", Number, RParen, Newline 0
, Newline 1
, T "foo", DoubleColon, T "a", Arrow, T "a", Newline 1
, T "foo", T "x", Equals, T "x", Newline 0
]
, " This is a factorial function\n\
\\n\
\> f :: Integer -> Integer\n\
\> f 0 = 1\n\
\> f n = \n\
\> n * (f $ n - 1)\n\
\\n\
\ And another function:\n\
\\n\
\> foo :: a -> a\n\
\> foo x = x"
|=>
[ Newline 1
, T "f", DoubleColon, T "Integer", Arrow, T "Integer", Newline 1
, T "f", Number, Equals, Number, Newline 1
, T "f", T "n", Equals, Newline 3
, T "n", T "*", LParen, T "f", T "$"
, T "n", T "-", Number, RParen, Newline 0
, Newline 1
, T "foo", DoubleColon, T "a", Arrow, T "a", Newline 1
, T "foo", T "x", Equals, T "x", Newline 0
]
, "This is a factorial function\n\
\\\begin{code}\n\
\f :: Integer -> Integer\n\
\f 0 = 1\n\
\f n = \n\
\ n * (f $ n - 1)\n\
\\\end{code}\n\
\And that's it !"
|=>
[ Newline 0
, T "f", DoubleColon, T "Integer", Arrow, T "Integer", Newline 0
, T "f", Number, Equals, Number, Newline 0
, T "f", T "n", Equals, Newline 2
, T "n", T "*", LParen, T "f", T "$", T "n", T "-", Number, RParen
]
, "This is a 'factorial' function\n\
\\\begin{code}\n\
\f :: Integer -> Integer\n\
\f 0 = 1\n\
\f n = \n\
\ n * (f $ n - 1)\n\
\\\end{code}\n\
\But that's not it yet! Here's another function:\n\
\\\begin{code}\n\
\foo :: a -> a\n\
\foo x = x\n\
\\\end{code}\n\
\And that's it !"
|=>
[ Newline 0
, T "f", DoubleColon, T "Integer", Arrow, T "Integer", Newline 0
, T "f", Number, Equals, Number, Newline 0
, T "f", T "n", Equals, Newline 2
, T "n", T "*", LParen, T "f", T "$"
, T "n", T "-", Number, RParen, Newline 0
, T "foo", DoubleColon, T "a", Arrow, T "a", Newline 0
, T "foo", T "x", Equals, T "x"
]
, "This is a 'factorial' function\n\
\\\begin{code}\n\
\ f :: Integer -> Integer\n\
\ f 0 = 1\n\
\ f n = \n\
\ n * (f $ n - 1)\n\
\\\end{code}\n\
\But that's not it yet! Here's another function:\n\
\\\begin{code}\n\
\ foo :: a -> a\n\
\ foo x = x\n\
\\\end{code}\n\
\And that's it !"
|=>
[ Newline 2
, T "f", DoubleColon, T "Integer", Arrow, T "Integer", Newline 2
, T "f", Number, Equals, Number, Newline 2
, T "f", T "n", Equals, Newline 4
, T "n", T "*", LParen, T "f", T "$", T "n", T "-", Number, RParen
, Newline 2
, T "foo", DoubleColon, T "a", Arrow, T "a", Newline 2
, T "foo", T "x", Equals, T "x"
]
, "Test\n\
\\\begin{code}\n\
\class (X x) => C a b where\n\
\ m :: a->b\n\
\ n :: c\n\
\\\end{code}"
|=>
[ Newline 0
, KWClass, LParen, T "X", T "x", RParen, Implies
, T "C", T "a", T "b", KWWhere, Newline 2
, T "m", DoubleColon, T "a", Arrow, T "b", Newline 2
, T "n", DoubleColon, T "c"
]
, "Test\n\
\\\begin{code}\n\
\class (X x) => C a b where\n\
\\tm :: a->b\n\
\\tn :: c\n\
\\\end{code}"
|=>
[ Newline 0
, KWClass, LParen, T "X", T "x", RParen, Implies
, T "C", T "a", T "b", KWWhere, Newline 1
, T "m", DoubleColon, T "a", Arrow, T "b", Newline 1
, T "n", DoubleColon, T "c"
]
]
]
where
(==>) = test (f LitVanilla)
(|=>) = test (f LitOutside)
f mode = map valOf . unstrippedTokensOf . tokenizeWith mode
testStripComments :: TestTree
testStripComments = testGroup "Comments stripping"
[ "hello -- there"
==>
[Newline 0, T "hello", Newline 0]
, "hello --there"
==>
[Newline 0, T "hello", Newline 0]
, "hello {- there -} fred"
==>
[Newline 0, T "hello", T "fred", Newline 0]
, "hello -- {- there -}\n\
\fred"
==>
[Newline 0, T "hello", Newline 0, T "fred", Newline 0]
, "{-# LANG #-} hello {- there {- nested -} comment -} fred"
==>
[Newline 1, T "hello", T "fred", Newline 0]
, "hello {-\n\
\there\n\
\------}\n\
\ fred"
==>
[Newline 0, T "hello", Newline 1, T "fred", Newline 0]
, "hello {- \n\
\there\n\
\ ------} \n\
\ fred"
==>
[Newline 0, T "hello", Newline 1, T "fred", Newline 0]
, "hello {-\n\
\there\n\
\-----}\n\
\ fred"
==>
[Newline 0, T "hello", Newline 1, T "fred", Newline 0]
, "hello {- \n\
\there\n\
\ -----} \n\
\ fred"
==>
[Newline 0, T "hello", Newline 1, T "fred", Newline 0]
, "hello {-\n\
\-- there -}"
==>
[Newline 0, T "hello", Newline 0]
, "foo --- my comment\n\
\--- my other comment\n\
\bar"
==>
[Newline 0, T "foo", Newline 0, Newline 0, T "bar", Newline 0]
]
where
(==>) = test f
f = map valOf . unstrippedTokensOf . tokenize
testBreakBlocks :: TestTree
testBreakBlocks = testGroup "Break blocks"
[ testGroup "vanilla"
[ "a\n\
\b\n"
==>
[ [T "a"]
, [T "b"]
]
, "a\n\
\ a\n\
\b\n"
==>
[ [T "a", Newline 1, T "a"]
, [T "b"]
]
, "a\n\
\ a\n\
\ a\n\
\b\n"
==>
[ [T "a", Newline 1, T "a", Newline 1, T "a"]
, [T "b"]
]
-- intervening blank lines are ignored
, "a\n\
\ a\n\
\\n\
\ a\n\
\b\n"
==>
[ [T "a", Newline 1, T "a", Newline 1, T "a"]
, [T "b"]
]
, "a\n\
\\n\
\\n\
\ a\n\
\b\n"
==>
[ [T "a", Newline 1, T "a"]
, [T "b"]
]
, "a\n\
\ aa\n\
\ aa\n"
==>
[[T "a", Newline 1, T "aa", Newline 1, T "aa"]]
, " aa\n\
\ aa\n"
==>
[ [T "aa"]
, [T "aa"]
]
, "one_hash, two_hash :: text_type\n\
\hash_prec :: Int -> Int\n\
\one_hash = from_char '#'\n\
\two_hash = from_string \"##\"\n\
\hash_prec = const 0"
==>
[ [T "one_hash", Comma, T "two_hash", DoubleColon, T "text_type"]
, [T "hash_prec", DoubleColon, T "Int", Arrow, T "Int"]
, [T "one_hash", Equals, T "from_char", Character]
, [T "two_hash", Equals, T "from_string", String]
, [T "hash_prec", Equals, T "const", Number]
]
, "one_hash, two_hash :: text_type; \
\hash_prec :: Int -> Int; \
\one_hash = from_char '#'; \
\two_hash = from_string \"##\"; \
\hash_prec = const 0"
==>
[ [T "one_hash", Comma, T "two_hash", DoubleColon, T "text_type"]
, [T "hash_prec", DoubleColon, T "Int", Arrow, T "Int"]
, [T "one_hash", Equals, T "from_char", Character]
, [T "two_hash", Equals, T "from_string", String]
, [T "hash_prec", Equals, T "const", Number]
]
, "{\n\
\ data F f :: * ; -- foo\n\
\ -- bar\n\
\ -- baz\n\
\ mkF :: f -> F f ; getF :: F f -> f ;\n\
\} ;"
==>
[ [ LBrace, Newline 2, KWData, T "F", T "f", DoubleColon
, T "*", Semicolon, Newline 2
, T "mkF", DoubleColon, T "f", Arrow, T "F", T "f", Semicolon
, T "getF", DoubleColon, T "F", T "f", Arrow, T "f", Semicolon
, Newline 0
, RBrace
]
]
]
, testGroup "literate"
[ "> a\n\
\>\n\
\>\n\
\> a\n\
\> b\n"
|=>
[ [T "a", Newline 2, T "a"]
, [T "b"]
]
, "> a\n\
\> \n\
\> \n\
\> a\n\
\> b\n"
|=>
[ [T "a", Newline 2, T "a"]
, [T "b"]
]
, "> a\n\
\> aa\n\
\> aa\n"
|=>
[[T "a", Newline 2, T "aa", Newline 2, T "aa"]]
, "> a\n\
\> aa\n\
\>\n\
\> aa\n"
|=>
[[T "a", Newline 2, T "aa", Newline 2, T "aa"]]
]
]
where
(==>) = test (f LitVanilla)
(|=>) = test (f LitOutside)
f :: LitMode Void -> Text -> [[TokenVal]]
f mode
= map (map valOf . unstrippedTokensOf)
. breakBlocks ProcessVanilla
. tokenizeWith mode
testWhereBlock :: TestTree
testWhereBlock = testGroup "whereBlock"
[ "class A f where\n\
\ data F f :: * -- foo\n\
\ -- bar\n\
\ -- baz\n\
\ mkF :: f -> F f\n\
\ getF :: F f -> f"
==>
[ [KWData, T "F", T "f", DoubleColon, T "*"]
, [T "mkF", DoubleColon, T "f", Arrow, T "F", T "f"]
, [T "getF", DoubleColon, T "F", T "f", Arrow, T "f"]
]
, "class A f where {\n\
\ data F f :: * ; -- foo\n\
\ -- bar\n\
\ -- baz\n\
\ mkF :: f -> F f ;\n\
\ getF :: F f -> f ;\n\
\} ;"
==>
[ [KWData, T "F", T "f", DoubleColon, T "*"]
, [T "mkF", DoubleColon, T "f", Arrow, T "F", T "f"]
, [T "getF", DoubleColon, T "F", T "f", Arrow, T "f"]
]
]
where
(==>) = test f
f = map (map valOf . Tag.stripNewlines)
. Tag.whereBlock
. tokenize
testEmacs :: TestTree
testEmacs = testGroup "Emacs" [emacsFormat]
emacsFormat :: TestTree
emacsFormat = testGroup "format"
[
test Emacs.formatTag (Pos tag val) $ T.concat ["wibble wobble", "\x7f", "wibble wobble", "\x01", "10,14"]
]
where tag = (SrcPos "fn" 10 20 "wibble" " wobble")
val = (TagVal "wibble wobble" Tag.Function Nothing)
testVim :: TestTree
testVim = testGroup "Vim" [parseTag, dropAdjacent]
parseTag :: TestTree
parseTag = testGroup "parseTag"
[ ("fn", 1, "text", Tag.Function) ==>
Just (Vim.Parsed "text" Tag.Function "fn" 1)
]
where
(==>) = test f
f (fn, line, text, typ) =
Vim.parseTag $ Vim.showTag $
Pos (SrcPos fn (Line line) (Offset 0) "" "") (TagVal text typ Nothing)
dropAdjacent :: TestTree
dropAdjacent = testGroup "dropAdjacent"
[ [fna 0] ==> [fna 0]
, [fna 0, fna 1] ==> [fna 0]
-- Line number order dosen't matter.
, [fna 1, fna 0] ==> [fna 0]
, [fna 0, fna 1, fna 2] ==> [fna 0]
, [fna 0, fna 1, fna 2, fna 3] ==> [fna 0, fna 3]
-- Filename differs.
, [fna 0, ("fn2", 1, "a")] ==> [fna 0, ("fn2", 1, "a")]
-- Tag name differs.
, [fna 0, ("fn", 1, "b")] ==> [fna 0, ("fn", 1, "b")]
]
where
fna n = ("fn", n, "a")
(==>) = test f
f = map extract . map fst . Vim.dropAdjacent 2
. Vim.keyOnJust Vim.parseTag . map (Vim.showTag . makeTag)
extract t = (Vim.filename t, Vim.line t, Vim.name t)
makeTag (fn, line, text) =
Pos (SrcPos fn (Line line) (Offset 0) "" "") (TagVal text Function Nothing)
testProcess :: TestTree
testProcess = testGroup "process"
[ testMeta
, testData
, testGADT
, testFamilies
, testFunctions
, testClass
, testInstance
, testLiterate
, testPatterns
, testFFI
, testDefine
, testHSC2HS
, testAlex
, testHappy
]
testMeta :: TestTree
testMeta = testGroup "prefix, suffix and offset tracking"
[ "module Bar.Foo where\n" ==>
[Pos (SrcPos fn 1 14 "module Bar.Foo" " where") (TagVal "Foo" Module Nothing)]
, "newtype Foo a b =\n\
\\tBar x y z\n" ==>
[ Pos (SrcPos fn 1 11 "newtype Foo" " a b =") (TagVal "Foo" Type Nothing)
, Pos (SrcPos fn 2 22 "\tBar" " x y z") (TagVal "Bar" Constructor (Just "Foo"))
]
, "data Foo a b =\n\
\\tBar x y z\n" ==>
[ Pos (SrcPos fn 1 8 "data Foo" " a b =") (TagVal "Foo" Type Nothing)
, Pos (SrcPos fn 2 19 "\tBar" " x y z") (TagVal "Bar" Constructor (Just "Foo"))
]
, "f :: A -> B\n\
\g :: C -> D\n\
\data D = C {\n\
\\tf :: A\n\
\\t}\n" ==>
[ Pos (SrcPos fn 1 1 "f" " :: A -> B") (TagVal "f" Function Nothing)
, Pos (SrcPos fn 2 13 "g" " :: C -> D") (TagVal "g" Function Nothing)
, Pos (SrcPos fn 3 30 "data D" " = C {") (TagVal "D" Type Nothing)
, Pos (SrcPos fn 3 34 "data D = C" " {") (TagVal "C" Constructor (Just "D"))
, Pos (SrcPos fn 4 39 "\tf" " :: A") (TagVal "f" Function (Just "D"))
]
, "instance Foo Bar where\n\
\ newtype FooFam Bar = BarList [Int]" ==>
[ Pos (SrcPos fn 2 53 " newtype FooFam Bar = BarList" " [Int]")
(TagVal "BarList" Constructor (Just "FooFam"))
]
, "instance Foo Bar where\n\
\ newtype FooFam Bar = BarList { getBarList :: [Int] }" ==>
[ Pos (SrcPos fn 2 53 " newtype FooFam Bar = BarList" " { getBarList :: [Int] }")
(TagVal "BarList" Constructor (Just "FooFam"))
, Pos (SrcPos fn 2 66 " newtype FooFam Bar = BarList { getBarList" " :: [Int] }")
(TagVal "getBarList" Function (Just "FooFam"))
]
, "instance Foo Bar where\n\
\ data (Ord a) => FooFam Bar a = BarList { getBarList :: [a] }\n\
\ | BarMap { getBarMap :: Map a Int }" ==>
[ Pos (SrcPos fn 2 63 " data (Ord a) => FooFam Bar a = BarList" " { getBarList :: [a] }")
(TagVal "BarList" Constructor (Just "FooFam"))
, Pos (SrcPos fn 2 76 " data (Ord a) => FooFam Bar a = BarList { getBarList" " :: [a] }")
(TagVal "getBarList" Function (Just "FooFam"))
, Pos (SrcPos fn 3 125 " | BarMap" " { getBarMap :: Map a Int }")
(TagVal "BarMap" Constructor (Just "FooFam"))
, Pos (SrcPos fn 3 137 " | BarMap { getBarMap" " :: Map a Int }")
(TagVal "getBarMap" Function (Just "FooFam"))
]
, "newtype instance FooFam Bar = BarList { getBarList :: [Int] }" ==>
[ Pos (SrcPos fn 1 37 "newtype instance FooFam Bar = BarList" " { getBarList :: [Int] }")
(TagVal "BarList" Constructor (Just "FooFam"))
, Pos (SrcPos fn 1 50 "newtype instance FooFam Bar = BarList { getBarList" " :: [Int] }")
(TagVal "getBarList" Function (Just "FooFam"))
]
, "data instance (Ord a) => FooFam Bar a = BarList { getBarList :: [a] }\n\
\ | BarMap { getBarMap :: Map a Int }"
==>
[ Pos (SrcPos fn 1 47 "data instance (Ord a) => FooFam Bar a = BarList" " { getBarList :: [a] }")
(TagVal "BarList" Constructor (Just "FooFam"))
, Pos (SrcPos fn 1 60 "data instance (Ord a) => FooFam Bar a = BarList { getBarList" " :: [a] }")
(TagVal "getBarList" Function (Just "FooFam"))
, Pos (SrcPos fn 2 116 " | BarMap" " { getBarMap :: Map a Int }")
(TagVal "BarMap" Constructor (Just "FooFam"))
, Pos (SrcPos fn 2 128 " | BarMap { getBarMap" " :: Map a Int }")
(TagVal "getBarMap" Function (Just "FooFam"))
]
]
where
(==>) = testFullTagsWithPrefixes fn
fn = "fn.hs"
testData :: TestTree
testData = testGroup "data"
[ "data X\n" ==> ["X"]
, "data X = X Int\n" ==> ["X", "X"]
, "data Foo = Bar | Baz" ==> ["Bar", "Baz", "Foo"]
, "data Foo =\n\tBar\n\t| Baz" ==> ["Bar", "Baz", "Foo"]
-- Records.
, "data Foo a = Bar { field :: Field }" ==> ["Bar", "Foo", "field"]
, "data R = R { a::X, b::Y }" ==> ["R", "R", "a", "b"]
, "data R = R { a, b::X }" ==> ["R", "R", "a", "b"]
, "data R = R { a∷X, b∷Y }" ==> ["R", "R", "a", "b"]
, "data R = R { a, b∷X }" ==> ["R", "R", "a", "b"]
, "data R = R {\n\ta::X\n\t, b::Y\n\t}" ==> ["R", "R", "a", "b"]
, "data R = R {\n\ta,b::X\n\t}" ==> ["R", "R", "a", "b"]
-- Record operators
, "data Foo a b = (:*:) { foo :: a, bar :: b }" ==>
[":*:", "Foo", "bar", "foo"]
, "data R = R {\n\
\ a :: !RealTime\n\
\ , b :: !RealTime\n\
\}"
==>
["R", "R", "a", "b"]
, "data Rec = Rec {\n\
\ a :: Int\n\
\, b :: !Double\n\
\, c :: Maybe Rec\
\\n\
\}"
==>
["Rec", "Rec", "a", "b", "c"]
, "data X = X !Int" ==> ["X", "X"]
, "data X = Y !Int !X | Z" ==> ["X", "Y", "Z"]
, "data X = Y :+: !Z | !X `Mult` X" ==> [":+:", "Mult", "X"]
, "data X = !Y `Add` !Z" ==> ["Add", "X"]
, "data X = forall a. Y a" ==> ["X", "Y"]
, "data X = forall a . Y a" ==> ["X", "Y"]
, "data X = forall a .Y a" ==> ["X", "Y"]
, "data X = forall a.Y a" ==> ["X", "Y"]
, "data X = forall a. Eq a => Y a" ==> ["X", "Y"]
, "data X = forall a. (Eq a) => Y a" ==> ["X", "Y"]
, "data X = forall (a :: Nat). (Eq' a) => Y a" ==> ["X", "Y"]
, "data X = forall a. (Eq a, Ord a) => Y a" ==> ["X", "Y"]
, "data X = forall a. Ref :<: a => Y a" ==> ["X", "Y"]
, "data X = forall a. (:<:) Ref a => Y a" ==> ["X", "Y"]
, "data X = forall a. ((:<:) Ref a) => Y a" ==> ["X", "Y"]
, "data X = forall a. Y !a" ==> ["X", "Y"]
, "data X = forall a. (Eq a, Ord a) => Y !a" ==> ["X", "Y"]
, "data Foo a = \n\
\ Plain Int\n\
\ | forall a. Bar a Int\n\
\ | forall a b. Baz b a\n\
\ | forall a . Quux a \
\ | forall a .Quuz a"
==>
["Bar", "Baz", "Foo", "Plain", "Quux", "Quuz"]
, "data X a = Add a " ==> ["Add", "X"]
, "data Eq a => X a = Add a" ==> ["Add", "X"]
, "data (Eq a) => X a = Add a" ==> ["Add", "X"]
, "data (Eq a, Ord a) => X a = Add a" ==> ["Add", "X"]
, "data (Eq (a), Ord (a)) => X a = Add a" ==> ["Add", "X"]
, "data Ref :<: f => X f = RRef f" ==>
["RRef", "X"]
, "data a :<: b => X a b = Add a" ==>
["Add", "X"]
, "newtype Ref :<: f => X f = RRef f" ==>
["RRef", "X"]
, "newtype a :<: b => X a b = Add a" ==>
["Add", "X"]
, "data Ref :<: [f] => X f = RRef f" ==>
["RRef", "X"]
, "data [a] :<: b => X a b = Add a" ==>
["Add", "X"]
, "newtype Ref :<: [f] => X f = RRef f" ==>
["RRef", "X"]
, "newtype [a] :<: b => X a b = Add a" ==>
["Add", "X"]
, "data (a :<: b) => X a b = Add a" ==>
["Add", "X"]
, "data a :><: b = a :>|<: b" ==>
[":><:", ":>|<:"]
, "data (:><:) a b = (:>|<:) a b" ==>
[":><:", ":>|<:"]
, "data (:><:) a b = Foo b | (:>|<:) a b" ==>
[":><:", ":>|<:", "Foo"]
, "data (:><:) a b = Foo b | forall c. (:>|<:) a c" ==>
[":><:", ":>|<:", "Foo"]
, "data (:><:) a b = Foo b | forall c. (Eq c) => (:>|<:) a c" ==>
[":><:", ":>|<:", "Foo"]
, "data (:><:) a b = Foo b | forall c. Eq c => (:>|<:) a c" ==>
[":><:", ":>|<:", "Foo"]
, "newtype Eq a => X a = Add a" ==>
["Add", "X"]
, "newtype (Eq a) => X a = Add a" ==>
["Add", "X"]
, "newtype (Eq a, Ord a) => X a = Add a" ==>
["Add", "X"]
, "newtype () => X a = Add a" ==>
["Add", "X"]
, "newtype (u :*: v) z = X" ==>
[":*:", "X"]
, "data (u :*: v) z = X" ==>
[":*:", "X"]
, "type (u :*: v) z = (u, v, z)" ==>
[":*:"]
, "newtype ((u :: (* -> *) -> *) :*: v) z = X" ==>
[":*:", "X"]
, "data ((u :: (* -> *) -> *) :*: v) z = X" ==>
[":*:", "X"]
, "type ((u :: (* -> *) -> *) :*: v) z = (u, v, z)" ==>
[":*:"]
, "newtype () => ((u :: (* -> *) -> *) :*: v) z = X" ==>
[":*:", "X"]
, "data () => ((u :: (* -> *) -> *) :*: v) z = X" ==>
[":*:", "X"]
, "type () => ((u :: (* -> *) -> *) :*: v) z = (u, v, z)" ==>
[":*:"]
, "newtype (Eq (v z)) => ((u :: (* -> *) -> *) :*: v) z = X" ==>
[":*:", "X"]
, "data (Eq (v z)) => ((u :: (* -> *) -> *) :*: v) z = X" ==>
[":*:", "X"]
, "type (Eq (v z)) => ((u :: (* -> *) -> *) :*: v) z = (u, v, z)" ==>
[":*:"]
, "newtype Eq (v z) => ((u :: (* -> *) -> *) :*: v) z = X" ==>
[":*:", "X"]
, "data Eq (v z) => ((u :: (* -> *) -> *) :*: v) z = X" ==>
[":*:", "X"]
, "type Eq (v z) => ((u :: (* -> *) -> *) :*: v) z = (u, v, z)" ==>
[":*:"]
, "newtype (Eq (v z)) => ((u :: (* -> *) -> *) `Foo` v) z = X" ==>
["Foo", "X"]
, "data (Eq (v z)) => ((u :: (* -> *) -> *) `Foo` v) z = X" ==>
["Foo", "X"]
, "type (Eq (v z)) => ((u :: (* -> *) -> *) `Foo` v) z = (u, v, z)" ==>
["Foo"]
, "type (Eq (v z)) => ((u ∷ (* -> *) -> *) `Foo` v) z = (u, v, z)" ==>
["Foo"]
, "newtype Eq (v z) => ((u :: (* -> *) -> *) `Foo` v) z = X" ==>
["Foo", "X"]
, "data Eq (v z) => ((u :: (* -> *) -> *) `Foo` v) z = X" ==>
["Foo", "X"]
, "type Eq (v z) => ((u :: (* -> *) -> *) `Foo` v) z = (u, v, z)" ==>
["Foo"]
, "type Eq (v z) ⇒ ((u ∷ (* → *) → *) `Foo` v) z = (u, v, z)" ==>
["Foo"]
, "data (:*:) u v z = X" ==>
[":*:", "X"]
, "data (Eq (u v), Ord (z)) => (:*:) u v z = X" ==>
[":*:", "X"]
, "data (u `W` v) z = X" ==>
["W", "X"]
, "data (Eq (u v), Ord (z)) => (u `W` v) z = X" ==>
["W", "X"]
, "newtype X a = Z {\n\
\ -- TODO blah\n\
\ foo :: [a] }"
==>
["X", "Z", "foo"]
, "newtype (u :*: v) z = X {\n\
\ -- my insightful comment\n\
\ extract :: (u (v z)) }"
==>
[":*:", "X", "extract"]
, "newtype (u :*: v) z = X {\n\
\ -- my insightful comment\n\
\ pattern :: (u (v z)) }"
==>
[":*:", "X", "pattern"]
, "data Hadron a b = Science { f :: a, g :: a, h :: b }"
==>
["Hadron", "Science", "f", "g", "h"]
, "data Hadron a b = Science { f :: a, g :: a, pattern :: b }"
==>
["Hadron", "Science", "f", "g", "pattern"]
, "data Hadron a b = Science { f :: a, g :: (a, b), h :: b }"
==>
["Hadron", "Science", "f", "g", "h"]
, "data Hadron a b = forall x. Science { f :: x, h :: b }"
==>
["Hadron", "Science", "f", "h"]
, "data Hadron a b = forall x. Science { f :: [x], h :: b }"
==>
["Hadron", "Science", "f", "h"]
, "data Hadron a b = forall x y. Science { f :: (x, y), h :: b }"
==>
["Hadron", "Science", "f", "h"]
, "data Hadron a b = forall x y. Science { f :: [(x, y)], h :: b }"
==>
["Hadron", "Science", "f", "h"]
, "data Hadron a b = \
\forall x y. Science { f :: [(Box x, Map x y)], h :: b }"
==>
["Hadron", "Science", "f", "h"]
, "data Hadron a b = forall x y. Science { f ∷ [(Box x, Map x y)], h ∷ b }"
==>
["Hadron", "Science", "f", "h"]
, "data Hadron a b = forall x y z. Science\n\
\ { f :: x\n\
\ , g :: [(Box x, Map x y, z)] \
\ }"
==>
["Hadron", "Science", "f", "g"]
, "data Hadron a b = forall x y z. Science\n\
\ { f :: x\n\
\ , g :: [(Box x, Map x y, z)] \
\ , h :: b\n\
\ }"
==>
["Hadron", "Science", "f", "g", "h"]
, "data Hadron a b = Science { h :: b }"
==>
["Hadron", "Science", "h"]
, "data Test a b =\n\
\ Foo a\n\
\ | Bar [(Maybe a, Map a b, b)]"
==>
["Bar", "Foo", "Test"]
, "data Test a b =\n\
\ Foo a\n\
\ | [(Maybe b, Map b a, a)] `Bar` [(Maybe a, Map a b, b)]"
==>
["Bar", "Foo", "Test"]
, "data IO a = IO (World->(a,World))"
==>
["IO", "IO"]
, "data SubTransformTriple a =\n\
\ SubTransformTriple\n\
\ (forall sh. (Shape sh, Slice sh) => Transform (sh:.Int) a)\n\
\ (forall sh. (Shape sh, Slice sh) => Transform (sh:.Int) a)\n\
\ (forall sh. (Shape sh, Slice sh) => Transform (sh:.Int) a)"
==>
["SubTransformTriple", "SubTransformTriple"]
, "data TestCase \n\
\ = forall a prop . (Testable prop, Data a) \n\
\ => TestCase (((String, a, a) -> Property) -> prop)\n\
\ deriving (Typeable)"
==>
["TestCase", "TestCase"]
, "-- | Binding List\n\
\data BindingList v a = Variable v => BindingList {source :: Source v a -- ^ the list's binding source\n\
\ , list :: v [v a] -- ^ the bound list\n\
\ , pos :: v Int} -- ^ the current position"
==>
["BindingList", "BindingList", "list", "pos", "source"]
, "data Tester a = Tester\n\
\ {(===) :: [String] -> a -> IO ()\n\
\ ,fails :: [String] -> IO ()\n\
\ ,isHelp :: [String] -> [String] -> IO ()\n\
\ ,isHelpNot :: [String] -> [String] -> IO ()\n\
\ ,isVersion :: [String] -> String -> IO ()\n\
\ ,isVerbosity :: [String] -> Verbosity -> IO ()\n\
\ ,completion :: [String] -> (Int,Int) -> [Complete] -> IO ()\n\
\ }"
==>
["===", "Tester", "Tester", "completion", "fails", "isHelp", "isHelpNot", "isVerbosity", "isVersion"]
, "data Tester a = Tester\n\
\ {(===) :: [String] -> a -> IO ()\n\
\ ,fails :: [String] -> IO ()\n\
\ ,isHelp, isHelpNot :: [String] -> [String] -> IO ()\n\
\ ,isVersion :: [String] -> String -> IO ()\n\
\ ,isVerbosity :: [String] -> Verbosity -> IO ()\n\
\ ,completion :: [String] -> (Int,Int) -> [Complete] -> IO ()\n\
\ }"
==>
["===", "Tester", "Tester", "completion", "fails", "isHelp", "isHelpNot", "isVerbosity", "isVersion"]
, "-- | View of the right end of a sequence.\n\
\data ViewR s a\n\
\ = EmptyR\n\
\ | s a :> a"
==>
[":>", "EmptyR", "ViewR"]
, "-- | View of the right end of a sequence.\n\
\data ViewR s a\n\
\ = s a :> a\n\
\ | EmptyR"
==>
[":>", "EmptyR", "ViewR"]
, "data [] a = [] | a : [a]"
==> [":", "[]", "[]"]
, "data () = ()"
==> ["()", "()"]
, "data (,) a b = (,) a b"
==> ["(,)", "(,)"]
, "data (,,) a b c = (,,) a b c"
==> ["(,,)", "(,,)"]
, "data (a, b) = (a, b)"
==> ["(,)", "(,)"]
, "data (a, b, c) = (a, b, c)"
==> ["(,,)", "(,,)"]
]
where
(==>) = testTagNames filename
testGADT :: TestTree
testGADT = testGroup "gadt"
[ "data X where A :: X\n" ==> ["A", "X"]
, "data X where\n\tA :: X\n" ==> ["A", "X"]
, "data X where\n\tA :: X\n\tB :: X\n" ==> ["A", "B", "X"]
, "data X where\n\tA, B :: X\n" ==> ["A", "B", "X"]
, "data X :: * -> * -> * where\n\
\ A, B :: Int -> Int -> X\n"
==>
["A", "B", "X"]
, "data X ∷ * → * → * where\n\
\ A, B ∷ Int → Int → X\n"
==>
["A", "B", "X"]
, "data Vec ix where\n\
\ Nil :: Int -> Foo Int\n\
\ (:::) :: Int -> Vec Int -> Vec Int\n\
\ (:+.) :: Int -> Int -> Vec Int -> Vec Int\n"
==>
[":+.", ":::", "Nil", "Vec"]
, "data Vec ix where\n\
\ Nil :: Int -> Foo Int\n\
\ -- foo\n\
\ (:::) :: Int -> Vec Int -> Vec Int\n\
\-- bar\n\
\ (:+.) :: Int -> \n\
\ -- ^ baz\n\
\ Int -> \n\
\ Vec Int -> \n\
\Vec Int\n"
==>
[":+.", ":::", "Nil", "Vec"]
, "data NatSing (n :: Nat) where\n\
\ ZeroSing :: 'Zero\n\
\ SuccSing :: NatSing n -> NatSing ('Succ n)\n"
==>
["NatSing", "SuccSing", "ZeroSing"]
, "data Rec a where\n\
\ C :: { foo :: Int } -> Rec a"
==> ["C", "Rec", "foo"]
, "data Rec a where\n\
\ C :: { foo :: Int, bar :: Int -> Int } -> Rec a"
==> ["C", "Rec", "bar", "foo"]
, "data Rec a where\n\
\ C :: { foo :: Int, bar :: Int -> Int } -> Rec a\n\
\ D :: { baz :: (Int -> Int) -> Int, bar :: (((Int) -> (Int))) } -> Rec a"
==> ["C", "D", "Rec", "bar", "bar", "baz", "foo"]
, "newtype TyConProxy a b where\n\
\ TyConProxy :: () -> TyConProxy a b\n\
\ deriving ( Arbitrary\n\
\ , Show\n\
\ , Generic\n\
\#if defined(__LANGUAGE_DERIVE_GENERIC1__)\n\
\ , Generic1\n\
\#endif\n\
\ )"
==> ["TyConProxy", "TyConProxy"]
, "data Foo a where\n\
\ Bar :: Baz a => { foo :: Int, bar :: a } -> Foo a"
==> ["Bar", "Foo", "bar", "foo"]
, "type role Map nominal representational"
==> []
]
where
(==>) = testTagNames filename
testFamilies :: TestTree
testFamilies = testGroup "families"
[ "type family X :: *\n" ==> ["X"]
, "data family X :: * -> *\n" ==> ["X"]
, "data family a ** b" ==> ["**"]
, "type family a :<: b\n" ==> [":<:"]
, "type family (a :: Nat) :<: (b :: Nat) :: Nat\n" ==> [":<:"]
, "type family (a :: Nat) `Family` (b :: Nat) :: Nat\n" ==> ["Family"]
, "type family (m :: Nat) <=? (n :: Nat) :: Bool" ==> ["<=?"]
, "type family (m ∷ Nat) <=? (n ∷ Nat) ∷ Bool" ==> ["<=?"]
, "data instance X a b = Y a | Z { unZ :: b }" ==>
["Y", "Z", "unZ"]
, "data instance (Eq a, Eq b) => X a b = Y a | Z { unZ :: b }" ==>
["Y", "Z", "unZ"]
, "data instance (Eq a, Eq b) => X a b = Y a | Z { pattern :: b }" ==>
["Y", "Z", "pattern"]
, "data instance XList Char = XCons !Char !(XList Char) | XNil" ==>
["XCons", "XNil"]
, "newtype instance Cxt x => T [x] = A (B x) deriving (Z,W)" ==> ["A"]
, "type instance Cxt x => T [x] = A (B x)" ==> []
, "data instance G [a] b where\n\
\ G1 :: c -> G [Int] b\n\
\ G2 :: G [a] Bool"
==>
["G1", "G2"]
, "class C where\n\ttype X y :: *\n" ==> ["C", "X"]
, "class C where\n\tdata X y :: *\n" ==> ["C", "X"]
, "class C where\n\ttype X y ∷ *\n" ==> ["C", "X"]
, "class C where\n\tdata X y ∷ *\n" ==> ["C", "X"]
]
where
(==>) = testTagNames filename
testFunctions :: TestTree
testFunctions = testGroup "functions"
-- Multiple declarations.
[ "a,b::X" ==> ["a", "b"]
-- With an operator.
, "(+), a :: X" ==> ["+", "a"]
-- Unicode operator.
, "(•) :: X" ==> ["•"]
-- Don't get fooled by literals.
, "1 :: Int" ==> []
-- Don't confuse _ wildcard for an operator.
, "f :: Int -> Int\n\
\f _ = 1" ==> ["f"]
-- plain functions and operators
, "(.::) :: X -> Y" ==> [".::"]
, "(+::) :: X -> Y" ==> ["+::"]
, "(->:) :: X -> Y" ==> ["->:"]
, "(--+) :: X -> Y" ==> ["--+"]
, "(=>>) :: X -> Y" ==> ["=>>"]
-- Multi-line with semicolons at the end
, "one_hash, two_hash :: text_type;\n\
\hash_prec :: Int -> Int;\n\
\one_hash = from_char '#';\n\
\two_hash = from_string \"##\";\n\
\hash_prec = const 0"
==>
["hash_prec", "one_hash", "two_hash"]
-- Single-line separated by semicolons - e.g. result of a macro expansion
, "one_hash, two_hash :: text_type; \
\hash_prec :: Int -> Int; \
\one_hash = from_char '#'; \
\two_hash = from_string \"##\"; \
\hash_prec = const 0"
==>
["hash_prec", "one_hash", "two_hash"]
, "assertDataFormatError :: DecompressError -> IO String\n\
\assertDataFormatError (DataFormatError detail) = return detail\n\
\assertDataFormatError _ = assertFailure \"expected DataError\"\n\
\ >> return \"\"\n"
==>
["assertDataFormatError"]
, "instance PartialComparison Double where\n\
\ type PartialCompareEffortIndicator Double = ()\n\
\ pCompareEff _ a b = Just $ toPartialOrdering $ Prelude.compare a b\n\
\-- case (isNaN a, isNaN b) of\n\
\-- (False, False) -> Just $ toPartialOrdering $ Prelude.compare a b \n\
\-- (True, True) -> Just EQ\n\
\-- _ -> Just NC \n\
\ pCompareDefaultEffort _ = ()\n\
\\n\
\pComparePreludeCompare _ a b =\n\
\ Just $ toPartialOrdering $ Prelude.compare a b\n\
\\n\
\propPartialComparisonReflexiveEQ :: \n\
\ (PartialComparison t) =>\n\
\ t -> \n\
\ (PartialCompareEffortIndicator t) -> \n\
\ (UniformlyOrderedSingleton t) -> \n\
\ Bool\n\
\propPartialComparisonReflexiveEQ _ effort (UniformlyOrderedSingleton e) = \n\
\ case pCompareEff effort e e of Just EQ -> True; Nothing -> True; _ -> False"
==>
["pComparePreludeCompare", "propPartialComparisonReflexiveEQ"]
, "hexQuad :: Z.Parser Int\n\
\hexQuad = do\n\
\ s <- Z.take 4\n\
\ let hex n | w >= C_0 && w <= C_9 = w - C_0\n\
\ | w >= C_a && w <= C_f = w - 87\n\
\ | w >= C_A && w <= C_F = w - 55\n\
\ | otherwise = 255\n\
\ where w = fromIntegral $ B.unsafeIndex s n\n\
\ a = hex 0; b = hex 1; c = hex 2; d = hex 3\n\
\ if (a .|. b .|. c .|. d) /= 255\n\
\ then return $! d .|. (c `shiftL` 4) .|. (b `shiftL` 8) .|. (a `shiftL` 12)\n\
\ else fail \"invalid hex escape\"\n"
==>
["hexQuad"]
-- Semicolon within instance does not produce toplevel tags
, "instance Path T.Text where readPath = Just; pathRep _ = typeRep (Proxy :: Proxy Text)"
==>
[]
, "prop_bounds2 o1 w1 o2 w2 = let n1 = fromW8 w1 ; n2 = fromW8 w2 ; bs = ((o1, o2), (o1 + n1, o2 + n2)) in bs == bounds (listArray bs (take ((n1 + 1) * (n2 + 1)) (cycle [False, True, True])))"
==>
["prop_bounds2"]
, "string :: String -> ReadP r String\n\
\-- ^ Parses and returns the specified string.\n\
\string this = do s <- look; scan this s\n\
\ where\n\
\ scan [] _ = do return this\n\
\ scan (x:xs) (y:ys) | x == y = do get >> scan xs ys\n\
\ scan _ _ = do pfail"
==>
["string"]
, "-- | Get every node of a tree, put it into a list.\n\
\climb :: Tree a -> [a]\n\
\climb x = case x of (Empty) -> [];(Branch a Empty b) -> a : climb b;\n\
\ (Branch a b Empty) -> a : climb b;\n\
\ (Branch a b d) -> a : climb b ++ climb d"
==>
["climb"]
, "addend hid a (NotM (App uid okh elr as)) = NotM $ App uid okh elr (f as)\n\
\ where f (NotM ALNil) = NotM $ ALCons hid a (NotM $ ALNil)\n\
\ f (NotM (ALCons hid a as)) = NotM $ ALCons hid a (f as)\n\
\ f _ = __IMPOSSIBLE__\n\
\addend _ _ _ = __IMPOSSIBLE__\n\
\copyarg _ = False"
==>
["addend", "copyarg"]
, "realWorldTc :: TyCon; \\\n\
\realWorldTc = mkTyCon3 \"ghc-prim\" \"GHC.Types\" \"RealWorld\"; \\\n\
\instance Typeable RealWorld where { typeOf _ = mkTyConApp realWorldTc [] }"
==>
["realWorldTc"]
, "(r `mkQ` br) a = _" ==> ["mkQ"]
, "_?_ = return unsafePerformIO" ==> ["?"]
, "(+) :: DebMap -> String -> DebianVersion\n\
\m + k = maybe (error (\"No version number for \" ++ show k ++ \" in \" ++ show (Map.map (maybe Nothing (Just . prettyDebianVersion)) m))) id (Map.findWithDefault Nothing k m)"
==>
["+"]
, "(!) :: DebMap -> String -> DebianVersion\n\
\_ ! k = maybe (error (\"No version number for \" ++ show k ++ \" in \" ++ show (Map.map (maybe Nothing (Just . prettyDebianVersion)) m))) id (Map.findWithDefault Nothing k m)"
==>
["!"]
, "(.) :: DebMap -> String -> DebianVersion\n\
\m . k = maybe (error (\"No version number for \" ++ show k ++ \" in \" ++ show (Map.map (maybe Nothing (Just . prettyDebianVersion)) m))) id (Map.findWithDefault Nothing k m)"
==>
["."]
, "(.) :: DebMap -> String -> DebianVersion\n\
\m . k x = maybe (error (\"No version number for \" ++ show k ++ \" in \" ++ show (Map.map (maybe Nothing (Just . prettyDebianVersion)) m))) id (Map.findWithDefault Nothing k m)"
==>
["."]
, "{- 123___ -}import Data.Char;main=putStr$do{c<-\"/1 AA A A;9+ )11929 )1191A 2C9A \";e\n\
\{- | -} .(`divMod`8).(+(-32)).ord$c};f(0,0)=\"\\n\";f(m,n)=m?\" \"++n?\"_/\"\n\
\{- | -}n?x=do{[1..n];x} --- obfuscated\n\
\{-\\_/ on Fairbairn, with apologies to Chris Brown. Above is / Haskell 98 -}"
==>
["?", "f", "main"]
, "{- 456___ -}import Data.Char;main=putStr$do{c<-\"/1 AA A A;9+ )11929 )1191A 2C9A \";e\n\
\ {- {- | -} -} {- {- || -} -}{- {- || -} -}{- {- || -} -} {--}.(`divMod`8).(+(-32)).ord$c};f(0,0)=\"\\n\";f(m,n)=m?\" \"++n?\"_/\"\n\
\{- {- | -} -}n?x=do{[1..n];x} --- obfuscated\n\
\{-\\_/ on Fairbairn, with apologies to Chris Brown. Above is / Haskell 98 -}"
==>
["?", "f", "main"]
, "showComplexFloat :: Double -> Double -> String\n\
\showComplexFloat x 0.0 = showFFloat Nothing x \"\"\n\
\showComplexFloat 0.0 y = showFFloat Nothing y \"i\"\n\
\showComplexFloat x y = (showFFloat Nothing x \"\") ++ (if y > 0 then \"+\" else \"\") ++ (showFFloat Nothing y \"i\")"
==>
["showComplexFloat"]
, "createAlert :<|>\n\
\ getAlert :<|>\n\
\ deleteAlert :<|>\n\
\ setAlertStatus :<|>\n\
\ tagAlert :<|>\n\
\ untagAlert :<|>\n\
\ updateAlertAttributes = client (Proxy :: Proxy AlertApi)"
==>
["createAlert"]
, "_g :: X -> Y" ==> ["_g"]
, "(f . g) x = f (g x)" ==> ["."]
, "(#) :: TransArray c => c -> (b -> IO r) -> Trans c b -> IO r\n\
\a # b = apply a b\n\
\{-# INLINE (#) #-}\n\
\\n"
==>
["#"]
, "escape :: FilePath -> FilePath\n\
\escape s = \"\\\"\" ++ concatMap esc s ++ \"\\\"\"\n\
\ where\n\
\ esc c | c `elem` ['\\\\', '\"'] = '\\\\' : [c]\n\
\ | isAscii c && isPrint c = [c]\n\
\ | otherwise = \"\\\\x\" ++ showHex (fromEnum c) \"\\\\ \"\n\
\\n\
\------------------------------------------------------------------------\n\
\-- Compiling Emacs Lisp files\n\
\\n\
\-- | The Agda mode's Emacs Lisp files, given in the order in which\n\
\-- they should be compiled.\n\
\\n\
\emacsLispFiles :: [FilePath]\n\
\emacsLispFiles =\n\
\ [ \"agda2-abbrevs.el\"\n\
\ , \"annotation.el\"\n\
\ , \"agda2-queue.el\"\n\
\ , \"eri.el\"\n\
\ , \"agda2.el\"\n\
\ , \"agda-input.el\"\n\
\ , \"agda2-highlight.el\"\n\
\ , \"agda2-mode.el\"\n\
\ ]\n"
==>
["emacsLispFiles", "escape"]
, "happyError = \tks i -> error (\n\
\\t\"Parse error in line \" ++ show (i::Int) ++ \"\\n\")\n"
==>
["happyError"]
, "> happyError = \tks i -> error (\n\
\>\t\"Parse error in line \" ++ show (i::Int) ++ \"\\n\")\n"
|=>
["happyError"]
, "module UnindentedImportList(\n\
\foo,\n\
\(++),\n\
\bar\
\,\n\
\quux \n\
\)\n\
\where\n\
\\n\
\import Test\n\
\\n\
\baz :: a -> a\n\
\baz x = x\n\
\"
==>
["UnindentedImportList", "baz"]
, "\n\
\\n\
\#define FOO\n\
\\n\
\\n\
\ module UnindentedImportList(\n\
\ foo,\n\
\ (++),\n\
\ bar\
\ ,\n\
\ quux \n\
\ )\n\
\ where\n\
\\n\
\ import Test\n\
\\n\
\ baz :: a -> a\n\
\ baz x = x\n\
\"
==>
["FOO", "UnindentedImportList", "baz"]
, "\n\
\{-# LANGAUGE TemplateHaskell #-}\n\
\module Example where\n\
\\n\
\import Local.TH\n\
\concat <$> sequence [thFunc1, thFunc2]\n\
\\n\
\foo :: a -> a\n\
\foo x = x\n"
==>
["Example", "foo"]
, "\n\
\{-# LANGAUGE TemplateHaskell #-}\n\
\module Example where\n\
\\n\
\import Local.TH\n\
\concat <$> sequence [thFunc1, thFunc2]\n\
\\n"
==>
["Example"]
, toplevelFunctionsWithoutSignatures
]
where
(==>) = testTagNames filename
(|=>) = testTagNames literateFilename
toplevelFunctionsWithoutSignatures =
testGroup "toplevel functions without signatures"
[ "$(return . map sumDeclaration $ [0..15])" ==> []
, "$( fmap (reverse . concat) . traverse prismsForSingleType $ [1..15] )" ==> []
, "T.makeInstances [2..6]\nx" ==> []
, "infix 5 |+|" ==> []
, "infixl 5 |+|" ==> []
, "infixr 5 |+|" ==> []
, "f = g" ==> ["f"]
-- Relies on RepeatableTag.
, "f :: a -> b -> a\n\
\f x y = x"
==>
["f"]
, "f x y = x" ==> ["f"]
, "f (x :+: y) z = x" ==> ["f"]
, "(x :+: y) `f` z = x" ==> ["f"]
, "(x :+: y) *: z = x" ==> ["*:"]
, "((:+:) x y) *: z = x" ==> ["*:"]
, "(*:) (x :+: y) z = x" ==> ["*:"]
, "(*:) ((:+:) x y) z = x" ==> ["*:"]
, strictMatchTests
, lazyMatchTests
, atPatternsTests
, "f x Nothing = x\n\
\f x (Just y) = y"
==>
["f"]
, "x `f` Nothing = x\n\
\x `f` (Just y) = y"
==>
["f"]
, "f x y = g x\n\
\ where\n\
\ g _ = y"
==>
["f"]
, "x `f` y = x" ==> ["f"]
, "(|+|) x y = x" ==> ["|+|"]
, "x |+| y = x" ==> ["|+|"]
, "(!) x y = x" ==> ["!"]
, "--- my comment" ==> []
, "foo :: Rec -> Bar\n\
\foo Rec{..} = Bar (recField + 1)"
==>
["foo"]
, "foo :: Rec -> Bar\n\
\foo Rec { bar = Baz {..}} = Bar (recField + 1)"
==>
["foo"]
-- Functions named "pattern"
, "pattern :: Int -> String -> [Int]" ==> ["pattern"]
, "pattern x () = x + x" ==> ["pattern"]
, "pattern, foo :: Int -> String -> [Int]" ==> ["foo", "pattern"]
, "foo, pattern :: Int -> String -> [Int]" ==> ["foo", "pattern"]
, "foo, pattern, bar :: Int -> String -> [Int]" ==> ["bar", "foo", "pattern"]
, "pattern x = x " ==> ["pattern"]
, "pattern x y = x + y" ==> ["pattern"]
, "x `pattern` y = x + y" ==> ["pattern"]
, "pattern x y z = x + y + z" ==> ["pattern"]
-- Arguments named "forall
, "f forall = forall + 1" ==> ["f"]
, "a # b = apply a b" ==> ["#"]
]
strictMatchTests = testGroup "strict match (!)"
[ "f !x y = x" ==> ["f"]
, "f x !y = x" ==> ["f"]
, "f !x !y = x" ==> ["f"]
, "f ! x y = x" ==> ["f"]
-- this one is a bit controversial but it seems to be the way ghc
-- parses it
, "f ! x = x" ==> ["f"]
, "(*:) !(x :+: y) z = x" ==> ["*:"]
, "(*:) !(!x :+: !y) !z = x" ==> ["*:"]
, "(*:) !((:+:) x y) z = x" ==> ["*:"]
, "(*:) !((:+:) !x !y) !z = x" ==> ["*:"]
, "(!) :: a -> b -> a\n\
\(!) x y = x"
==>
["!"]
-- this is a degenerate case since even ghc treats ! here as
-- a BangPatterns instead of operator
, "x ! y = x" ==> ["x"]
]
lazyMatchTests = testGroup "lazy match (~)"
[ "f ~x y = x" ==> ["f"]
, "f x ~y = x" ==> ["f"]
, "f ~x ~y = x" ==> ["f"]
, "f ~ x y = x" ==> ["f"]
-- this one is a bit controversial but it seems to be the way ghc
-- parses it
, "f ~ x = x" ==> ["f"]
, "(*:) ~(x :+: y) z = x" ==> ["*:"]
, "(*:) ~(~x :+: ~y) ~z = x" ==> ["*:"]
, "(*:) ~((:+:) x y) z = x" ==> ["*:"]
, "(*:) ~((:+:) ~x ~y) ~z = x" ==> ["*:"]
, "(~) :: a -> b -> a\n\
\(~) x y = x"
==>
["~"]
-- this is a degenerate case since even ghc treats ~ here as
-- a BangPatterns instead of operator
, "x ~ y = x" ==> ["x"]
]
atPatternsTests = testGroup "at patterns (@)"
[ "f z@x y = z" ==> ["f"]
, "f x z'@y = z'" ==> ["f"]
, "f z@x z'@y = z" ==> ["f"]
, "f z@(Foo _) z'@y = z" ==> ["f"]
, "f z@(Foo _) z'@(Bar _) = z" ==> ["f"]
, "f z @ x y = z" ==> ["f"]
, "f z @ (x : xs) = z: [x: xs]" ==> ["f"]
, "f z @ (x : zs @ xs) = z: [x: zs]" ==> ["f"]
, "f z @ (zz @x : zs @ xs) = z: [zz: zs]" ==> ["f"]
, "(*:) zzz@(x :+: y) z = x" ==> ["*:"]
, "(*:) zzz@(zx@x :+: zy@y) zz@z = x" ==> ["*:"]
, "(*:) zzz@((:+:) x y) z = x" ==> ["*:"]
, "(*:) zzz@((:+:) zs@x zs@y) zz@z = x" ==> ["*:"]
, "f z@(!x) ~y = x" ==> ["f"]
]
testClass :: TestTree
testClass = testGroup "class"
[ "class (X x) => C a b where\n\tm :: a->b\n\tn :: c\n" ==>
["C", "m", "n"]
, "class (X x) ⇒ C a b where\n\tm ∷ a→b\n\tn ∷ c\n" ==>
["C", "m", "n"]
, "class (X x) => C a b | a -> b where\n\tm :: a->b\n\tn :: c\n" ==>
["C", "m", "n"]
, "class (X x) ⇒ C a b | a → b where\n\tm ∷ a→b\n\tn ∷ c\n" ==>
["C", "m", "n"]
, "class A a where f :: X\n" ==>
["A", "f"]
-- indented inside where
, "class X where\n\ta, (+) :: X\n" ==>
["+", "X", "a"]
, "class X where\n\ta :: X\n\tb, c :: Y" ==>
["X", "a", "b", "c"]
, "class X\n\twhere\n\ta :: X\n\tb, c :: Y" ==>
["X", "a", "b", "c"]
, "class X\n\twhere\n\ta ::\n\t\tX\n\tb :: Y" ==>
["X", "a", "b"]
, "class a :<: b where\n f :: a -> b" ==>
[":<:", "f"]
, "class (:<:) a b where\n f :: a -> b" ==>
[":<:", "f"]
, "class Eq a => a :<: b where\n f :: a -> b" ==>
[":<:", "f"]
, "class a ~ 'Foo => a :<: b where\n f :: a -> b" ==>
[":<:", "f"]
, "class 'Foo ~ a => a :<: b where\n f :: a -> b" ==>
[":<:", "f"]
, "class (Eq a) => a :<: b where\n f :: a -> b" ==>
[":<:", "f"]
, "class (a ~ 'Foo) => a :<: b where\n f :: a -> b" ==>
[":<:", "f"]
, "class ('Foo ~ a) => a :<: b where\n f :: a -> b" ==>
[":<:", "f"]
, "class a :<<<: b => a :<: b where\n f :: a -> b" ==>
[":<:", "f"]
, "class (a :<<<: b) => a :<: b where\n f :: a -> b" ==> [":<:", "f"]
, "class (a :<<<: b) ⇒ a :<: b where\n f ∷ a → b" ==> [":<:", "f"]
, "class (Eq a, Ord b) => a :<: b where\n f :: a -> b" ==> [":<:", "f"]
, "class (Eq a, Ord b) => (a :: (* -> *) -> *) :<: b where\n f :: a -> b"
==>
[":<:", "f"]
-- this is bizzarre
, "class (Eq (a), Ord (f a [a])) => f `Z` a" ==> ["Z"]
, "class A f where\n data F f :: *\n g :: a -> f a\n h :: f a -> a"
==>
["A", "F", "g", "h"]
, "class A f where\n data F f :: *\n mkF :: f -> F f\n getF :: F f -> f"
==>
["A", "F", "getF", "mkF"]
, "class A f where\n\
\ data F f :: * -- foo\n\
\ -- bar\n\
\ -- baz\n\
\ mkF :: f -> F f\n\
\ getF :: F f -> f"
==>
["A", "F", "getF", "mkF"]
-- Not confused by a class context on a method.
, "class X a where\n\tfoo :: Eq a => a -> a\n" ==> ["X", "foo"]
, "class Category cat where\n\
\ -- | the identity morphism\n\
\ id :: cat a a\n\
\ \n\
\ -- | morphism composition\n\
\ (.) :: cat b c -> cat a b -> cat a c" ==> [".", "Category", "id"]
, "class Match a b where\n\
\ pattern :: Pattern a b\n" ==> ["Match", "pattern"]
, "class a ~~ b => (a :: k) ~ (b :: k) | a -> b, b -> a"
==>
["~"]
, "class a ~~ b => (a :: k) ! (b :: k) | a -> b, b -> a"
==>
["!"]
, "class A f where {\n\
\ data F f :: * ; -- foo\n\
\ -- bar\n\
\ -- baz\n\
\ mkF :: f -> F f ; getF :: F f -> f ;\n\
\} ;"
==>
["A", "F", "getF", "mkF"]
]
where
(==>) = testTagNames filename
testInstance :: TestTree
testInstance = testGroup "instance"
[ "instance Foo Quux where\n\
\ data Bar Quux a = QBar { frob :: a }\n\
\ | QBaz { fizz :: String }\n\
\ deriving (Show)"
==>
["QBar", "QBaz", "fizz", "frob"]
, "instance Foo Quux where\n\
\ data Bar Quux a = QBar a | QBaz String deriving (Show)"
==>
["QBar", "QBaz"]
, "instance Foo Quux where\n\
\ data Bar Quux a = QBar { frob :: a }\n\
\ | QBaz { fizz :: String }\n\
\ deriving (Show)\n\
\ data IMRuunningOutOfNamesHere Quux = Whatever"
==>
["QBar", "QBaz", "Whatever", "fizz", "frob"]
-- in this test foo function should not affect tags found
, "instance Foo Quux where\n\
\ data Bar Quux a = QBar { frob :: a }\n\
\ | QBaz { fizz :: String }\n\
\ deriving (Show)\n\
\\n\
\ foo _ = QBaz \"hey there\""
==>
["QBar", "QBaz", "fizz", "frob"]
, "instance Foo Int where foo _ = 1"
==>
[]
, "instance Foo Quux where\n\
\ newtype Bar Quux a = QBar a \n\
\ deriving (Show)\n\
\\n\
\ foo _ = QBaz \"hey there\""
==>
["QBar"]
, "instance Foo Quux where\n\
\ newtype Bar Quux a = QBar { frob :: a }"
==>
["QBar", "frob"]
, "instance (Monoid w, MBC b m) => MBC b (JournalT w m) where\n\
\ newtype StM (JournalT w m) a =\n\
\ StMJournal { unStMJournal :: ComposeSt (JournalT w) m a }\n\
\ liftBaseWith = defaultLiftBaseWith StMJournal\n\
\ restoreM = defaultRestoreM unStMJournal\n\
\ {-# INLINE liftBaseWith #-}\n\
\ {-# INLINE restoreM #-}\n\
\"
==>
["StMJournal", "unStMJournal"]
]
where
(==>) = testTagNames filename
testLiterate :: TestTree
testLiterate = testGroup "Literate"
[ "> class (X x) => C a b where\n\
\>\tm :: a->b\n\
\>\tn :: c\n"
==>
["C", "m", "n"]
, "Test\n\
\\\begin{code}\n\
\class (X x) => C a b where\n\
\\tm :: a->b\n\
\\tn :: c\n\
\\\end{code}"
==>
["C", "m", "n"]
, "> precalcClosure0 :: Grammar -> Name -> RuleList\n\
\> precalcClosure0 g = \n\
\>\t\\n -> case lookup n info' of\n\
\>\t\tNothing -> []\n\
\>\t\tJust c -> c\n\
\> where"
==>
["precalcClosure0"]
, "New Resolutions by Jean-Luc Ponty, Scott O'Neil, and John Garvin\r\n\
\\r\n\
\> module Euterpea.Examples.NewResolutions where\r\n\
\> import Euterpea\r\n\
\\r\n\
\> nrContext = Context {cTime = 0,\r\n\
\> cPlayer = fancyPlayer,\r\n\
\> cInst = Marimba,\r\n\
\> cDur = 1.0,\r\n\
\> cPch = 0,\r\n\
\> cKey = (C,Major),\r\n\
\> cVol = 100}\r\n\
\>\r\n\
\> tNewRes m = makeMidi (m, nrContext, defUpm)\r\n\
\\r\n\
\> root, minThird, fifth, octave :: Pitch -> Dur -> Music Pitch\r\n\
\> root p dur = Prim $ Note dur p\r\n\
\> minThird p dur = Prim $ Note dur (trans 3 p)\r\n\
\> majThird p dur = Prim $ Note dur (trans 4 p)\r\n\
\> fifth p dur = Prim $ Note dur (trans 7 p)\r\n\
\> majSixth p dur = Prim $ Note dur (trans 9 p)\r\n\
\> minSeventh p dur = Prim $ Note dur (trans 10 p)\r\n\
\> octave p dur = Prim $ Note dur (trans 12 p)\r\n\
\> oMinThird p dur = Prim $ Note dur (trans 15 p)\r\n\
\> oFifth p dur = Prim $ Note dur (trans 19 p)"
==>
[ "NewResolutions"
, "fifth"
, "majSixth"
, "majThird"
, "minSeventh"
, "minThird"
, "nrContext"
, "oFifth"
, "oMinThird"
, "octave"
, "root"
, "tNewRes"
]
]
where
(==>) = test f
f = List.sort . map untag . fst . Tag.process "fn.lhs" False
testPatterns :: TestTree
testPatterns = testGroup "patterns"
[ "pattern Arrow a b = ConsT \"->\" [a, b]"
==>
["Arrow"]
, "pattern Arrow a b = ConsT \"->\" [a, b]\n\
\pattern Pair a b = [a, b]"
==>
["Arrow", "Pair"]
, "pattern Sub a b = Op '-' [a, b]\n\
\pattern Pair a b = [a, b]"
==>
["Pair", "Sub"]
, "pattern (:++) x y = [x, y]"
==>
[":++"]
, "pattern x :** y = [x, y]"
==>
[":**"]
, "pattern Nil :: Vec2 a\n\
\pattern Nil = Vec2 []\n"
==>
["Nil", "Nil"]
, "pattern (:>) x xs <- ((\\ys -> (head $ unvec2 ys,Vec2 . tail $ unvec2 ys)) -> (x,xs))\n\
\where\n\
\ (:>) x xs = Vec2 (x:unvec2 xs)"
==>
[":>"]
, "\n\
\data Foo = Foo_ { _foo :: !(Last String) } deriving (Eq)\n\
\n\
\pattern Bar :: A -> B\n\
\pattern Bar { foo } = Foo_ (Last foo)\n\
\{-# COMPLETE Bar #-}\n"
==>
["Bar", "Foo", "Foo_", "_foo", "foo"]
, "\n\
\data Foo = Foo_ { _foo :: !(Last String), _bar :: !(Last String) } deriving (Eq)\n\
\n\
\pattern Bar :: A -> B\n\
\pattern Bar { foo, bar } = Foo_ (Last foo) (Last bar)\n\
\{-# COMPLETE Bar #-}\n"
==>
["Bar", "Foo", "Foo_", "_bar", "_foo", "bar", "foo"]
]
where
(==>) = testTagNames filename
testFFI :: TestTree
testFFI = testGroup "ffi"
[ "foreign import ccall foo :: Double -> IO Double" ==> ["foo"]
, "foreign import unsafe java foo :: Double -> IO Double" ==> ["foo"]
, "foreign import safe stdcall foo :: Double -> IO Double" ==> ["foo"]
, "foreign import safe stdcall pattern :: Double -> IO Double" ==> ["pattern"]
]
where
(==>) = testTagNames filename
testDefine :: TestTree
testDefine = testGroup "preprocessor defines"
[ "#define FOO 1" ==>
["FOO"]
, "#define FOO \n\
\ 1" ==>
["FOO"]
, "#define FOO \n\
\1" ==>
["FOO"]
, "#define FOO(x) (x + x)" ==>
["FOO"]
, "#if X\n\
\#define FOO 1\n\
\#else\n\
\#define FOO 2\n\
\#endif" ==>
["FOO"]
, "#if X\n\
\\n\
\#define FOO 1\n\
\\n\
\\n\
\#else\n\
\\n\
\\n\
\#define FOO 2\n\
\\n\
\#endif" ==>
["FOO"]
, "#define FOO(x) (x + x)" ==>
["FOO"]
, "#let BAR x y z = \"x + y + z\"" ==>
["BAR"]
]
where
(==>) = testTagNames filename
testHSC2HS :: TestTree
testHSC2HS = testGroup "hsc2hs"
[ "#{enum ControlOp, ControlOp\n\
\ , controlOpAdd = EPOLL_CTL_ADD\n\
\ , controlOpModify = EPOLL_CTL_MOD\n\
\ , controlOpDelete = EPOLL_CTL_DEL\n\
\ }"
==>
[ "controlOpAdd", "controlOpDelete", "controlOpModify"
]
, "#{\n\
\enum ControlOp, ControlOp\n\
\ , controlOpAdd = EPOLL_CTL_ADD\n\
\ , controlOpModify = EPOLL_CTL_MOD\n\
\ , controlOpDelete = EPOLL_CTL_DEL\n\
\ }"
==>
[ "controlOpAdd", "controlOpDelete", "controlOpModify"
]
, "#{enum Test1, Test2 \n\
\ , foo\n\
\ , foo_bar\n\
\ , BAR_BAZ\n\
\ , BAR_BAZquux\n\
\ }"
==>
[ "barBaz", "barBazquux", "foo", "fooBar"
]
, "#enum Mask, UserSpace, IN_ACCESS, IN_MODIFY, IN_ATTRIB, IN_CLOSE_WRITE\n\
\#enum Mask, UserSpace, IN_CLOSE_NOWRITE, IN_OPEN, IN_MOVED_FROM, IN_MOVED_TO\n\
\#enum Mask, UserSpace, IN_CREATE, IN_DELETE, IN_DELETE_SELF, IN_MOVE_SELF\n"
==>
[ "inAccess", "inAttrib", "inCloseNowrite", "inCloseWrite"
, "inCreate", "inDelete", "inDeleteSelf", "inModify"
, "inMoveSelf", "inMovedFrom", "inMovedTo", "inOpen"
]
, "#enum ExecOption,ExecOption, \\\n\
\ execAnchored = PCRE_ANCHORED, \\\n\
\ execNotBOL = PCRE_NOTBOL, \\\n\
\ execNotEOL = PCRE_NOTEOL, \\\n\
\ execNotEmpty = PCRE_NOTEMPTY, \\\n\
\ execNoUTF8Check = PCRE_NO_UTF8_CHECK, \\\n\
\ execPartial = PCRE_PARTIAL"
==>
[ "execAnchored"
, "execNoUTF8Check"
, "execNotBOL"
, "execNotEOL"
, "execNotEmpty"
, "execPartial"
]
, "#enum ReturnCode,ReturnCode, \\\n\
\ retNoMatch = PCRE_ERROR_NOMATCH, \\\n\
\ retNull = PCRE_ERROR_NULL, \\\n\
\ retBadOption = PCRE_ERROR_BADOPTION, \\\n\
\ retBadMagic = PCRE_ERROR_BADMAGIC, \\\n\
\ retUnknownNode = PCRE_ERROR_UNKNOWN_NODE, \\\n\
\ retNoMemory = PCRE_ERROR_NOMEMORY, \\\n\
\ retNoSubstring = PCRE_ERROR_NOSUBSTRING"
==>
[ "retBadMagic"
, "retBadOption"
, "retNoMatch"
, "retNoMemory"
, "retNoSubstring"
, "retNull"
, "retUnknownNode"
]
, "#{\n\
\define hsc_patsyn(l, typ, cons, hprefix, recmac) { \\\n\
\ struct { const char *s; unsigned n; } *p, list[] = { LLVM_HS_FOR_EACH_ ## l(recmac) }; \\\n\
\ for(p = list; p < list + sizeof(list)/sizeof(list[0]); ++p) { \\\n\
\ hsc_printf(\"pattern \" #hprefix \"%s :: \" #typ \"\\n\", p->s); \\\n\
\ hsc_printf(\"pattern \" #hprefix \"%s = \" #cons \" %u\\n\", p->s, p->n); \\\n\
\ }\\\n\
\}\\\n\
\}\\\n\
\\n\
\foo x = x"
==>
[ "foo"
]
]
where
(==>) = testTagNames "Test.hsc"
testAlex :: TestTree
testAlex = testGroup "alex"
[ testGroup "vanilla"
[ "{\n\
\module AlexTest where\n\
\\n\
\import FooBar\n\
\\n\
\foobar :: Int -> Int\n\
\foobar = (+ 1)\n\
\\n\
\}\n\
\\n\
\\n\
\-- Can skip whitespace everywhere since it does not affect meaning in any\n\
\-- state.\n\
\<0, comment, qq, literate> $ws+ ;\n\
\\n\
\-- Literate Haskell support. 'literate' code handles all text except actual\n\
\-- Haskell program text. It aims to strip all non-Haskell text.\n\
\<literate> {\n\
\$nl \">\" $ws*\n\
\ { \\_ len -> (Newline $! len - 2) <$ startLiterateBird }\n\
\$nl \"\\begin{code}\" @nl $space*\n\
\ { \\input len -> (Newline $! countInputSpace input len) <$ startLiterateLatex }\n\
\$nl ;\n\
\.\n\
\ { \\_ _ -> dropUntilNL' }\n\
\}\n\
\\n\
\-- Vanilla tokens\n\
\<0> {\n\
\\n\
\\"#\" @cpp_opt_ws (\"{\" (@cpp_ws | @nl)*)? \"enum\"\n\
\ { \\_ _ -> pure HSCEnum }\n\
\\"#\" @cpp_opt_ws\n\
\ ( ($ascident # [e]) $ascident*\n\
\ | $ascident ($ascident # [n]) $ascident*\n\
\ | $ascident $ascident ($ascident # [u]) $ascident*\n\
\ | $ascident $ascident $ascident ($ascident # [m]) $ascident*\n\
\ | $ascident $ascident $ascident $ascident $ascident+\n\
\ )\n\
\ { \\_ _ -> pure HSCDirective }\n\
\\"#\" @cpp_opt_ws \"{\" (@cpp_ws | @nl)*\n\
\ ( ($ascident # [e]) $ascident*\n\
\ | $ascident ($ascident # [n]) $ascident*\n\
\ | $ascident $ascident ($ascident # [u]) $ascident*\n\
\ | $ascident $ascident $ascident ($ascident # [m]) $ascident*\n\
\ | $ascident $ascident $ascident $ascident $ascident+\n\
\ )\n\
\ { \\_ _ -> pure HSCDirectiveBraced }\n\
\}\n\
\\n\
\\n\
\\n\
\\n\
\{\n\
\foo :: Int -> Int\n\
\foo x = x + x\n\
\}\n\
\\n"
==>
["AlexTest", "foo", "foobar"]
]
, testGroup "literate"
[ "Very useful description 1\n\
\Very useful description 2\n\
\> {\n\
\> module AlexTest where\n\
\>\n\
\> import FooBar\n\
\>\n\
\> foobar :: Int -> Int\n\
\> foobar = (+ 1)\n\
\>\n\
\> }\n\
\\n\
\Useful description 1\n\
\Useful description 2\n\
\Useful description 3\n\
\Useful description 4\n\
\\n\
\> -- Can skip whitespace everywhere since it does not affect meaning in any\n\
\> -- state.\n\
\> <0, comment, qq, literate> $ws+ ;\n\
\>\n\
\> -- Literate Haskell support. 'literate' code handles all text except actual\n\
\> -- Haskell program text. It aims to strip all non-Haskell text.\n\
\> <literate> {\n\
\> $nl \">\" $ws*\n\
\> { \\_ len -> (Newline $! len - 2) <$ startLiterateBird }\n\
\> $nl \"\\begin{code}\" @nl $space*\n\
\> { \\input len -> (Newline $! countInputSpace input len) <$ startLiterateLatex }\n\
\> $nl ;\n\
\> .\n\
\> { \\_ _ -> dropUntilNL' }\n\
\> }\n\
\>\n\
\Useful description 1\n\
\Useful description 2\n\
\Useful description 3\n\
\Useful description 4\n\
\> -- Vanilla tokens\n\
\> <0> {\n\
\>\n\
\> \"#\" @cpp_opt_ws (\"{\" (@cpp_ws | @nl)*)? \"enum\"\n\
\> { \\_ _ -> pure HSCEnum }\n\
\> \"#\" @cpp_opt_ws\n\
\> ( ($ascident # [e]) $ascident*\n\
\> | $ascident ($ascident # [n]) $ascident*\n\
\> | $ascident $ascident ($ascident # [u]) $ascident*\n\
\> | $ascident $ascident $ascident ($ascident # [m]) $ascident*\n\
\> | $ascident $ascident $ascident $ascident $ascident+\n\
\> )\n\
\> { \\_ _ -> pure HSCDirective }\n\
\> \"#\" @cpp_opt_ws \"{\" (@cpp_ws | @nl)*\n\
\> ( ($ascident # [e]) $ascident*\n\
\> | $ascident ($ascident # [n]) $ascident*\n\
\> | $ascident $ascident ($ascident # [u]) $ascident*\n\
\> | $ascident $ascident $ascident ($ascident # [m]) $ascident*\n\
\> | $ascident $ascident $ascident $ascident $ascident+\n\
\> )\n\
\> { \\_ _ -> pure HSCDirectiveBraced }\n\
\> }\n\
\>\n\
\>\n\
\> {\n\
\> foo :: Int -> Int\n\
\> foo x = x + x\n\
\> }\n\
\>\n\
\\n"
|=>
["AlexTest", "foo", "foobar"]
, "Very useful description 1\n\
\Very useful description 2\n\
\\\begin{code}\n\
\{\n\
\module AlexTest where\n\
\\n\
\import FooBar\n\
\\n\
\foobar :: Int -> Int\n\
\foobar = (+ 1)\n\
\\n\
\}\n\
\\\end{code}\n\
\\n\
\Useful description 1\n\
\Useful description 2\n\
\Useful description 3\n\
\Useful description 4\n\
\\n\
\\\begin{code}\n\
\-- Can skip whitespace everywhere since it does not affect meaning in any\n\
\-- state.\n\
\<0, comment, qq, literate> $ws+ ;\n\
\\n\
\-- Literate Haskell support. 'literate' code handles all text except actual\n\
\-- Haskell program text. It aims to strip all non-Haskell text.\n\
\<literate> {\n\
\$nl \">\" $ws*\n\
\ { \\_ len -> (Newline $! len - 2) <$ startLiterateBird }\n\
\$nl \"\\begin{code}\" @nl $space*\n\
\ { \\input len -> (Newline $! countInputSpace input len) <$ startLiterateLatex }\n\
\$nl ;\n\
\.\n\
\ { \\_ _ -> dropUntilNL' }\n\
\}\n\
\\n\
\\\end{code}\n\
\\n\
\Useful description 1\n\
\Useful description 2\n\
\Useful description 3\n\
\Useful description 4\n\
\\n\
\\\begin{code}\n\
\-- Vanilla tokens\n\
\<0> {\n\
\\n\
\\"#\" @cpp_opt_ws (\"{\" (@cpp_ws | @nl)*)? \"enum\"\n\
\ { \\_ _ -> pure HSCEnum }\n\
\\"#\" @cpp_opt_ws\n\
\ ( ($ascident # [e]) $ascident*\n\
\ | $ascident ($ascident # [n]) $ascident*\n\
\ | $ascident $ascident ($ascident # [u]) $ascident*\n\
\ | $ascident $ascident $ascident ($ascident # [m]) $ascident*\n\
\ | $ascident $ascident $ascident $ascident $ascident+\n\
\ )\n\
\ { \\_ _ -> pure HSCDirective }\n\
\\"#\" @cpp_opt_ws \"{\" (@cpp_ws | @nl)*\n\
\ ( ($ascident # [e]) $ascident*\n\
\ | $ascident ($ascident # [n]) $ascident*\n\
\ | $ascident $ascident ($ascident # [u]) $ascident*\n\
\ | $ascident $ascident $ascident ($ascident # [m]) $ascident*\n\
\ | $ascident $ascident $ascident $ascident $ascident+\n\
\ )\n\
\ { \\_ _ -> pure HSCDirectiveBraced }\n\
\}\n\
\\n\
\\n\
\{\n\
\foo :: Int -> Int\n\
\foo x = x + x\n\
\}\n\
\\n\
\\\end{code}\n\
\\n"
|=>
["AlexTest", "foo", "foobar"]
]
]
where
(==>) = testTagNames "Test.x"
(|=>) = testTagNames "Test.lx"
testHappy :: TestTree
testHappy = testGroup "happy"
[ testGroup "vanilla"
[ "{\n\
\{-# OPTIONS_GHC -w #-}\n\
\module AttrGrammarParser (agParser) where\n\
\import ParseMonad\n\
\import AttrGrammar\n\
\}\n\
\\n\
\%name agParser\n\
\%tokentype { AgToken }\n\
\%token\n\
\ \"{\" { AgTok_LBrace }\n\
\ \"}\" { AgTok_RBrace }\n\
\ \";\" { AgTok_Semicolon }\n\
\ '{' { AgTok_LBrace }\n\
\ '}' { AgTok_RBrace }\n\
\ '::' { AgTok_Semicolon }\n\
\ \"=\" { AgTok_Eq }\n\
\ where { AgTok_Where }\n\
\ selfRef { AgTok_SelfRef _ }\n\
\ subRef { AgTok_SubRef _ }\n\
\ rightRef { AgTok_RightmostRef _ }\n\
\ unknown { AgTok_Unknown _ }\n\
\\n\
\%monad { P }\n\
\%lexer { agLexer } { AgTok_EOF }\n\
\\n\
\%%\n\
\\n\
\agParser :: { [AgRule] }\n\
\ : rules { $1 }\n\
\\n\
\rules :: { [AgRule] }\n\
\ : rule '::' rules { $1 : $3 }\n\
\ | rule { $1 : [] }\n\
\ | { [] }\n\
\\n\
\rule :: { AgRule }\n\
\ : selfRef \"=\" code { SelfAssign (selfRefVal $1) $3 }\n\
\ | subRef \"=\" code { SubAssign (subRefVal $1) $3 }\n\
\ | rightRef \"=\" code { RightmostAssign (rightRefVal $1) $3 }\n\
\ | where code { Conditional $2 }\n\
\\n\
\code :: { [AgToken] }\n\
\ : '{' code0 '}' code { [$1] ++ $2 ++ [$3] ++ $4 }\n\
\ | \"=\" code { $1 : $2 }\n\
\ | selfRef code { $1 : $2 }\n\
\ | subRef code { $1 : $2 }\n\
\ | rightRef code { $1 : $2 }\n\
\ | unknown code { $1 : $2 }\n\
\ | { [] }\n\
\\n\
\code0 :: { [AgToken] }\n\
\ : \"{\" code0 \"}\" code0 { [$1] ++ $2 ++ [$3] ++ $4 }\n\
\ | \"=\" code0 { $1 : $2 }\n\
\ | '::' code0 { $1 : $2 }\n\
\ | selfRef code0 { $1 : $2 }\n\
\ | subRef code0 { $1 : $2 }\n\
\ | rightRef code { $1 : $2 }\n\
\ | unknown code0 { $1 : $2 }\n\
\ | { [] }\n\
\\n\
\{\n\
\happyError :: P a\n\
\happyError = fail (\"Parse error\\n\")\n\
\\n\
\test :: a -> a\n\
\test x = x\n\
\}\n\
\\n"
==>
["AttrGrammarParser", "happyError", "test"]
]
, testGroup "literate"
[ "This parser parses the contents of the attribute grammar\n\
\into a list of rules. A rule can either be an assignment\n\
\to an attribute of the LHS (synthesized attribute), and\n\
\assignment to an attribute of the RHS (an inherited attribute),\n\
\or a conditional statement.\n\
\\n\
\> {\n\
\> {-# OPTIONS_GHC -w #-}\n\
\> module AttrGrammarParser (agParser) where\n\
\> import ParseMonad\n\
\> import AttrGrammar\n\
\> }\n\
\\n\
\> %name agParser\n\
\> %tokentype { AgToken }\n\
\> %token\n\
\> \"{\" { AgTok_LBrace }\n\
\> \"}\" { AgTok_RBrace }\n\
\> \";\" { AgTok_Semicolon }\n\
\> \"=\" { AgTok_Eq }\n\
\> where { AgTok_Where }\n\
\> selfRef { AgTok_SelfRef _ }\n\
\> subRef { AgTok_SubRef _ }\n\
\> rightRef { AgTok_RightmostRef _ }\n\
\> unknown { AgTok_Unknown _ }\n\
\>\n\
\> %monad { P }\n\
\> %lexer { agLexer } { AgTok_EOF }\n\
\\n\
\> %%\n\
\\n\
\> agParser :: { [AgRule] }\n\
\> : rules { $1 }\n\
\\n\
\> rules :: { [AgRule] }\n\
\> : rule \";\" rules { $1 : $3 }\n\
\> | rule { $1 : [] }\n\
\> | { [] }\n\
\\n\
\> rule :: { AgRule }\n\
\> : selfRef \"=\" code { SelfAssign (selfRefVal $1) $3 }\n\
\> | subRef \"=\" code { SubAssign (subRefVal $1) $3 }\n\
\> | rightRef \"=\" code { RightmostAssign (rightRefVal $1) $3 }\n\
\> | where code { Conditional $2 }\n\
\\n\
\> code :: { [AgToken] }\n\
\> : \"{\" code0 \"}\" code { [$1] ++ $2 ++ [$3] ++ $4 }\n\
\> | \"=\" code { $1 : $2 }\n\
\> | selfRef code { $1 : $2 }\n\
\> | subRef code { $1 : $2 }\n\
\> | rightRef code { $1 : $2 }\n\
\> | unknown code { $1 : $2 }\n\
\> | { [] }\n\
\\n\
\> code0 :: { [AgToken] }\n\
\> : \"{\" code0 \"}\" code0 { [$1] ++ $2 ++ [$3] ++ $4 }\n\
\> | \"=\" code0 { $1 : $2 }\n\
\> | \";\" code0 { $1 : $2 }\n\
\> | selfRef code0 { $1 : $2 }\n\
\> | subRef code0 { $1 : $2 }\n\
\> | rightRef code { $1 : $2 }\n\
\> | unknown code0 { $1 : $2 }\n\
\> | { [] }\n\
\\n\
\> {\n\
\> happyError :: P a\n\
\> happyError = fail (\"Parse error\\n\")\n\
\>\n\
\> test :: a -> a\n\
\> test x = x\n\
\> }\n\
\\n"
|=>
["AttrGrammarParser", "happyError", "test"]
, "This parser parses the contents of the attribute grammar\n\
\into a list of rules. A rule can either be an assignment\n\
\to an attribute of the LHS (synthesized attribute), and\n\
\assignment to an attribute of the RHS (an inherited attribute),\n\
\or a conditional statement.\n\
\\n\
\\\begin{code}\n\
\\n\
\{\n\
\{-# OPTIONS_GHC -w #-}\n\
\module AttrGrammarParser (agParser) where\n\
\import ParseMonad\n\
\import AttrGrammar\n\
\}\n\
\\n\
\\\end{code}\n\
\\n\
\\\begin{code}\n\
\%name agParser\n\
\%tokentype { AgToken }\n\
\%token\n\
\ \"{\" { AgTok_LBrace }\n\
\ \"}\" { AgTok_RBrace }\n\
\ \";\" { AgTok_Semicolon }\n\
\ \"=\" { AgTok_Eq }\n\
\ where { AgTok_Where }\n\
\ selfRef { AgTok_SelfRef _ }\n\
\ subRef { AgTok_SubRef _ }\n\
\ rightRef { AgTok_RightmostRef _ }\n\
\ unknown { AgTok_Unknown _ }\n\
\\n\
\%monad { P }\n\
\%lexer { agLexer } { AgTok_EOF }\n\
\\\end{code}\n\
\\n\
\\\begin{code}\n\
\%%\n\
\\\end{code}\n\
\\n\
\\\begin{code}\n\
\agParser :: { [AgRule] }\n\
\ : rules { $1 }\n\
\\\end{code}\n\
\\n\
\\\begin{code}\n\
\rules :: { [AgRule] }\n\
\ : rule \";\" rules { $1 : $3 }\n\
\ | rule { $1 : [] }\n\
\ | { [] }\n\
\\\end{code}\n\
\\n\
\\\begin{code}\n\
\rule :: { AgRule }\n\
\ : selfRef \"=\" code { SelfAssign (selfRefVal $1) $3 }\n\
\ | subRef \"=\" code { SubAssign (subRefVal $1) $3 }\n\
\ | rightRef \"=\" code { RightmostAssign (rightRefVal $1) $3 }\n\
\ | where code { Conditional $2 }\n\
\\\end{code}\n\
\\n\
\\\begin{code}\n\
\code :: { [AgToken] }\n\
\ : \"{\" code0 \"}\" code { [$1] ++ $2 ++ [$3] ++ $4 }\n\
\ | \"=\" code { $1 : $2 }\n\
\ | selfRef code { $1 : $2 }\n\
\ | subRef code { $1 : $2 }\n\
\ | rightRef code { $1 : $2 }\n\
\ | unknown code { $1 : $2 }\n\
\ | { [] }\n\
\\\end{code}\n\
\\n\
\\\begin{code}\n\
\code0 :: { [AgToken] }\n\
\ : \"{\" code0 \"}\" code0 { [$1] ++ $2 ++ [$3] ++ $4 }\n\
\ | \"=\" code0 { $1 : $2 }\n\
\ | \";\" code0 { $1 : $2 }\n\
\ | selfRef code0 { $1 : $2 }\n\
\ | subRef code0 { $1 : $2 }\n\
\ | rightRef code { $1 : $2 }\n\
\ | unknown code0 { $1 : $2 }\n\
\ | { [] }\n\
\\\end{code}\n\
\\n\
\\\begin{code}\n\
\{\n\
\happyError :: P a\n\
\happyError = fail (\"Parse error\\n\")\n\
\\n\
\test :: a -> a\n\
\test x = x\n\
\}\n\
\\\end{code}\n\
\\n"
|=>
["AttrGrammarParser", "happyError", "test"]
]
]
where
(==>) = testTagNames "Test.y"
(|=>) = testTagNames "Test.ly"
test :: (Show a, ExtendedEq b, Show b) => (a -> b) -> a -> b -> TestTree
test f x expected =
HUnit.testCase (take 70 $ show x) $
HUnit.assertBool msg (actual === expected)
where
actual = f x
msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual
filename :: FilePath
filename = "fn.hs"
literateFilename :: FilePath
literateFilename = "fn.lhs"
testFullTagsWithPrefixes :: FilePath -> Text -> [Pos TagVal] -> TestTree
testFullTagsWithPrefixes fn = \source tags ->
test (first List.sort . Tag.process fn trackPrefixes . TE.encodeUtf8) source (tags, warnings)
where
warnings :: [String]
warnings = []
trackPrefixes :: Bool
trackPrefixes = True
testTagNames :: FilePath -> Text -> [String] -> TestTree
testTagNames fn source tags =
test process source (tags, warnings)
where
warnings :: [String]
warnings = []
process :: Text -> ([String], [String])
process
= first (List.sort . map untag)
. Tag.process fn trackPrefixes
. TE.encodeUtf8
trackPrefixes :: Bool
trackPrefixes = False
untag :: Pos TagVal -> String
untag (Pos _ (TagVal name _ _)) = T.unpack name
tokenize :: Text -> UnstrippedTokens
tokenize = tokenizeWith LitVanilla
tokenizeWith :: LitMode Void -> Text -> UnstrippedTokens
tokenizeWith mode =
either (error . T.unpack) UnstrippedTokens .
Lexer.tokenize filename mode trackPrefixes .
TE.encodeUtf8
where
trackPrefixes = False
extractTokens :: UnstrippedTokens -> [Text]
extractTokens = map tokenName . Tag.unstrippedTokensOf
where
tokenName token = case Tag.valOf token of
T name -> name
Newline n -> T.pack ("nl " ++ show n)
t -> T.pack $ show t