{-# LANGUAGE DeriveGeneric, FlexibleInstances, OverloadedStrings,
ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where
import qualified Language.Lua.Annotated.Lexer as L
import qualified Language.Lua.Annotated.Parser as AP
import qualified Language.Lua.Parser as P
import Language.Lua.PrettyPrinter
import Language.Lua.StringLiteral
import Language.Lua.Syntax
import qualified Language.Lua.Token as T
import Test.QuickCheck hiding (Args)
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import Control.Applicative
import Control.DeepSeq (deepseq, force)
import Control.Monad (forM_)
import qualified Data.ByteString.Lazy as B
import Data.Char (isSpace)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import GHC.Generics
import Prelude hiding (Ordering (..), exp)
import System.Directory (getDirectoryContents)
import System.FilePath
main :: IO ()
main = defaultMain tests
tests :: TestTree
tests = testGroup "Tests" [unitTests, propertyTests]
unitTests :: TestTree
unitTests = testGroup "Unit tests"
[stringTests, numberTests, regressions, lua531Tests, literalDecodingTests]
where
lua531Tests = parseFilesTest "Parsing Lua files from Lua 5.3.1 test suite" "lua-5.3.1-tests"
propertyTests :: TestTree
propertyTests = testGroup "Property tests" [{-genPrintParse-}]
parseExps :: String -> Maybe [Exp]
parseExps contents =
mapM (either (const Nothing) Just . AP.parseText P.exp . Text.pack)
(lines contents)
literalDecodingTests :: TestTree
literalDecodingTests = testGroup "Literal codec tests"
[ testCase "decoding"
(do assertEqual "C escapes wrong"
(Just "\a\b\f\n\r\t\v\\\"'")
$ interpretStringLiteral "\"\\a\\b\\f\\n\\r\\t\\v\\\\\\\"'\""
assertEqual "C escapes wrong"
(Just "\a \b \f \n \r \t \v \\ \" '")
$ interpretStringLiteral "\"\\a \\b \\f \\n \\r \\t \\v \\\\ \\\" '\""
assertEqual "ASCII characters wrong"
(Just "the quick brown fox jumps over the lazy dog")
$ interpretStringLiteral "'the quick brown fox jumps over the lazy dog'"
assertEqual "Test decimal escapes"
(Just "\0\1\2\3\4\60\127\255")
$ interpretStringLiteral "'\\0\\1\\2\\3\\4\\60\\127\\255'"
assertEqual "Test hexadecimal escapes"
(Just "\0\1\2\3\4\127\255")
$ interpretStringLiteral "\"\\x00\\x01\\x02\\x03\\x04\\x7f\\xff\""
assertEqual "Test UTF-8 encoding"
(Just "\230\177\137\229\173\151")
$ interpretStringLiteral "'汉字'"
assertEqual "Test unicode escape"
(Just "\0 \16 \230\177\137\229\173\151")
$ interpretStringLiteral "'\\u{0} \\u{10} \\u{6c49}\\u{5b57}'"
assertEqual "Test continued line"
(Just "hello\nworld")
$ interpretStringLiteral "\"hello\\\nworld\""
assertEqual "Test skipped whitespace"
(Just "helloworld")
$ interpretStringLiteral "'hello\\z \n \f \t \r \v world'"
assertEqual "Long-quote leading newline"
(Just "line1\nline2\n")
$ interpretStringLiteral "[===[\nline1\nline2\n]===]"
assertEqual "Long-quote without leading newline"
(Just "line1\nline2\n")
$ interpretStringLiteral "[===[line1\nline2\n]===]"
assertEqual "Long-quote no escapes"
(Just "\\0\\x00\\u{000}")
$ interpretStringLiteral "[===[\\0\\x00\\u{000}]===]"
assertEqual "Empty single quoted"
(Just "")
$ interpretStringLiteral "''"
assertEqual "Empty double quoted"
(Just "")
$ interpretStringLiteral "\"\""
assertEqual "Empty long quoted"
(Just "")
$ interpretStringLiteral "[[]]"
)
, testCase "encoding"
(do assertEqual "Empty string"
"\"\""
$ constructStringLiteral ""
assertEqual "Normal escapes"
"\"\\a\\b\\f\\n\\r\\t\\v\\\\\\\"\""
$ constructStringLiteral "\a\b\f\n\r\t\v\\\""
assertEqual "Exhaustive test"
"\"\\x00\\x01\\x02\\x03\\x04\\x05\\x06\\a\
\\\b\\t\\n\\v\\f\\r\\x0e\\x0f\
\\\x10\\x11\\x12\\x13\\x14\\x15\\x16\\x17\
\\\x18\\x19\\x1a\\x1b\\x1c\\x1d\\x1e\\x1f\
\ !\\\"#$%&'()*+,-./0123456789:;<=>?@\
\ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\\\]^_`\
\abcdefghijklmnopqrstuvwxyz{|}~\\x7f\
\\\x80\\x81\\x82\\x83\\x84\\x85\\x86\\x87\
\\\x88\\x89\\x8a\\x8b\\x8c\\x8d\\x8e\\x8f\
\\\x90\\x91\\x92\\x93\\x94\\x95\\x96\\x97\
\\\x98\\x99\\x9a\\x9b\\x9c\\x9d\\x9e\\x9f\
\\\xa0\\xa1\\xa2\\xa3\\xa4\\xa5\\xa6\\xa7\
\\\xa8\\xa9\\xaa\\xab\\xac\\xad\\xae\\xaf\
\\\xb0\\xb1\\xb2\\xb3\\xb4\\xb5\\xb6\\xb7\
\\\xb8\\xb9\\xba\\xbb\\xbc\\xbd\\xbe\\xbf\
\\\xc0\\xc1\\xc2\\xc3\\xc4\\xc5\\xc6\\xc7\
\\\xc8\\xc9\\xca\\xcb\\xcc\\xcd\\xce\\xcf\
\\\xd0\\xd1\\xd2\\xd3\\xd4\\xd5\\xd6\\xd7\
\\\xd8\\xd9\\xda\\xdb\\xdc\\xdd\\xde\\xdf\
\\\xe0\\xe1\\xe2\\xe3\\xe4\\xe5\\xe6\\xe7\
\\\xe8\\xe9\\xea\\xeb\\xec\\xed\\xee\\xef\
\\\xf0\\xf1\\xf2\\xf3\\xf4\\xf5\\xf6\\xf7\
\\\xf8\\xf9\\xfa\\xfb\\xfc\\xfd\\xfe\\xff\""
(constructStringLiteral (B.pack [0..255]))
)
]
stringTests :: TestTree
stringTests = testGroup "String tests"
[ testCase
"Equal strings from 5.3.1 reference manual"
(do let file = "tests/strings"
res <- P.parseFile file
stats <- case res of
Left e -> assertFailure (show e) >> undefined
Right (Block stats _) -> return stats
let extract (Assign _ [String s]) = Just s
extract _ = Nothing
strs <- case mapM extract stats of
Nothing -> assertFailure "couldn't extract strings" >> undefined
Just strs -> return strs
assertBool "Wrong number of strings parsed" (length strs == 5)
let expected = Just "alo\n123\""
forM_ strs $ \str ->
assertEqual
"String not same"
expected
(interpretStringLiteral (Text.unpack str)))
, testCase
"Round-trip through the pretty-printer"
(do let file = "tests/string-literal-roundtrip.lua"
contents <- Text.readFile file
case P.parseText P.chunk contents of
Left parseErr -> assertFailure (show parseErr)
Right x -> assertEqual
"pretty printer didn't preserve"
contents
(Text.pack (show (pprint x) ++ "\n")))
-- text file lines always end in a newline
-- but the pretty printer doesn't know this
]
numberTests :: TestTree
numberTests = testGroup "Number tests"
[ testCase
"Numbers from 5.3.1 reference manual"
(do let file = "tests/numbers"
contents <- readFile file
case parseExps contents of
Nothing -> assertFailure "bad tests/numbers"
Just exps -> do
assertBool "Wrong number of numbers parsed" (length exps == 9)
forM_ exps assertNumber)
]
where
assertNumber :: Exp -> Assertion
assertNumber Number{} = return ()
assertNumber nan = assertFailure ("Not a number: " ++ show nan)
regressions :: TestTree
regressions = testGroup "Regression tests"
[ testCase "Lexing comment with text \"EOF\" in it" $
assertEqual "Lexing is wrong" [] (L.llex "--EOF")
, testCase "Binary/unary operator parsing/printing" $ do
pp "2^3^2 == 2^(3^2)"
pp "2^3*4 == (2^3)*4"
pp "2^-2 == 1/4 and -2^- -2 == - - -4"
pp "not nil and 2 and not(2>3 or 3<2)"
pp "-3-1-5 == 0+0-9"
pp "-2^2 == -4 and (-2)^2 == 4 and 2*2-3-1 == 0"
pp "2*1+3/3 == 3 and 1+2 .. 3*1 == \"33\""
pp "not(2+1 > 3*1) and \"a\"..\"b\" > \"a\""
pp "not ((true or false) and nil)"
pp "true or false and nil"
pp "(((1 or false) and true) or false) == true"
pp "(((nil and true) or false) and true) == false"
, testCase "Lexing unnecessarily escaped quotes" $ do
show (L.llex "'\\\"'") `deepseq` return ()
show (L.llex "\"\\\'\"") `deepseq` return ()
, testCase "Lexing Lua string: '\\\\\"'" $ do
let get t = (L.ltokToken t, L.ltokLexeme t)
assertEqual "String lexed wrong"
[(T.TokSLit, "'\\\\\"'")]
(map get (L.llex "'\\\\\"'"))
, testCase "Lexing long literal `[====[ ... ]====]`" $
show (L.llex "[=[]]=]") `deepseq` return ()
, testCase "Handling \\z" $
show (L.llex "\"\\z\n \"") `deepseq` return ()
, testCase "varlist parser shouldn't accept empty list of variables in local declarations" $
assertParseFailure (P.parseText P.stat "local = test")
, testCase "explist parser shouldn't accept empty list of expressions in local declarations" $
assertParseFailure (P.parseText P.stat "local x =")
, testCase "empty varlist and explist in single assignment, should be rejected" $
assertParseFailure (P.parseText P.stat "local =")
, testCase "varlist parser shouldn't accept empty list of expressions in global declarations" $
assertParseFailure (P.parseText P.stat "= test")
, testCase "explist parsers shouldn't accept empty list of expressions in global declarations" $
assertParseFailure (P.parseText P.stat "x =")
, testCase "empty list of return values should be accpeted" $
assertEqual "Parsed wrong" (Right $ Block [] (Just [])) (P.parseText P.chunk "return")
, testCase "Long comments should start immediately after --" $ do
assertEqual "Parsed wrong" (Right $ Block [] Nothing)
(P.parseText P.chunk "--[[ line1\nline2 ]]")
assertParseFailure (P.parseText P.chunk "-- [[ line1\nline2 ]]")
, testCase "Print EmptyStat for disambiguation" $ ppChunk "f();(f)()"
, testCase "printing negation chains" $
let exp = Unop Neg (Unop Neg (Unop Neg (Number "120")))
in assertEqual "Parsed and/or printed wrong"
(Right exp)
(P.parseText P.exp (Text.pack (show (pprint exp))))
]
where
pp :: String -> Assertion
pp = ppTest (P.parseText P.exp . Text.pack) (show . pprint)
ppChunk :: String -> Assertion
ppChunk = ppTest (P.parseText P.chunk . Text.pack) (show . pprint)
ppTest :: Show err => (String -> Either err ret) -> (ret -> String) -> String -> Assertion
ppTest parser printer str =
case parser str of
Left err -> assertFailure $ "Parsing failed: " ++ show err
Right expr' ->
assertEqual "Printed string is not equal to original one modulo whitespace"
(filter (not . isSpace) str) (filter (not . isSpace) (printer expr'))
assertParseFailure (Left _parseError) = return ()
assertParseFailure (Right ret) = assertFailure $ "Unexpected parse: " ++ show ret
parseFilesTest :: String -> FilePath -> TestTree
parseFilesTest msg root = testCase msg $ do
luaFiles <- map (root </>) . filter ((==) ".lua" . takeExtension) <$> getDirectoryContents root
putStrLn $ "Trying to parse " ++ show (length luaFiles) ++ " Lua files."
forM_ luaFiles $ \luaFile -> do
putStrLn $ "Parsing file: " ++ luaFile
ret <- P.parseFile luaFile
case ret of
Left err -> assertFailure ("Parser error in " ++ luaFile ++ ": " ++ show err)
Right st -> -- force st `seq` return ()
let printed = show (pprint st)
in case P.parseText P.chunk (Text.pack printed) of
Left err ->
assertFailure ("Parser error while parsing printed version of "
++ luaFile ++ ": " ++ show err ++ "\nPrinted file:\n"
++ printed)
Right st' ->
force st' `seq` return ()
genPrintParse :: TestTree
genPrintParse =
localOption (QuickCheckTests 10)
. localOption (mkTimeout 100000)
. localOption (QuickCheckMaxSize 2)
$ testGroup "Generate-Print-Parse" [ testProperty "forall l, (parse . pprint) l = l" prop ]
where
prop :: Property
prop = forAll arbitrary printAndParseEq
printAndParseEq :: Block -> Property
printAndParseEq b = Right b === AP.parseText P.chunk (Text.pack (show (pprint b)))
-- * Arbitrary instances
newtype LuaString = LuaString { unwrapLuaString :: String } deriving (Generic)
-- FIXME: either fix this or implement separate lexer tests
instance Arbitrary LuaString where
arbitrary = LuaString <$> listOf1 (elements ['a'..'z'])
shrink = recursivelyShrink
arbitraryLuaStringList :: Gen [String]
arbitraryLuaStringList = liftA unwrapLuaString <$> listOf1 arbitrary
arbitraryLuaString :: Gen String
arbitraryLuaString = unwrapLuaString <$> arbitrary
instance Arbitrary Stat where
arbitrary = oneof
[ Assign <$> arbitrary <*> arbitrary
, FunCall <$> arbitrary
, Label <$> arbitrary
, return Break
, Goto <$> arbitrary
, Do <$> arbitrary
, While <$> arbitrary <*> arbitrary
, Repeat <$> arbitrary <*> arbitrary
, If <$> listOf1 arbitrary <*> arbitrary
, ForRange <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
, ForIn <$> listOf1 arbitrary <*> arbitrary <*> arbitrary
, FunAssign <$> arbitrary <*> arbitrary
, LocalFunAssign <$> arbitrary <*> arbitrary
, LocalAssign <$> listOf1 arbitrary <*> arbitrary
-- Don't generate EmptyState - it's not printed by pretty-printer
, return EmptyStat
]
shrink = recursivelyShrink
instance Arbitrary Exp where
arbitrary = oneof
[ return Nil
, Bool <$> arbitrary
, Number . Text.pack <$> listOf1 (elements ['0'..'9']) -- TODO: implement number lexer tests
, String . Text.pack <$> arbitraryLuaString
, return Vararg
, EFunDef <$> arbitrary
, PrefixExp <$> arbitrary
, TableConst <$> arbitrary
, Binop <$> arbitrary <*> arbitrary <*> arbitrary
, Unop <$> arbitrary <*> expNotUnop
]
shrink = const []
-- | Any expression except Unop. (see #2)
expNotUnop :: Gen Exp
expNotUnop = suchThat arbitrary notUnop
where
notUnop :: Exp -> Bool
notUnop Unop{} = False
notUnop _ = True
instance Arbitrary Var where
arbitrary = oneof
[ VarName <$> arbitrary
, Select <$> arbitrary <*> arbitrary
, SelectName <$> arbitrary <*> arbitrary
]
shrink = recursivelyShrink
instance Arbitrary Binop where
arbitrary = oneof $
map return [Add, Sub, Mul, Div, Exp, Mod, Concat, LT, LTE, GT, GTE, EQ, NEQ, And, Or]
shrink = recursivelyShrink
instance Arbitrary Unop where
arbitrary = oneof
[ return Neg
, return Not
, return Len
]
shrink = recursivelyShrink
instance Arbitrary PrefixExp where
arbitrary = oneof
[ PEVar <$> arbitrary
, PEFunCall <$> arbitrary
, Paren <$> arbitrary
]
shrink = recursivelyShrink
instance Arbitrary TableField where
arbitrary = oneof
[ ExpField <$> arbitrary <*> arbitrary
, NamedField <$> arbitrary <*> arbitrary
, Field <$> arbitrary
]
shrink = recursivelyShrink
instance Arbitrary Block where
arbitrary = Block <$> arbitrary
<*> suchThat arbitrary (maybe True (not . null))
shrink = recursivelyShrink
instance Arbitrary FunName where
arbitrary = FunName <$> arbitrary <*> listOf arbitrary <*> arbitrary
shrink = recursivelyShrink
instance Arbitrary FunBody where
arbitrary = FunBody <$> listOf1 arbitrary <*> arbitrary <*> arbitrary
shrink = recursivelyShrink
instance Arbitrary FunCall where
arbitrary = oneof
[ NormalFunCall <$> arbitrary <*> arbitrary
, MethodCall <$> arbitrary <*> arbitrary <*> arbitrary
]
shrink = recursivelyShrink
instance Arbitrary FunArg where
arbitrary = oneof
[ Args <$> arbitrary
, TableArg <$> arbitrary
, StringArg . Text.pack . unwrapLuaString <$> arbitrary
]
shrink = const []
instance Arbitrary Name where
arbitrary = return (Name "a")
shrink = const []