1{- 2Copyright © 2017-2020 Albert Krewinkel 3 4Permission is hereby granted, free of charge, to any person obtaining a copy 5of this software and associated documentation files (the "Software"), to deal 6in the Software without restriction, including without limitation the rights 7to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8copies of the Software, and to permit persons to whom the Software is 9furnished to do so, subject to the following conditions: 10 11The above copyright notice and this permission notice shall be included in 12all copies or substantial portions of the Software. 13 14THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20THE SOFTWARE. 21-} 22{-# LANGUAGE OverloadedStrings #-} 23{-# OPTIONS_GHC -fno-warn-deprecations #-} 24{-| 25Module : Foreign.Lua.CoreTests 26Copyright : © 2017-2020 Albert Krewinkel 27License : MIT 28 29Maintainer : Albert Krewinkel <tarleb+hslua@zeitkraut.de> 30Stability : stable 31Portability : portable 32 33Tests for Lua C API-like functions. 34-} 35module Foreign.Lua.CoreTests (tests) where 36 37import Prelude hiding (compare) 38 39import Control.Monad (forM_) 40import Data.Maybe (fromMaybe) 41import Foreign.Lua as Lua 42import Test.HsLua.Arbitrary () 43import Test.HsLua.Util ( (?:), (=:), shouldBeErrorMessageOf, shouldBeResultOf 44 , shouldHoldForResultOf, pushLuaExpr ) 45import Test.QuickCheck (Property, (.&&.)) 46import Test.QuickCheck.Monadic (assert, monadicIO) 47import Test.Tasty (TestTree, testGroup) 48import Test.Tasty.HUnit (assertBool, assertEqual, testCase) 49import Test.Tasty.QuickCheck (testProperty) 50 51import qualified Prelude 52import qualified Data.ByteString as B 53import qualified Foreign.Lua.Core.RawBindings as LuaRaw 54import qualified Foreign.Lua.Core.AuxiliaryTests 55import qualified Foreign.Lua.Core.ErrorTests 56import qualified Foreign.Marshal as Foreign 57import qualified Foreign.Ptr as Foreign 58import qualified Test.QuickCheck.Monadic as QCMonadic 59 60 61-- | Specifications for Attributes parsing functions. 62tests :: TestTree 63tests = testGroup "Core module" 64 [ Foreign.Lua.Core.ErrorTests.tests 65 , Foreign.Lua.Core.AuxiliaryTests.tests 66 , testGroup "copy" 67 [ "copies stack elements using positive indices" ?: do 68 pushLuaExpr "5, 4, 3, 2, 1" 69 copy 4 3 70 rawequal (nthFromBottom 4) (nthFromBottom 3) 71 72 , "copies stack elements using negative indices" ?: do 73 pushLuaExpr "5, 4, 3, 2, 1" 74 copy (-1) (-3) 75 rawequal (-1) (-3) 76 ] 77 78 , testGroup "insert" 79 [ "inserts stack elements using positive indices" ?: do 80 pushLuaExpr "1, 2, 3, 4, 5, 6, 7, 8, 9" 81 insert (-6) 82 movedEl <- peek (-6) :: Lua Lua.Integer 83 newTop <- peek (-1) :: Lua Lua.Integer 84 return (movedEl == 9 && newTop == 8) 85 86 , "inserts stack elements using negative indices" ?: do 87 pushLuaExpr "1, 2, 3, 4, 5, 6, 7, 8, 9" 88 insert 4 89 movedEl <- peek 4 :: Lua Lua.Integer 90 newTop <- peek (-1) :: Lua Lua.Integer 91 return (movedEl == 9 && newTop == 8) 92 ] 93 94 , testCase "absindex" . run $ do 95 pushLuaExpr "1, 2, 3, 4" 96 liftIO . assertEqual "index from bottom doesn't change" (nthFromBottom 3) 97 =<< absindex (nthFromBottom 3) 98 liftIO . assertEqual "index from top is made absolute" (nthFromBottom 2) 99 =<< absindex (nthFromTop 3) 100 liftIO . assertEqual "pseudo indices are left unchanged" registryindex 101 =<< absindex registryindex 102 103 , "gettable gets a table value" =: 104 Just 13.37 `shouldBeResultOf` do 105 pushLuaExpr "{sum = 13.37}" 106 pushstring "sum" 107 gettable (nthFromTop 2) 108 tonumber stackTop 109 110 , "rawlen gives the length of a list" =: 111 7 `shouldBeResultOf` do 112 pushLuaExpr "{1, 1, 2, 3, 5, 8, 13}" 113 rawlen stackTop 114 115 , testGroup "Type checking" 116 [ "isfunction" ?: do 117 pushLuaExpr "function () print \"hi!\" end" 118 isfunction (-1) 119 120 , "isnil" ?: pushLuaExpr "nil" *> isnil (-1) 121 122 , "isnone" ?: isnone 500 -- stack index 500 does not exist 123 124 , "isnoneornil" ?: do 125 pushLuaExpr "nil" 126 (&&) <$> isnoneornil 500 <*> isnoneornil (-1) 127 ] 128 129 , testCase "CFunction handling" . run $ do 130 pushcfunction LuaRaw.lua_open_debug_ptr 131 liftIO . assertBool "not recognized as CFunction" =<< iscfunction (-1) 132 liftIO . assertEqual "CFunction changed after receiving it from the stack" 133 (Just LuaRaw.lua_open_debug_ptr) =<< tocfunction (-1) 134 135 , testGroup "getting values" 136 [ testGroup "tointeger" 137 [ "tointeger returns numbers verbatim" =: 138 Just 149 `shouldBeResultOf` do 139 pushLuaExpr "149" 140 tointeger (-1) 141 142 , "tointeger accepts strings coercible to integers" =: 143 Just 451 `shouldBeResultOf` do 144 pushLuaExpr "'451'" 145 tointeger (-1) 146 147 , "tointeger returns Nothing when given a boolean" =: 148 Nothing `shouldBeResultOf` do 149 pushLuaExpr "true" 150 tointeger (-1) 151 ] 152 153 , testGroup "tonumber" 154 [ "tonumber returns numbers verbatim" =: 155 Just 14.9 `shouldBeResultOf` do 156 pushLuaExpr "14.9" 157 tonumber (-1) 158 159 , "tonumber accepts strings as numbers" =: 160 Just 42.23 `shouldBeResultOf` do 161 pushLuaExpr "'42.23'" 162 tonumber (-1) 163 164 , "tonumber returns Nothing when given a boolean" =: 165 Nothing `shouldBeResultOf` do 166 pushLuaExpr "true" 167 tonumber (-1) 168 ] 169 170 , testGroup "tostring" 171 [ "get a string" =: 172 Just "a string" `shouldBeResultOf` do 173 pushLuaExpr "'a string'" 174 tostring stackTop 175 176 , "get a number as string" =: 177 Just "17.0" `shouldBeResultOf` do 178 pushnumber 17 179 tostring stackTop 180 181 , "fail when looking at a boolean" =: 182 Nothing `shouldBeResultOf` do 183 pushboolean True 184 tostring stackTop 185 ] 186 ] 187 188 , "setting and getting a global works" =: 189 Just "Moin" `shouldBeResultOf` do 190 pushLuaExpr "{'Moin', Hello = 'World'}" 191 setglobal "hamburg" 192 193 -- get first field 194 getglobal "hamburg" 195 rawgeti stackTop 1 -- first field 196 tostring stackTop 197 198 , testGroup "get functions (Lua to stack)" 199 [ "unicode characters in field name are ok" =: 200 True `shouldBeResultOf` do 201 pushLuaExpr "{['\xE2\x9A\x94'] = true}" 202 getfield stackTop "⚔" 203 toboolean stackTop 204 ] 205 206 , "can push and receive a thread" ?: do 207 luaSt <- state 208 isMain <- pushthread 209 liftIO (assertBool "pushing the main thread should return True" isMain) 210 luaSt' <- peek stackTop 211 return (luaSt == luaSt') 212 213 , "different threads are not equal in Haskell" ?: 214 liftIO 215 (do luaSt1 <- newstate 216 luaSt2 <- newstate 217 let result = luaSt1 /= luaSt2 218 close luaSt1 219 close luaSt2 220 return result) 221 222 , testGroup "thread status" 223 [ "OK is base thread status" =: 224 OK `shouldBeResultOf` status 225 226 , "Yield is the thread status after yielding" =: 227 Yield `shouldBeResultOf` do 228 openlibs 229 getglobal "coroutine" 230 getfield stackTop "resume" 231 pushLuaExpr "coroutine.create(function() coroutine.yield(9) end)" 232 contThread <- fromMaybe (Prelude.error "not a thread at top of stack") 233 <$> tothread stackTop 234 call 1 0 235 liftIO $ runWith contThread status 236 ] 237 238 , testGroup "miscellaneous functions" 239 [ testGroup "pushglobaltable" 240 [ "globals are fields in global table" =: 241 "yep" `shouldBeResultOf` do 242 pushstring "yep" 243 setglobal "TEST" 244 pushglobaltable 245 getfield stackTop "TEST" 246 tostring' stackTop 247 ] 248 ] 249 250 , testGroup "auxiliary functions" 251 [ testGroup "tostring'" 252 [ "integers are converted in base10" =: 253 "5" `shouldBeResultOf` do 254 pushinteger 5 255 tostring' stackTop 256 257 , "a nil value is converted into the literal string 'nil'" =: 258 "nil" `shouldBeResultOf` do 259 pushnil 260 tostring' stackTop 261 262 , "strings are returned verbatim" =: 263 "Hello\NULWorld" `shouldBeResultOf` do 264 pushstring "Hello\NULWorld" 265 tostring' stackTop 266 267 , "string for userdata shows the pointer value" =: 268 ("userdata: " `B.isPrefixOf`) `shouldHoldForResultOf` do 269 l <- state 270 liftIO . Foreign.alloca $ \ptr -> 271 runWith l (pushlightuserdata (ptr :: Foreign.Ptr Int)) 272 tostring' stackTop 273 274 , "string is also pushed to the stack" =: 275 Just "true" `shouldBeResultOf` do 276 pushboolean True 277 _ <- tostring' stackTop 278 tostring stackTop -- note the use of tostring instead of tostring' 279 280 , "errors during metamethod execution are caught" =: 281 "'__tostring' must return a string" `shouldBeErrorMessageOf` do 282 -- create a table with a faulty `__tostring` metamethod 283 let mt = "{__tostring = function() return nil end }" 284 let tbl = "return setmetatable({}, " <> mt <> ")" 285 openlibs <* dostring tbl 286 tostring' stackTop 287 ] 288 289 , testGroup "ref and unref" 290 [ "store nil value to registry" =: 291 Lua.RefNil `shouldBeResultOf` do 292 Lua.pushnil 293 Lua.ref Lua.registryindex 294 295 , "get referenced value from registry" =: 296 Just "Berlin" `shouldBeResultOf` do 297 Lua.pushstring "Berlin" 298 cityref <- Lua.ref Lua.registryindex 299 Lua.pushnil -- dummy op 300 Lua.getref Lua.registryindex cityref 301 Lua.tostring Lua.stackTop 302 303 , "references become invalid after unref" =: 304 Nothing `shouldBeResultOf` do 305 Lua.pushstring "Heidelberg" 306 cityref <- Lua.ref Lua.registryindex 307 Lua.unref Lua.registryindex cityref 308 Lua.getref Lua.registryindex cityref 309 Lua.tostring Lua.stackTop 310 ] 311 ] 312 313 , testGroup "loading" 314 [ testGroup "loadstring" 315 [ "loading a valid string should succeed" =: 316 OK `shouldBeResultOf` loadstring "return 1" 317 318 , "loading an invalid string should give a syntax error" =: 319 ErrSyntax `shouldBeResultOf` loadstring "marzipan" 320 ] 321 322 , testGroup "dostring" 323 [ "loading a string which fails should give a run error" =: 324 ErrRun `shouldBeResultOf` dostring "error 'this fails'" 325 326 , "loading an invalid string should return a syntax error" =: 327 ErrSyntax `shouldBeResultOf` dostring "marzipan" 328 329 , "loading a valid program should succeed" =: 330 OK `shouldBeResultOf` dostring "return 1" 331 332 , "top of the stack should be result of last computation" =: 333 (5 :: Lua.Integer) `shouldBeResultOf` 334 (dostring "return (2+3)" *> peek (-1)) 335 ] 336 337 , testGroup "loadbuffer" 338 [ "loading a valid string should succeed" =: 339 OK `shouldBeResultOf` loadbuffer "return '\NUL'" "test" 340 341 , "loading a string containing NUL should be correct" =: 342 Just "\NUL" `shouldBeResultOf` do 343 _ <- loadbuffer "return '\NUL'" "test" 344 call 0 1 345 tostring stackTop 346 ] 347 348 , testGroup "loadfile" 349 [ "file error should be returned when file does not exist" =: 350 ErrFile `shouldBeResultOf` loadfile "./file-does-not-exist.lua" 351 352 , "loading an invalid file should give a syntax error" =: 353 ErrSyntax `shouldBeResultOf` loadfile "test/lua/syntax-error.lua" 354 355 , "loading a valid program should succeed" =: 356 OK `shouldBeResultOf` loadfile "./test/lua/example.lua" 357 358 , "example fib program should be loaded correctly" =: 359 (8 :: Lua.Integer) `shouldBeResultOf` do 360 loadfile "./test/lua/example.lua" *> call 0 0 361 getglobal "fib" 362 pushinteger 6 363 call 1 1 364 peek stackTop 365 ] 366 367 , testGroup "dofile" 368 [ "file error should be returned when file does not exist" =: 369 ErrFile `shouldBeResultOf` dofile "./file-does-not-exist.lua" 370 371 , "loading an invalid file should give a syntax error" =: 372 ErrSyntax `shouldBeResultOf` dofile "test/lua/syntax-error.lua" 373 374 , "loading a failing program should give an run error" =: 375 ErrRun `shouldBeResultOf` dofile "test/lua/error.lua" 376 377 , "loading a valid program should succeed" =: 378 OK `shouldBeResultOf` dofile "./test/lua/example.lua" 379 380 , "example fib program should be loaded correctly" =: 381 (21 :: Lua.Integer) `shouldBeResultOf` do 382 _ <- dofile "./test/lua/example.lua" 383 getglobal "fib" 384 pushinteger 8 385 call 1 1 386 peek stackTop 387 ] 388 ] 389 390 , testGroup "pcall" 391 [ "raising an error should lead to an error status" =: 392 ErrRun `shouldBeResultOf` do 393 _ <- loadstring "error \"this fails\"" 394 pcall 0 0 Nothing 395 396 , "raising an error in the error handler should give a 'double error'" =: 397 ErrErr `shouldBeResultOf` do 398 pushLuaExpr "function () error 'error in error handler' end" 399 _ <- loadstring "error \"this fails\"" 400 pcall 0 0 (Just (nthFromTop 2)) 401 ] 402 403 , testCase "garbage collection" . run $ 404 -- test that gc can be called with all constructors of type GCCONTROL. 405 forM_ [GCSTOP .. GCSETSTEPMUL] $ \what -> gc what 23 406 407 , testGroup "compare" 408 [ testProperty "identifies strictly smaller values" $ compareWith (<) Lua.LT 409 , testProperty "identifies smaller or equal values" $ compareWith (<=) Lua.LE 410 , testProperty "identifies equal values" $ compareWith (==) Lua.EQ 411 ] 412 413 , testProperty "lessthan works" $ \n1 n2 -> monadicIO $ do 414 luaCmp <- QCMonadic.run . run $ do 415 push (n2 :: Lua.Number) 416 push (n1 :: Lua.Number) 417 lessthan (-1) (-2) <* pop 2 418 assert $ luaCmp == (n1 < n2) 419 420 , testProperty "order of Lua types is consistent" $ \ lt1 lt2 -> 421 let n1 = fromType lt1 422 n2 = fromType lt2 423 in Prelude.compare n1 n2 == Prelude.compare lt1 lt2 424 425 , testCase "boolean values are correct" $ do 426 trueIsCorrect <- run $ 427 pushboolean True *> dostring "return true" *> rawequal (-1) (-2) 428 falseIsCorrect <- run $ 429 pushboolean False *> dostring "return false" *> rawequal (-1) (-2) 430 assertBool "LuaBool true is not equal to Lua's true" trueIsCorrect 431 assertBool "LuaBool false is not equal to Lua's false" falseIsCorrect 432 433 , testCase "functions can throw a table as error message" $ do 434 let mt = "{__tostring = function (e) return e.error_code end}" 435 let err = "error(setmetatable({error_code = 23}," <> mt <> "))" 436 res <- run . try $ openbase *> loadstring err *> call 0 0 437 assertEqual "wrong error message" (Left (Lua.Exception "23")) res 438 439 , testCase "handling table errors won't leak" $ do 440 let mt = "{__tostring = function (e) return e.code end}" 441 let err = "error(setmetatable({code = 5}," <> mt <> "))" 442 let luaOp = do 443 openbase 444 oldtop <- gettop 445 _ <- try $ loadstring err *> call 0 0 446 newtop <- gettop 447 return (newtop - oldtop) 448 res <- run luaOp 449 assertEqual "error handling leaks values to the stack" 0 res 450 ] 451 452compareWith :: (Lua.Integer -> Lua.Integer -> Bool) 453 -> RelationalOperator -> Lua.Integer -> Property 454compareWith op luaOp n = compareLT .&&. compareEQ .&&. compareGT 455 where 456 compareLT :: Property 457 compareLT = monadicIO $ do 458 luaCmp <- QCMonadic.run . run $ do 459 push $ n - 1 460 push n 461 compare (-2) (-1) luaOp 462 assert $ luaCmp == op (n - 1) n 463 464 compareEQ :: Property 465 compareEQ = monadicIO $ do 466 luaCmp <- QCMonadic.run . run $ do 467 push n 468 push n 469 compare (-2) (-1) luaOp 470 assert $ luaCmp == op n n 471 472 compareGT :: Property 473 compareGT = monadicIO $ do 474 luaRes <- QCMonadic.run . run $ do 475 push $ n + 1 476 push n 477 compare (-2) (-1) luaOp 478 assert $ luaRes == op (n + 1) n 479