1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
{-|
Module : Lua.ErsatzTests
Copyright : © 2021-2022 Albert Krewinkel
License : MIT
Maintainer : Albert Krewinkel <tarleb+hslua@zeitkraut.de>
Stability : beta
Tests for Lua bindings.
-}
module Lua.ErsatzTests (tests) where
import Control.Monad (void)
import Foreign.C.String (withCString, withCStringLen)
import Foreign.Marshal (alloca)
import Foreign.Ptr (nullPtr)
import Foreign.Storable (peek)
import Lua
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, HasCallStack, testCase, (@=?) )
-- | Tests for unsafe methods.
tests :: TestTree
tests = testGroup "ersatz"
[ testGroup "arith"
[ "adds two numbers" =: do
7 `shouldBeResultOf` \l -> do
lua_pushinteger l 5
lua_pushinteger l 2
hslua_arith l LUA_OPADD nullPtr
lua_tointegerx l top nullPtr
, "negates number" =: do
(-5) `shouldBeResultOf` \l -> do
lua_pushinteger l 5
hslua_arith l LUA_OPUNM nullPtr
lua_tointegerx l top nullPtr
, "pops its arguments from the stack" =: do
1 `shouldBeResultOf` \l -> do
old <- lua_gettop l
lua_pushinteger l 4
lua_pushinteger l 3
hslua_arith l LUA_OPADD nullPtr
new <- lua_gettop l
return (new - old)
, "pops a single argument for unary negation" =: do
1 `shouldBeResultOf` \l -> do
old <- lua_gettop l
lua_pushinteger l 3
hslua_arith l LUA_OPUNM nullPtr
new <- lua_gettop l
return (new - old)
, "sets status to LUA_OK on success" =: do
(LUA_OK, 1024) `shouldBeResultOf` \l -> do
lua_pushinteger l 2
lua_pushinteger l 10
stts <- alloca $ \status -> do
hslua_arith l LUA_OPPOW status
peek status
result <- lua_tointegerx l top nullPtr
return (stts, result)
, "sets error status on error" =: do
LUA_ERRRUN `shouldBeResultOf` \l -> do
lua_pushinteger l 2
lua_pushboolean l TRUE
alloca $ \status -> do
hslua_arith l LUA_OPSHR status
peek status
, "runs metamethod" =: do
(LUA_OK, 7) `shouldBeResultOf` \l -> do
lua_pushinteger l 2
lua_createtable l 0 0
LUA_OK <- withCStringLen "return {__mod = function() return 7 end}" $
\(s, len) -> luaL_loadbuffer l s (fromIntegral len) s
LUA_OK <- lua_pcall l 0 1 0
lua_setmetatable l (-2)
stts <- alloca $ \status -> do
hslua_arith l LUA_OPMOD status
peek status
result <- lua_tointegerx l top nullPtr
return (stts, result)
, "catches runtime error in metamethod" =: do
LUA_ERRRUN `shouldBeResultOf` \l -> do
lua_pushinteger l 2
lua_createtable l 0 0
LUA_OK <- withCStringLen "return {__bor = function() error'no' end}" $
\(s, len) -> luaL_loadbuffer l s (fromIntegral len) s
LUA_OK <- lua_pcall l 0 1 0
lua_setmetatable l (-2)
alloca $ \status -> do
hslua_arith l LUA_OPBOR status
peek status
]
, testGroup "global"
[ "set and get global field" =: do
(42, LUA_TNUMBER) `shouldBeResultOf` \l -> do
lua_pushinteger l 42
tp <- withCStringLen "ups" $ \(name, nameLen) -> do
hslua_setglobal l name (fromIntegral nameLen) nullPtr
hslua_getglobal l name (fromIntegral nameLen) nullPtr
i <- lua_tointegerx l top nullPtr
return (i, tp)
, "get value from table" =: do
(-23, LUA_TNUMBER) `shouldBeResultOf` \l -> do
withCStringLen "return {[5] = -23}" $ \(name, len) -> void $
luaL_loadbuffer l name (fromIntegral len) name
LUA_OK <- lua_pcall l 0 1 0
lua_pushinteger l 5
ty <- hslua_gettable l (nth 2) nullPtr
i <- lua_tointegerx l top nullPtr
return (i, ty)
]
, testGroup "Auxiliary"
[ testGroup "hslua_requiref"
[ "can load a module" =: do
LUA_TTABLE `shouldBeResultOf` \l -> do
lua_pushcfunction l luaopen_package
LUA_OK <- lua_pcall l 0 0 0
withCString "math" $ \s ->
hsluaL_requiref l s luaopen_math FALSE nullPtr
lua_type l (-1)
, "returns LUA_OK on success" =: do
LUA_OK `shouldBeResultOf` \l -> do
lua_pushcfunction l luaopen_package
LUA_OK <- lua_pcall l 0 0 0
alloca $ \status -> do
withCString "math" $ \s ->
hsluaL_requiref l s luaopen_package FALSE status
peek status
, "sets global if flag is set" =: do
LUA_TTABLE `shouldBeResultOf` \l -> do
luaL_openlibs l
withCString "mathematics" $ \s ->
hsluaL_requiref l s luaopen_math TRUE nullPtr
withCStringLen "mathematics" $ \(name, len) ->
hslua_getglobal l name (fromIntegral len) nullPtr
, "catches errors" =: do
LUA_ERRRUN `shouldBeResultOf` \l -> do
-- unset registry
lua_pushnil l
lua_copy l (-1) LUA_REGISTRYINDEX
alloca $ \status -> do
withCString "math" $ \s ->
hsluaL_requiref l s luaopen_package FALSE status
peek status
]
]
]
infix 3 =:
(=:) :: String -> Assertion -> TestTree
(=:) = testCase
shouldBeResultOf :: (HasCallStack, Eq a, Show a)
=> a -> (State -> IO a) -> Assertion
shouldBeResultOf expected luaOp = do
result <- withNewState luaOp
expected @=? result
|
