diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,9 +2,49 @@ `lua` uses [PVP Versioning][1]. -## lua 1.0 +## lua 2.0.0 -Release pending +Release pending. + +- Module hierarchy moved from `Foreign.Lua.Raw` to `Lua`. + +- Documentation has been improved. + +- Added new function `withNewState` to run Lua operations. + +- New modules `Lua.Ersatz` containing all bindings to safe + ersatz functions. + +- Higher level and enum types have been removed, only the + low-level "code" types are kept in this package. + +- Constants are now represented as pattern synonyms like `LUA_OK`. + +- Provide bindings to more functions: + + `lua_is...` type-checking functions; + + `lua_pushstring` to push plain CStrings; + + auxiliary functions + * `luaL_loadfile`, and + * `luaL_loadfilex`; + + unsafe functions + * `lua_gettable`, + * `lua_settable`, + * `lua_getglobal`, and + * `lua_setglobal`. + +- The function `lua_pop` now expects a `CInt` instead of a + `StackIndex`. + +- New StackIndex constructor functions `nthTop`, `nthBottom`, + `nth`, and `top`. + +- Avoid unnecessary modification of HSFUN metatable. + +- Various cleanups and test improvements. + +## lua 1.0.0 + +Released 2021-02-18. - Initially created. Contains all modules in the `Foreign.Lua.Raw` hierarchy from `hslua-1.3`. Documentation has been improved. diff --git a/cbits/hslua/hslauxlib.c b/cbits/hslua/hslauxlib.c new file mode 100644 --- /dev/null +++ b/cbits/hslua/hslauxlib.c @@ -0,0 +1,52 @@ +#include +#include +#include +#include "hslauxlib.h" +#include "hslcall.h" + +/* Auxiliary Library */ + +/* +** Creates a new Lua state and set extra registry values for error +** bookkeeping. +*/ +lua_State *hsluaL_newstate() +{ + lua_State *L = luaL_newstate(); + + /* add error value */ + lua_createtable(L, 0, 0); + lua_setfield(L, LUA_REGISTRYINDEX, HSLUA_ERR); + + /* register HaskellFunction userdata metatable */ + hslua_registerhsfunmetatable(L); + + return L; +} + + +/* +** Helper for hsluaL_tostring +*/ +int hsluaL__tolstring(lua_State *L) +{ + luaL_tolstring(L, 1, NULL); + return 1; +} + +/* +** Converts object to string, respecting any metamethods; returns NULL +** if an error occurs. +*/ +const char *hsluaL_tolstring(lua_State *L, int index, size_t *len) +{ + lua_pushvalue(L, index); + lua_pushcfunction(L, hsluaL__tolstring); + lua_insert(L, -2); + int res = lua_pcall(L, 1, 1, 0); + if (res != LUA_OK) { + /* error */ + return NULL; + } + return lua_tolstring(L, -1, len); +} diff --git a/cbits/hslua/hslauxlib.h b/cbits/hslua/hslauxlib.h new file mode 100644 --- /dev/null +++ b/cbits/hslua/hslauxlib.h @@ -0,0 +1,21 @@ +#ifndef hslauxlib_h +#define hslauxlib_h + +#include +#include +#include + +/* Auxiliary Library */ + +/* +** Creates a new state for use with the Haskell bindings. +*/ +lua_State *hsluaL_newstate(); + +/* +** Converts object to string, respecting any metamethods; returns NULL +** if an error occurs. +*/ +const char *hsluaL_tolstring(lua_State *L, int index, size_t *len); + +#endif diff --git a/cbits/hslua/hslcall.c b/cbits/hslua/hslcall.c --- a/cbits/hslua/hslcall.c +++ b/cbits/hslua/hslcall.c @@ -1,7 +1,7 @@ #include #include #include -#include "hslua-export.h" +#include "hslexport.h" #include "hslcall.h" #include "hsludata.h" @@ -71,7 +71,7 @@ ** function-wrapping userdata when it's been called and removes ** the userdata from the stack. */ -void *hslua_hs_fun_ptr(lua_State *L) +void *hslua_extracthsfun(lua_State *L) { void *fn = luaL_testudata(L, 1, HSLUA_HSFUN_NAME); lua_remove(L, 1); @@ -84,10 +84,11 @@ */ void hslua_registerhsfunmetatable(lua_State *L) { - hslua_newudmetatable(L, HSLUA_HSFUN_NAME); - lua_pushcfunction(L, &hslua_call_wrapped_hs_fun); - lua_setfield(L, -2, "__call"); - lua_pop(L, 1); + if (hslua_newudmetatable(L, HSLUA_HSFUN_NAME)) { + lua_pushcfunction(L, &hslua_callhsfun); + lua_setfield(L, -2, "__call"); + lua_pop(L, 1); + } } /* diff --git a/cbits/hslua/hslexport.h b/cbits/hslua/hslexport.h new file mode 100644 --- /dev/null +++ b/cbits/hslua/hslexport.h @@ -0,0 +1,9 @@ +/* *************************************************************** + * Functions exported from Haskell + * ***************************************************************/ + +#include +#include + +/* exported from Lua.Call */ +int hslua_callhsfun(lua_State *L); diff --git a/cbits/hslua/hslua-export.h b/cbits/hslua/hslua-export.h deleted file mode 100644 --- a/cbits/hslua/hslua-export.h +++ /dev/null @@ -1,8 +0,0 @@ -/* *************************************************************** - * Functions exported from Haskell - * ***************************************************************/ - -#include - -/* exported from Foreign.Lua.Raw.Call */ -int hslua_call_wrapped_hs_fun(lua_State *L); diff --git a/cbits/hslua/hslua.c b/cbits/hslua/hslua.c --- a/cbits/hslua/hslua.c +++ b/cbits/hslua/hslua.c @@ -19,6 +19,11 @@ return 1; } +/* +** Compares two values on the stack. Behaves mostly like lua_compare, +** but takes an additional parameter `status`, the referent of which is +** assigned the result of calling the helper function. + */ int hslua_compare(lua_State *L, int index1, int index2, int op, int *status) { index1 = lua_absindex(L, index1); @@ -27,8 +32,11 @@ lua_pushvalue(L, index1); lua_pushvalue(L, index2); lua_pushinteger(L, op); - *status = lua_pcall(L, 3, 1, 0); - if (*status != LUA_OK) { + int outcome = lua_pcall(L, 3, 1, 0); + if (status != NULL) { + *status = outcome; + } + if (outcome != LUA_OK) { return 0; } int result = lua_tointeger(L, -1); @@ -63,12 +71,13 @@ return 1; } -void hslua_getglobal(lua_State *L, const char *name, size_t len, int *status) +int hslua_getglobal(lua_State *L, const char *name, size_t len, int *status) { lua_pushcfunction(L, hslua__getglobal); lua_pushglobaltable(L); lua_pushlstring(L, name, len); *status = lua_pcall(L, 2, 1, 0); + return lua_type(L, -1); } @@ -82,12 +91,13 @@ return 1; } -void hslua_gettable(lua_State *L, int index, int *status) +int hslua_gettable(lua_State *L, int index, int *status) { lua_pushvalue(L, index); lua_pushcfunction(L, hslua__gettable); lua_insert(L, -3); *status = lua_pcall(L, 2, 1, 0); + return lua_type(L, -1); } @@ -157,49 +167,4 @@ } /* success */ return (lua_gettop(L) - oldsize + 1); /* correct for popped value */ -} - - -/* -** Auxiliary Library -*/ - -/* -** newstate -*/ -lua_State *hsluaL_newstate() -{ - lua_State *L = luaL_newstate(); - - /* add error value */ - lua_createtable(L, 0, 0); - lua_setfield(L, LUA_REGISTRYINDEX, HSLUA_ERR); - - /* register HaskellFunction userdata metatable */ - hslua_registerhsfunmetatable(L); - - return L; -} - - -/* -** tolstring' -*/ -int hsluaL__tolstring(lua_State *L) -{ - luaL_tolstring(L, 1, NULL); - return 1; -} - -const char *hsluaL_tolstring(lua_State *L, int index, size_t *len) -{ - lua_pushvalue(L, index); - lua_pushcfunction(L, hsluaL__tolstring); - lua_insert(L, -2); - int res = lua_pcall(L, 1, 1, 0); - if (res != 0) { - /* error */ - return NULL; - } - return lua_tolstring(L, -1, len); } diff --git a/cbits/hslua/hslua.h b/cbits/hslua/hslua.h --- a/cbits/hslua/hslua.h +++ b/cbits/hslua/hslua.h @@ -1,5 +1,4 @@ -#include "lua.h" -#include "lauxlib.h" +#include int hslua_error(lua_State *L); @@ -11,23 +10,12 @@ void hslua_concat(lua_State *L, int n, int *status); -void hslua_getglobal(lua_State *L, const char *name, size_t len, int *status); +int hslua_getglobal(lua_State *L, const char *name, size_t len, int *status); -void hslua_gettable(lua_State *L, int index, int *status); +int hslua_gettable(lua_State *L, int index, int *status); void hslua_setglobal(lua_State *L, const char *k, size_t len, int *status); void hslua_settable(lua_State *L, int index, int *status); int hslua_next(lua_State *L, int index, int *status); - - -/* auxiliary library */ -const char *hsluaL_tolstring(lua_State *L, int index, size_t *len); - -/* -** function calling -*/ - -/* Wraps a Haskell function with an userdata object. */ -void hslua_newhsfunwrapper(lua_State *L, HsStablePtr fn); diff --git a/cbits/hslua/hsludata.c b/cbits/hslua/hsludata.c --- a/cbits/hslua/hsludata.c +++ b/cbits/hslua/hsludata.c @@ -3,7 +3,7 @@ #include "hsludata.h" /* *************************************************************** - * Userdata Creation and Garbage Collection + * Userdata for Haskell values * ***************************************************************/ /* @@ -24,6 +24,9 @@ /* ** Creates a new userdata metatable for Haskell objects, or gets ** is from the registry if possible. +** +** Returns `true` if the metatable was created, and `false` if it +** already existed and was fetched from the registry. */ int hslua_newudmetatable(lua_State *L, const char *tname) { diff --git a/cbits/hslua/hsludata.h b/cbits/hslua/hsludata.h --- a/cbits/hslua/hsludata.h +++ b/cbits/hslua/hsludata.h @@ -1,5 +1,6 @@ #include #include +#include /* *************************************************************** * Userdata for Haskell values diff --git a/lua.cabal b/lua.cabal --- a/lua.cabal +++ b/lua.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: lua -version: 1.0.0 +version: 2.0.0 synopsis: Lua, an embeddable scripting language description: This package provides bindings and types to bridge Haskell and . @@ -8,7 +8,7 @@ The full Lua interpreter version 5.3.6 is included. Alternatively, a system-wide Lua installation can be linked instead. -homepage: https://hslua.github.io/ +homepage: https://hslua.org/ bug-reports: https://github.com/hslua/hslua/issues license: MIT license-file: LICENSE @@ -28,7 +28,8 @@ , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 - , GHC == 8.10.2 + , GHC == 8.10.4 + , GHC == 9.0.1 source-repository head type: git @@ -88,7 +89,6 @@ common common-options default-language: Haskell2010 build-depends: base >= 4.8 && < 5 - , bytestring >= 0.10.2 && < 0.11 ghc-options: -Wall -Wincomplete-record-updates -Wnoncanonical-monad-instances @@ -102,15 +102,32 @@ -Wpartial-fields -fhide-source-paths + if flag(lua_32bits) + cc-options: -DLUA_32BITS + + if flag(apicheck) + cc-options: -DLUA_USE_APICHECK + + if flag(allow-unsafe-gc) + cpp-options: -DALLOW_UNSAFE_GC + + if flag(hardcode-reg-keys) + cpp-options: -DHARDCODE_REG_KEYS + + library import: common-options - exposed-modules: Foreign.Lua.Raw.Auxiliary - , Foreign.Lua.Raw.Call - , Foreign.Lua.Raw.Constants - , Foreign.Lua.Raw.Error - , Foreign.Lua.Raw.Functions - , Foreign.Lua.Raw.Types - , Foreign.Lua.Raw.Userdata + exposed-modules: Lua + , Lua.Auxiliary + , Lua.Call + , Lua.Constants + , Lua.Ersatz + , Lua.Ersatz.Auxiliary + , Lua.Ersatz.Functions + , Lua.Lib + , Lua.Primary + , Lua.Types + , Lua.Userdata hs-source-dirs: src default-extensions: CApiFFI , ForeignFunctionInterface @@ -118,16 +135,23 @@ other-extensions: CPP , DeriveGeneric , GeneralizedNewtypeDeriving + , PatternSynonyms c-sources: cbits/hslua/hsludata.c , cbits/hslua/hslcall.c + , cbits/hslua/hslauxlib.c , cbits/hslua/hslua.c include-dirs: cbits/hslua + includes: lua.h + , luaconf.h + , lauxlib.h + install-includes: lua.h + , luaconf.h + , lauxlib.h if flag(system-lua) || flag(pkg-config) if flag(pkg-config) pkgconfig-depends: lua5.3 else extra-libraries: lua - includes: lua.h else include-dirs: cbits/lua-5.3.6 c-sources: cbits/lua-5.3.6/lapi.c @@ -178,23 +202,12 @@ if flag(export-dynamic) ld-options: -Wl,-E - if flag(lua_32bits) - cc-options: -DLUA_32BITS - - if flag(apicheck) - cc-options: -DLUA_USE_APICHECK - - if flag(allow-unsafe-gc) - cpp-options: -DALLOW_UNSAFE_GC - - if flag(hardcode-reg-keys) - cpp-options: -DHARDCODE_REG_KEYS - test-suite test-lua import: common-options type: exitcode-stdio-1.0 main-is: test-lua.hs hs-source-dirs: test + other-modules: Lua.UnsafeTests build-depends: lua , tasty >= 0.11 , tasty-hunit >= 0.9 diff --git a/src/Foreign/Lua/Raw/Auxiliary.hs b/src/Foreign/Lua/Raw/Auxiliary.hs deleted file mode 100644 --- a/src/Foreign/Lua/Raw/Auxiliary.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE CPP #-} -{-| -Module : Foreign.Lua.Raw.Auxiliary -Copyright : © 2007–2012 Gracjan Polak; - © 2012–2016 Ömer Sinan Ağacan; - © 2017-2021 Albert Krewinkel -License : MIT -Maintainer : Albert Krewinkel -Stability : beta -Portability : non-portable (depends on GHC) - -Raw bindings to functions and constants of the auxiliary library. --} -module Foreign.Lua.Raw.Auxiliary - ( hsluaL_newstate - , hsluaL_tolstring - , luaL_getmetafield - , luaL_getmetatable - , luaL_loadbuffer - , luaL_newmetatable - , luaL_ref - , luaL_testudata - , luaL_traceback - , luaL_unref - -- * Registry fields - , loadedTableRegistryField - , preloadTableRegistryField - -- * References - , Reference (..) - , fromReference - , toReference - ) where - -import Foreign.C (CChar, CInt (CInt), CSize (CSize), CString) -import Foreign.Lua.Raw.Types (StackIndex) -import Foreign.Ptr -import qualified Foreign.Lua.Raw.Types as Lua - -#ifndef HARDCODE_REG_KEYS -import System.IO.Unsafe (unsafePerformIO) -import qualified Foreign.C as C -#endif - -#ifdef ALLOW_UNSAFE_GC -#define SAFTY unsafe -#else -#define SAFTY safe -#endif - --- * The Auxiliary Library - --- | Key, in the registry, for table of loaded modules. -loadedTableRegistryField :: String -#ifdef HARDCODE_REG_KEYS -loadedTableRegistryField = "_LOADED" -#else -loadedTableRegistryField = unsafePerformIO (C.peekCString c_loaded_table) -{-# NOINLINE loadedTableRegistryField #-} - -foreign import capi unsafe "lauxlib.h value LUA_LOADED_TABLE" - c_loaded_table :: CString -#endif - --- | Key, in the registry, for table of preloaded loaders. -preloadTableRegistryField :: String -#ifdef HARDCODE_REG_KEYS -preloadTableRegistryField = "_PRELOAD" -#else -preloadTableRegistryField = unsafePerformIO (C.peekCString c_preload_table) -{-# NOINLINE preloadTableRegistryField #-} - -foreign import capi unsafe "lauxlib.h value LUA_PRELOAD_TABLE" - c_preload_table :: CString -#endif - -foreign import capi SAFTY "lauxlib.h luaL_getmetafield" - luaL_getmetafield :: Lua.State -> StackIndex -> CString -> IO Lua.TypeCode - -foreign import capi SAFTY "lauxlib.h luaL_getmetatable" - luaL_getmetatable :: Lua.State -> CString -> IO Lua.TypeCode - -foreign import capi SAFTY "lauxlib.h luaL_loadbuffer" - luaL_loadbuffer :: Lua.State -> Ptr CChar -> CSize -> CString - -> IO Lua.StatusCode - -foreign import ccall SAFTY "lauxlib.h luaL_newmetatable" - luaL_newmetatable :: Lua.State -> CString -> IO Lua.LuaBool - -foreign import ccall unsafe "lauxlib.h hsluaL_newstate" - hsluaL_newstate :: IO Lua.State - -foreign import ccall SAFTY "lauxlib.h luaL_ref" - luaL_ref :: Lua.State -> StackIndex -> IO CInt - -foreign import ccall safe "hslua.h hsluaL_tolstring" - hsluaL_tolstring :: Lua.State -> StackIndex -> Ptr CSize -> IO (Ptr CChar) - -foreign import capi SAFTY "lauxlib.h luaL_traceback" - luaL_traceback :: Lua.State -> Lua.State -> CString -> CInt -> IO () - -foreign import ccall SAFTY "lauxlib.h luaL_unref" - luaL_unref :: Lua.State -> StackIndex -> CInt -> IO () - --- | See --- -foreign import capi SAFTY "lauxlib.h luaL_testudata" - luaL_testudata :: Lua.State -> StackIndex -> CString -> IO (Ptr ()) - --- --- References --- - --- | Reference to a stored value. -data Reference = - Reference CInt -- ^ Reference to a stored value - | RefNil -- ^ Reference to a nil value - deriving (Eq, Show) - -foreign import capi SAFTY "lauxlib.h value LUA_REFNIL" - refnil :: CInt - --- | Convert a reference to its C representation. -fromReference :: Reference -> CInt -fromReference = \case - Reference x -> x - RefNil -> refnil - --- | Create a reference from its C representation. -toReference :: CInt -> Reference -toReference x = - if x == refnil - then RefNil - else Reference x diff --git a/src/Foreign/Lua/Raw/Call.hs b/src/Foreign/Lua/Raw/Call.hs deleted file mode 100644 --- a/src/Foreign/Lua/Raw/Call.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE CPP #-} -{-| -Module : Foreign.Lua.Raw.Call -Copyright : © 2007–2012 Gracjan Polak; - © 2012–2016 Ömer Sinan Ağacan; - © 2017-2021 Albert Krewinkel -License : MIT -Maintainer : Albert Krewinkel -Stability : beta -Portability : non-portable (depends on GHC) - -Raw bindings to function call helpers. --} -module Foreign.Lua.Raw.Call - ( HsFunction - , hslua_newhsfunction - , hslua_pushhsfunction - ) where - -import Foreign.C (CInt (CInt)) -import Foreign.Ptr (Ptr, castPtr, nullPtr) -import Foreign.StablePtr (StablePtr, deRefStablePtr, newStablePtr) -import Foreign.Storable (peek) -import Foreign.Lua.Raw.Types - ( NumResults (NumResults) - , State (State) - ) - -#ifdef ALLOW_UNSAFE_GC -#define SAFTY unsafe -#else -#define SAFTY safe -#endif - --- | Type of raw Haskell functions that can be made into --- 'CFunction's. -type HsFunction = State -> IO NumResults - --- | Retrieve the pointer to a Haskell function from the wrapping --- userdata object. -foreign import ccall SAFTY "hslua.h hslua_hs_fun_ptr" - hslua_hs_fun_ptr :: State -> IO (Ptr ()) - --- | Pushes a new C function created from an 'HsFunction'. -foreign import ccall SAFTY "hslua.h hslua_newhsfunction" - hslua_newhsfunction :: State -> StablePtr a -> IO () - -hslua_pushhsfunction :: State -> HsFunction -> IO () -hslua_pushhsfunction l preCFn = - newStablePtr preCFn >>= hslua_newhsfunction l -{-# INLINABLE hslua_pushhsfunction #-} - --- | Call the Haskell function stored in the userdata. This --- function is exported as a C function, as the C code uses it as --- the @__call@ value of the wrapping userdata metatable. -hslua_call_wrapped_hs_fun :: HsFunction -hslua_call_wrapped_hs_fun l = do - udPtr <- hslua_hs_fun_ptr l - if udPtr == nullPtr - then error "Cannot call function; corrupted Lua object!" - else do - fn <- peek (castPtr udPtr) >>= deRefStablePtr - fn l - -foreign export ccall hslua_call_wrapped_hs_fun :: HsFunction diff --git a/src/Foreign/Lua/Raw/Constants.hs b/src/Foreign/Lua/Raw/Constants.hs deleted file mode 100644 --- a/src/Foreign/Lua/Raw/Constants.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-| -Module : Foreign.Lua.Raw.Constants -Copyright : © 2007–2012 Gracjan Polak; - © 2012–2016 Ömer Sinan Ağacan; - © 2017-2021 Albert Krewinkel -License : MIT -Maintainer : Albert Krewinkel -Stability : beta -Portability : ForeignFunctionInterface - -Lua constants --} -module Foreign.Lua.Raw.Constants - ( multret - , registryindex - , refnil - , noref - ) where - -import Foreign.C (CInt (..)) -import Foreign.Lua.Raw.Types - --- | Alias for C constant @LUA_MULTRET@. See --- . -foreign import capi unsafe "lua.h value LUA_MULTRET" - multret :: NumResults - --- | Alias for C constant @LUA_REGISTRYINDEX@. See --- . -foreign import capi unsafe "lua.h value LUA_REGISTRYINDEX" - registryindex :: StackIndex - --- | Value signaling that no reference was created. -foreign import capi unsafe "lauxlib.h value LUA_REFNIL" - refnil :: Int - --- | Value signaling that no reference was found. -foreign import capi unsafe "lauxlib.h value LUA_NOREF" - noref :: Int diff --git a/src/Foreign/Lua/Raw/Error.hs b/src/Foreign/Lua/Raw/Error.hs deleted file mode 100644 --- a/src/Foreign/Lua/Raw/Error.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-| -Module : Foreign.Lua.Raw.Error -Copyright : © 2017-2021 Albert Krewinkel -License : MIT -Maintainer : Albert Krewinkel -Stability : beta -Portability : portable - -Lua exceptions and exception handling. --} -module Foreign.Lua.Raw.Error - ( -- * Passing Lua errors to Haskell - errorMessage - ) where - -import Data.ByteString (ByteString) -import Foreign.Lua.Raw.Auxiliary (hsluaL_tolstring) -import Foreign.Lua.Raw.Functions (lua_pop) -import Foreign.Marshal.Alloc (alloca) -import Foreign.Ptr (nullPtr) - -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as Char8 -import qualified Foreign.Storable as Storable -import qualified Foreign.Lua.Raw.Types as Lua - --- | Retrieve and pop the top object as an error message. This is very similar --- to tostring', but ensures that we don't recurse if getting the message --- failed. -errorMessage :: Lua.State -> IO ByteString -errorMessage l = alloca $ \lenPtr -> do - cstr <- hsluaL_tolstring l (-1) lenPtr - if cstr == nullPtr - then return $ Char8.pack ("An error occurred, but the error object " ++ - "cannot be converted into a string.") - else do - cstrLen <- Storable.peek lenPtr - msg <- B.packCStringLen (cstr, fromIntegral cstrLen) - lua_pop l 2 - return msg diff --git a/src/Foreign/Lua/Raw/Functions.hs b/src/Foreign/Lua/Raw/Functions.hs deleted file mode 100644 --- a/src/Foreign/Lua/Raw/Functions.hs +++ /dev/null @@ -1,403 +0,0 @@ -{-# LANGUAGE CPP #-} -{-| -Module : Foreign.Lua.Raw.Functions -Copyright : © 2007–2012 Gracjan Polak; - © 2012–2016 Ömer Sinan Ağacan; - © 2017-2021 Albert Krewinkel -License : MIT -Maintainer : Albert Krewinkel -Stability : beta -Portability : ForeignFunctionInterface, CPP - -Haskell bindings to Lua C API functions. - -The exposed functions correspond closely to the respective C Lua API -functions. However, C API functions which can throw Lua errors are not -exported directly, as any errors would crash the program. Non-error -throwing @hslua_@ versions are provided instead. The @hslua@ ersatz -functions have worse performance than the original. - -Some of the Lua functions may, directly or indirectly, call a Haskell -function, and trigger garbage collection, rescheduling etc. These -functions are always imported safely (i.e., with the @safe@ keyword). - -However, all function can trigger garbage collection. If that can lead -to problems, then the package should be configured without flag -@allow-unsafe-gc@. --} -module Foreign.Lua.Raw.Functions where - -import Foreign.C -import Foreign.Lua.Raw.Types as Lua -import Foreign.Ptr - -#ifdef ALLOW_UNSAFE_GC -#define SAFTY unsafe -#else -#define SAFTY safe -#endif - --- * State manipulation - --- | Wrapper of @lua_close@. See the Lua docs at --- . -foreign import ccall safe "lua.h lua_close" - lua_close :: Lua.State -> IO () - - --- * Basic stack manipulation - --- | Wrapper of @lua_absindex@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_absindex" - lua_absindex :: Lua.State -> StackIndex -> IO StackIndex - --- | Wrapper of @lua_gettop@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_gettop" - lua_gettop :: Lua.State -> IO StackIndex - --- | Wrapper of @lua_settop@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_settop" - lua_settop :: Lua.State -> StackIndex -> IO () - --- | Wrapper of @lua_pushvalue@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_pushvalue" - lua_pushvalue :: Lua.State -> StackIndex -> IO () - --- | Wrapper of @lua_pop@. See the Lua docs at --- . -foreign import capi SAFTY "lua.h lua_pop" - lua_pop :: Lua.State -> StackIndex -> IO () - --- | Wrapper of @lua_copy@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_copy" - lua_copy :: Lua.State -> StackIndex -> StackIndex -> IO () - --- | Wrapper of @lua_remove@. See the Lua docs at --- . -foreign import capi SAFTY "lua.h lua_remove" - lua_remove :: Lua.State -> StackIndex -> IO () - --- | Wrapper of @lua_insert@. See the Lua docs at --- . -foreign import capi SAFTY "lua.h lua_insert" - lua_insert :: Lua.State -> StackIndex -> IO () - --- | Wrapper of @lua_replace@. See the Lua docs at --- . -foreign import capi SAFTY "lua.h lua_replace" - lua_replace :: Lua.State -> StackIndex -> IO () - --- | Wrapper of @lua_checkstack@. See the Lua docs at --- . -foreign import capi SAFTY "lua.h lua_checkstack" - lua_checkstack :: Lua.State -> CInt -> IO LuaBool - - --- * Access functions (stack -> Haskell) - --- | Wrapper of @lua_isnumber@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_isnumber" - lua_isnumber :: Lua.State -> StackIndex -> IO LuaBool - --- | Wrapper of @lua_isinteger@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_isinteger" - lua_isinteger :: Lua.State -> StackIndex -> IO LuaBool - --- | Wrapper of @lua_isstring@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_isstring" - lua_isstring :: Lua.State -> StackIndex -> IO LuaBool - --- | Wrapper of @lua_iscfunction@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_iscfunction" - lua_iscfunction :: Lua.State -> StackIndex -> IO LuaBool - --- | Wrapper of @lua_isuserdata@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_isuserdata" - lua_isuserdata :: Lua.State -> StackIndex -> IO LuaBool - --- | Wrapper of @lua_type@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_type" - lua_type :: Lua.State -> StackIndex -> IO TypeCode - --- | Wrapper of @lua_typename@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_typename" - lua_typename :: Lua.State -> TypeCode -> IO CString - --- | Wrapper around which catches any Lua errors. -foreign import capi safe "hslua.h hslua_compare" - hslua_compare :: Lua.State - -> StackIndex -> StackIndex -> CInt - -> Ptr StatusCode -> IO LuaBool - --- | Wrapper of @lua_rawequal@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_rawequal" - lua_rawequal :: Lua.State -> StackIndex -> StackIndex -> IO LuaBool - - --- | Wrapper of @lua_toboolean@. See the Lua docs at --- . -foreign import capi SAFTY "lua.h lua_toboolean" - lua_toboolean :: Lua.State -> StackIndex -> IO LuaBool - --- | Wrapper of @lua_tocfunction@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_tocfunction" - lua_tocfunction :: Lua.State -> StackIndex -> IO CFunction - --- | Wrapper of @lua_tointegerx@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_tointegerx" - lua_tointegerx :: Lua.State -> StackIndex -> Ptr LuaBool -> IO Lua.Integer - --- | Wrapper of @lua_tonumberx@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_tonumberx" - lua_tonumberx :: Lua.State -> StackIndex -> Ptr LuaBool -> IO Lua.Number - --- | Wrapper of @lua_tolstring@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_tolstring" - lua_tolstring :: Lua.State -> StackIndex -> Ptr CSize -> IO (Ptr CChar) - --- | Wrapper of @lua_topointer@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_topointer" - lua_topointer :: Lua.State -> StackIndex -> IO (Ptr ()) - --- | Wrapper of @lua_tothread@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_tothread" - lua_tothread :: Lua.State -> StackIndex -> IO Lua.State - --- | Wrapper of @lua_touserdata@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_touserdata" - lua_touserdata :: Lua.State -> StackIndex -> IO (Ptr a) - - --- | Wrapper of @lua_rawlen@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_rawlen" - lua_rawlen :: Lua.State -> StackIndex -> IO CSize - - --- * Push functions (Haskell -> stack) - --- | Wrapper of @lua_pushnil@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_pushnil" - lua_pushnil :: Lua.State -> IO () - --- | Wrapper of @lua_pushnumber@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_pushnumber" - lua_pushnumber :: Lua.State -> Lua.Number -> IO () - --- | Wrapper of @lua_pushinteger@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_pushinteger" - lua_pushinteger :: Lua.State -> Lua.Integer -> IO () - --- | Wrapper of @lua_pushlstring@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_pushlstring" - lua_pushlstring :: Lua.State -> Ptr CChar -> CSize -> IO () - --- | Wrapper of @lua_pushcclosure@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_pushcclosure" - lua_pushcclosure :: Lua.State -> CFunction -> NumArgs -> IO () - --- | Wrapper of @lua_pushboolean@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_pushboolean" - lua_pushboolean :: Lua.State -> LuaBool -> IO () - --- | Wrapper of @lua_pushlightuserdata@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_pushlightuserdata" - lua_pushlightuserdata :: Lua.State -> Ptr a -> IO () - --- | Wrapper of @lua_pushthread@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_pushthread" - lua_pushthread :: Lua.State -> IO CInt - - --- * Get functions (Lua -> stack) - --- | Wrapper around --- . --- which catches any Lua errors. -foreign import ccall safe "hslua.h hslua_gettable" - hslua_gettable :: Lua.State -> StackIndex -> Ptr StatusCode -> IO () - --- | Wrapper of @lua_rawget@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_rawget" - lua_rawget :: Lua.State -> StackIndex -> IO () - --- | Wrapper of @lua_rawgeti@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_rawgeti" - lua_rawgeti :: Lua.State -> StackIndex -> Lua.Integer -> IO () - --- | Wrapper of @lua_createtable@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_createtable" - lua_createtable :: Lua.State -> CInt -> CInt -> IO () - --- | Wrapper of @lua_newuserdata@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_newuserdata" - lua_newuserdata :: Lua.State -> CSize -> IO (Ptr ()) - --- | Wrapper of @lua_getmetatable@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_getmetatable" - lua_getmetatable :: Lua.State -> StackIndex -> IO LuaBool - --- | Wrapper around --- --- which catches any Lua errors. -foreign import ccall safe "hslua.h hslua_getglobal" - hslua_getglobal :: Lua.State -> CString -> CSize -> Ptr StatusCode -> IO () - - --- * Set functions (stack -> Lua) - --- | Wrapper around which catches any Lua errors. -foreign import ccall safe "hslua.h hslua_settable" - hslua_settable :: Lua.State -> StackIndex -> Ptr StatusCode -> IO () - --- | Wrapper of @lua_rawset@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_rawset" - lua_rawset :: Lua.State -> StackIndex -> IO () - --- | Wrapper of @lua_rawseti@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_rawseti" - lua_rawseti :: Lua.State -> StackIndex -> Lua.Integer -> IO () - --- | Wrapper of @lua_setmetatable@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_setmetatable" - lua_setmetatable :: Lua.State -> StackIndex -> IO () - --- | Wrapper around which catches any Lua errors. -foreign import ccall safe "hslua.h hslua_setglobal" - hslua_setglobal :: Lua.State -> CString -> CSize -> Ptr StatusCode -> IO () - - --- * \'load\' and \'call\' functions (load and run Lua code) - --- | Wrapper of @lua_pcall@. See the Lua docs at --- . -foreign import capi safe "lua.h lua_pcall" - lua_pcall :: Lua.State -> NumArgs -> NumResults -> StackIndex - -> IO StatusCode - --- | Wrapper of @lua_load@. See the Lua docs at --- . -foreign import ccall safe "lua.h lua_load" - lua_load :: Lua.State -> Lua.Reader -> Ptr () -> CString -> CString - -> IO StatusCode - - --- * Coroutine functions - --- | Wrapper of @lua_status@. See the Lua docs at --- . -foreign import ccall SAFTY "lua.h lua_status" - lua_status :: Lua.State -> IO StatusCode - - --- * Garbage-collection functions and options - --- | Wrapper of @lua_gc@. See the Lua docs at --- . -foreign import ccall safe "lua.h lua_gc" - lua_gc :: Lua.State -> CInt -> CInt -> IO CInt - - --- * Miscellaneous functions - --- | Replacement for --- ; it uses --- the HsLua error signaling convention instead of raw Lua errors. -foreign import ccall SAFTY "hslua.h hslua_error" - hslua_error :: Lua.State -> IO NumResults - --- | Wrapper around --- which --- catches any Lua errors. -foreign import ccall safe "hslua.h hslua_next" - hslua_next :: Lua.State -> StackIndex -> Ptr StatusCode -> IO LuaBool - --- | Wrapper around --- --- which catches any Lua errors. -foreign import ccall safe "hslua.h hslua_concat" - hslua_concat :: Lua.State -> NumArgs -> Ptr StatusCode -> IO () - --- | Wrapper of @lua_pushglobaltable@. See the Lua docs at --- . -foreign import capi SAFTY "lua.h lua_pushglobaltable" - lua_pushglobaltable :: Lua.State -> IO () - - --- * Lua Libraries - --- | Wrapper of @luaL_openlibs@. See the Lua docs at --- . -foreign import ccall unsafe "lualib.h luaL_openlibs" - luaL_openlibs :: Lua.State -> IO () - --- | Point to function opening the base library. -foreign import ccall unsafe "lualib.h &luaopen_base" - lua_open_base_ptr :: CFunction - --- | Point to function opening the table library. -foreign import ccall unsafe "lualib.h &luaopen_table" - lua_open_table_ptr :: CFunction - --- | Point to function opening the io library. -foreign import ccall unsafe "lualib.h &luaopen_io" - lua_open_io_ptr :: CFunction - --- | Point to function opening the os library. -foreign import ccall unsafe "lualib.h &luaopen_os" - lua_open_os_ptr :: CFunction - --- | Point to function opening the string library. -foreign import ccall unsafe "lualib.h &luaopen_string" - lua_open_string_ptr :: CFunction - --- | Point to function opening the math library. -foreign import ccall unsafe "lualib.h &luaopen_math" - lua_open_math_ptr :: CFunction - --- | Point to function opening the debug library. -foreign import ccall unsafe "lualib.h &luaopen_debug" - lua_open_debug_ptr :: CFunction - --- | Point to function opening the package library. -foreign import ccall unsafe "lualib.h &luaopen_package" - lua_open_package_ptr :: CFunction diff --git a/src/Foreign/Lua/Raw/Types.hsc b/src/Foreign/Lua/Raw/Types.hsc deleted file mode 100644 --- a/src/Foreign/Lua/Raw/Types.hsc +++ /dev/null @@ -1,281 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-| -Module : Foreign.Lua.Raw.Types -Copyright : © 2007–2012 Gracjan Polak; - © 2012–2016 Ömer Sinan Ağacan; - © 2017-2021 Albert Krewinkel -License : MIT -Maintainer : Albert Krewinkel -Stability : beta -Portability : non-portable (depends on GHC) - -The core Lua types, including mappings of Lua types to Haskell. --} -module Foreign.Lua.Raw.Types - ( State (..) - , Reader - , GCCONTROL (..) - , Type (..) - , TypeCode (..) - , fromType - , toType - , CFunction - , LuaBool (..) - , false - , true - , fromLuaBool - , toLuaBool - , Integer (..) - , Number (..) - , StackIndex (..) - , NumArgs (..) - , NumResults (..) - , RelationalOperator (..) - , fromRelationalOperator - , Status (..) - , StatusCode (..) - , toStatus - ) where - -#include "lua.h" --- required only for LUA_ERRFILE -#include "lauxlib.h" - -import Prelude hiding (Integer, EQ, LT) - -import Data.Int (#{type LUA_INTEGER}) -import Foreign.C (CChar, CInt, CSize) -import Foreign.Ptr (FunPtr, Ptr) -import Foreign.Storable (Storable) -import GHC.Generics (Generic) - --- | An opaque structure that points to a thread and indirectly (through the --- thread) to the whole state of a Lua interpreter. The Lua library is fully --- reentrant: it has no global variables. All information about a state is --- accessible through this structure. --- --- Synonym for @lua_State *@. See . -newtype State = State (Ptr ()) deriving (Eq, Generic) - --- | Type for C functions. --- --- In order to communicate properly with Lua, a C function must use the --- following protocol, which defines the way parameters and results are --- passed: a C function receives its arguments from Lua in its stack in --- direct order (the first argument is pushed first). So, when the --- function starts, @'Foreign.Lua.Core.Functions.gettop'@ returns the --- number of arguments received by the function. The first argument (if --- any) is at index 1 and its last argument is at index --- @'Foreign.Lua.Core.Functions.gettop'@. To return values to Lua, a C --- function just pushes them onto the stack, in direct order (the first --- result is pushed first), and returns the number of results. Any other --- value in the stack below the results will be properly discarded by --- Lua. Like a Lua function, a C function called by Lua can also return --- many results. --- --- See . -type CFunction = FunPtr (State -> IO NumResults) - --- | The reader function used by @'Foreign.Lua.Core.Functions.load'@. --- Every time it needs another piece of the chunk, lua_load calls the --- reader, passing along its data parameter. The reader must return a --- pointer to a block of memory with a new piece of the chunk and set --- size to the block size. The block must exist until the reader --- function is called again. To signal the end of the chunk, the reader --- must return @NULL@ or set size to zero. The reader function may --- return pieces of any size greater than zero. --- --- See . -type Reader = FunPtr (State -> Ptr () -> Ptr CSize -> IO (Ptr CChar)) - --- | The type of integers in Lua. --- --- By default this type is @'Int64'@, but that can be changed to different --- values in lua. (See @LUA_INT_TYPE@ in @luaconf.h@.) --- --- See . -newtype Integer = Integer #{type LUA_INTEGER} - deriving (Bounded, Enum, Eq, Integral, Num, Ord, Real, Show) - --- | The type of floats in Lua. --- --- By default this type is @'Double'@, but that can be changed in Lua to a --- single float or a long double. (See @LUA_FLOAT_TYPE@ in @luaconf.h@.) --- --- See . -newtype Number = Number #{type LUA_NUMBER} - deriving (Eq, Floating, Fractional, Num, Ord, Real, RealFloat, RealFrac, Show) - - --- --- LuaBool --- - --- | Boolean value returned by a Lua C API function. This is a @'CInt'@ and --- interpreted as @'False'@ iff the value is @0@, @'True'@ otherwise. -newtype LuaBool = LuaBool CInt - deriving (Eq, Storable, Show) - --- | Generic Lua representation of a value interpreted as being true. -true :: LuaBool -true = LuaBool 1 - --- | Lua representation of the value interpreted as false. -false :: LuaBool -false = LuaBool 0 - --- | Convert a @'LuaBool'@ to a Haskell @'Bool'@. -fromLuaBool :: LuaBool -> Bool -fromLuaBool (LuaBool 0) = False -fromLuaBool _ = True -{-# INLINABLE fromLuaBool #-} - --- | Convert a Haskell @'Bool'@ to a @'LuaBool'@. -toLuaBool :: Bool -> LuaBool -toLuaBool True = true -toLuaBool False = false -{-# INLINABLE toLuaBool #-} - - --- --- * Type of Lua values --- - --- | Enumeration used as type tag. --- See . -data Type - = TypeNone -- ^ non-valid stack index - | TypeNil -- ^ type of lua's @nil@ value - | TypeBoolean -- ^ type of lua booleans - | TypeLightUserdata -- ^ type of light userdata - | TypeNumber -- ^ type of lua numbers. See @'Lua.Number'@ - | TypeString -- ^ type of lua string values - | TypeTable -- ^ type of lua tables - | TypeFunction -- ^ type of functions, either normal or @'CFunction'@ - | TypeUserdata -- ^ type of full user data - | TypeThread -- ^ type of lua threads - deriving (Bounded, Eq, Ord, Show) - --- | Integer code used to encode the type of a lua value. -newtype TypeCode = TypeCode { fromTypeCode :: CInt } - deriving (Eq, Ord, Show) - -instance Enum Type where - fromEnum = fromIntegral . fromTypeCode . fromType - toEnum = toType . TypeCode . fromIntegral - --- | Convert a lua Type to a type code which can be passed to the C API. -fromType :: Type -> TypeCode -fromType tp = TypeCode $ case tp of - TypeNone -> #{const LUA_TNONE} - TypeNil -> #{const LUA_TNIL} - TypeBoolean -> #{const LUA_TBOOLEAN} - TypeLightUserdata -> #{const LUA_TLIGHTUSERDATA} - TypeNumber -> #{const LUA_TNUMBER} - TypeString -> #{const LUA_TSTRING} - TypeTable -> #{const LUA_TTABLE} - TypeFunction -> #{const LUA_TFUNCTION} - TypeUserdata -> #{const LUA_TUSERDATA} - TypeThread -> #{const LUA_TTHREAD} - --- | Convert numerical code to lua type. -toType :: TypeCode -> Type -toType (TypeCode c) = case c of - #{const LUA_TNONE} -> TypeNone - #{const LUA_TNIL} -> TypeNil - #{const LUA_TBOOLEAN} -> TypeBoolean - #{const LUA_TLIGHTUSERDATA} -> TypeLightUserdata - #{const LUA_TNUMBER} -> TypeNumber - #{const LUA_TSTRING} -> TypeString - #{const LUA_TTABLE} -> TypeTable - #{const LUA_TFUNCTION} -> TypeFunction - #{const LUA_TUSERDATA} -> TypeUserdata - #{const LUA_TTHREAD} -> TypeThread - _ -> error ("No Type corresponding to " ++ show c) - --- --- * Relational Operator --- - --- | Lua comparison operations. -data RelationalOperator - = EQ -- ^ Correponds to lua's equality (==) operator. - | LT -- ^ Correponds to lua's strictly-lesser-than (<) operator - | LE -- ^ Correponds to lua's lesser-or-equal (<=) operator - deriving (Eq, Ord, Show) - --- | Convert relation operator to its C representation. -fromRelationalOperator :: RelationalOperator -> CInt -fromRelationalOperator EQ = #{const LUA_OPEQ} -fromRelationalOperator LT = #{const LUA_OPLT} -fromRelationalOperator LE = #{const LUA_OPLE} -{-# INLINABLE fromRelationalOperator #-} - - --- --- * Status --- - --- | Lua status values. -data Status - = OK -- ^ success - | Yield -- ^ yielding / suspended coroutine - | ErrRun -- ^ a runtime rror - | ErrSyntax -- ^ syntax error during precompilation - | ErrMem -- ^ memory allocation (out-of-memory) error. - | ErrErr -- ^ error while running the message handler. - | ErrGcmm -- ^ error while running a @__gc@ metamethod. - | ErrFile -- ^ opening or reading a file failed. - deriving (Eq, Show) - --- | Convert C integer constant to @'Status'@. -toStatus :: StatusCode -> Status -toStatus (StatusCode c) = case c of - #{const LUA_OK} -> OK - #{const LUA_YIELD} -> Yield - #{const LUA_ERRRUN} -> ErrRun - #{const LUA_ERRSYNTAX} -> ErrSyntax - #{const LUA_ERRMEM} -> ErrMem - #{const LUA_ERRGCMM} -> ErrGcmm - #{const LUA_ERRERR} -> ErrErr - #{const LUA_ERRFILE} -> ErrFile - n -> error $ "Cannot convert (" ++ show n ++ ") to Status" -{-# INLINABLE toStatus #-} - --- | Integer code used to signal the status of a thread or computation. --- See @'Status'@. -newtype StatusCode = StatusCode CInt deriving (Eq, Storable) - - --- --- * Gargabe Collection Control --- - --- | Enumeration used by @gc@ function. -data GCCONTROL - = GCSTOP - | GCRESTART - | GCCOLLECT - | GCCOUNT - | GCCOUNTB - | GCSTEP - | GCSETPAUSE - | GCSETSTEPMUL - deriving (Enum, Eq, Ord, Show) - --- | A stack index -newtype StackIndex = StackIndex { fromStackIndex :: CInt } - deriving (Enum, Eq, Num, Ord, Show) - --- --- Number of arguments and return values --- - --- | The number of arguments consumed curing a function call. -newtype NumArgs = NumArgs { fromNumArgs :: CInt } - deriving (Eq, Num, Ord, Show) - --- | The number of results returned by a function call. -newtype NumResults = NumResults { fromNumResults :: CInt } - deriving (Eq, Num, Ord, Show) diff --git a/src/Foreign/Lua/Raw/Userdata.hs b/src/Foreign/Lua/Raw/Userdata.hs deleted file mode 100644 --- a/src/Foreign/Lua/Raw/Userdata.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE CPP #-} -{-| -Module : Foreign.Lua.Raw.Userdata -Copyright : © 2017-2021 Albert Krewinkel -License : MIT -Maintainer : Albert Krewinkel -Stability : beta -Portability : ForeignFunctionInterface - -Bindings to HsLua-specific functions used to push Haskell values -as userdata. --} -module Foreign.Lua.Raw.Userdata - ( hslua_fromuserdata - , hslua_newhsuserdata - , hslua_newudmetatable - ) where - -import Foreign.C (CInt (CInt), CString) -import Foreign.Lua.Raw.Auxiliary (luaL_testudata) -import Foreign.Lua.Raw.Functions (lua_newuserdata) -import Foreign.Lua.Raw.Types - ( LuaBool (..) - , StackIndex (..) - , State (..) - ) -import Foreign.Ptr (castPtr, nullPtr) -import Foreign.StablePtr (newStablePtr, deRefStablePtr) -import Foreign.Storable (peek, poke, sizeOf) - -#ifdef ALLOW_UNSAFE_GC -#define SAFTY unsafe -#else -#define SAFTY safe -#endif - --- | Creates and registers a new metatable for a userdata-wrapped --- Haskell value; checks whether a metatable of that name has been --- registered yet and uses the registered table if possible. -foreign import ccall SAFTY "hsludata.h hslua_newudmetatable" - hslua_newudmetatable :: State -- ^ Lua state - -> CString -- ^ Userdata name (__name) - -> IO LuaBool -- ^ True iff new metatable - -- was created. - --- | Creates a new userdata wrapping the given Haskell object. -hslua_newhsuserdata :: State -> a -> IO () -hslua_newhsuserdata l x = do - xPtr <- newStablePtr x - udPtr <- lua_newuserdata l (fromIntegral $ sizeOf xPtr) - poke (castPtr udPtr) xPtr -{-# INLINABLE hslua_newhsuserdata #-} - --- | Retrieves a Haskell object from userdata at the given index. --- The userdata /must/ have the given name. -hslua_fromuserdata :: State - -> StackIndex -- ^ userdata index - -> CString -- ^ name - -> IO (Maybe a) -hslua_fromuserdata l idx name = do - udPtr <- luaL_testudata l idx name - if udPtr == nullPtr - then return Nothing - else Just <$> (peek (castPtr udPtr) >>= deRefStablePtr) -{-# INLINABLE hslua_fromuserdata #-} diff --git a/src/Lua.hs b/src/Lua.hs new file mode 100644 --- /dev/null +++ b/src/Lua.hs @@ -0,0 +1,293 @@ +{-# OPTIONS_GHC -Wno-warnings-deprecations #-} +{-# LANGUAGE PatternSynonyms #-} +{-| +Module : Lua +Copyright : © 2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : portable + +Extend Haskell programs with a Lua interpreter. + +This package provides the basic building blocks to integrate Lua into a +Haskell program. The library is kept very close to the C Lua API, and +users familiar with the C API should have no problem using it. + +However, there are important differences of which users must be aware: +The method for error signaling used in Lua, based on @setjmp@ and +@longjmp@, is incompatible with the Haskell FFI. All errors /must/ be +handled at language boundaries, as failure to do so will lead to +unrecoverable crashes. C API functions that can throw Lua errors are +still exported, but non-error throwing @hslua_@ versions are provided as +safer alternatives. . The @hslua@ ersatz functions have worse +performance than the original versions, but should be fast enough for +most use cases. + +The Haskell FFI requires all C function that can call back into Haskell +to be imported @safe@ly. Some of the Lua functions may, directly or +indirectly, call a Haskell function, so they are always imported with +the @safe@ keyword. + +Many API functions can trigger garbage collection. This will lead to +problems if Haskell functions are used as part of finalizers (i.e., +@__gc@ metamethods). Haskell in finalizers is not supported by default, +but can be enabled by unsetting the @allow-unsafe-gc@ flag. +-} +module Lua + ( -- * Run Lua operations + withNewState + -- * Types + , State (..) + , Reader + -- ** Base Lua types + , CFunction + , PreCFunction + , Lua.Integer (..) + , Number (..) + -- *** Booleans + , LuaBool (..) + , pattern TRUE + , pattern FALSE + -- ** Stack indices + , StackIndex (..) + , pattern LUA_REGISTRYINDEX + -- ** Function calling + , NumArgs (..) + , NumResults (..) + , pattern LUA_MULTRET + -- ** Basic types + , TypeCode (..) + , pattern LUA_TNONE + , pattern LUA_TNIL + , pattern LUA_TBOOLEAN + , pattern LUA_TLIGHTUSERDATA + , pattern LUA_TNUMBER + , pattern LUA_TSTRING + , pattern LUA_TTABLE + , pattern LUA_TFUNCTION + , pattern LUA_TUSERDATA + , pattern LUA_TTHREAD + -- ** Relational operator codes + , OPCode (..) + , pattern LUA_OPEQ + , pattern LUA_OPLT + , pattern LUA_OPLE + , StatusCode (..) + -- ** Status codes + , pattern LUA_OK + , pattern LUA_YIELD + , pattern LUA_ERRRUN + , pattern LUA_ERRSYNTAX + , pattern LUA_ERRMEM + , pattern LUA_ERRGCMM + , pattern LUA_ERRERR + , pattern LUA_ERRFILE + + -- * Stack index helpers + , nthTop + , nthBottom + , nth + , top + -- * Functions + , -- ** State manipulation + lua_close + , lua_newthread + -- ** Basic stack manipulation + , lua_absindex + , lua_gettop + , lua_settop + , lua_pushvalue + , lua_pop + , lua_copy + , lua_remove + , lua_insert + , lua_replace + , lua_checkstack + -- ** Access functions (stack → Haskell) + , lua_isnil + , lua_isboolean + , lua_isnumber + , lua_isinteger + , lua_isstring + , lua_isfunction + , lua_istable + , lua_iscfunction + , lua_isuserdata + , lua_islightuserdata + , lua_isthread + , lua_isnone + , lua_isnoneornil + , lua_type + , lua_typename + , lua_rawequal + , lua_toboolean + , lua_tocfunction + , lua_tointegerx + , lua_tonumberx + , lua_tolstring + , lua_topointer + , lua_tothread + , lua_touserdata + , lua_rawlen + -- ** Push functions (Haskell → stack) + , lua_pushnil + , lua_pushnumber + , lua_pushinteger + , lua_pushlstring + , lua_pushstring + , lua_pushcclosure + , lua_pushboolean + , lua_pushlightuserdata + , lua_pushthread + -- ** Get functions (Lua → stack) + , lua_rawget + , lua_rawgeti + , lua_createtable + , lua_newuserdata + , lua_getmetatable + , lua_getuservalue + , lua_getglobal + , lua_gettable + -- ** Set functions (stack → Lua) + , lua_rawset + , lua_rawseti + , lua_setmetatable + , lua_setuservalue + , lua_setglobal + , lua_settable + -- ** Misc (unsafe) + , lua_concat + , lua_next + -- ** Load and run Lua code + , lua_pcall + , lua_load + -- ** Coroutine functions + , lua_status + -- ** Garbage-collection + , lua_gc + , GCCode (..) + , pattern LUA_GCSTOP + , pattern LUA_GCRESTART + , pattern LUA_GCCOLLECT + , pattern LUA_GCCOUNT + , pattern LUA_GCCOUNTB + , pattern LUA_GCSTEP + , pattern LUA_GCSETPAUSE + , pattern LUA_GCSETSTEPMUL + , pattern LUA_GCISRUNNING + -- ** Miscellaneous functions + , lua_pushglobaltable + + -- * The Auxiliary Library + , luaL_getmetafield + , luaL_getmetatable + , luaL_loadbuffer + , luaL_openlibs + , luaL_newmetatable + , luaL_ref + , luaL_testudata + , luaL_traceback + , luaL_unref + -- ** Registry fields + , loadedTableRegistryField + , preloadTableRegistryField + -- ** References + , Reference (..) + , pattern LUA_REFNIL + , pattern LUA_NOREF + , fromReference + , toReference + + -- * Ersatz functions + , hsluaL_newstate + , hsluaL_tolstring + -- ** Get functions (Lua → stack) + , hslua_gettable + , hslua_getglobal + -- ** Set functions (stack → Lua) + , hslua_settable + , hslua_setglobal + -- ** Misc + , hslua_error + , hslua_next + , hslua_concat + , hslua_compare + + -- * Standard Lua libraries + , luaopen_base + , luaopen_table + , luaopen_io + , luaopen_os + , luaopen_string + , luaopen_math + , luaopen_debug + , luaopen_package + + -- * Push Haskell functions + , hslua_pushhsfunction + ) where + +import Foreign.C (CInt) +import Lua.Auxiliary +import Lua.Call +import Lua.Constants +import Lua.Ersatz.Functions +import Lua.Ersatz.Auxiliary +import Lua.Lib +import Lua.Primary +import Lua.Types as Lua + +-- | Runs operations on a new Lua @'Lua.State'@. The state is created +-- when the function is called and closed on return. The state, and all +-- pointers to values within it, __must not__ be used after the function +-- returns. +-- +-- === Example +-- Run a small Lua operation (prints the major version of Lua). +-- +-- > withNewState $ \l -> do +-- > luaL_openlibs l +-- > withCString "print" (lua_getglobal l) +-- > withCString "_VERSION" (lua_getglobal l) +-- > lua_pcall l (NumArgs 1) (NumResults 1) (StackIndex 0) +-- +-- @since 2.0.0 +withNewState :: (State -> IO a) -> IO a +withNewState f = do + l <- hsluaL_newstate + result <- f l + lua_close l + return result + +-- +-- Stack index helpers +-- + +-- | Stack index of the nth element from the top of the stack. +-- +-- @since 2.0.0 +nthTop :: CInt -> StackIndex +nthTop n = StackIndex (-n) +{-# INLINABLE nthTop #-} + +-- | Stack index of the nth element from the bottom of the stack. +-- +-- @since 2.0.0 +nthBottom :: CInt -> StackIndex +nthBottom = StackIndex +{-# INLINABLE nthBottom #-} + +-- | Alias for 'nthTop'. +-- +-- @since 2.0.0 +nth :: CInt -> StackIndex +nth = nthTop +{-# INLINABLE nth #-} + +-- | Index of the topmost stack element. +-- +-- @since 2.0.0 +top :: StackIndex +top = nthTop 1 +{-# INLINABLE top #-} diff --git a/src/Lua/Auxiliary.hs b/src/Lua/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/src/Lua/Auxiliary.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE CPP #-} +{-| +Module : Lua.Auxiliary +Copyright : © 2007–2012 Gracjan Polak; + © 2012–2016 Ömer Sinan Ağacan; + © 2017-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : non-portable (depends on GHC) + +Raw bindings to functions and constants of the auxiliary library. +-} +module Lua.Auxiliary + ( -- * The Auxiliary Library + luaL_getmetafield + , luaL_getmetatable + , luaL_loadbuffer + , luaL_loadfile + , luaL_loadfilex + , luaL_openlibs + , luaL_newmetatable + , luaL_ref + , luaL_testudata + , luaL_traceback + , luaL_unref + , luaL_where + -- ** Registry fields + , loadedTableRegistryField + , preloadTableRegistryField + -- ** References + , Reference (..) + , fromReference + , toReference + ) where + +import Foreign.C (CChar, CInt (CInt), CSize (CSize), CString) +import Lua.Types as Lua +import Foreign.Ptr + +#ifndef HARDCODE_REG_KEYS +import System.IO.Unsafe (unsafePerformIO) +import qualified Foreign.C as C +#endif + +#ifdef ALLOW_UNSAFE_GC +#define SAFTY unsafe +#else +#define SAFTY safe +#endif + +-- * The Auxiliary Library + +-- | Key, in the registry, for table of loaded modules. +loadedTableRegistryField :: String +#ifdef HARDCODE_REG_KEYS +loadedTableRegistryField = "_LOADED" +#else +loadedTableRegistryField = unsafePerformIO (C.peekCString c_loaded_table) +{-# NOINLINE loadedTableRegistryField #-} + +foreign import capi unsafe "lauxlib.h value LUA_LOADED_TABLE" + c_loaded_table :: CString +#endif + +-- | Key, in the registry, for table of preloaded loaders. +preloadTableRegistryField :: String +#ifdef HARDCODE_REG_KEYS +preloadTableRegistryField = "_PRELOAD" +#else +preloadTableRegistryField = unsafePerformIO (C.peekCString c_preload_table) +{-# NOINLINE preloadTableRegistryField #-} + +foreign import capi unsafe "lauxlib.h value LUA_PRELOAD_TABLE" + c_preload_table :: CString +#endif + +-- | Pushes onto the stack the field @e@ from the metatable of the +-- object at index @obj@ and returns the type of the pushed value. If +-- the object does not have a metatable, or if the metatable does not +-- have this field, pushes nothing and returns +-- @'Lua.Constants.LUA_TNIL'@. +foreign import capi SAFTY "lauxlib.h luaL_getmetafield" + luaL_getmetafield :: Lua.State + -> StackIndex -- ^ obj + -> CString -- ^ e + -> IO TypeCode + +-- | Pushes onto the stack the metatable associated with name tname in +-- the registry (see @'luaL_newmetatable'@) (__nil__ if there is no +-- metatable associated with that name). Returns the type of the pushed +-- value. +foreign import capi SAFTY "lauxlib.h luaL_getmetatable" + luaL_getmetatable :: Lua.State -> CString -> IO Lua.TypeCode + +-- | Loads a buffer as a Lua chunk. This function uses @lua_load@ to +-- load the chunk in the buffer pointed to by @buff@ with size @sz@. +-- +-- This function returns the same results as @lua_load@. @name@ is the +-- chunk name, used for debug information and error messages. +foreign import capi SAFTY "lauxlib.h luaL_loadbuffer" + luaL_loadbuffer :: Lua.State + -> Ptr CChar -- ^ buff + -> CSize -- ^ sz + -> CString -- ^ name + -> IO Lua.StatusCode + +-- | Equivalent to luaL_loadfilex with mode equal to @NULL@. +foreign import capi SAFTY "lauxlib.h luaL_loadfile" + luaL_loadfile :: Lua.State + -> Ptr CChar -- ^ filename + -> IO Lua.StatusCode + +-- | Loads a file as a Lua chunk. This function uses @lua_load@ to load +-- the chunk in the file named filename. If filename is @NULL@, then it +-- loads from the standard input. The first line in the file is ignored +-- if it starts with a @#@. +-- +-- The string mode works as in function @lua_load@. +-- +-- This function returns the same results as @lua_load@, but it has an +-- extra error code LUA_ERRFILE for file-related errors (e.g., it cannot +-- open or read the file). +-- +-- As @lua_load@, this function only loads the chunk; it does not run +-- it. +foreign import capi SAFTY "lauxlib.h luaL_loadfilex" + luaL_loadfilex :: Lua.State + -> Ptr CChar -- ^ filename + -> Ptr CChar -- ^ mode + -> IO Lua.StatusCode + +-- | If the registry already has the key @tname@, returns @0@. +-- Otherwise, creates a new table to be used as a metatable for +-- userdata, adds to this new table the pair @__name = tname@, adds to +-- the registry the pair @[tname] = new table@, and returns @1@. (The +-- entry @__name@ is used by some error-reporting functions.) +-- +-- In both cases pushes onto the stack the final value associated with +-- @tname@ in the registry. +foreign import ccall SAFTY "lauxlib.h luaL_newmetatable" + luaL_newmetatable :: Lua.State -> CString {- ^ tname -} -> IO Lua.LuaBool + +-- | Opens all standard Lua libraries into the given state. +-- +-- +foreign import ccall unsafe "lualib.h luaL_openlibs" + luaL_openlibs :: Lua.State -> IO () + +-- | Creates and returns a reference, in the table at index @t@, for the +-- object at the top of the stack (and pops the object). +-- +-- A reference is a unique integer key. As long as you do not manually +-- add integer keys into table @t@, @luaL_ref@ ensures the uniqueness of +-- the key it returns. You can retrieve an object referred by reference +-- @r@ by calling @lua_rawgeti l t r@. Function @'luaL_unref'@ frees a +-- reference and its associated object. +-- +-- If the object at the top of the stack is nil, @luaL_ref@ returns the +-- constant @'Lua.Constants.LUA_REFNIL'@. The constant +-- @'Lua.Constants.LUA_NOREF'@ is guaranteed to be different +-- from any reference returned by @luaL_ref@. +foreign import ccall SAFTY "lauxlib.h luaL_ref" + luaL_ref :: Lua.State -> StackIndex {- ^ t -} -> IO CInt + +-- | Creates and pushes a traceback of the stack @l1@. If @msg@ is not +-- @NULL@ it is appended at the beginning of the traceback. The level +-- parameter tells at which level to start the traceback. +foreign import capi SAFTY "lauxlib.h luaL_traceback" + luaL_traceback :: Lua.State -- ^ l + -> Lua.State -- ^ l1 + -> CString -- ^ msg + -> CInt -- ^ level + -> IO () + +-- | Releases reference @ref@ from the table at index @t@ (see +-- @'luaL_ref'@). The entry is removed from the table, so that the +-- referred object can be collected. The reference @ref@ is also freed +-- to be used again. +foreign import ccall SAFTY "lauxlib.h luaL_unref" + luaL_unref :: Lua.State -> StackIndex {- ^ t -} -> CInt {- ^ ref -} -> IO () + +-- | Checks whether the function argument @arg@ is a userdata of the +-- type @tname@ (see @'luaL_newmetatable'@) and returns the userdata +-- address (see @'Lua.lua_touserdata'@). Returns @NULL@ if the +-- test fails. +-- +-- +foreign import capi SAFTY "lauxlib.h luaL_testudata" + luaL_testudata :: Lua.State -- ^ l + -> StackIndex -- ^ arg + -> CString -- ^ tname + -> IO (Ptr ()) + +-- | Pushes onto the stack a string identifying the current position of +-- the control at level @lvl@ in the call stack. Typically this string +-- has the following format: +-- +-- > chunkname:currentline: +-- +-- Level 0 is the running function, level 1 is the function that called +-- the running function, etc. +-- +-- This function is used to build a prefix for error messages. +foreign import capi SAFTY "lauxlib.h luaL_where" + luaL_where :: Lua.State -- ^ l + -> CInt -- ^ lvl + -> IO () + +-- +-- References +-- + +-- | Reference to a stored value. +data Reference = + Reference CInt -- ^ Reference to a stored value + | RefNil -- ^ Reference to a nil value + deriving (Eq, Show) + +foreign import capi SAFTY "lauxlib.h value LUA_REFNIL" + refnil :: CInt + +-- | Convert a reference to its C representation. +fromReference :: Reference -> CInt +fromReference = \case + Reference x -> x + RefNil -> refnil + +-- | Create a reference from its C representation. +toReference :: CInt -> Reference +toReference x = + if x == refnil + then RefNil + else Reference x diff --git a/src/Lua/Call.hs b/src/Lua/Call.hs new file mode 100644 --- /dev/null +++ b/src/Lua/Call.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE CPP #-} +{-| +Module : Lua.Call +Copyright : © 2007–2012 Gracjan Polak; + © 2012–2016 Ömer Sinan Ağacan; + © 2017-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : non-portable (depends on GHC) + +Function to push Haskell functions as Lua C functions. + +Haskell functions are converted into C functions in a two-step process. +First, a function pointer to the Haskell function is stored in a Lua +userdata object. The userdata gets a metatable which allows to invoke +the object as a function. The userdata also ensures that the function +pointer is freed when the object is garbage collected in Lua. + +In a second step, the userdata is then wrapped into a C closure. The +wrapping function calls the userdata object and implements the error +protocol, converting special error values into proper Lua errors. +-} +module Lua.Call + ( hslua_pushhsfunction + ) where + +import Foreign.C (CInt (CInt)) +import Foreign.Ptr (Ptr, castPtr, nullPtr) +import Foreign.StablePtr (StablePtr, deRefStablePtr, newStablePtr) +import Foreign.Storable (peek) +import Lua.Types + ( NumResults (NumResults) + , PreCFunction + , State (State) + ) + +#ifdef ALLOW_UNSAFE_GC +#define SAFTY unsafe +#else +#define SAFTY safe +#endif + +-- | Retrieve the pointer to a Haskell function from the wrapping +-- userdata object. +foreign import ccall SAFTY "hslcall.c hslua_extracthsfun" + hslua_extracthsfun :: State -> IO (Ptr ()) + +-- | Creates a new C function created from a 'PreCFunction'. The +-- function pointer to the PreCFunction is stored in a userdata object, +-- which is then wrapped by a C closure. The userdata object ensures +-- that the function pointer is freed when the function is garbage +-- collected in Lua. +foreign import ccall SAFTY "hslcall.c hslua_newhsfunction" + hslua_newhsfunction :: State -> StablePtr a -> IO () + +-- | Pushes a Haskell operation as a Lua function. The Haskell operation +-- is expected to follow the custom error protocol, i.e., it must signal +-- errors with @'Lua.hslua_error'@. +-- +-- === Example +-- Export the function to calculate triangular numbers. +-- +-- > let triangular :: PreCFunction +-- > triangular l' = do +-- > n <- lua_tointegerx l' (nthBottom 1) nullPtr +-- > lua_pushinteger l' (sum [1..n]) +-- > return (NumResults 1) +-- > +-- > hslua_newhsfunction l triangular +-- > withCString "triangular" (lua_setglobal l) +-- +hslua_pushhsfunction :: State -> PreCFunction -> IO () +hslua_pushhsfunction l preCFn = + newStablePtr preCFn >>= hslua_newhsfunction l +{-# INLINABLE hslua_pushhsfunction #-} + +-- | Call the Haskell function stored in the userdata. This +-- function is exported as a C function, as the C code uses it as +-- the @__call@ value of the wrapping userdata metatable. +hslua_callhsfun :: PreCFunction +hslua_callhsfun l = do + udPtr <- hslua_extracthsfun l + if udPtr == nullPtr + then error "Cannot call function; corrupted Lua object!" + else do + fn <- peek (castPtr udPtr) >>= deRefStablePtr + fn l + +foreign export ccall hslua_callhsfun :: PreCFunction diff --git a/src/Lua/Constants.hsc b/src/Lua/Constants.hsc new file mode 100644 --- /dev/null +++ b/src/Lua/Constants.hsc @@ -0,0 +1,243 @@ +{-# LANGUAGE PatternSynonyms #-} +{-| +Module : Lua.Constants +Copyright : © 2007–2012 Gracjan Polak; + © 2012–2016 Ömer Sinan Ağacan; + © 2017-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : ForeignFunctionInterface + +Lua constants +-} +module Lua.Constants + ( -- * Special values + pattern LUA_MULTRET + -- * Pseudo-indices + , pattern LUA_REGISTRYINDEX + -- * Basic types + , pattern LUA_TNONE + , pattern LUA_TNIL + , pattern LUA_TBOOLEAN + , pattern LUA_TLIGHTUSERDATA + , pattern LUA_TNUMBER + , pattern LUA_TSTRING + , pattern LUA_TTABLE + , pattern LUA_TFUNCTION + , pattern LUA_TUSERDATA + , pattern LUA_TTHREAD + -- * Status codes + , pattern LUA_OK + , pattern LUA_YIELD + , pattern LUA_ERRRUN + , pattern LUA_ERRSYNTAX + , pattern LUA_ERRMEM + , pattern LUA_ERRGCMM + , pattern LUA_ERRERR + , pattern LUA_ERRFILE + -- * Relational operator codes + , pattern LUA_OPEQ + , pattern LUA_OPLT + , pattern LUA_OPLE + -- * Garbage-collection options + , pattern LUA_GCSTOP + , pattern LUA_GCRESTART + , pattern LUA_GCCOLLECT + , pattern LUA_GCCOUNT + , pattern LUA_GCCOUNTB + , pattern LUA_GCSTEP + , pattern LUA_GCSETPAUSE + , pattern LUA_GCSETSTEPMUL + , pattern LUA_GCISRUNNING + -- * Predefined references + , pattern LUA_REFNIL + , pattern LUA_NOREF + -- * Boolean + , pattern TRUE + , pattern FALSE + ) where + +import Foreign.C (CInt (..)) +import Lua.Types + +#include +#include + +-- +-- Special values +-- + +-- | Option for multiple returns in @'Lua.lua_pcall'@. +pattern LUA_MULTRET :: NumResults +pattern LUA_MULTRET = NumResults (#{const LUA_MULTRET}) + +-- | Stack index of the Lua registry. +pattern LUA_REGISTRYINDEX :: StackIndex +pattern LUA_REGISTRYINDEX = StackIndex (#{const LUA_REGISTRYINDEX}) + +-- +-- Type of Lua values +-- +-- | Non-valid stack index +pattern LUA_TNONE :: TypeCode +pattern LUA_TNONE = TypeCode (#{const LUA_TNONE}) + +-- | Type of Lua's @nil@ value +pattern LUA_TNIL :: TypeCode +pattern LUA_TNIL = TypeCode (#{const LUA_TNIL}) + +-- | Type of Lua booleans +pattern LUA_TBOOLEAN :: TypeCode +pattern LUA_TBOOLEAN = TypeCode (#{const LUA_TBOOLEAN}) + +-- | Type of light userdata +pattern LUA_TLIGHTUSERDATA :: TypeCode +pattern LUA_TLIGHTUSERDATA = TypeCode (#{const LUA_TLIGHTUSERDATA}) + +-- | Type of Lua numbers. See @'Lua.Number'@ +pattern LUA_TNUMBER :: TypeCode +pattern LUA_TNUMBER = TypeCode (#{const LUA_TNUMBER}) + +-- | Type of Lua string values +pattern LUA_TSTRING :: TypeCode +pattern LUA_TSTRING = TypeCode (#{const LUA_TSTRING}) + +-- | Type of Lua tables +pattern LUA_TTABLE :: TypeCode +pattern LUA_TTABLE = TypeCode (#{const LUA_TTABLE}) + +-- | Type of functions, either normal or @'CFunction'@ +pattern LUA_TFUNCTION :: TypeCode +pattern LUA_TFUNCTION = TypeCode (#{const LUA_TFUNCTION}) + +-- | Type of full user data +pattern LUA_TUSERDATA :: TypeCode +pattern LUA_TUSERDATA = TypeCode (#{const LUA_TUSERDATA}) + +-- | Type of Lua threads +pattern LUA_TTHREAD :: TypeCode +pattern LUA_TTHREAD = TypeCode (#{const LUA_TTHREAD}) + +-- +-- Status codes +-- + +-- | Success. +pattern LUA_OK :: StatusCode +pattern LUA_OK = StatusCode #{const LUA_OK} + +-- | Yielding / suspended coroutine. +pattern LUA_YIELD :: StatusCode +pattern LUA_YIELD = StatusCode #{const LUA_YIELD} + +-- | A runtime error. +pattern LUA_ERRRUN :: StatusCode +pattern LUA_ERRRUN = StatusCode #{const LUA_ERRRUN} + +-- | A syntax error. +pattern LUA_ERRSYNTAX :: StatusCode +pattern LUA_ERRSYNTAX = StatusCode #{const LUA_ERRSYNTAX} + +-- | Memory allocation error. For such errors, Lua does not call the +-- message handler. +pattern LUA_ERRMEM :: StatusCode +pattern LUA_ERRMEM = StatusCode #{const LUA_ERRMEM} + +-- | Error while running a @__gc@ metamethod. For such errors, Lua does +-- not call the message handler (as this kind of error typically has no +-- relation with the function being called). +pattern LUA_ERRGCMM :: StatusCode +pattern LUA_ERRGCMM = StatusCode #{const LUA_ERRGCMM} + +-- | Error while running the message handler. +pattern LUA_ERRERR :: StatusCode +pattern LUA_ERRERR = StatusCode #{const LUA_ERRERR} + +-- | File related error (e.g., the file cannot be opened or read). +pattern LUA_ERRFILE :: StatusCode +pattern LUA_ERRFILE = StatusCode #{const LUA_ERRFILE} + +-- +-- Comparison operators +-- + +-- | Compares for equality (==) +pattern LUA_OPEQ :: OPCode +pattern LUA_OPEQ = OPCode #{const LUA_OPEQ} + +-- | Compares for less than (<) +pattern LUA_OPLT :: OPCode +pattern LUA_OPLT = OPCode #{const LUA_OPLT} + +-- | Compares for less or equal (<=) +pattern LUA_OPLE :: OPCode +pattern LUA_OPLE = OPCode #{const LUA_OPLE} + +-- +-- Garbage-collection options +-- + +-- | Stops the garbage collector. +pattern LUA_GCSTOP :: GCCode +pattern LUA_GCSTOP = GCCode #{const LUA_GCSTOP} + +-- | Restarts the garbage collector. +pattern LUA_GCRESTART :: GCCode +pattern LUA_GCRESTART = GCCode #{const LUA_GCRESTART} + +-- | Performs a full garbage-collection cycle. +pattern LUA_GCCOLLECT :: GCCode +pattern LUA_GCCOLLECT = GCCode #{const LUA_GCCOLLECT} + +-- | Returns the current amount of memory (in Kbytes) in use by Lua. +pattern LUA_GCCOUNT :: GCCode +pattern LUA_GCCOUNT = GCCode #{const LUA_GCCOUNT} + +-- | Returns the remainder of dividing the current amount of bytes of +-- memory in use by Lua by 1024. +pattern LUA_GCCOUNTB :: GCCode +pattern LUA_GCCOUNTB = GCCode #{const LUA_GCCOUNTB} + +-- | Performs an incremental step of garbage collection. +pattern LUA_GCSTEP :: GCCode +pattern LUA_GCSTEP = GCCode #{const LUA_GCSTEP} + +-- | Sets data as the new value for the pause of the collector (see +-- §2.5) and returns the previous value of the pause. +pattern LUA_GCSETPAUSE :: GCCode +pattern LUA_GCSETPAUSE = GCCode #{const LUA_GCSETPAUSE} + +-- | Sets data as the new value for the step multiplier of the collector +-- (see §2.5) and returns the previous value of the step multiplier. +pattern LUA_GCSETSTEPMUL :: GCCode +pattern LUA_GCSETSTEPMUL = GCCode #{const LUA_GCSETSTEPMUL} + +-- | Returns a boolean that tells whether the collector is running +-- (i.e., not stopped). +pattern LUA_GCISRUNNING :: GCCode +pattern LUA_GCISRUNNING = GCCode #{const LUA_GCISRUNNING} + +-- +-- Special registry values +-- + +-- | Value signaling that no reference was created. +pattern LUA_REFNIL :: CInt +pattern LUA_REFNIL = #{const LUA_NOREF} + +-- | Value signaling that no reference was found. +pattern LUA_NOREF :: CInt +pattern LUA_NOREF = #{const LUA_NOREF} + +-- +-- Booleans +-- + +-- | Value which Lua usually uses as 'True'. +pattern TRUE :: LuaBool +pattern TRUE = LuaBool 1 + +-- | Value which Lua usually uses as 'False'. +pattern FALSE :: LuaBool +pattern FALSE = LuaBool 0 diff --git a/src/Lua/Ersatz.hs b/src/Lua/Ersatz.hs new file mode 100644 --- /dev/null +++ b/src/Lua/Ersatz.hs @@ -0,0 +1,31 @@ +{-| +Module : Lua.Ersatz +Copyright : © 2007–2012 Gracjan Polak; + © 2012–2016 Ömer Sinan Ağacan; + © 2017-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta + +Ersatz functions for Lua API items which may, directly or indirectly, +throw a Lua error. +-} +module Lua.Ersatz + ( -- * Get functions (Lua -> stack) + hslua_gettable + , hslua_getglobal + -- * Set functions (stack -> Lua) + , hslua_settable + , hslua_setglobal + -- * Misc + , hslua_error + , hslua_next + , hslua_concat + , hslua_compare + -- * Auxiliary Library + , hsluaL_newstate + , hsluaL_tolstring + )where + +import Lua.Ersatz.Functions +import Lua.Ersatz.Auxiliary (hsluaL_newstate, hsluaL_tolstring) diff --git a/src/Lua/Ersatz/Auxiliary.hs b/src/Lua/Ersatz/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/src/Lua/Ersatz/Auxiliary.hs @@ -0,0 +1,32 @@ +{-| +Module : Lua.Ersatz.Auxiliary +Copyright : © 2007–2012 Gracjan Polak; + © 2012–2016 Ömer Sinan Ağacan; + © 2017-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : non-portable (depends on GHC) + +Raw bindings to ersatz functions of the auxiliary library. +-} +module Lua.Ersatz.Auxiliary + ( -- * Auxiliary Library + hsluaL_newstate + , hsluaL_tolstring + ) where + +import Foreign.C (CChar, CInt (CInt), CSize) +import Lua.Types (StackIndex) +import Foreign.Ptr (Ptr) +import qualified Lua.Types as Lua + +-- | Creates a new Lua state and set extra registry values for error +-- bookkeeping. +foreign import ccall unsafe "hslauxlib.h hsluaL_newstate" + hsluaL_newstate :: IO Lua.State + +-- | Converts object to string, respecting any metamethods; returns +-- @NULL@ if an error occurs. +foreign import ccall safe "hslauxlib.h hsluaL_tolstring" + hsluaL_tolstring :: Lua.State -> StackIndex -> Ptr CSize -> IO (Ptr CChar) diff --git a/src/Lua/Ersatz/Functions.hs b/src/Lua/Ersatz/Functions.hs new file mode 100644 --- /dev/null +++ b/src/Lua/Ersatz/Functions.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE CPP #-} +{-| +Module : Lua.Ersatz.Functions +Copyright : © 2007–2012 Gracjan Polak; + © 2012–2016 Ömer Sinan Ağacan; + © 2017-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : ForeignFunctionInterface, CPP + +Ersatz functions for Lua API items which may, directly or indirectly, +throw a Lua error. +-} +module Lua.Ersatz.Functions + ( hslua_compare + -- * Get functions (Lua -> stack) + , hslua_gettable + , hslua_getglobal + -- * Set functions (stack -> Lua) + , hslua_settable + , hslua_setglobal + -- * Misc + , hslua_error + , hslua_next + , hslua_concat + )where + +import Foreign.C +import Lua.Types as Lua +import Foreign.Ptr + +#ifdef ALLOW_UNSAFE_GC +#define SAFTY unsafe +#else +#define SAFTY safe +#endif + +-- | Compares two Lua values. Returns @1@ if the value at index @index1@ +-- satisfies op when compared with the value at index @index2@, +-- following the semantics of the corresponding Lua operator (that is, +-- it may call metamethods). Otherwise returns @0@. Also returns @0@ if +-- any of the indices is not valid. +-- +-- The value of op must be one of the following constants: +-- +-- - 'Lua.Constants.LUA_OPEQ': compares for equality (==) +-- - 'Lua.Constants.LUA_OPLT': compares for less than (<) +-- - 'Lua.Constants.LUA_OPLE': compares for less or equal (<=) +-- +-- This function wraps @lua_compare@ and takes an additional parameter +-- @status@; if it is not @NULL@, then the return value is set to the +-- status after calling @lua_compare@. +foreign import capi safe "hslua.h hslua_compare" + hslua_compare :: Lua.State + -> StackIndex -- ^ index 1 + -> StackIndex -- ^ index 2 + -> OPCode -- ^ operator + -> Ptr StatusCode -- ^ status + -> IO LuaBool + +-- +-- Get functions (Lua -> stack) +-- + +-- | Behaves like @'Lua.Functions.lua_gettable'@, but prevents +-- unrecoverable program crashes by calling that function through +-- @'Lua.lua_pcall'@. Takes an additional status code pointer +-- that is set to the status returned by @lua_pcall@. +foreign import ccall safe "hslua.h hslua_gettable" + hslua_gettable :: Lua.State -> StackIndex -> Ptr StatusCode -> IO TypeCode + +-- | Behaves like @'Lua.Functions.lua_getglobal'@, but prevents +-- unrecoverable program crashes by calling that function through +-- @'Lua.lua_pcall'@. Takes an additional status code pointer +-- that is set to the status returned by @lua_pcall@. +foreign import ccall safe "hslua.h hslua_getglobal" + hslua_getglobal :: Lua.State + -> CString + -> CSize + -> Ptr StatusCode + -> IO TypeCode + +-- +-- Set functions (stack -> Lua) +-- + +-- | Behaves like @'Lua.Functions.lua_settable'@, but prevents +-- unrecoverable program crashes by calling that function through +-- @'Lua.lua_pcall'@. Takes an additional status code pointer +-- that is set to the status returned by @lua_pcall@. +foreign import ccall safe "hslua.h hslua_settable" + hslua_settable :: Lua.State -> StackIndex -> Ptr StatusCode -> IO () + +-- | Behaves like @'Lua.Functions.lua_setglobal'@, but prevents +-- unrecoverable program crashes by calling that function through +-- @'Lua.lua_pcall'@. Takes an additional status code pointer +-- that is set to the status returned by @lua_pcall@. +foreign import ccall safe "hslua.h hslua_setglobal" + hslua_setglobal :: Lua.State -> CString -> CSize -> Ptr StatusCode -> IO () + +-- +-- Miscellaneous functions +-- + +-- | Replacement for +-- ; it uses +-- the HsLua error signaling convention instead of raw Lua errors. +foreign import ccall SAFTY "hslua.h hslua_error" + hslua_error :: Lua.State -> IO NumResults + +-- | Wrapper around +-- which +-- catches any Lua errors. +foreign import ccall safe "hslua.h hslua_next" + hslua_next :: Lua.State -> StackIndex -> Ptr StatusCode -> IO LuaBool + +-- | Wrapper around +-- +-- which catches any Lua errors. +foreign import ccall safe "hslua.h hslua_concat" + hslua_concat :: Lua.State -> NumArgs -> Ptr StatusCode -> IO () diff --git a/src/Lua/Lib.hs b/src/Lua/Lib.hs new file mode 100644 --- /dev/null +++ b/src/Lua/Lib.hs @@ -0,0 +1,59 @@ +{-| +Module : Lua.Lib +Copyright : © 2007–2012 Gracjan Polak; + © 2012–2016 Ömer Sinan Ağacan; + © 2017-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : ForeignFunctionInterface, CPP + +Lua standard libraries. +-} +module Lua.Lib + ( luaopen_base + , luaopen_table + , luaopen_io + , luaopen_os + , luaopen_string + , luaopen_math + , luaopen_debug + , luaopen_package + ) +where + +import Lua.Types (CFunction) + +-- * Lua Libraries + +-- | Pointer to function opening the base library. +foreign import ccall unsafe "lualib.h &luaopen_base" + luaopen_base :: CFunction + +-- | Pointer to function opening the table library. +foreign import ccall unsafe "lualib.h &luaopen_table" + luaopen_table :: CFunction + +-- | Pointer to function opening the io library. +foreign import ccall unsafe "lualib.h &luaopen_io" + luaopen_io :: CFunction + +-- | Pointer to function opening the os library. +foreign import ccall unsafe "lualib.h &luaopen_os" + luaopen_os :: CFunction + +-- | Pointer to function opening the string library. +foreign import ccall unsafe "lualib.h &luaopen_string" + luaopen_string :: CFunction + +-- | Pointer to function opening the math library. +foreign import ccall unsafe "lualib.h &luaopen_math" + luaopen_math :: CFunction + +-- | Pointer to function opening the debug library. +foreign import ccall unsafe "lualib.h &luaopen_debug" + luaopen_debug :: CFunction + +-- | Pointer to function opening the package library. +foreign import ccall unsafe "lualib.h &luaopen_package" + luaopen_package :: CFunction diff --git a/src/Lua/Primary.hs b/src/Lua/Primary.hs new file mode 100644 --- /dev/null +++ b/src/Lua/Primary.hs @@ -0,0 +1,896 @@ +{-# LANGUAGE CPP #-} +{-| +Module : Lua.Primary +Copyright : © 2007–2012 Gracjan Polak; + © 2012–2016 Ömer Sinan Ağacan; + © 2017-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : ForeignFunctionInterface, CPP + +Haskell bindings to Lua C API functions. + +The exposed functions correspond closely to the respective C Lua API +functions. However, C API functions which can throw Lua errors are not +exported directly, as any errors would crash the program. Non-error +throwing @hslua_@ versions are provided instead. The @hslua@ ersatz +functions have worse performance than the original. + +Some of the Lua functions may, directly or indirectly, call a Haskell +function, and trigger garbage collection, rescheduling etc. These +functions are always imported safely (i.e., with the @safe@ keyword). + +However, all function can trigger garbage collection. If that can lead +to problems, then the package should be configured without flag +@allow-unsafe-gc@. +-} +module Lua.Primary + ( lua_absindex + , lua_checkstack + , lua_close + , lua_concat + , lua_copy + , lua_createtable + , lua_gc + , lua_getglobal + , lua_getmetatable + , lua_gettable + , lua_gettop + , lua_getuservalue + , lua_insert + , lua_isboolean + , lua_iscfunction + , lua_isfunction + , lua_isinteger + , lua_islightuserdata + , lua_isnil + , lua_isnone + , lua_isnoneornil + , lua_isnumber + , lua_isstring + , lua_istable + , lua_isthread + , lua_isuserdata + , lua_load + , lua_newthread + , lua_newuserdata + , lua_next + , lua_pcall + , lua_pop + , lua_pushboolean + , lua_pushcclosure + , lua_pushglobaltable + , lua_pushinteger + , lua_pushlightuserdata + , lua_pushlstring + , lua_pushnil + , lua_pushnumber + , lua_pushstring + , lua_pushthread + , lua_pushvalue + , lua_rawequal + , lua_rawget + , lua_rawgeti + , lua_rawlen + , lua_rawset + , lua_rawseti + , lua_remove + , lua_replace + , lua_setglobal + , lua_setmetatable + , lua_settable + , lua_settop + , lua_setuservalue + , lua_status + , lua_toboolean + , lua_tocfunction + , lua_tointegerx + , lua_tolstring + , lua_tonumberx + , lua_topointer + , lua_tothread + , lua_touserdata + , lua_type + , lua_typename + , module Lua.Ersatz.Functions + , module Lua.Ersatz.Auxiliary + ) +where + +import Foreign.C +import Lua.Ersatz.Auxiliary +import Lua.Ersatz.Functions +import Lua.Types as Lua +import Foreign.Ptr + +#ifdef ALLOW_UNSAFE_GC +#define SAFTY unsafe +#else +#define SAFTY safe +#endif + +-- | Converts the acceptable index @idx@ into an equivalent absolute +-- index (that is, one that does not depend on the stack top). +-- +-- +foreign import ccall unsafe "lua.h lua_absindex" + lua_absindex :: Lua.State + -> StackIndex -- ^ idx + -> IO StackIndex + +-- | Ensures that the stack has space for at least @n@ extra slots (that +-- is, that you can safely push up to @n@ values into it). It returns +-- false if it cannot fulfill the request, either because it would cause +-- the stack to be larger than a fixed maximum size (typically at least +-- several thousand elements) or because it cannot allocate memory for +-- the extra space. This function never shrinks the stack; if the stack +-- already has space for the extra slots, it is left unchanged. +-- +-- +foreign import capi unsafe "lua.h lua_checkstack" + lua_checkstack :: Lua.State -> CInt {- ^ n -} -> IO LuaBool + +-- | Destroys all objects in the given Lua state (calling the +-- corresponding garbage-collection metamethods, if any) and frees all +-- dynamic memory used by this state. In several platforms, you may not +-- need to call this function, because all resources are naturally +-- released when the host program ends. On the other hand, long-running +-- programs that create multiple states, such as daemons or web servers, +-- will probably need to close states as soon as they are not needed. +-- +-- +foreign import ccall safe "lua.h lua_close" + lua_close :: Lua.State -> IO () + +-- | Concatenates the @n@ values at the top of the stack, pops them, and +-- leaves the result at the top. If @n@ is 1, the result is the single +-- value on the stack (that is, the function does nothing); if @n@ is 0, +-- the result is the empty string. Concatenation is performed following +-- the usual semantics of Lua (see +-- of the Lua +-- manual). +-- +-- __WARNING__: @lua_concat@ is unsafe in Haskell: This function will +-- cause an unrecoverable crash an error if any of the concatenated +-- values causes an error when executing a metamethod. Consider using +-- the @'Lua.hslua_concat'@ ersatz function instead. +foreign import ccall SAFTY "lua.h lua_concat" + lua_concat :: State -> CInt {- ^ n -} -> IO () +{-# WARNING lua_concat + [ "This is an unsafe function, it will cause a program crash if" + , "a metamethod throws an error." + , "Consider using hslua_concat instead." + ] #-} + +-- | Copies the element at index @fromidx@ into the valid index @toidx@, +-- replacing the value at that position. Values at other positions are +-- not affected. +-- +-- +foreign import ccall unsafe "lua.h lua_copy" + lua_copy :: Lua.State + -> StackIndex -- ^ fromidx + -> StackIndex -- ^ toidx + -> IO () + +-- | Creates a new empty table and pushes it onto the stack. Parameter +-- @narr@ is a hint for how many elements the table will have as a +-- sequence; parameter @nrec@ is a hint for how many other elements the +-- table will have. Lua may use these hints to preallocate memory for +-- the new table. This preallocation is useful for performance when you +-- know in advance how many elements the table will have. Otherwise you +-- can use the function @lua_newtable@. +-- +-- . +foreign import ccall SAFTY "lua.h lua_createtable" + lua_createtable :: Lua.State + -> CInt -- ^ narr + -> CInt -- ^ nrec + -> IO () + +-- | Controls the garbage collector. +-- +-- See the Lua docs at +-- . +foreign import ccall safe "lua.h lua_gc" + lua_gc :: Lua.State -> GCCode {- ^ what -} -> CInt {- ^ data -} -> IO CInt + +-- | Pushes onto the stack the value of the global name. Returns the +-- type of that value. +-- +-- __WARNING__: @lua_getglobal@ is unsafe in Haskell: if the call to a +-- metamethod triggers an error, then that error cannot be handled and +-- will lead to an unrecoverable program crash. Consider using the +-- @'Lua.hslua_getglobal'@ ersatz function instead. Likewise, the +-- metamethod may not call a Haskell function unless the library was +-- compiled without @allow-unsafe-gc@. +-- +-- . +foreign import ccall SAFTY "lua.h lua_getglobal" + lua_getglobal :: State -> CString {- ^ name -} -> IO TypeCode +{-# WARNING lua_getglobal + [ "This is an unsafe function, errors will lead to a program crash;" + , "consider using hslua_getglobal instead." + ] #-} + +-- | If the value at the given index has a metatable, the function +-- pushes that metatable onto the stack and returns @1@. Otherwise, the +-- function returns @0@ and pushes nothing on the stack. +-- +-- . +foreign import ccall unsafe "lua.h lua_getmetatable" + lua_getmetatable :: Lua.State -> StackIndex -> IO LuaBool + +-- | Pushes onto the stack the value @t[k]@, where @t@ is the value at +-- the given index and @k@ is the value at the top of the stack. +-- +-- This function pops the key from the stack, pushing the resulting +-- value in its place. As in Lua, this function may trigger a metamethod +-- for the \"index\" event (see +-- ). +-- +-- Returns the type of the pushed value. +-- +-- __WARNING__: @lua_gettable@ is unsafe in Haskell: if the call to a +-- metamethod triggers an error, then that error cannot be handled and +-- will lead to an unrecoverable program crash. Consider using the +-- @'Lua.hslua_gettable'@ ersatz function instead. Likewise, the +-- metamethod may not call a Haskell function unless the library was +-- compiled without @allow-unsafe-gc@. +-- +-- . +foreign import ccall SAFTY "lua.h lua_gettable" + lua_gettable :: Lua.State -> StackIndex {- ^ index -} -> IO TypeCode +{-# WARNING lua_gettable + [ "This is an unsafe function, errors will lead to a program crash;" + , "consider using hslua_gettable instead." + ] #-} + +-- | Returns the index of the top element in the stack. Because indices +-- start at 1, this result is equal to the number of elements in the +-- stack (and so 0 means an empty stack). +-- +-- +foreign import ccall unsafe "lua.h lua_gettop" + lua_gettop :: Lua.State -> IO StackIndex + +-- | Pushes onto the stack the Lua value associated with the full +-- userdata at the given index. +-- +-- Returns the type of the pushed value. +-- +-- +foreign import ccall unsafe "lua.h lua_getuservalue" + lua_getuservalue :: Lua.State -> StackIndex -> IO TypeCode + +-- | Moves the top element into the given valid index, shifting up the +-- elements above this index to open space. This function cannot be +-- called with a pseudo-index, because a pseudo-index is not an actual +-- stack position. +-- +-- +foreign import capi unsafe "lua.h lua_insert" + lua_insert :: Lua.State -> StackIndex -> IO () + +-- | Returns @'Lua.TRUE'@ if the value at the given index is a +-- boolean, and @'Lua.FALSE'@ otherwise. +-- +-- +foreign import capi unsafe "lua.h lua_isboolean" + lua_isboolean :: Lua.State -> StackIndex -> IO LuaBool + +-- | Returns @'Lua.TRUE'@ if the value at the given index is a C +-- function, and @'Lua.FALSE'@ otherwise. +-- +-- +foreign import ccall unsafe "lua.h lua_iscfunction" + lua_iscfunction :: Lua.State -> StackIndex -> IO LuaBool + +-- | Returns @'Lua.TRUE'@ if the value at the given index is a +-- function (either C or Lua), and @'Lua.FALSE'@ otherwise. +-- +-- +foreign import capi unsafe "lua.h lua_isfunction" + lua_isfunction :: Lua.State -> StackIndex -> IO LuaBool + +-- | Returns @'Lua.TRUE'@ if the value at the given index is an +-- integer (that is, the value is a number and is represented as an +-- integer), and @'Lua.FALSE'@ otherwise. +-- +-- +foreign import ccall unsafe "lua.h lua_isinteger" + lua_isinteger :: Lua.State -> StackIndex -> IO LuaBool + +-- | Returns @'Lua.TRUE'@ if the value at the given index is a +-- light userdata, and @'Lua.FALSE'@ otherwise. +-- +-- +foreign import capi unsafe "lua.h lua_islightuserdata" + lua_islightuserdata :: Lua.State -> StackIndex -> IO LuaBool + +-- | Returns @'Lua.TRUE'@ if the value at the given index is +-- __nil__, and @'Lua.FALSE'@ otherwise. +-- +-- +foreign import capi unsafe "lua.h lua_isnil" + lua_isnil :: Lua.State -> StackIndex -> IO LuaBool + +-- | Returns @'Lua.TRUE'@ if the given index is not valid, and +-- @'Lua.FALSE'@ otherwise. +-- +-- +foreign import capi unsafe "lua.h lua_isnone" + lua_isnone :: Lua.State -> StackIndex -> IO LuaBool + +-- | Returns @'Lua.TRUE'@ if the given index is not valid or if +-- the value at the given index is __nil__, and @'Lua.FALSE'@ +-- otherwise. +-- +-- +foreign import capi unsafe "lua.h lua_isnoneornil" + lua_isnoneornil :: Lua.State -> StackIndex -> IO LuaBool + +-- | Returns @'Lua.TRUE'@ if the value at the given index is a +-- number or a string convertible to a number, and @'Lua.FALSE'@ +-- otherwise. +-- +-- +foreign import ccall unsafe "lua.h lua_isnumber" + lua_isnumber :: Lua.State -> StackIndex -> IO LuaBool + +-- | Returns @'Lua.TRUE'@ if the value at the given index is a +-- string or a number (which is always convertible to a string), and +-- @'Lua.FALSE'@ otherwise. +-- +-- +foreign import ccall unsafe "lua.h lua_isstring" + lua_isstring :: Lua.State -> StackIndex -> IO LuaBool + +-- | Returns @'Lua.TRUE'@ if the value at the given index is a +-- table, and @'Lua.FALSE'@ otherwise. +-- +-- +foreign import capi unsafe "lua.h lua_istable" + lua_istable :: Lua.State -> StackIndex -> IO LuaBool + +-- | Returns @'Lua.TRUE'@ if the value at the given index is a +-- thread, and @'Lua.FALSE'@ otherwise. +-- +-- +foreign import capi unsafe "lua.h lua_isthread" + lua_isthread :: Lua.State -> StackIndex -> IO LuaBool + +-- | Returns @'Lua.TRUE'@ if the value at the given index is a +-- userdata (either full or light), and @'Lua.FALSE'@ otherwise. +-- +-- +foreign import ccall unsafe "lua.h lua_isuserdata" + lua_isuserdata :: Lua.State -> StackIndex -> IO LuaBool + +-- | Loads a Lua chunk (without running it). If there are no errors, +-- @lua_load@ pushes the compiled chunk as a Lua function on top of the +-- stack. Otherwise, it pushes an error message. +-- +-- The return values of @lua_load@ are: +-- +-- - @'Lua.LUA_OK'@: no errors; +-- - @'Lua.LUA_ERRSYNTAX'@: syntax error during pre-compilation; +-- - @'Lua.LUA_ERRMEM'@: memory allocation error; +-- - @'Lua.LUA_ERRGCMM'@: error while running a @__gc@ +-- metamethod. (This error has no relation with the chunk being +-- loaded. It is generated by the garbage collector.) +-- +-- This function only loads a chunk; it does not run it. +-- +-- @lua_load@ automatically detects whether the chunk is text or binary, +-- and loads it accordingly (see program luac). +-- +-- The @lua_load@ function uses a user-supplied reader function to +-- read the chunk (see @'Lua.Reader'@). The data argument is an opaque +-- value passed to the reader function. +-- +-- The @chunkname@ argument gives a name to the chunk, which is used for +-- error messages and in debug information (see +-- ). +-- +-- @lua_load@ automatically detects whether the chunk is text or binary +-- and loads it accordingly (see program @luac@). The string mode works +-- as in function @load@, with the addition that a @NULL@ value is +-- equivalent to the string "bt". +-- +-- @lua_load@ uses the stack internally, so the reader function must +-- always leave the stack unmodified when returning. +-- +-- . +foreign import ccall safe "lua.h lua_load" + lua_load :: Lua.State + -> Lua.Reader -- ^ reader + -> Ptr () -- ^ data + -> CString -- ^ chunkname + -> CString -- ^ mode + -> IO StatusCode + +-- | Creates a new thread, pushes it on the stack, and returns a +-- 'Lua.State' that represents this new thread. The new thread returned +-- by this function shares with the original thread its global +-- environment, but has an independent execution stack. +-- +-- There is no explicit function to close or to destroy a thread. +-- Threads are subject to garbage collection, like any Lua object. +-- +-- +foreign import ccall SAFTY "lua.h lua_newthread" + lua_newthread :: Lua.State -> IO Lua.State + +-- | This function allocates a new block of memory with the given size, +-- pushes onto the stack a new full userdata with the block address, and +-- returns this address. The host program can freely use this memory. +-- +-- . +foreign import ccall SAFTY "lua.h lua_newuserdata" + lua_newuserdata :: Lua.State -> CSize -> IO (Ptr ()) + + +-- | Pops a key from the stack, and pushes a key–value pair from the +-- table at the given index (the \"next\" pair after the given key). If +-- there are no more elements in the table, then +-- +-- returns 'FALSE' (and pushes nothing). +-- +-- A typical traversal looks like this: +-- +-- > -- table is in the stack at index 't' +-- > lua_pushnil l -- first key +-- > let loop = lua_next l t >>= \case +-- > FALSE -> return () +-- > _ -> do +-- > lua_type l (-2) >>= lua_typename l >>= peekCString >>= putStrLn +-- > lua_type l (-1) >>= lua_typename l >>= peekCString >>= putStrLn +-- > -- removes 'value'; keeps 'key' for next iteration +-- > lua_pop l 1 +-- > loop +-- > loop +-- +-- While traversing a table, do not call 'lua_tolstring' directly on a +-- key, unless you know that the key is actually a string. Recall that +-- 'lua_tolstring' may change the value at the given index; this +-- confuses the next call to +-- . +-- +-- See function +-- for the +-- caveats of modifying the table during its traversal. +-- +-- __WARNING__: @lua_next@ is unsafe in Haskell: This function will +-- cause an unrecoverable crash an error if the given key is neither +-- @nil@ nor present in the table. Consider using the @'Lua.hslua_next'@ +-- ersatz function instead. +foreign import ccall SAFTY "lua.h lua_next" + lua_next :: State -> StackIndex {- ^ index -} -> IO LuaBool +{-# WARNING lua_next + [ "This is an unsafe function, it will cause a program crash if" + , "the given key is neither nil nor present in the table." + , "Consider using hslua_next instead." + ] #-} + +-- | Calls a function in protected mode. +-- +-- To call a function you must use the following protocol: first, the +-- function to be called is pushed onto the stack; then, the arguments +-- to the function are pushed in direct order; that is, the first +-- argument is pushed first. Finally you call @lua_pcall@; @nargs@ is +-- the number of arguments that you pushed onto the stack. All arguments +-- and the function value are popped from the stack when the function is +-- called. The function results are pushed onto the stack when the +-- function returns. The number of results is adjusted to @nresults@, +-- unless @nresults@ is @'Lua.LUA_MULTRET'@. In this case, all +-- results from the function are pushed. Lua takes care that the +-- returned values fit into the stack space. The function results are +-- pushed onto the stack in direct order (the first result is pushed +-- first), so that after the call the last result is on the top of the +-- stack. +-- +-- If there is any error, @lua_pcall@ catches it, pushes a single value +-- on the stack (the error message), and returns the error code. +-- @lua_pcall@ always removes the function and its arguments from the +-- stack. +-- +-- If @msgh@ is @0@, then the error object returned on the stack is +-- exactly the original error object. Otherwise, @msgh@ is the location +-- of a message handler. (This index cannot be a pseudo-index.) In case +-- of runtime errors, this function will be called with the error object +-- and its return value will be the object returned on the stack by +-- @'lua_pcall'@. +-- +-- Typically, the message handler is used to add more debug information +-- to the error object, such as a stack traceback. Such information +-- cannot be gathered after the return of @'lua_pcall'@, since by then +-- the stack has unwound. +-- +-- . +foreign import capi safe "lua.h lua_pcall" + lua_pcall :: Lua.State + -> NumArgs -- ^ nargs + -> NumResults -- ^ nresults + -> StackIndex -- ^ msgh + -> IO StatusCode + +-- | Pops @n@ elements from the stack. +-- +-- +foreign import capi unsafe "lua.h lua_pop" + lua_pop :: Lua.State -> CInt {- ^ n -} -> IO () + +-- | Pushes a boolean value with the given value onto the stack. +-- +-- . +foreign import ccall unsafe "lua.h lua_pushboolean" + lua_pushboolean :: Lua.State -> LuaBool -> IO () + +-- | Pushes a new C closure onto the stack. +-- +-- When a C function is created, it is possible to associate some values +-- with it, thus creating a C closure (see +-- ); these values +-- are then accessible to the function whenever it is called. To +-- associate values with a C function, first these values should be +-- pushed onto the stack (when there are multiple values, the first +-- value is pushed first). Then lua_pushcclosure is called to create and +-- push the C function onto the stack, with the argument @n@ telling how +-- many values should be associated with the function. lua_pushcclosure +-- also pops these values from the stack. +-- +-- The maximum value for @n@ is 255. +-- +-- . +foreign import ccall SAFTY "lua.h lua_pushcclosure" + lua_pushcclosure :: Lua.State + -> CFunction -- ^ fn + -> NumArgs -- ^ n + -> IO () + +-- | Pushes the global environment onto the stack. +-- +-- +foreign import capi unsafe "lua.h lua_pushglobaltable" + lua_pushglobaltable :: Lua.State -> IO () + +-- | Pushes an integer with with the given value onto the stack. +-- +-- . +foreign import ccall unsafe "lua.h lua_pushinteger" + lua_pushinteger :: Lua.State -> Lua.Integer -> IO () + +-- | Pushes a light userdata onto the stack. +-- +-- Userdata represent C values in Lua. A light userdata represents a +-- pointer, a @Ptr ()@ (i.e., @void*@ in C lingo). It is a value (like a +-- number): you do not create it, it has no individual metatable, and it +-- is not collected (as it was never created). A light userdata is equal +-- to "any" light userdata with the same C address. +-- +-- . +foreign import ccall unsafe "lua.h lua_pushlightuserdata" + lua_pushlightuserdata :: Lua.State -> Ptr a -> IO () + +-- | Pushes the string pointed to by @s@ with size @len@ onto the stack. +-- Lua makes (or reuses) an internal copy of the given string, so the +-- memory at s can be freed or reused immediately after the function +-- returns. The string can contain any binary data, including embedded +-- zeros. +-- +-- Returns a pointer to the internal copy of the string. +-- +-- . +foreign import ccall SAFTY "lua.h lua_pushlstring" + lua_pushlstring :: Lua.State + -> Ptr CChar -- ^ s + -> CSize -- ^ len + -> IO () + +-- | Pushes a nil value onto the stack. +-- +-- . +foreign import ccall unsafe "lua.h lua_pushnil" + lua_pushnil :: Lua.State -> IO () + +-- | Pushes a float with the given value onto the stack. +-- +-- . +foreign import ccall unsafe "lua.h lua_pushnumber" + lua_pushnumber :: Lua.State -> Lua.Number -> IO () + + +-- | Pushes the zero-terminated string pointed to by @s@ onto the stack. +-- Lua makes (or reuses) an internal copy of the given string, so the +-- memory at @s@ can be freed or reused immediately after the function +-- returns. +-- +-- Returns a pointer to the internal copy of the string. +-- +-- If s is NULL, pushes nil and returns NULL. +foreign import ccall unsafe "lua.h lua_pushstring" + lua_pushstring :: Lua.State -> CString {- ^ s -} -> IO CString + + +-- | Pushes the current thread onto the stack. Returns @1@ iff this +-- thread is the main thread of its state. +-- +-- . +foreign import ccall unsafe "lua.h lua_pushthread" + lua_pushthread :: Lua.State -> IO CInt + +-- | Pushes a copy of the element at the given index onto the stack. +-- +-- +foreign import ccall unsafe "lua.h lua_pushvalue" + lua_pushvalue :: Lua.State -> StackIndex -> IO () + +-- | Returns @True@ if the two values in indices @idx1@ and @idx2@ are +-- primitively equal (that is, without calling the @__eq@ metamethod). +-- Otherwise returns @False@. Also returns @False@ if any of the indices +-- are not valid. +-- +-- +foreign import ccall unsafe "lua.h lua_rawequal" + lua_rawequal :: Lua.State + -> StackIndex -- ^ idx1 + -> StackIndex -- ^ idx2 + -> IO LuaBool + +-- | Similar to @'lua_gettable'@, but does a raw access (i.e., without +-- metamethods). +-- +-- . +foreign import ccall unsafe "lua.h lua_rawget" + lua_rawget :: Lua.State -> StackIndex -> IO () + +-- | Pushes onto the stack the value @t[n]@, where @t@ is the table at +-- the given index. The access is raw, that is, it does not invoke the +-- @__index@ metamethod. +-- +-- . +foreign import ccall unsafe "lua.h lua_rawgeti" + lua_rawgeti :: Lua.State -> StackIndex -> Lua.Integer {- ^ n -} -> IO () + +-- | Returns the raw "length" of the value at the given index: for +-- strings, this is the string length; for tables, this is the result of +-- the length operator (@#@) with no metamethods; for userdata, this is +-- the size of the block of memory allocated for the userdata; for other +-- values, it is 0. +-- +-- . +foreign import ccall unsafe "lua.h lua_rawlen" + lua_rawlen :: Lua.State -> StackIndex -> IO CSize + +-- | Similar to @'lua_settable'@, but does a raw assignment (i.e., +-- without metamethods). +-- +-- . +foreign import ccall SAFTY "lua.h lua_rawset" + lua_rawset :: Lua.State -> StackIndex -> IO () + +-- | Does the equivalent of @t[i] = v@, where @t@ is the table at the +-- given index and @v@ is the value at the top of the stack. +-- +-- This function pops the value from the stack. The assignment is raw, +-- that is, it does not invoke the @__newindex@ metamethod. +-- +-- . +foreign import ccall SAFTY "lua.h lua_rawseti" + lua_rawseti :: Lua.State -> StackIndex -> Lua.Integer -> IO () + +-- | Removes the element at the given valid index, shifting down the +-- elements above this index to fill the gap. This function cannot be +-- called with a pseudo-index, because a pseudo-index is not an actual +-- stack position. +-- +-- +foreign import capi unsafe "lua.h lua_remove" + lua_remove :: Lua.State -> StackIndex -> IO () + +-- | Moves the top element into the given valid index without shifting +-- any element (therefore replacing the value at that given index), and +-- then pops the top element. +-- +-- +foreign import capi unsafe "lua.h lua_replace" + lua_replace :: Lua.State -> StackIndex -> IO () + +-- | Pops a value from the stack and sets it as the new value of global +-- @name@. +-- +-- __WARNING__: @lua_setglobal@ is unsafe in Haskell: if the call to a +-- metamethod triggers an error, then that error cannot be handled and +-- will lead to an unrecoverable program crash. Consider using the +-- @'Lua.hslua_setglobal'@ ersatz function instead. Likewise, +-- the global metamethod may not call a Haskell function unless the +-- library was compiled without @allow-unsafe-gc@. +-- +-- . +foreign import ccall SAFTY "lua.h lua_setglobal" + lua_setglobal :: State -> CString {- ^ name -} -> IO () +{-# WARNING lua_setglobal + [ "This is an unsafe function, errors will lead to a program crash;" + , "consider using hslua_getglobal instead." + ] #-} + +-- | Pops a table from the stack and sets it as the new metatable for +-- the value at the given index. +-- +-- . +foreign import ccall unsafe "lua.h lua_setmetatable" + lua_setmetatable :: Lua.State -> StackIndex -> IO () + +-- | Does the equivalent to @t[k] = v@, where @t@ is the value at the +-- given index, @v@ is the value at the top of the stack, and @k@ is the +-- value just below the top. +-- +-- This function pops both the key and the value from the stack. As in +-- Lua, this function may trigger a metamethod for the \"newindex\" +-- event (see ). +-- +-- __WARNING__: @lua_settable@ is unsafe in Haskell: if the call to a +-- metamethod triggers an error, then that error cannot be handled and +-- will lead to an unrecoverable program crash. Consider using the +-- @'Lua.hslua_settable'@ ersatz function instead. Likewise, the +-- metamethod may not call a Haskell function unless the library was +-- compiled without @allow-unsafe-gc@. +-- +-- +foreign import ccall SAFTY "lua.h lua_settable" + lua_settable :: Lua.State -> StackIndex {- ^ index -} -> IO () +{-# WARNING lua_settable + [ "This is an unsafe function, errors will lead to a program crash;" + , "consider using hslua_settable instead." + ] #-} + +-- | Accepts any index, or 0, and sets the stack top to this index. If +-- the new top is larger than the old one, then the new elements are +-- filled with *nil*. If @index@ is 0, then all stack elements are +-- removed. +-- +-- +foreign import ccall unsafe "lua.h lua_settop" + lua_settop :: Lua.State -> StackIndex {- ^ index -} -> IO () + +-- | Pops a value from the stack and sets it as the new value associated +-- to the full userdata at the given index. +-- +-- +foreign import ccall unsafe "lua.h lua_setuservalue" + lua_setuservalue :: Lua.State -> StackIndex -> IO () + +-- | Returns the status of this Lua thread. +-- +-- The status can be @'Lua.LUA_OK'@ for a normal thread, an +-- error value if the thread finished the execution of a @lua_resume@ +-- with an error, or @'Lua.LUA_YIELD'@ if the thread is +-- suspended. +-- +-- You can only call functions in threads with status +-- @'Lua.LUA_OK'@. You can resume threads with status +-- @'Lua.LUA_OK'@ (to start a new coroutine) or +-- @'Lua.LUA_YIELD'@ (to resume a coroutine). +-- +-- . +foreign import ccall unsafe "lua.h lua_status" + lua_status :: Lua.State -> IO StatusCode + +-- | Converts the Lua value at the given index to a haskell boolean +-- value. Like all tests in Lua, @toboolean@ returns @True@ for any Lua +-- value different from *false* and *nil*; otherwise it returns @False@. +-- (If you want to accept only actual boolean values, use +-- @'lua_isboolean'@ to test the value's type.) +-- +-- +foreign import capi unsafe "lua.h lua_toboolean" + lua_toboolean :: Lua.State -> StackIndex -> IO LuaBool + +-- | Converts a value at the given index to a C function. That value +-- must be a C function; otherwise, returns @Nothing@. +-- +-- +foreign import ccall unsafe "lua.h lua_tocfunction" + lua_tocfunction :: Lua.State -> StackIndex -> IO CFunction + +-- | Converts the Lua value at the given acceptable index to the signed +-- integral type 'Lua.Integer'. The Lua value must be an integer, a +-- number, or a string convertible to an integer (see +-- of the Lua +-- 5.3 Reference Manual); otherwise, @lua_tointegerx@ returns @0@. +-- +-- If the number is not an integer, it is truncated in some +-- non-specified way. +-- +-- If @isnum@ is not @NULL@, its referent is assigned a boolean value +-- that indicates whether the operation succeeded. +-- +-- +foreign import ccall unsafe "lua.h lua_tointegerx" + lua_tointegerx :: Lua.State + -> StackIndex -- ^ index + -> Ptr LuaBool -- ^ isnum + -> IO Lua.Integer + +-- | Converts the Lua value at the given index to a C string. If @len@ +-- is not @NULL@, it sets the referent with the string length. The Lua +-- value must be a string or a number; otherwise, the function returns +-- @NULL@. If the value is a number, then @lua_tolstring@ also changes +-- the actual value in the stack to a string. (This change confuses +-- @lua_next@ when @lua_tolstring@ is applied to keys during a table +-- traversal.) +-- +-- @lua_tolstring@ returns a pointer to a string inside the Lua state. +-- This string always has a zero ('\0') after its last character (as in +-- C), but can contain other zeros in its body. +-- +-- Because Lua has garbage collection, there is no guarantee that the +-- pointer returned by @lua_tolstring@ will be valid after the +-- corresponding Lua value is removed from the stack. +-- +-- +foreign import ccall SAFTY "lua.h lua_tolstring" + lua_tolstring :: Lua.State + -> StackIndex -- ^ index + -> Ptr CSize -- ^ len + -> IO (Ptr CChar) + +-- | Converts the Lua value at the given index to the C type lua_Number +-- (see lua_Number). The Lua value must be a number or a string +-- convertible to a number (see §3.4.3); otherwise, lua_tonumberx +-- returns 0. +-- +-- If @isnum@ is not @NULL@, its referent is assigned a boolean value +-- that indicates whether the operation succeeded. +-- +-- +foreign import ccall unsafe "lua.h lua_tonumberx" + lua_tonumberx :: Lua.State + -> StackIndex -- ^ index + -> Ptr LuaBool -- ^ isnum + -> IO Lua.Number + +-- | Converts the value at the given index to a generic C pointer +-- (@void*@). The value can be a userdata, a table, a thread, or a +-- function; otherwise, @lua_topointer@ returns @'nullPtr'@. Different +-- objects will give different pointers. There is no way to convert the +-- pointer back to its original value. +-- +-- Typically this function is used only for hashing and debug +-- information. +-- +-- +foreign import ccall unsafe "lua.h lua_topointer" + lua_topointer :: Lua.State -> StackIndex -> IO (Ptr ()) + +-- | Converts the value at the given index to a Lua thread (represented +-- as @'Lua.State'@). This value must be a thread; otherwise, the +-- function returns @'nullPtr'@. +-- +-- +foreign import ccall unsafe "lua.h lua_tothread" + lua_tothread :: Lua.State -> StackIndex -> IO Lua.State + +-- | If the value at the given index is a full userdata, returns its +-- block address. If the value is a light userdata, returns its pointer. +-- Otherwise, returns @'nullPtr'@. +-- +-- +foreign import ccall unsafe "lua.h lua_touserdata" + lua_touserdata :: Lua.State -> StackIndex -> IO (Ptr a) + +-- | Returns the type of the value in the given valid index, or +-- @'Lua.LUA_TNONE'@ for a non-valid (but acceptable) index. +-- +-- +foreign import ccall unsafe "lua.h lua_type" + lua_type :: Lua.State -> StackIndex -> IO TypeCode + +-- | Returns the name of the type encoded by the value @tp@, which must +-- be one the values returned by @'lua_type'@. +-- +-- +foreign import ccall unsafe "lua.h lua_typename" + lua_typename :: Lua.State -> TypeCode {- ^ tp -} -> IO CString diff --git a/src/Lua/Types.hsc b/src/Lua/Types.hsc new file mode 100644 --- /dev/null +++ b/src/Lua/Types.hsc @@ -0,0 +1,143 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternSynonyms #-} +{-| +Module : Lua.Types +Copyright : © 2007–2012 Gracjan Polak; + © 2012–2016 Ömer Sinan Ağacan; + © 2017-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : non-portable (depends on GHC) + +The core Lua types, including mappings of Lua types to Haskell. +-} +module Lua.Types + ( State (..) + , Reader + , TypeCode (..) + , CFunction + , PreCFunction + , LuaBool (..) + , Integer (..) + , Number (..) + , StackIndex (..) + , NumArgs (..) + , NumResults (..) + , OPCode (..) + , StatusCode (..) + -- * Garbage-Collection + , GCCode (..) + ) +where + +#include + +import Prelude hiding (Integer) + +import Data.Int (#{type LUA_INTEGER}) +import Foreign.C (CChar, CInt, CSize) +import Foreign.Ptr (FunPtr, Ptr) +import Foreign.Storable (Storable) +import GHC.Generics (Generic) + +-- | An opaque structure that points to a thread and indirectly (through the +-- thread) to the whole state of a Lua interpreter. The Lua library is fully +-- reentrant: it has no global variables. All information about a state is +-- accessible through this structure. +-- +-- Synonym for @lua_State *@. See +-- . +newtype State = State (Ptr ()) deriving (Eq, Generic) + +-- | Type for C functions. +-- +-- In order to communicate properly with Lua, a C function must use the +-- following protocol, which defines the way parameters and results are +-- passed: a C function receives its arguments from Lua in its stack in +-- direct order (the first argument is pushed first). So, when the +-- function starts, @'Lua.Functions.lua_gettop'@ returns the +-- number of arguments received by the function. The first argument (if +-- any) is at index 1 and its last argument is at index +-- @'Lua.Functions.lua_gettop'@. To return values to Lua, a C +-- function just pushes them onto the stack, in direct order (the first +-- result is pushed first), and returns the number of results. Any other +-- value in the stack below the results will be properly discarded by +-- Lua. Like a Lua function, a C function called by Lua can also return +-- many results. +-- +-- See +-- . +type CFunction = FunPtr PreCFunction + +-- | Type of Haskell functions that can be turned into C functions. +-- +-- This is the same as a dereferenced 'CFunction'. +type PreCFunction = State -> IO NumResults + +-- | The reader function used by @'Lua.load'@. +-- Every time it needs another piece of the chunk, lua_load calls the +-- reader, passing along its data parameter. The reader must return a +-- pointer to a block of memory with a new piece of the chunk and set +-- size to the block size. The block must exist until the reader +-- function is called again. To signal the end of the chunk, the reader +-- must return @NULL@ or set size to zero. The reader function may +-- return pieces of any size greater than zero. +-- +-- See . +type Reader = FunPtr (State -> Ptr () -> Ptr CSize -> IO (Ptr CChar)) + +-- | The type of integers in Lua. +-- +-- By default this type is @'Int64'@, but that can be changed to +-- different values in lua. (See @LUA_INT_TYPE@ in @luaconf.h@.) +-- +-- See . +newtype Integer = Integer #{type LUA_INTEGER} + deriving (Bounded, Enum, Eq, Integral, Num, Ord, Real, Show) + +-- | The type of floats in Lua. +-- +-- By default this type is @'Double'@, but that can be changed in Lua to +-- a single float or a long double. (See @LUA_FLOAT_TYPE@ in +-- @luaconf.h@.) +-- +-- See . +newtype Number = Number #{type LUA_NUMBER} + deriving (Eq, Floating, Fractional, Num, Ord, Real, RealFloat, RealFrac, Show) + +-- | Boolean value returned by a Lua C API function. This is a @'CInt'@ +-- and should be interpreted as @'False'@ iff the value is @0@, @'True'@ +-- otherwise. +newtype LuaBool = LuaBool CInt + deriving (Eq, Storable, Show) + +-- | Integer code used to encode the type of a Lua value. +newtype TypeCode = TypeCode { fromTypeCode :: CInt } + deriving (Eq, Ord, Show) + +-- | Relational operator code. +newtype OPCode = OPCode CInt deriving (Eq, Storable) + +-- | Integer code used to signal the status of a thread or computation. +newtype StatusCode = StatusCode CInt deriving (Eq, Storable) + +-- | Garbage-collection options. +newtype GCCode = GCCode CInt deriving (Eq, Storable) + +-- | A stack index +newtype StackIndex = StackIndex { fromStackIndex :: CInt } + deriving (Enum, Eq, Num, Ord, Show) + +-- +-- Number of arguments and return values +-- + +-- | The number of arguments consumed curing a function call. +newtype NumArgs = NumArgs { fromNumArgs :: CInt } + deriving (Eq, Num, Ord, Show) + +-- | The number of results returned by a function call. +newtype NumResults = NumResults { fromNumResults :: CInt } + deriving (Eq, Num, Ord, Show) diff --git a/src/Lua/Userdata.hs b/src/Lua/Userdata.hs new file mode 100644 --- /dev/null +++ b/src/Lua/Userdata.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE CPP #-} +{-| +Module : Lua.Userdata +Copyright : © 2017-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : ForeignFunctionInterface + +Bindings to HsLua-specific functions used to push Haskell values +as userdata. +-} +module Lua.Userdata + ( hslua_fromuserdata + , hslua_newhsuserdata + , hslua_newudmetatable + , hslua_putuserdata + ) where + +import Foreign.C (CInt (CInt), CString) +import Lua.Auxiliary (luaL_testudata) +import Lua.Primary (lua_newuserdata) +import Lua.Types + ( LuaBool (..) + , StackIndex (..) + , State (..) + ) +import Foreign.Ptr (castPtr, nullPtr) +import Foreign.StablePtr (newStablePtr, deRefStablePtr, freeStablePtr) +import Foreign.Storable (peek, poke, sizeOf) + +#ifdef ALLOW_UNSAFE_GC +#define SAFTY unsafe +#else +#define SAFTY safe +#endif + +-- | Creates and registers a new metatable for a userdata-wrapped +-- Haskell value; checks whether a metatable of that name has been +-- registered yet and uses the registered table if possible. +foreign import ccall SAFTY "hsludata.h hslua_newudmetatable" + hslua_newudmetatable :: State -- ^ Lua state + -> CString -- ^ Userdata name (__name) + -> IO LuaBool -- ^ True iff new metatable + -- was created. + +-- | Creates a new userdata wrapping the given Haskell object. +hslua_newhsuserdata :: State -> a -> IO () +hslua_newhsuserdata l x = do + xPtr <- newStablePtr x + udPtr <- lua_newuserdata l (fromIntegral $ sizeOf xPtr) + poke (castPtr udPtr) xPtr +{-# INLINABLE hslua_newhsuserdata #-} + +-- | Retrieves a Haskell object from userdata at the given index. +-- The userdata /must/ have the given name. +hslua_fromuserdata :: State + -> StackIndex -- ^ userdata index + -> CString -- ^ name + -> IO (Maybe a) +hslua_fromuserdata l idx name = do + udPtr <- luaL_testudata l idx name + if udPtr == nullPtr + then return Nothing + else Just <$> (peek (castPtr udPtr) >>= deRefStablePtr) +{-# INLINABLE hslua_fromuserdata #-} + +-- | Replaces the Haskell value contained in the userdata value at +-- @index@. Checks that the userdata is of type @name@ and returns +-- 'True' on success, or 'False' otherwise. +hslua_putuserdata :: State + -> StackIndex -- ^ index + -> CString -- ^ name + -> a -- ^ new Haskell value + -> IO Bool +hslua_putuserdata l idx name x = do + xPtr <- newStablePtr x + udPtr <- luaL_testudata l idx name + if udPtr == nullPtr + then return False + else do + peek (castPtr udPtr) >>= freeStablePtr + poke (castPtr udPtr) xPtr + return True +{-# INLINABLE hslua_putuserdata #-} diff --git a/test/Lua/UnsafeTests.hs b/test/Lua/UnsafeTests.hs new file mode 100644 --- /dev/null +++ b/test/Lua/UnsafeTests.hs @@ -0,0 +1,131 @@ +{-# OPTIONS_GHC -Wno-warnings-deprecations #-} +{-| +Module : Lua.UnsafeTests +Copyright : © 2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta + +Tests for bindings to unsafe functions. +-} +module Lua.UnsafeTests (tests) where + +import Foreign.C.String (withCString, withCStringLen) +import Foreign.Ptr (nullPtr) +import Lua +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, HasCallStack, testCase, (@=?) ) + +-- | Tests for unsafe methods. +tests :: TestTree +tests = testGroup "Unsafe" + [ testGroup "tables" + [ "set and get integer field" =: do + (-23, LUA_TNUMBER) `shouldBeResultOf` \l -> do + lua_createtable l 0 0 + lua_pushinteger l 5 + lua_pushinteger l (-23) + lua_settable l (nth 3) + lua_pushinteger l 5 + tp <- lua_gettable l (nth 2) + i <- lua_tointegerx l top nullPtr + return (i, tp) + + , "get metamethod field" =: do + (TRUE, LUA_TBOOLEAN) `shouldBeResultOf` \l -> do + -- create table + lua_createtable l 0 0 + -- create metatable + lua_createtable l 0 0 + withCStringLen "__index" $ \(ptr, len) -> + lua_pushlstring l ptr (fromIntegral len) + -- create index table + lua_createtable l 0 0 + lua_pushinteger l 5 + lua_pushboolean l TRUE + lua_rawset l (nth 3) + -- set index table to "__index" in metatable + lua_rawset l (nth 3) + -- set metatable + lua_setmetatable l (nth 2) + -- access field in metatable + lua_pushinteger l 5 + tp <- lua_gettable l (nth 2) + b <- lua_toboolean l top + return (b, tp) + + , "set metamethod field" =: do + 1337 `shouldBeResultOf` \l -> do + lua_createtable l 0 0 -- index table + -- create table t + lua_createtable l 0 0 + -- create metatable + lua_createtable l 0 0 + withCStringLen "__newindex" $ \(ptr, len) -> + lua_pushlstring l ptr (fromIntegral len) + lua_pushvalue l (nth 4) -- index table + -- set index table to "__newindex" in metatable + lua_rawset l (nth 3) + -- set metatable + lua_setmetatable l (nth 2) + + -- set field n index table via __newindex on t + lua_pushinteger l 1 + lua_pushinteger l 1337 + lua_settable l (nth 3) + + lua_pop l 1 -- drop table t + lua_pushinteger l 1 + lua_rawget l (nth 2) + lua_tointegerx l top nullPtr + ] + + , testGroup "globals" + [ "get global from base library" =: + LUA_TFUNCTION `shouldBeResultOf` \l -> do + luaL_openlibs l + withCString "print" $ \ptr -> + lua_getglobal l ptr + + , "set global" =: + 13.37 `shouldBeResultOf` \l -> do + lua_pushnumber l 13.37 + withCString "foo" $ lua_setglobal l + lua_pushglobaltable l + withCStringLen "foo" $ \(ptr, len) -> + lua_pushlstring l ptr (fromIntegral len) + lua_rawget l (nth 2) + lua_tonumberx l top nullPtr + ] + + , testGroup "next" + [ "get next key from table" =: + 41 `shouldBeResultOf` \l -> do + -- create table {41} + lua_createtable l 0 0 + lua_pushinteger l 41 + lua_rawseti l (nth 2) 1 + -- first key + lua_pushnil l + x <- lua_next l (nth 2) + if x == FALSE + then fail "expected truish return value" + else lua_tonumberx l top nullPtr + + , "returns FALSE if table is empty" =: + FALSE `shouldBeResultOf` \l -> do + lua_createtable l 0 0 + lua_pushnil l + lua_next l (nth 2) + ] + ] + +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 diff --git a/test/test-lua.hs b/test/test-lua.hs --- a/test/test-lua.hs +++ b/test/test-lua.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-| Module : Main Copyright : © 2021 Albert Krewinkel @@ -9,13 +10,21 @@ -} module Main (main) where +#ifdef ALLOW_UNSAFE_GC +import Control.Monad (void) +#else +import Control.Monad (forM_, void) +import Data.IORef (newIORef, readIORef, writeIORef) +#endif + import Foreign.C.String (peekCString, withCStringLen) -import Foreign.Ptr (nullPtr) -import Foreign.Lua.Raw.Auxiliary -import Foreign.Lua.Raw.Functions -import Foreign.Lua.Raw.Types +import Foreign.Marshal (alloca) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable as Storable +import Lua import Test.Tasty (TestTree, defaultMain, testGroup) -import Test.Tasty.HUnit ( Assertion, testCase, (@=?) ) +import Test.Tasty.HUnit (Assertion, HasCallStack, assertBool, testCase, (@=?)) +import qualified Lua.UnsafeTests -- | Runs tests. main :: IO () @@ -24,70 +33,384 @@ -- | Specifications for Attributes parsing functions. tests :: TestTree tests = testGroup "lua" - [ testGroup "state" + [ testGroup "thread" [ "create and close" =: do l <- hsluaL_newstate lua_close l + + , "newthread" =: do + (5, 23) `shouldBeResultOf` \l -> do + l1 <- lua_newthread l + lua_pushnumber l 5 + lua_pushnumber l1 23 + (,) <$> lua_tonumberx l top nullPtr + <*> lua_tonumberx l1 top nullPtr + + , "type check" =: do + TRUE `shouldBeResultOf` \l -> do + _ <- lua_newthread l + lua_isthread l top + + , "thread type is LUA_TTHREAD" =: do + LUA_TTHREAD `shouldBeResultOf` \l -> do + _ <- lua_newthread l + lua_type l top + + , "pushing" =: do + LUA_TTHREAD `shouldBeResultOf` \l -> do + newl <- lua_newthread l + lua_pop l 1 + _ <- lua_pushthread newl + lua_type newl top ] , testGroup "booleans" [ "push and retrieve" =: do - l <- hsluaL_newstate - lua_pushboolean l true - b <- lua_toboolean l (-1) - lua_close l - true @=? b + TRUE `shouldBeResultOf` \l -> do + lua_pushboolean l TRUE + lua_toboolean l top + , "check" =: do + TRUE `shouldBeResultOf` \l -> do + lua_pushboolean l FALSE + lua_isboolean l top + , "type" =: do - l <- hsluaL_newstate - lua_pushboolean l false - ty <- lua_type l (-1) - lua_close l - TypeBoolean @=? toType ty + LUA_TBOOLEAN `shouldBeResultOf` \l -> do + lua_pushboolean l FALSE + lua_type l top ] , testGroup "numbers" - [ "push and retrieve" =: do - l <- hsluaL_newstate - lua_pushinteger l 5 - i <- lua_tointegerx l (-1) nullPtr - lua_close l - 5 @=? i + [ "push and retrieve integer" =: do + 5 `shouldBeResultOf` \l -> do + lua_pushinteger l 5 + lua_tointegerx l top nullPtr + , "push and retrieve float" =: do + (-0.1) `shouldBeResultOf` \l -> do + lua_pushnumber l (-0.1) + lua_tonumberx l top nullPtr + + , "check for integer" =: do + (TRUE, FALSE) `shouldBeResultOf` \l -> do + lua_pushinteger l 0 + t <- lua_isinteger l top + lua_pushnil l + f <- lua_isinteger l top + return (t, f) + + , "check for number" =: do + (TRUE, FALSE) `shouldBeResultOf` \l -> do + lua_pushinteger l 0 + t <- lua_isnumber l top + lua_pushnil l + f <- lua_isnumber l top + return (t, f) + , "type" =: do - l <- hsluaL_newstate - lua_pushinteger l 0 - ty <- lua_type l (-1) - lua_close l - TypeNumber @=? toType ty + LUA_TNUMBER `shouldBeResultOf` \l -> do + lua_pushinteger l 0 + lua_type l top ] + , testGroup "nil" + [ "push and type check" =: + (TRUE, FALSE) `shouldBeResultOf` \l -> do + lua_pushnil l + t <- lua_isnil l top + lua_pushglobaltable l + f <- lua_isnil l top + return (t, f) + + , "type is LUA_TNIL" =: + LUA_TNIL `shouldBeResultOf` \l -> do + lua_pushnil l + lua_type l top + ] + + , testGroup "none" + [ "invalid index is 'none'" =: + TRUE `shouldBeResultOf` \l -> lua_isnone l 1 + + , "valid index is not none" =: + FALSE `shouldBeResultOf` \l -> do + lua_pushnil l + lua_isnone l 1 + + , "invalid index has type LUA_TNONE" =: + LUA_TNONE `shouldBeResultOf` \l -> lua_type l 9 + ] + , testGroup "strings" [ "push and retrieve" =: do - l <- hsluaL_newstate - withCStringLen "testing" $ \(ptr, len) -> - lua_pushlstring l ptr (fromIntegral len) - str <- peekCString =<< lua_tolstring l (-1) nullPtr - lua_close l - "testing" @=? str + "testing" `shouldBeResultOf` \l -> do + withCStringLen "testing" $ \(ptr, len) -> + lua_pushlstring l ptr (fromIntegral len) + peekCString =<< lua_tolstring l top nullPtr , "type" =: do - l <- hsluaL_newstate - withCStringLen "Olsen Olsen" $ \(ptr, len) -> - lua_pushlstring l ptr (fromIntegral len) - ty <- lua_type l (-1) - lua_close l - TypeString @=? toType ty + LUA_TSTRING `shouldBeResultOf` \l -> do + withCStringLen "Olsen Olsen" $ \(ptr, len) -> + lua_pushlstring l ptr (fromIntegral len) + lua_type l top ] + , testGroup "tables" + [ "check type" =: do + TRUE `shouldBeResultOf` \l -> do + lua_createtable l 0 0 + lua_istable l top + + , "has type LUA_TTABLE" =: do + LUA_TTABLE `shouldBeResultOf` \l -> do + lua_createtable l 0 0 + lua_type l top + + , "set and get integer field" =: do + (-23) `shouldBeResultOf` \l -> do + lua_createtable l 0 0 + lua_pushinteger l 5 + lua_pushinteger l (-23) + lua_rawset l (nth 3) + lua_pushinteger l 5 + lua_rawget l (nth 2) + lua_tointegerx l top nullPtr + ] + , testGroup "constants" [ "loadedTableRegistryField" =: ("_LOADED" @=? loadedTableRegistryField) , "preloadTableRegistryField" =: ("_PRELOAD" @=? preloadTableRegistryField) ] + + , testGroup "compare" + [ "equality" =: do + TRUE `shouldBeResultOf` \l -> do + lua_pushinteger l 42 + lua_pushnumber l 42 + hslua_compare l (nth 2) (nth 1) LUA_OPEQ nullPtr + + , "less then" =: do + TRUE `shouldBeResultOf` \l -> do + lua_pushinteger l (-2) + lua_pushnumber l 3 + hslua_compare l (nth 2) (nth 1) LUA_OPLT nullPtr + + , "not less then" =: do + FALSE `shouldBeResultOf` \l -> do + lua_pushinteger l 42 + lua_pushnumber l 42 + hslua_compare l (nth 2) (nth 1) LUA_OPLT nullPtr + + , "less then or equal" =: do + TRUE `shouldBeResultOf` \l -> do + lua_pushinteger l 23 + lua_pushnumber l 42 + alloca $ \statusPtr -> do + result <- hslua_compare l (nth 2) (nth 1) LUA_OPLE statusPtr + status <- Storable.peek statusPtr + assertBool "comparison failed" (LUA_OK == status) + return result + ] + + , testGroup "function calling" + [ "call `type(true)`" =: do + "boolean" `shouldBeResultOf` \l -> do + luaL_openlibs l + -- push function `type` + lua_pushglobaltable l + withCStringLen "type" $ \(ptr, len) -> + lua_pushlstring l ptr (fromIntegral len) + lua_rawget l (nth 2) + -- push boolean + lua_pushboolean l TRUE + status <- lua_pcall l (NumArgs 1) (NumResults 1) 0 + assertBool "call status" (status == LUA_OK) + peekCString =<< lua_tolstring l top nullPtr + + , "call type" =: do + (== LUA_ERRRUN) `shouldHoldForResultOf` \l -> do + luaL_openlibs l + -- push function `error` + lua_pushglobaltable l + withCStringLen "error" $ \(ptr, len) -> + lua_pushlstring l ptr (fromIntegral len) + lua_rawget l (nth 2) + -- push boolean + lua_pushboolean l TRUE + lua_pcall l (NumArgs 1) (NumResults 1) 0 + ] + + , testGroup "garbage-collection" + [ "stop, restart GC" =: do + counts <- withNewState $ \l -> do + lua_createtable l 0 0 + _ <- lua_gc l LUA_GCSTOP 0 + lua_pop l 1 + kb1 <- lua_gc l LUA_GCCOUNT 0 + b1 <- lua_gc l LUA_GCCOUNTB 0 + _ <- lua_gc l LUA_GCCOLLECT 0 + kb2 <- lua_gc l LUA_GCCOUNT 0 + b2 <- lua_gc l LUA_GCCOUNTB 0 + return (b1 + 1024 * kb1, b2 + 1024 * kb2) + assertBool "first count should be larger" (uncurry (>) counts) + , "count memory" =: do + count <- withNewState $ \l -> do + lua_gc l LUA_GCCOUNT 0 + assertBool "memory consumption not between 0 and 10 kB" + (count > 0 && count < 10) + ] + + , testGroup "ersatz functions" + [ testGroup "globals" + [ "get global from base library" =: + LUA_TFUNCTION `shouldBeResultOf` \l -> do + luaL_openlibs l + withCStringLen "print" $ \(cstr, len) -> + withAssertOK $ hslua_getglobal l cstr (fromIntegral len) + + , "set global" =: + 13.37 `shouldBeResultOf` \l -> do + lua_pushnumber l 13.37 + withCStringLen "foo" $ \(cstr, len) -> + withAssertOK $ hslua_setglobal l cstr (fromIntegral len) + lua_pushglobaltable l + withCStringLen "foo" $ \(ptr, len) -> + lua_pushlstring l ptr (fromIntegral len) + lua_rawget l (nth 2) + lua_tonumberx l top nullPtr + ] + + , testGroup "table" + [ "get metamethod field via ersatz function" =: + (TRUE, LUA_TBOOLEAN) `shouldBeResultOf` \l -> do + -- create table + lua_createtable l 0 0 + -- create metatable + lua_createtable l 0 0 + withCStringLen "__index" $ \(ptr, len) -> + lua_pushlstring l ptr (fromIntegral len) + -- create index table + lua_createtable l 0 0 + lua_pushinteger l 5 + lua_pushboolean l TRUE + lua_rawset l (nth 3) + -- set index table to "__index" in metatable + lua_rawset l (nth 3) + -- set metatable + lua_setmetatable l (nth 2) + -- access field in metatable + lua_pushinteger l 5 + tp <- alloca $ \status -> + hslua_gettable l (nth 2) status <* + (peek status >>= assertBool "gettable status" . (== LUA_OK)) + b <- lua_toboolean l top + return (b, tp) + + , "set metamethod field" =: + 1337 `shouldBeResultOf` \l -> do + lua_createtable l 0 0 -- index table + -- create table t + lua_createtable l 0 0 + -- create metatable + lua_createtable l 0 0 + withCStringLen "__newindex" $ \(ptr, len) -> + lua_pushlstring l ptr (fromIntegral len) + lua_pushvalue l (nth 4) -- index table + -- set index table to "__newindex" in metatable + lua_rawset l (nth 3) + -- set metatable + lua_setmetatable l (nth 2) + + -- set field n index table via __newindex on t + lua_pushinteger l 1 + lua_pushinteger l 1337 + alloca $ \status -> + hslua_settable l (nth 3) status <* + (peek status >>= assertBool "settable status" . (== LUA_OK)) + + lua_pop l 1 -- drop table t + lua_pushinteger l 1 + lua_rawget l (nth 2) + lua_tointegerx l top nullPtr + ] + ] + + , testGroup "Haskell functions" + [ let add5 l = do + n <- lua_tointegerx l top nullPtr + lua_pushinteger l $ n + 5 + return (NumResults 1) + in "call Haskell function" =: do + 23 `shouldBeResultOf` \l -> do + hslua_pushhsfunction l add5 + lua_pushinteger l 18 + void $ lua_pcall l (NumArgs 1) (NumResults 1) 0 + lua_tointegerx l (nth 1) nullPtr + +#ifndef ALLOW_UNSAFE_GC + , "Haskell function as finalizer" =: do + msg <- newIORef "nope" + let sendMessage _ = do + writeIORef msg "HI MOM!" + return (NumResults 0) + "HI MOM!" `shouldBeResultOf` \l -> do + -- create dummy table + lua_createtable l 0 0 + -- create metatable with Haskell __gc function + lua_createtable l 0 0 + withCStringLen "__gc" $ \(ptr, len) -> + lua_pushlstring l ptr (fromIntegral len) + hslua_pushhsfunction l sendMessage + lua_rawset l (nth 3) + -- set metatable with finalizer + lua_setmetatable l (nth 2) + -- remove dummy table from stack so the GC to collect it + lua_pop l 1 + -- perform a large number of operations to allow the GC to kick in. + forM_ [1..100] $ \i -> do + -- push some string + withCStringLen "some nonesense" $ \(ptr, len) -> + lua_pushlstring l ptr (fromIntegral len) + -- create new table with integer field + lua_createtable l 0 0 + lua_pushinteger l i + lua_pushinteger l 23 + lua_rawset l (nth 3) + -- set empty table as metatable + lua_createtable l 0 0 + lua_setmetatable l (nth 2) + -- remove table and strings from stack + lua_pop l 2 + -- the GC should have run now, check the message + readIORef msg +#endif + ] + + , Lua.UnsafeTests.tests ] 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 + +shouldHoldForResultOf :: HasCallStack + => (a -> Bool) -> (State -> IO a) -> Assertion +shouldHoldForResultOf predicate luaOp = do + result <- withNewState luaOp + assertBool "predicate does not hold" (predicate result) + +withAssertOK :: HasCallStack => (Ptr StatusCode -> IO a) -> IO a +withAssertOK f = + alloca $ \status -> do + result <- f status + peek status >>= assertBool "status not OK" . (== LUA_OK) + return result