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