{-# 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.lexemeToken t, L.lexemeText 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 IntNum "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 IntNum . 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 []