---------------------------------------------------------------------------- -- | -- 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 -> IO \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\ \ {\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\ \> {\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\ \ {\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