diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,11 +1,61 @@ ## Changelog +### 1.2.0 + +Released 2020-08-15 + +- New module `Foreign.Lua.Call`: the module offers an alternative + method of exposing Haskell functions to Lua. The focus is on + maintainability: types and marshaling methods are made explicit; + the possibility of adding documentation and parameter names + improves error messages and allows for automatic documentation + extraction. + + Work on this module is ongoing; the interface is likely to + change. Suggestions and feedback are welcome. + +- New types `Module`, `Field`, and new functions `registerModule`, + `preloadModule`, `pushModule`, and `render` exported from + `Foreign.Lua.Module`: this builds on the new `Call` module and + allows the creation of documented modules as well as automatic + generation of Markdown-formatted module documentation. + +- Export new items `nth` and `top` from Foreign.Lua.Core and + Foreign.Lua. They are short-hands for `nthFromTop` and + `stackTop`. + +- Performance improvements: Calling of Lua functions and creation + of Haskell data wrapping userdata has been sped up by about 10%. + This is mostly due to using of previously missed optimization + opportunities. + +- All foreign imports have been moved to into the new + `Foreign.Lua.Raw` module. This module will replace the current + `Foreign.Lua.Core` module in the future and will be distributed + as a separate package (likely starting with the 2.0 release); + the remaining parts of the current `Core` module will be + promoted one level in the module hierarchy. + + The `Raw` module can be used whenever the full power of HsLua is + not needed. + +- Error-signaling of API wrapper functions has been changed: + instead of returning special integer values, functions now take + an additional pointer argument, which is set to the status + result of the computation. + + The `Failable` type in Core.Error is no longer needed and has + been removed. + +- CI builds now include GHC 8.8 and GHC 8.10, ensuring that all + GHC 8.* versions are supported. + ### 1.1.2 -Released 2020-06-02 +Released 2020-06-27 - Revert signature of function `pushList` to it's proper 1.1 - value. This fixes a mistake which made caused the 1.1.1 release + value. This fixes a mistake which caused the 1.1.1 release to be in violation of the PVP versioning policy. - Module Foreign.Lua.Peek: add function `pushKeyValuePairs` (Alex diff --git a/cbits/error-conversion/error-conversion.c b/cbits/error-conversion/error-conversion.c deleted file mode 100644 --- a/cbits/error-conversion/error-conversion.c +++ /dev/null @@ -1,261 +0,0 @@ -#include -#include -#include -#include "error-conversion.h" - -/* ********************************************************************* - * Transforming Haskell errors to Lua errors - * *********************************************************************/ -void hslua_pushhaskellerr(lua_State *L) -{ - lua_getfield(L, LUA_REGISTRYINDEX, "HSLUA_ERR"); -} - -/* -** Marks the occurence of an error; the returned value should be used as -** the error message. -*/ -int hslua_error(lua_State *L) -{ - hslua_pushhaskellerr(L); - lua_insert(L, -2); - return 2; -} - -/* -** Checks whether the object at the given index is a Haskell error. -*/ -int hslua_is_haskell_error(lua_State *L, int idx) { - hslua_pushhaskellerr(L); - int is_err = lua_rawequal(L, idx, -1); - lua_pop(L, 1); /* pop haskellerr used for equality test */ - return is_err; -} - -/* -** Converts a Haskell function into a CFunction. -** -** We signal an error on the haskell side by passing two values: the -** special haskellerr object and the error message. The function -** returned an error iff there are exactly two results objects where the -** first object is the special HSLUA_ERR registry entry. -*/ -int hslua_call_hs(lua_State *L) -{ - int nargs = lua_gettop(L); - /* Push HaskellImportFunction and call the underlying function */ - lua_pushvalue(L, lua_upvalueindex(1)); - lua_insert(L, 1); - lua_call(L, nargs, LUA_MULTRET); - - /* Check whether an error value was returned */ - int nres = lua_gettop(L); - - /* If there are two results, the first of which is the special error - * object, then the other object is thrown as an error. - */ - if (nres == 2 && hslua_is_haskell_error(L, 1)) { - return lua_error(L); /* throw 2nd return value as error */ - } - - return nres; -} - -/* ********************************************************************* - * Garbage Collection - * *********************************************************************/ - -/* -** Free stable Haskell pointer in userdata. -*/ -int hslua_userdata_gc(lua_State *L) -{ - HsStablePtr *userdata = lua_touserdata(L, 1); - if (userdata) { - hs_free_stable_ptr(*userdata); - } - return 0; -} - - -/* ********************************************************************* - * Transforming Lua errors to Haskell errors - * *********************************************************************/ - -/* -** compare -*/ -int hslua__compare(lua_State *L) -{ - int op = lua_tointeger(L, 3); - int res = lua_compare(L, 1, 2, op); - lua_pushinteger(L, res); - return 1; -} - -int hslua_compare(lua_State *L, int index1, int index2, int op) -{ - index1 = lua_absindex(L, index1); - index2 = lua_absindex(L, index2); - lua_pushcfunction(L, hslua__compare); - lua_pushvalue(L, index1); - lua_pushvalue(L, index2); - lua_pushinteger(L, op); - int callres = lua_pcall(L, 3, 1, 0); - if (callres != 0) { - return -callres; - } - int res = lua_tointeger(L, -1); - lua_pop(L, 1); - return res; -} - - -/* -** concat -*/ -int hslua__concat(lua_State *L) -{ - lua_concat(L, lua_gettop(L)); - return 1; -} - -int hslua_concat(lua_State *L, int n) -{ - lua_pushcfunction(L, hslua__concat); - lua_insert(L, -n - 1); - return -lua_pcall(L, n, 1, 0); -} - - -/* -** getglobal -*/ -int hslua__getglobal(lua_State *L) -{ - lua_gettable(L, 1); - return 1; -} - -int hslua_getglobal(lua_State *L, const char *name, size_t len) -{ - lua_pushcfunction(L, hslua__getglobal); - lua_pushglobaltable(L); - lua_pushlstring(L, name, len); - return -lua_pcall(L, 2, 1, 0); -} - - -/* -** gettable -*/ -int hslua__gettable(lua_State *L) -{ - lua_pushvalue(L, 1); - lua_gettable(L, 2); - return 1; -} - -int hslua_gettable(lua_State *L, int index) -{ - lua_pushvalue(L, index); - lua_pushcfunction(L, hslua__gettable); - lua_insert(L, -3); - return -lua_pcall(L, 2, 1, 0); -} - - -/* -** setglobal -*/ -int hslua__setglobal(lua_State *L) -{ - /* index 1: value */ - /* index 2: the global table */ - /* index 3: key */ - lua_pushvalue(L, 1); - lua_settable(L, 2); - return 0; -} - -int hslua_setglobal(lua_State *L, const char *name, size_t len) -{ - /* we expect the new value to be at the top of the stack */ - lua_pushglobaltable(L); - lua_pushlstring(L, name, len); - lua_pushcfunction(L, hslua__setglobal); - lua_insert(L, -4); - return -lua_pcall(L, 3, 0, 0); -} - - -/* -** settable -*/ -int hslua__settable(lua_State *L) -{ - lua_pushvalue(L, 1); /* key */ - lua_pushvalue(L, 2); /* value */ - lua_settable(L, 3); /* table is the third argument */ - return 0; -} - -int hslua_settable(lua_State *L, int index) -{ - lua_pushvalue(L, index); - lua_pushcfunction(L, hslua__settable); - lua_insert(L, -4); - return -lua_pcall(L, 3, 0, 0); -} - - -/* -** next -*/ -int hslua__next(lua_State *L) -{ - lua_pushvalue(L, 1); - return lua_next(L, 2) ? 2 : 0; -} - -int hslua_next(lua_State *L, int index) -{ - int oldsize = lua_gettop(L); - lua_pushvalue(L, index); - lua_pushcfunction(L, hslua__next); - lua_insert(L, -3); - int res = lua_pcall(L, 2, LUA_MULTRET, 0); - if (res != 0) { - /* error */ - return (- res); - } - /* success */ - return (lua_gettop(L) - oldsize + 1); /* correct for popped value */ -} - - -/* -** Auxiliary Library -*/ - -/* -** 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/error-conversion/error-conversion.h b/cbits/error-conversion/error-conversion.h deleted file mode 100644 --- a/cbits/error-conversion/error-conversion.h +++ /dev/null @@ -1,26 +0,0 @@ -#include "lua.h" -#include "lauxlib.h" - -int hslua_error(lua_State *L); - -int hslua_call_hs(lua_State *L); - -int hslua_userdata_gc(lua_State *L); - -int hslua_compare(lua_State *L, int index1, int index2, int op); - -int hslua_concat(lua_State *L, int n); - -int hslua_getglobal(lua_State *L, const char *name, size_t len); - -int hslua_gettable(lua_State *L, int index); - -int hslua_setglobal(lua_State *L, const char *k, size_t len); - -int hslua_settable(lua_State *L, int index); - -int hslua_next(lua_State *L, int index); - - -/* auxiliary library */ -const char *hsluaL_tolstring(lua_State *L, int index, size_t *len); diff --git a/cbits/hslua/hslcall.c b/cbits/hslua/hslcall.c new file mode 100644 --- /dev/null +++ b/cbits/hslua/hslcall.c @@ -0,0 +1,102 @@ +#include +#include +#include +#include "hslua-export.h" +#include "hslcall.h" +#include "hsludata.h" + +/* *************************************************************** + * Transforming Haskell errors to Lua errors + * ***************************************************************/ +void hslua_pushhaskellerr(lua_State *L) +{ + lua_getfield(L, LUA_REGISTRYINDEX, HSLUA_ERR); +} + +/* +** Marks the occurence of an error; the returned value should be +** used as the error message. +*/ +int hslua_error(lua_State *L) +{ + hslua_pushhaskellerr(L); + lua_insert(L, -2); + return 2; +} + +/* +** Checks whether the object at the given index is a Haskell error. +*/ +int hslua_is_haskell_error(lua_State *L, int idx) +{ + int erridx = lua_absindex(L, idx); + hslua_pushhaskellerr(L); + int is_err = lua_rawequal(L, erridx, -1); + lua_pop(L, 1); /* pop haskellerr used for equality test */ + return is_err; +} + +/* +** Converts a Haskell function into a CFunction. +** +** We signal an error on the haskell side by passing two values: +** the special HSLUA_ERR object and the error message. The +** function returned an error iff there are exactly two results +** objects where the first object is the special HSLUA_ERR +** registry entry. +*/ +int hslua_call_hs(lua_State *L) +{ + int nargs = lua_gettop(L); + /* Push HaskellFunction and call the underlying function */ + lua_pushvalue(L, lua_upvalueindex(1)); + lua_insert(L, 1); + lua_call(L, nargs, LUA_MULTRET); + + /* Check whether an error value was returned */ + int nres = lua_gettop(L); + + /* If there are two results, the first of which is the special + * error object, then the other object is thrown as an error. + */ + if (nres == 2 && hslua_is_haskell_error(L, 1)) { + return lua_error(L); /* throw 2nd return value as error */ + } + + return nres; +} + +/* +** Retrieves a HsStablePtr to a Haskell function from a +** function-wrapping userdata when it's been called and removes +** the userdata from the stack. +*/ +void *hslua_hs_fun_ptr(lua_State *L) +{ + void *fn = luaL_testudata(L, 1, HSLUA_HSFUN_NAME); + lua_remove(L, 1); + return fn; +} + +/* +** Pushes a metatable for Haskell function wrapping userdata to +** the stack. +*/ +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); +} + +/* +** Creates a new C function from a Haskell function. +*/ +void hslua_newhsfunction(lua_State *L, HsStablePtr fn) +{ + HsStablePtr *ud = lua_newuserdata(L, sizeof fn); + *ud = fn; + luaL_setmetatable(L, HSLUA_HSFUN_NAME); + lua_pushcclosure(L, &hslua_call_hs, 1); +} diff --git a/cbits/hslua/hslcall.h b/cbits/hslua/hslcall.h new file mode 100644 --- /dev/null +++ b/cbits/hslua/hslcall.h @@ -0,0 +1,12 @@ +#ifndef hslcall_h +#define hslcall_h + +#define HSLUA_ERR "HSLUA_ERR" +#define HSLUA_HSFUN_NAME "HsLuaFunction" +#include +#include + +/* register metatable for HaskellFunction userdata wrappers */ +void hslua_registerhsfunmetatable(lua_State *L); + +#endif diff --git a/cbits/hslua/hslua-export.h b/cbits/hslua/hslua-export.h new file mode 100644 --- /dev/null +++ b/cbits/hslua/hslua-export.h @@ -0,0 +1,8 @@ +/* *************************************************************** + * 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 new file mode 100644 --- /dev/null +++ b/cbits/hslua/hslua.c @@ -0,0 +1,205 @@ +#include +#include +#include +#include "hslua.h" +#include "hslcall.h" + +/* *************************************************************** + * Transforming Lua errors to Haskell errors + * ***************************************************************/ + +/* +** compare +*/ +int hslua__compare(lua_State *L) +{ + int op = lua_tointeger(L, 3); + int res = lua_compare(L, 1, 2, op); + lua_pushinteger(L, res); + return 1; +} + +int hslua_compare(lua_State *L, int index1, int index2, int op, int *status) +{ + index1 = lua_absindex(L, index1); + index2 = lua_absindex(L, index2); + lua_pushcfunction(L, hslua__compare); + lua_pushvalue(L, index1); + lua_pushvalue(L, index2); + lua_pushinteger(L, op); + *status = lua_pcall(L, 3, 1, 0); + if (*status != LUA_OK) { + return 0; + } + int result = lua_tointeger(L, -1); + lua_pop(L, 1); + return result; +} + + +/* +** concat +*/ +int hslua__concat(lua_State *L) +{ + lua_concat(L, lua_gettop(L)); + return 1; +} + +void hslua_concat(lua_State *L, int n, int *status) +{ + lua_pushcfunction(L, hslua__concat); + lua_insert(L, -n - 1); + *status = lua_pcall(L, n, 1, 0); +} + + +/* +** getglobal +*/ +int hslua__getglobal(lua_State *L) +{ + lua_gettable(L, 1); + return 1; +} + +void 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); +} + + +/* +** gettable +*/ +int hslua__gettable(lua_State *L) +{ + lua_pushvalue(L, 1); + lua_gettable(L, 2); + return 1; +} + +void 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); +} + + +/* +** setglobal +*/ +int hslua__setglobal(lua_State *L) +{ + /* index 1: value */ + /* index 2: the global table */ + /* index 3: key */ + lua_pushvalue(L, 1); + lua_settable(L, 2); + return 0; +} + +void hslua_setglobal(lua_State *L, const char *name, size_t len, int *status) +{ + /* we expect the new value to be at the top of the stack */ + lua_pushglobaltable(L); + lua_pushlstring(L, name, len); + lua_pushcfunction(L, hslua__setglobal); + lua_insert(L, -4); + *status = lua_pcall(L, 3, 0, 0); +} + + +/* +** settable +*/ +int hslua__settable(lua_State *L) +{ + lua_pushvalue(L, 1); /* key */ + lua_pushvalue(L, 2); /* value */ + lua_settable(L, 3); /* table is the third argument */ + return 0; +} + +void hslua_settable(lua_State *L, int index, int *status) +{ + lua_pushvalue(L, index); + lua_pushcfunction(L, hslua__settable); + lua_insert(L, -4); + *status = lua_pcall(L, 3, 0, 0); +} + + +/* +** next +*/ +int hslua__next(lua_State *L) +{ + lua_pushvalue(L, 1); + return lua_next(L, 2) ? 2 : 0; +} + +int hslua_next(lua_State *L, int index, int *status) +{ + int oldsize = lua_gettop(L); + lua_pushvalue(L, index); + lua_pushcfunction(L, hslua__next); + lua_insert(L, -3); + *status = lua_pcall(L, 2, LUA_MULTRET, 0); + if (*status != 0) { + /* error */ + return 0; + } + /* 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 new file mode 100644 --- /dev/null +++ b/cbits/hslua/hslua.h @@ -0,0 +1,33 @@ +#include "lua.h" +#include "lauxlib.h" + +int hslua_error(lua_State *L); + +int hslua_call_hs(lua_State *L); + +int hslua_userdata_gc(lua_State *L); + +int hslua_compare(lua_State *L, int index1, int index2, int op, int *status); + +void hslua_concat(lua_State *L, int n, int *status); + +void hslua_getglobal(lua_State *L, const char *name, size_t len, int *status); + +void 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 new file mode 100644 --- /dev/null +++ b/cbits/hslua/hsludata.c @@ -0,0 +1,41 @@ +#include +#include "hslua.h" +#include "hsludata.h" + +/* *************************************************************** + * Userdata Creation and Garbage Collection + * ***************************************************************/ + +/* +** Free stable Haskell pointer in userdata. +** +** The userdata whose contents is garbage collected must be on +** stack index 1 (i.e., the first argument). +*/ +int hslua_userdata_gc(lua_State *L) +{ + HsStablePtr *userdata = lua_touserdata(L, 1); + if (userdata) { + hs_free_stable_ptr(*userdata); + } + return 0; +} + +/* +** Creates a new userdata metatable for Haskell objects, or gets +** is from the registry if possible. +*/ +int hslua_newudmetatable(lua_State *L, const char *tname) +{ + int created = luaL_newmetatable(L, tname); + if (created) { + /* Prevent accessing or changing the metatable with + * getmetatable/setmetatable. */ + lua_pushboolean(L, 1); + lua_setfield(L, -2, "__metatable"); + /* Mark objects for finalization when collecting garbage. */ + lua_pushcfunction(L, &hslua_userdata_gc); + lua_setfield(L, -2, "__gc"); + } + return created; +} diff --git a/cbits/hslua/hsludata.h b/cbits/hslua/hsludata.h new file mode 100644 --- /dev/null +++ b/cbits/hslua/hsludata.h @@ -0,0 +1,11 @@ +#include +#include + +/* *************************************************************** + * Userdata for Haskell values + * ***************************************************************/ + +/* +** Creates a new userdata metatable for Haskell objects. +*/ +int hslua_newudmetatable(lua_State *L, const char *tname); diff --git a/hslua.cabal b/hslua.cabal --- a/hslua.cabal +++ b/hslua.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.2 name: hslua -version: 1.1.2 +version: 1.2.0 synopsis: Bindings to Lua, an embeddable scripting language description: HsLua provides bindings, wrappers, types, and helper functions to bridge Haskell and . @@ -22,16 +23,16 @@ category: Foreign build-type: Simple extra-source-files: cbits/lua-5.3.5/*.h - cbits/error-conversion/*.h - README.md - CHANGELOG.md - test/lua/*.lua -cabal-version: >=1.10 + , cbits/hslua/*.h + , README.md + , CHANGELOG.md + , test/lua/*.lua tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.3 , GHC == 8.6.5 , GHC == 8.8.3 + , GHC == 8.10.1 source-repository head type: git @@ -85,6 +86,7 @@ library exposed-modules: Foreign.Lua + , Foreign.Lua.Call , Foreign.Lua.Core , Foreign.Lua.Core.Constants , Foreign.Lua.Core.Error @@ -94,6 +96,13 @@ , Foreign.Lua.Module , Foreign.Lua.Peek , Foreign.Lua.Push + , 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 , Foreign.Lua.Types , Foreign.Lua.Types.Peekable , Foreign.Lua.Types.Pushable @@ -111,6 +120,17 @@ hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + -Wincomplete-record-updates + -Wnoncanonical-monad-instances + -Wredundant-constraints + if impl(ghc >= 8.2) + ghc-options: -Wcpp-undef + -Werror=missing-home-modules + if impl(ghc >= 8.4) + ghc-options: -Widentities + -Wincomplete-uni-patterns + -Wpartial-fields + -fhide-source-paths default-extensions: CApiFFI , ForeignFunctionInterface , LambdaCase @@ -120,9 +140,10 @@ , FlexibleContexts , FlexibleInstances , ScopedTypeVariables - c-sources: cbits/error-conversion/error-conversion.c - include-dirs: cbits/error-conversion - + c-sources: cbits/hslua/hsludata.c + , cbits/hslua/hslcall.c + , cbits/hslua/hslua.c + include-dirs: cbits/hslua if flag(system-lua) || flag(pkg-config) if flag(pkg-config) pkgconfig-depends: lua5.3 @@ -205,8 +226,18 @@ main-is: test-hslua.hs hs-source-dirs: test ghc-options: -Wall -threaded + -Wincomplete-record-updates + -Wnoncanonical-monad-instances + if impl(ghc >= 8.2) + ghc-options: -Wcpp-undef + if impl(ghc >= 8.4) + ghc-options: -Wincomplete-uni-patterns + -Widentities + -Werror=missing-home-modules + -fhide-source-paths default-language: Haskell2010 other-modules: Foreign.LuaTests + , Foreign.Lua.CallTests , Foreign.Lua.CoreTests , Foreign.Lua.Core.AuxiliaryTests , Foreign.Lua.Core.ErrorTests diff --git a/src/Foreign/Lua/Call.hs b/src/Foreign/Lua/Call.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Lua/Call.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-| +Module : Foreign.Lua.Call +Copyright : © 2020 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : alpha +Portability : Portable + +Marshaling and documenting Haskell functions. +-} +module Foreign.Lua.Call + ( HaskellFunction (..) + , toHsFnPrecursor + , toHsFnPrecursorWithStartIndex + , applyParameter + , returnResult + , Parameter (..) + , FunctionResult (..) + , FunctionResults + -- * Operators + , (<#>) + , (=#>) + , (#?) + -- * Documentation + , FunctionDoc (..) + , ParameterDoc (..) + , FunctionResultDoc (..) + , render + -- * Pushing to Lua + , pushHaskellFunction + -- * Convenience functions + , parameter + , optionalParameter + , functionResult + ) where + +import Control.Monad.Except +import Data.Text (Text) +import Foreign.Lua.Core as Lua +import Foreign.Lua.Core.Types (liftLua) +import Foreign.Lua.Peek +import Foreign.Lua.Push +import Foreign.Lua.Raw.Call (hslua_pushhsfunction) +import qualified Data.Text as T + +-- | Lua operation with an explicit error type and state (i.e., +-- without exceptions). +type LuaExcept a = ExceptT PeekError Lua a + + +-- +-- Function components +-- + +-- | Result of a call to a Haskell function. +data FunctionResult a + = FunctionResult + { fnResultPusher :: Pusher a + , fnResultDoc :: FunctionResultDoc + } + +-- | List of function results in the order in which they are +-- returned in Lua. +type FunctionResults a = [FunctionResult a] + +-- | Function parameter. +data Parameter a = Parameter + { parameterPeeker :: Peeker a + , parameterDoc :: ParameterDoc + } + +-- | Haskell equivallent to CFunction, i.e., function callable +-- from Lua. +data HaskellFunction = HaskellFunction + { callFunction :: Lua NumResults + , functionDoc :: Maybe FunctionDoc + } + +-- +-- Documentation +-- + +-- | Documentation for a Haskell function +data FunctionDoc = FunctionDoc + { functionDescription :: Text + , parameterDocs :: [ParameterDoc] + , functionResultDocs :: [FunctionResultDoc] + } + deriving (Eq, Ord, Show) + +-- | Documentation for function parameters. +data ParameterDoc = ParameterDoc + { parameterName :: Text + , parameterType :: Text + , parameterDescription :: Text + , parameterIsOptional :: Bool + } + deriving (Eq, Ord, Show) + +-- | Documentation for the result of a function. +data FunctionResultDoc = FunctionResultDoc + { functionResultType :: Text + , functionResultDescription :: Text + } + deriving (Eq, Ord, Show) + + +-- +-- Haskell function building +-- + +-- | Helper type used to create 'HaskellFunction's. +data HsFnPrecursor a = HsFnPrecursor + { hsFnPrecursorAction :: LuaExcept a + , hsFnMaxParameterIdx :: StackIndex + , hsFnParameterDocs :: [ParameterDoc] + } + deriving (Functor) + +-- | Create a HaskellFunction precursor from a pure function. +toHsFnPrecursor :: a -> HsFnPrecursor a +toHsFnPrecursor = toHsFnPrecursorWithStartIndex (StackIndex 0) + +toHsFnPrecursorWithStartIndex :: StackIndex -> a -> HsFnPrecursor a +toHsFnPrecursorWithStartIndex idx f = HsFnPrecursor + { hsFnPrecursorAction = return f + , hsFnMaxParameterIdx = idx + , hsFnParameterDocs = mempty + } + +-- | Partially apply a parameter. +applyParameter :: HsFnPrecursor (a -> b) + -> Parameter a + -> HsFnPrecursor b +applyParameter bldr param = do + let action = hsFnPrecursorAction bldr + let i = hsFnMaxParameterIdx bldr + 1 + let context = "retrieving function argument " <> + (parameterName . parameterDoc) param + let nextAction f = withExceptT (pushMsg context) $ do + x <- ExceptT $ parameterPeeker param i + return $ f x + HsFnPrecursor + { hsFnPrecursorAction = action >>= nextAction + , hsFnMaxParameterIdx = i + , hsFnParameterDocs = parameterDoc param : hsFnParameterDocs bldr + } + +-- | Take a 'HaskellFunction' precursor and convert it into a full +-- 'HaskellFunction', using the given 'FunctionResult's to return +-- the result to Lua. +returnResults :: HsFnPrecursor a + -> FunctionResults a + -> HaskellFunction +returnResults bldr fnResults = HaskellFunction + { callFunction = do + hsResult <- runExceptT $ hsFnPrecursorAction bldr + case hsResult of + Left err -> do + pushString $ formatPeekError err + Lua.error + Right x -> do + forM_ fnResults $ \(FunctionResult push _) -> push x + return $ NumResults (fromIntegral $ length fnResults) + + , functionDoc = Just $ FunctionDoc + { functionDescription = "" + , parameterDocs = reverse $ hsFnParameterDocs bldr + , functionResultDocs = map fnResultDoc fnResults + } + } + +-- | Like @'returnResult'@, but returns only a single result. +returnResult :: HsFnPrecursor a + -> FunctionResult a + -> HaskellFunction +returnResult bldr = returnResults bldr . (:[]) + +-- | Updates the description of a Haskell function. Leaves the function +-- unchanged if it has no documentation. +updateFunctionDescription :: HaskellFunction -> Text -> HaskellFunction +updateFunctionDescription fn desc = + case functionDoc fn of + Nothing -> fn + Just fnDoc -> + fn { functionDoc = Just $ fnDoc { functionDescription = desc} } + +-- +-- Operators +-- + +infixl 8 <#>, =#>, #? + +-- | Inline version of @'applyParameter'@. +(<#>) :: HsFnPrecursor (a -> b) + -> Parameter a + -> HsFnPrecursor b +(<#>) = applyParameter + +-- | Inline version of @'returnResult'@. +(=#>) :: HsFnPrecursor a + -> FunctionResults a + -> HaskellFunction +(=#>) = returnResults + +-- | Inline version of @'updateFunctionDescription'@. +(#?) :: HaskellFunction -> Text -> HaskellFunction +(#?) = updateFunctionDescription + +-- +-- Render documentation +-- + +render :: FunctionDoc -> Text +render (FunctionDoc desc paramDocs resultDoc) = + (if T.null desc then "" else desc <> "\n\n") <> + renderParamDocs paramDocs <> + case resultDoc of + [] -> "" + rd -> "\nReturns:\n\n" <> T.intercalate "\n" (map renderResultDoc rd) + +renderParamDocs :: [ParameterDoc] -> Text +renderParamDocs pds = "Parameters:\n\n" <> + T.intercalate "\n" (map renderParamDoc pds) + +renderParamDoc :: ParameterDoc -> Text +renderParamDoc pd = mconcat + [ parameterName pd + , "\n: " + , parameterDescription pd + , " (", parameterType pd, ")\n" + ] + +renderResultDoc :: FunctionResultDoc -> Text +renderResultDoc rd = mconcat + [ " - " + , functionResultDescription rd + , " (", functionResultType rd, ")\n" + ] + +-- +-- Push to Lua +-- + +pushHaskellFunction :: HaskellFunction -> Lua () +pushHaskellFunction fn = do + errConv <- Lua.errorConversion + let hsFn = flip (runWithConverter errConv) $ callFunction fn + liftLua $ \l -> hslua_pushhsfunction l hsFn + +-- +-- Convenience functions +-- + +-- | Creates a parameter. +parameter :: Peeker a -- ^ method to retrieve value from Lua + -> Text -- ^ expected Lua type + -> Text -- ^ parameter name + -> Text -- ^ parameter description + -> Parameter a +parameter peeker type_ name desc = Parameter + { parameterPeeker = peeker + , parameterDoc = ParameterDoc + { parameterName = name + , parameterDescription = desc + , parameterType = type_ + , parameterIsOptional = False + } + } + +-- | Creates an optional parameter. +optionalParameter :: Peeker a -- ^ method to retrieve the value from Lua + -> Text -- ^ expected Lua type + -> Text -- ^ parameter name + -> Text -- ^ parameter description + -> Parameter (Maybe a) +optionalParameter peeker type_ name desc = Parameter + { parameterPeeker = optional peeker + , parameterDoc = ParameterDoc + { parameterName = name + , parameterDescription = desc + , parameterType = type_ + , parameterIsOptional = True + } + } + +-- | Creates a function result. +functionResult :: Pusher a -- ^ method to push the Haskell result to Lua + -> Text -- ^ Lua type of result + -> Text -- ^ result description + -> FunctionResults a +functionResult pusher type_ desc = (:[]) $ FunctionResult + { fnResultPusher = pusher + , fnResultDoc = FunctionResultDoc + { functionResultType = type_ + , functionResultDescription = desc + } + } diff --git a/src/Foreign/Lua/Core.hs b/src/Foreign/Lua/Core.hs --- a/src/Foreign/Lua/Core.hs +++ b/src/Foreign/Lua/Core.hs @@ -30,10 +30,12 @@ , Lua.Number (..) -- ** Stack index , StackIndex (..) + , nth , nthFromBottom , nthFromTop , stackTop , stackBottom + , top -- ** Number of arguments and return values , NumArgs (..) , NumResults (..) diff --git a/src/Foreign/Lua/Core/Auxiliary.hs b/src/Foreign/Lua/Core/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Lua/Core/Auxiliary.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Foreign.Lua.Core.Auxiliary +Copyright : © 2007–2012 Gracjan Polak, + 2012–2016 Ömer Sinan Ağacan, + 2017-2020 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : non-portable (depends on GHC) + +Wrappers for the auxiliary library. +-} +module Foreign.Lua.Core.Auxiliary + ( dostring + , dofile + , getmetafield + , getmetatable' + , getsubtable + , loadbuffer + , loadfile + , loadstring + , newmetatable + , newstate + , tostring' + , traceback + -- * References + , getref + , ref + , unref + -- * Registry fields + , loadedTableRegistryField + , preloadTableRegistryField + ) where + +import Control.Exception (IOException, try) +import Data.ByteString (ByteString) +import Foreign.C (withCString) +import Foreign.Lua.Core.Types (Lua, liftLua) +import Foreign.Lua.Raw.Auxiliary +import Foreign.Lua.Raw.Constants (multret) +import Foreign.Lua.Raw.Types (StackIndex, Status) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Ptr + +import qualified Data.ByteString as B +import qualified Foreign.Lua.Core.Functions as Lua +import qualified Foreign.Lua.Core.Types as Lua +import qualified Foreign.Lua.Utf8 as Utf8 +import qualified Foreign.Storable as Storable + +-- * The Auxiliary Library + +-- | Loads and runs the given string. +-- +-- Returns 'Lua.OK' on success, or an error if either loading of the +-- string or calling of the thunk failed. +dostring :: ByteString -> Lua Status +dostring s = do + loadRes <- loadstring s + if loadRes == Lua.OK + then Lua.pcall 0 multret Nothing + else return loadRes + +-- | Loads and runs the given file. Note that the filepath is interpreted by +-- Haskell, not Lua. The resulting chunk is named using the UTF8 encoded +-- filepath. +dofile :: FilePath -> Lua Status +dofile fp = do + loadRes <- loadfile fp + if loadRes == Lua.OK + then Lua.pcall 0 multret Nothing + else return loadRes + +-- | 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 TypeNil. +getmetafield :: StackIndex -- ^ obj + -> String -- ^ e + -> Lua Lua.Type +getmetafield obj e = liftLua $ \l -> + withCString e $ fmap Lua.toType . luaL_getmetafield l obj + +-- | Pushes onto the stack the metatable associated with name @tname@ in the +-- registry (see @newmetatable@) (@nil@ if there is no metatable associated +-- with that name). Returns the type of the pushed value. +getmetatable' :: String -- ^ tname + -> Lua Lua.Type +getmetatable' tname = liftLua $ \l -> + withCString tname $ fmap Lua.toType . luaL_getmetatable l + +-- | Push referenced value from the table at the given index. +getref :: StackIndex -> Reference -> Lua () +getref idx ref' = Lua.rawgeti idx (fromIntegral (Lua.fromReference ref')) + +-- | Ensures that the value @t[fname]@, where @t@ is the value at index @idx@, +-- is a table, and pushes that table onto the stack. Returns True if it finds a +-- previous table there and False if it creates a new table. +getsubtable :: StackIndex -> String -> Lua Bool +getsubtable idx fname = do + -- This is a reimplementation of luaL_getsubtable from lauxlib.c. + idx' <- Lua.absindex idx + Lua.pushstring (Utf8.fromString fname) + Lua.gettable idx' + isTbl <- Lua.istable Lua.stackTop + if isTbl + then return True + else do + Lua.pop 1 + Lua.newtable + Lua.pushvalue Lua.stackTop -- copy to be left at top + Lua.setfield idx' fname + return False + +-- | Loads a ByteString as a Lua chunk. +-- +-- This function returns the same results as @'Lua.load'@. @name@ is the +-- chunk name, used for debug information and error messages. Note that +-- @name@ is used as a C string, so it may not contain null-bytes. +-- +-- See . +loadbuffer :: ByteString -- ^ Program to load + -> String -- ^ chunk name + -> Lua Status +loadbuffer bs name = liftLua $ \l -> + B.useAsCStringLen bs $ \(str, len) -> + withCString name + (fmap Lua.toStatus . luaL_loadbuffer l str (fromIntegral len)) + +-- | Loads a file as a Lua chunk. This function uses @lua_load@ (see +-- @'Lua.load'@) to load the chunk in the file named filename. 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. +-- +-- Note that the file is opened by Haskell, not Lua. +-- +-- See . +loadfile :: FilePath -- ^ filename + -> Lua Status +loadfile fp = Lua.liftIO contentOrError >>= \case + Right script -> loadbuffer script ("@" <> fp) + Left e -> do + Lua.pushstring (Utf8.fromString (show e)) + return Lua.ErrFile + where + contentOrError :: IO (Either IOException ByteString) + contentOrError = try (B.readFile fp) + + +-- | Loads a string as a Lua chunk. This function uses @lua_load@ to +-- load the chunk in the given ByteString. The given string may not +-- contain any NUL characters. +-- +-- This function returns the same results as @lua_load@ (see +-- @'Lua.load'@). +-- +-- Also as @'Lua.load'@, this function only loads the chunk; it does not +-- run it. +-- +-- See . +loadstring :: ByteString -> Lua Status +loadstring s = loadbuffer s (Utf8.toString s) + + +-- | If the registry already has the key tname, returns @False@. 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 @True@. (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. +-- +-- The value of @tname@ is used as a C string and hence must not contain null +-- bytes. +-- +-- See also: +-- . +newmetatable :: String -> Lua Bool +newmetatable tname = liftLua $ \l -> + Lua.fromLuaBool <$> withCString tname (luaL_newmetatable l) + +-- | Creates a new Lua state. It calls @lua_newstate@ with an allocator +-- based on the standard C @realloc@ function and then sets a panic +-- function (see +-- of the Lua 5.3 Reference Manual) that prints an error message to the +-- standard error output in case of fatal errors. +-- +-- See also: +-- . +newstate :: IO Lua.State +newstate = hsluaL_newstate + +-- | 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@, @ref@ ensures the uniqueness of the key it +-- returns. You can retrieve an object referred by reference @r@ by calling +-- @rawgeti t r@. Function @'unref'@ frees a reference and its associated +-- object. +-- +-- If the object at the top of the stack is nil, @'ref'@ returns the +-- constant @'Lua.refnil'@. The constant @'Lua.noref'@ is guaranteed to +-- be different from any reference returned by @'ref'@. +-- +-- See also: . +ref :: StackIndex -> Lua Reference +ref t = liftLua $ \l -> Lua.toReference <$> luaL_ref l t + +-- | Converts any Lua value at the given index to a @'ByteString'@ in a +-- reasonable format. The resulting string is pushed onto the stack and also +-- returned by the function. +-- +-- If the value has a metatable with a @__tostring@ field, then @tolstring'@ +-- calls the corresponding metamethod with the value as argument, and uses the +-- result of the call as its result. +tostring' :: StackIndex -> Lua B.ByteString +tostring' n = do + l <- Lua.state + e2e <- Lua.errorToException <$> Lua.errorConversion + Lua.liftIO $ alloca $ \lenPtr -> do + cstr <- hsluaL_tolstring l n lenPtr + if cstr == nullPtr + then e2e l + else do + cstrLen <- Storable.peek lenPtr + B.packCStringLen (cstr, fromIntegral cstrLen) + +-- | Creates and pushes a traceback of the stack L1. If a message is given it +-- appended at the beginning of the traceback. The level parameter tells at +-- which level to start the traceback. +traceback :: Lua.State -> Maybe String -> Int -> Lua () +traceback l1 msg level = liftLua $ \l -> + case msg of + Nothing -> luaL_traceback l l1 nullPtr (fromIntegral level) + Just msg' -> withCString msg' $ \cstr -> + luaL_traceback l l1 cstr (fromIntegral level) + +-- | Releases reference @'ref'@ from the table at index @idx@ (see @'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. +-- +-- See also: +-- . +unref :: StackIndex -- ^ idx + -> Reference -- ^ ref + -> Lua () +unref idx r = liftLua $ \l -> + luaL_unref l idx (Lua.fromReference r) diff --git a/src/Foreign/Lua/Core/Auxiliary.hsc b/src/Foreign/Lua/Core/Auxiliary.hsc deleted file mode 100644 --- a/src/Foreign/Lua/Core/Auxiliary.hsc +++ /dev/null @@ -1,335 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-| -Module : Foreign.Lua.Core.Auxiliary -Copyright : © 2007–2012 Gracjan Polak, - 2012–2016 Ömer Sinan Ağacan, - 2017-2020 Albert Krewinkel -License : MIT -Maintainer : Albert Krewinkel -Stability : beta -Portability : non-portable (depends on GHC) - -Wrappers for the auxiliary library. --} -module Foreign.Lua.Core.Auxiliary - ( dostring - , dofile - , getmetafield - , getmetatable' - , getsubtable - , loadbuffer - , loadfile - , loadstring - , newmetatable - , newstate - , tostring' - , traceback - -- * References - , getref - , ref - , unref - -- * Registry fields - , loadedTableRegistryField - , preloadTableRegistryField - ) where - -import Control.Exception (IOException, try) -import Data.ByteString (ByteString) -import Foreign.C ( CChar, CInt (CInt), CSize (CSize), CString, withCString ) -import Foreign.Lua.Core.Constants (multret, registryindex) -import Foreign.Lua.Core.Error (hsluaErrorRegistryField) -import Foreign.Lua.Core.Types (Lua, Reference, StackIndex, Status, liftLua) -import Foreign.Marshal.Alloc (alloca) -import Foreign.Ptr - -import qualified Data.ByteString as B -import qualified Foreign.Lua.Core.Functions as Lua -import qualified Foreign.Lua.Core.Types as Lua -import qualified Foreign.Lua.Utf8 as Utf8 -import qualified Foreign.Storable as Storable - -#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 "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 "lauxlib.h value LUA_PRELOAD_TABLE" - c_preload_table :: CString -#endif - --- | Loads and runs the given string. --- --- Returns 'Lua.OK' on success, or an error if either loading of the --- string or calling of the thunk failed. -dostring :: ByteString -> Lua Status -dostring s = do - loadRes <- loadstring s - if loadRes == Lua.OK - then Lua.pcall 0 multret Nothing - else return loadRes - --- | Loads and runs the given file. Note that the filepath is interpreted by --- Haskell, not Lua. The resulting chunk is named using the UTF8 encoded --- filepath. -dofile :: FilePath -> Lua Status -dofile fp = do - loadRes <- loadfile fp - if loadRes == Lua.OK - then Lua.pcall 0 multret Nothing - else return loadRes - --- | 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 TypeNil. -getmetafield :: StackIndex -- ^ obj - -> String -- ^ e - -> Lua Lua.Type -getmetafield obj e = liftLua $ \l -> - withCString e $ fmap Lua.toType . luaL_getmetafield l obj - -foreign import capi SAFTY "lauxlib.h luaL_getmetafield" - luaL_getmetafield :: Lua.State -> StackIndex -> CString -> IO Lua.TypeCode - --- | Pushes onto the stack the metatable associated with name @tname@ in the --- registry (see @newmetatable@) (@nil@ if there is no metatable associated --- with that name). Returns the type of the pushed value. -getmetatable' :: String -- ^ tname - -> Lua Lua.Type -getmetatable' tname = liftLua $ \l -> - withCString tname $ fmap Lua.toType . luaL_getmetatable l - -foreign import capi SAFTY "lauxlib.h luaL_getmetatable" - luaL_getmetatable :: Lua.State -> CString -> IO Lua.TypeCode - --- | Push referenced value from the table at the given index. -getref :: StackIndex -> Reference -> Lua () -getref idx ref' = Lua.rawgeti idx (fromIntegral (Lua.fromReference ref')) - --- | Ensures that the value @t[fname]@, where @t@ is the value at index @idx@, --- is a table, and pushes that table onto the stack. Returns True if it finds a --- previous table there and False if it creates a new table. -getsubtable :: StackIndex -> String -> Lua Bool -getsubtable idx fname = do - -- This is a reimplementation of luaL_getsubtable from lauxlib.c. - idx' <- Lua.absindex idx - Lua.pushstring (Utf8.fromString fname) - Lua.gettable idx' - isTbl <- Lua.istable Lua.stackTop - if isTbl - then return True - else do - Lua.pop 1 - Lua.newtable - Lua.pushvalue Lua.stackTop -- copy to be left at top - Lua.setfield idx' fname - return False - --- | Loads a ByteString as a Lua chunk. --- --- This function returns the same results as @'Lua.load'@. @name@ is the --- chunk name, used for debug information and error messages. Note that --- @name@ is used as a C string, so it may not contain null-bytes. --- --- See . -loadbuffer :: ByteString -- ^ Program to load - -> String -- ^ chunk name - -> Lua Status -loadbuffer bs name = liftLua $ \l -> - B.useAsCStringLen bs $ \(str, len) -> - withCString name - (fmap Lua.toStatus . luaL_loadbuffer l str (fromIntegral len)) - -foreign import capi SAFTY "lauxlib.h luaL_loadbuffer" - luaL_loadbuffer :: Lua.State -> Ptr CChar -> CSize -> CString - -> IO Lua.StatusCode - - --- | Loads a file as a Lua chunk. This function uses @lua_load@ (see --- @'Lua.load'@) to load the chunk in the file named filename. 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. --- --- Note that the file is opened by Haskell, not Lua. --- --- See . -loadfile :: FilePath -- ^ filename - -> Lua Status -loadfile fp = Lua.liftIO contentOrError >>= \case - Right script -> loadbuffer script ("@" <> fp) - Left e -> do - Lua.pushstring (Utf8.fromString (show e)) - return Lua.ErrFile - where - contentOrError :: IO (Either IOException ByteString) - contentOrError = try (B.readFile fp) - - --- | Loads a string as a Lua chunk. This function uses @lua_load@ to --- load the chunk in the given ByteString. The given string may not --- contain any NUL characters. --- --- This function returns the same results as @lua_load@ (see --- @'Lua.load'@). --- --- Also as @'Lua.load'@, this function only loads the chunk; it does not --- run it. --- --- See . -loadstring :: ByteString -> Lua Status -loadstring s = loadbuffer s (Utf8.toString s) - - --- | If the registry already has the key tname, returns @False@. 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 @True@. (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. --- --- The value of @tname@ is used as a C string and hence must not contain null --- bytes. --- --- See also: --- . -newmetatable :: String -> Lua Bool -newmetatable tname = liftLua $ \l -> - Lua.fromLuaBool <$> withCString tname (luaL_newmetatable l) - -foreign import ccall SAFTY "lauxlib.h luaL_newmetatable" - luaL_newmetatable :: Lua.State -> CString -> IO Lua.LuaBool - - --- | Creates a new Lua state. It calls @lua_newstate@ with an allocator --- based on the standard C @realloc@ function and then sets a panic --- function (see --- of the Lua 5.3 Reference Manual) that prints an error message to the --- standard error output in case of fatal errors. --- --- See also: --- . -newstate :: IO Lua.State -newstate = do - l <- luaL_newstate - Lua.unsafeRunWith l $ do - Lua.createtable 0 0 - Lua.setfield registryindex hsluaErrorRegistryField - return l - -foreign import ccall unsafe "lauxlib.h luaL_newstate" - luaL_newstate :: IO Lua.State - - --- | 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@, @ref@ ensures the uniqueness of the key it --- returns. You can retrieve an object referred by reference @r@ by calling --- @rawgeti t r@. Function @'unref'@ frees a reference and its associated --- object. --- --- If the object at the top of the stack is nil, @'ref'@ returns the --- constant @'Lua.refnil'@. The constant @'Lua.noref'@ is guaranteed to --- be different from any reference returned by @'ref'@. --- --- See also: . -ref :: StackIndex -> Lua Reference -ref t = liftLua $ \l -> Lua.toReference <$> luaL_ref l t - -foreign import ccall SAFTY "lauxlib.h luaL_ref" - luaL_ref :: Lua.State -> StackIndex -> IO CInt - - --- | Converts any Lua value at the given index to a @'ByteString'@ in a --- reasonable format. The resulting string is pushed onto the stack and also --- returned by the function. --- --- If the value has a metatable with a @__tostring@ field, then @tolstring'@ --- calls the corresponding metamethod with the value as argument, and uses the --- result of the call as its result. -tostring' :: StackIndex -> Lua B.ByteString -tostring' n = do - l <- Lua.state - e2e <- Lua.errorToException <$> Lua.errorConversion - Lua.liftIO $ alloca $ \lenPtr -> do - cstr <- hsluaL_tolstring l n lenPtr - if cstr == nullPtr - then e2e l - else do - cstrLen <- Storable.peek lenPtr - B.packCStringLen (cstr, fromIntegral cstrLen) - -foreign import ccall safe "error-conversion.h hsluaL_tolstring" - hsluaL_tolstring :: Lua.State -> StackIndex -> Ptr CSize -> IO (Ptr CChar) - - --- | Creates and pushes a traceback of the stack L1. If a message is given it --- appended at the beginning of the traceback. The level parameter tells at --- which level to start the traceback. -traceback :: Lua.State -> Maybe String -> Int -> Lua () -traceback l1 msg level = liftLua $ \l -> - case msg of - Nothing -> luaL_traceback l l1 nullPtr (fromIntegral level) - Just msg' -> withCString msg' $ \cstr -> - luaL_traceback l l1 cstr (fromIntegral level) - -foreign import capi unsafe "lauxlib.h luaL_traceback" - luaL_traceback :: Lua.State -> Lua.State -> CString -> CInt -> IO () - - --- | Releases reference @'ref'@ from the table at index @idx@ (see @'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. --- --- See also: --- . -unref :: StackIndex -- ^ idx - -> Reference -- ^ ref - -> Lua () -unref idx r = liftLua $ \l -> - luaL_unref l idx (Lua.fromReference r) - -foreign import ccall SAFTY "lauxlib.h luaL_unref" - luaL_unref :: Lua.State -> StackIndex -> CInt -> IO () diff --git a/src/Foreign/Lua/Core/Constants.hs b/src/Foreign/Lua/Core/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Lua/Core/Constants.hs @@ -0,0 +1,22 @@ +{-| +Module : Foreign.Lua.Core.Constants +Copyright : © 2007–2012 Gracjan Polak, + 2012–2016 Ömer Sinan Ağacan, + 2017-2020 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : ForeignFunctionInterface + +Lua constants. This module was moved to +@'Foreign.Lua.Raw.Constants'@. It now merely exists for backwards +compatibility and will be removed in the future. +-} +module Foreign.Lua.Core.Constants + ( multret + , registryindex + , refnil + , noref + ) where + +import Foreign.Lua.Raw.Constants diff --git a/src/Foreign/Lua/Core/Constants.hsc b/src/Foreign/Lua/Core/Constants.hsc deleted file mode 100644 --- a/src/Foreign/Lua/Core/Constants.hsc +++ /dev/null @@ -1,41 +0,0 @@ -{-| -Module : Foreign.Lua.Core.Constants -Copyright : © 2007–2012 Gracjan Polak, - 2012–2016 Ömer Sinan Ağacan, - 2017-2020 Albert Krewinkel -License : MIT -Maintainer : Albert Krewinkel -Stability : beta -Portability : ForeignFunctionInterface - -Lua constants --} -module Foreign.Lua.Core.Constants - ( multret - , registryindex - , refnil - , noref - ) where - -import Foreign.Lua.Core.Types - -#include "lua.h" -#include "lauxlib.h" - --- | Alias for C constant @LUA_MULTRET@. See --- . -multret :: NumResults -multret = NumResults $ #{const LUA_MULTRET} - --- | Alias for C constant @LUA_REGISTRYINDEX@. See --- . -registryindex :: StackIndex -registryindex = StackIndex $ #{const LUA_REGISTRYINDEX} - --- | Value signaling that no reference was created. -refnil :: Int -refnil = #{const LUA_REFNIL} - --- | Value signaling that no reference was found. -noref :: Int -noref = #{const LUA_NOREF} diff --git a/src/Foreign/Lua/Core/Error.hs b/src/Foreign/Lua/Core/Error.hs --- a/src/Foreign/Lua/Core/Error.hs +++ b/src/Foreign/Lua/Core/Error.hs @@ -23,30 +23,24 @@ , errorMessage , try -- * Helpers for hslua C wrapper functions. - , Failable (..) - , fromFailable - , throwOnError , throwMessage - , boolFromFailable - -- * Signaling errors to Lua - , hsluaErrorRegistryField + , liftLuaThrow ) where import Control.Applicative (Alternative (..)) import Data.Typeable (Typeable) -import Foreign.C (CChar, CInt (CInt), CSize (CSize)) +import Foreign.Lua.Core.Types (Lua) +import Foreign.Lua.Raw.Error (errorMessage) +import Foreign.Lua.Raw.Functions (lua_pushlstring) import Foreign.Marshal.Alloc (alloca) -import Foreign.Ptr (Ptr, nullPtr) -import Foreign.Lua.Core.Types (Lua, StackIndex, fromLuaBool) +import Foreign.Ptr +import qualified Data.ByteString.Unsafe as B import qualified Control.Exception as E import qualified Control.Monad.Catch as Catch -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as Char8 -import qualified Data.ByteString.Unsafe as B -import qualified Foreign.Storable as Storable import qualified Foreign.Lua.Core.Types as Lua import qualified Foreign.Lua.Utf8 as Utf8 +import qualified Foreign.Storable as F -- | Exceptions raised by Lua-related operations. newtype Exception = Exception { exceptionMessage :: String} @@ -92,6 +86,15 @@ throwTopMessage :: Lua a throwTopMessage = throwErrorAsException +-- | Helper function which uses proper error-handling to throw an +-- exception with the given message. +throwMessage :: String -> Lua a +throwMessage msg = do + Lua.liftLua $ \l -> + B.unsafeUseAsCStringLen (Utf8.fromString msg) $ \(msgPtr, z) -> + lua_pushlstring l msgPtr (fromIntegral z) + Lua.errorConversion >>= Lua.liftLua . Lua.errorToException + instance Alternative Lua where empty = throwMessage "empty" x <|> y = do @@ -108,66 +111,15 @@ msg <- Lua.liftIO (errorMessage l) Catch.throwM $ Exception (Utf8.toString msg) --- | Helper function which uses proper error-handling to throw an --- exception with the given message. -throwMessage :: String -> Lua a -throwMessage msg = do - Lua.liftLua $ \l -> - B.unsafeUseAsCStringLen (Utf8.fromString msg) $ \(msgPtr, z) -> - lua_pushlstring l msgPtr (fromIntegral z) - Lua.errorConversion >>= Lua.liftLua . Lua.errorToException - --- | 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 B.ByteString -errorMessage l = alloca $ \lenPtr -> do - cstr <- hsluaL_tolstring l Lua.stackTop 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 - -foreign import ccall safe "error-conversion.h hsluaL_tolstring" - hsluaL_tolstring :: Lua.State -> StackIndex -> Ptr CSize -> IO (Ptr CChar) - -foreign import capi unsafe "lua.h lua_pop" - lua_pop :: Lua.State -> CInt -> IO () - -foreign import capi unsafe "lua.h lua_pushlstring" - lua_pushlstring :: Lua.State -> Ptr CChar -> CSize -> IO () - --- | Registry field under which the special HsLua error indicator is stored. -hsluaErrorRegistryField :: String -hsluaErrorRegistryField = "HSLUA_ERR" - --- --- * Custom protocol to communicate with hslua C wrapper functions. --- - --- | CInt value or an error, using the convention that value below zero indicate --- an error. Values greater than zero are used verbatim. The phantom type is --- used for additional type safety and gives the type into which the wrapped --- CInt should be converted. -newtype Failable a = Failable CInt - --- | Convert from Failable to target type, throwing an error if the value --- indicates a failure. -fromFailable :: (CInt -> a) -> Failable a -> Lua a -fromFailable fromCInt (Failable x) = - if x < 0 - then throwTopMessage - else return (fromCInt x) - --- | Throw a Haskell exception if the computation signaled a failure. -throwOnError :: Failable () -> Lua () -throwOnError = fromFailable (const ()) - --- | Convert lua boolean to Haskell Bool, throwing an exception if the return --- value indicates that an error had happened. -boolFromFailable :: Failable Lua.LuaBool -> Lua Bool -boolFromFailable = fmap fromLuaBool . fromFailable Lua.LuaBool +-- | Takes a failable HsLua function and transforms it into a +-- monadic 'Lua' operation. Throws an exception if an error +-- occured. +liftLuaThrow :: (Lua.State -> Ptr Lua.StatusCode -> IO a) -> Lua a +liftLuaThrow f = do + (result, status) <- Lua.liftLua $ \l -> alloca $ \statusPtr -> do + result <- f l statusPtr + status <- Lua.toStatus <$> F.peek statusPtr + return (result, status) + if status == Lua.OK + then return result + else throwTopMessage diff --git a/src/Foreign/Lua/Core/Functions.hs b/src/Foreign/Lua/Core/Functions.hs --- a/src/Foreign/Lua/Core/Functions.hs +++ b/src/Foreign/Lua/Core/Functions.hs @@ -142,8 +142,8 @@ -- This is a wrapper function of -- . compare :: StackIndex -> StackIndex -> RelationalOperator -> Lua Bool -compare idx1 idx2 relOp = boolFromFailable =<< do - liftLua $ \l -> hslua_compare l idx1 idx2 (fromRelationalOperator relOp) +compare idx1 idx2 relOp = fromLuaBool <$> do + liftLuaThrow $ \l -> hslua_compare l idx1 idx2 (fromRelationalOperator relOp) -- | 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 @@ -155,7 +155,7 @@ -- This is a wrapper function of -- . concat :: NumArgs -> Lua () -concat n = throwOnError =<< liftLua (`hslua_concat` n) +concat n = liftLuaThrow (`hslua_concat` n) -- | Copies the element at index @fromidx@ into the valid index @toidx@, -- replacing the value at that position. Values at other positions are not @@ -256,9 +256,9 @@ -- Wrapper of -- . getglobal :: String -> Lua () -getglobal name = throwOnError <=< liftLua $ \l -> +getglobal name = liftLuaThrow $ \l status' -> C.withCStringLen name $ \(namePtr, len) -> - hslua_getglobal l namePtr (fromIntegral len) + hslua_getglobal l namePtr (fromIntegral len) status' -- | If the value at the given index has a metatable, the function pushes that -- metatable onto the stack and returns @True@. Otherwise, the function returns @@ -283,8 +283,7 @@ -- See also: -- . gettable :: StackIndex -> Lua () -gettable n = throwOnError =<< - liftLua (\l -> hslua_gettable l n) +gettable n = liftLuaThrow (\l -> hslua_gettable l n) -- | 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 @@ -473,7 +472,7 @@ -- See also: -- . next :: StackIndex -> Lua Bool -next idx = boolFromFailable =<< liftLua (\l -> hslua_next l idx) +next idx = fromLuaBool <$> liftLuaThrow (\l -> hslua_next l idx) -- | Opens all standard Lua libraries into the current state and sets each -- library name as a global value. @@ -566,7 +565,7 @@ -- -- See also: . pop :: StackIndex -> Lua () -pop n = settop (-n - 1) +pop n = liftLua $ \l -> lua_pop l n -- | Pushes a boolean value with the given value onto the stack. -- @@ -774,9 +773,9 @@ -- See also: -- . setglobal :: String -> Lua () -setglobal name = throwOnError <=< liftLua $ \l -> +setglobal name = liftLuaThrow $ \l status' -> C.withCStringLen name $ \(namePtr, nameLen) -> - hslua_setglobal l namePtr (fromIntegral nameLen) + hslua_setglobal l namePtr (fromIntegral nameLen) status' -- | Pops a table from the stack and sets it as the new metatable for the value -- at the given index. @@ -801,8 +800,7 @@ -- See also: -- . settable :: StackIndex -> Lua () -settable index = throwOnError =<< - liftLua (\l -> hslua_settable l index) +settable index = liftLuaThrow $ \l -> hslua_settable l index -- | 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 diff --git a/src/Foreign/Lua/Core/RawBindings.hs b/src/Foreign/Lua/Core/RawBindings.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Lua/Core/RawBindings.hs @@ -0,0 +1,21 @@ +{-| +Module : Foreign.Lua.Core.RawBindings +Copyright : © 2007–2012 Gracjan Polak, + 2012–2016 Ömer Sinan Ağacan, + 2017-2020 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : ForeignFunctionInterface + +Haskell bindings to Lua C API functions. + +This module was moved to @'Foreign.Lua.Raw.Functions'@. It now +merely exists for backwards compatibility and will be removed in +the future. +-} +module Foreign.Lua.Core.RawBindings + ( module Foreign.Lua.Raw.Functions + ) where + +import Foreign.Lua.Raw.Functions diff --git a/src/Foreign/Lua/Core/RawBindings.hsc b/src/Foreign/Lua/Core/RawBindings.hsc deleted file mode 100644 --- a/src/Foreign/Lua/Core/RawBindings.hsc +++ /dev/null @@ -1,389 +0,0 @@ -{-# LANGUAGE CPP #-} -{-| -Module : Foreign.Lua.Core.RawBindings -Copyright : © 2007–2012 Gracjan Polak, - 2012–2016 Ömer Sinan Ağacan, - 2017-2020 Albert Krewinkel -License : MIT -Maintainer : Albert Krewinkel -Stability : beta -Portability : ForeignFunctionInterface - -Haskell bindings to lua C API functions. --} -module Foreign.Lua.Core.RawBindings where - -import Foreign.C -import Foreign.Lua.Core.Error (Failable (Failable)) -import Foreign.Lua.Core.Types as Lua -import Foreign.Ptr - -##ifdef ALLOW_UNSAFE_GC -##define SAFTY unsafe -##else -##define SAFTY safe -##endif - --- TODO: lua_getallocf, lua_setallocf --- TODO: Debugger functions - --- Some of the Lua functions may call a Haskell function, and trigger --- garbage collection, rescheduling etc. This means we must declare these --- functions as 'safe'. - - --------------------------------------------------------------------------------- --- * State manipulation - --- lua_newstate is currently not supported. - --- | See -foreign import ccall "lua.h lua_close" - lua_close :: Lua.State -> IO () - --- lua_newthread is currently not supported. - - --------------------------------------------------------------------------------- --- * Basic stack manipulation - --- | See -foreign import ccall unsafe "lua.h lua_absindex" - lua_absindex :: Lua.State -> StackIndex -> IO StackIndex - --- | See -foreign import ccall unsafe "lua.h lua_gettop" - lua_gettop :: Lua.State -> IO StackIndex - --- | See -foreign import ccall SAFTY "lua.h lua_settop" - lua_settop :: Lua.State -> StackIndex -> IO () - --- | See -foreign import ccall SAFTY "lua.h lua_pushvalue" - lua_pushvalue :: Lua.State -> StackIndex -> IO () - --- | See -foreign import ccall SAFTY "lua.h lua_copy" - lua_copy :: Lua.State -> StackIndex -> StackIndex -> IO () - --- | See -foreign import capi SAFTY "lua.h lua_remove" - lua_remove :: Lua.State -> StackIndex -> IO () - --- | See -foreign import capi SAFTY "lua.h lua_insert" - lua_insert :: Lua.State -> StackIndex -> IO () - --- | See -foreign import capi SAFTY "lua.h lua_replace" - lua_replace :: Lua.State -> StackIndex -> IO () - --- | See -foreign import capi SAFTY "lua.h lua_checkstack" - lua_checkstack :: Lua.State -> CInt -> IO LuaBool - --- lua_xmove is currently not supported. - - --------------------------------------------------------------------------------- --- * Stack access functions - --- | See -foreign import ccall SAFTY "lua.h lua_isnumber" - lua_isnumber :: Lua.State -> StackIndex -> IO LuaBool - --- | See -foreign import ccall SAFTY "lua.h lua_isinteger" - lua_isinteger :: Lua.State -> StackIndex -> IO LuaBool - --- | See -foreign import ccall SAFTY "lua.h lua_isstring" - lua_isstring :: Lua.State -> StackIndex -> IO LuaBool - --- | See -foreign import ccall SAFTY "lua.h lua_iscfunction" - lua_iscfunction :: Lua.State -> StackIndex -> IO LuaBool - --- | See -foreign import ccall SAFTY "lua.h lua_isuserdata" - lua_isuserdata :: Lua.State -> StackIndex -> IO LuaBool - --- | See -foreign import ccall SAFTY "lua.h lua_type" - lua_type :: Lua.State -> StackIndex -> IO TypeCode - --- | See -foreign import ccall SAFTY "lua.h lua_typename" - lua_typename :: Lua.State -> TypeCode -> IO CString - --- lua_compare is unsafe (might cause a longjmp), use hslua_compare instead. - --- | Wrapper around which catches any @longjmp@s. -foreign import ccall "error-conversion.h hslua_compare" - hslua_compare :: Lua.State -> StackIndex -> StackIndex -> CInt - -> IO (Failable LuaBool) - --- | See -foreign import ccall SAFTY "lua.h lua_rawequal" - lua_rawequal :: Lua.State -> StackIndex -> StackIndex -> IO LuaBool - --- --- Type coercion --- --- | See -foreign import capi SAFTY "lua.h lua_toboolean" - lua_toboolean :: Lua.State -> StackIndex -> IO LuaBool - --- | See -foreign import ccall SAFTY "lua.h lua_tocfunction" - lua_tocfunction :: Lua.State -> StackIndex -> IO CFunction - --- | See -foreign import ccall SAFTY "lua.h lua_tointegerx" - lua_tointegerx :: Lua.State -> StackIndex -> Ptr LuaBool -> IO Lua.Integer - --- | See -foreign import ccall SAFTY "lua.h lua_tonumberx" - lua_tonumberx :: Lua.State -> StackIndex -> Ptr LuaBool -> IO Lua.Number - --- | See -foreign import ccall SAFTY "lua.h lua_tolstring" - lua_tolstring :: Lua.State -> StackIndex -> Ptr CSize -> IO (Ptr CChar) - --- | See -foreign import ccall SAFTY "lua.h lua_topointer" - lua_topointer :: Lua.State -> StackIndex -> IO (Ptr ()) - --- | See -foreign import ccall SAFTY "lua.h lua_tothread" - lua_tothread :: Lua.State -> StackIndex -> IO Lua.State - --- | See -foreign import ccall SAFTY "lua.h lua_touserdata" - lua_touserdata :: Lua.State -> StackIndex -> IO (Ptr a) - - --- --- Object size --- - --- | See -foreign import ccall SAFTY "lua.h lua_rawlen" - lua_rawlen :: Lua.State -> StackIndex -> IO CSize - - --------------------------------------------------------------------------------- --- * Push functions - --- | See -foreign import ccall SAFTY "lua.h lua_pushnil" - lua_pushnil :: Lua.State -> IO () - --- | See -foreign import ccall SAFTY "lua.h lua_pushnumber" - lua_pushnumber :: Lua.State -> Lua.Number -> IO () - --- | See -foreign import ccall SAFTY "lua.h lua_pushinteger" - lua_pushinteger :: Lua.State -> Lua.Integer -> IO () - --- | See -foreign import ccall SAFTY "lua.h lua_pushlstring" - lua_pushlstring :: Lua.State -> Ptr CChar -> CSize -> IO () - --- lua_pushstring is currently not supported. It's difficult to use in a haskell --- context. - --- | See -foreign import ccall SAFTY "lua.h lua_pushcclosure" - lua_pushcclosure :: Lua.State -> CFunction -> NumArgs -> IO () - --- | See -foreign import ccall SAFTY "lua.h lua_pushboolean" - lua_pushboolean :: Lua.State -> LuaBool -> IO () - --- | See -foreign import ccall SAFTY "lua.h lua_pushlightuserdata" - lua_pushlightuserdata :: Lua.State -> Ptr a -> IO () - --- | See -foreign import ccall SAFTY "lua.h lua_pushthread" - lua_pushthread :: Lua.State -> IO CInt - - --------------------------------------------------------------------------------- --- * Get functions - --- + lua_gettable is unsafe, use hslua_gettable instead. --- + lua_getglobal is unsafe, use hslua_getglobal instead. --- + lua_getfield is unsafe, we build something equivallent using pushlstring and --- gettable. - --- | Wrapper around which catches any @longjmp@s. -foreign import ccall "error-conversion.h hslua_gettable" - hslua_gettable :: Lua.State -> StackIndex -> IO (Failable ()) - --- | See -foreign import ccall SAFTY "lua.h lua_rawget" - lua_rawget :: Lua.State -> StackIndex -> IO () - --- | See -foreign import ccall SAFTY "lua.h lua_rawgeti" - lua_rawgeti :: Lua.State -> StackIndex -> Lua.Integer -> IO () - --- | See -foreign import ccall SAFTY "lua.h lua_createtable" - lua_createtable :: Lua.State -> CInt -> CInt -> IO () - --- | See -foreign import ccall SAFTY "lua.h lua_newuserdata" - lua_newuserdata :: Lua.State -> CSize -> IO (Ptr ()) - --- | See -foreign import ccall SAFTY "lua.h lua_getmetatable" - lua_getmetatable :: Lua.State -> StackIndex -> IO LuaBool - --- | Wrapper around which catches any @longjmp@s. -foreign import ccall "error-conversion.h hslua_getglobal" - hslua_getglobal :: Lua.State -> CString -> CSize -> IO (Failable ()) - - --------------------------------------------------------------------------------- --- * Set functions - --- lua_settable is unsafe, use hslua_settable instead. --- lua_setfield is unsafe, use hslua_setfield instead. --- lua_setglobal is unsafe, use hslua_setglobal instead. --- lua_setfenv (5.1 only) is not supported. - --- | Wrapper around which catches any @longjmp@s. -foreign import ccall "error-conversion.h hslua_settable" - hslua_settable :: Lua.State -> StackIndex -> IO (Failable ()) - --- | See -foreign import ccall SAFTY "lua.h lua_rawset" - lua_rawset :: Lua.State -> StackIndex -> IO () - --- | See -foreign import ccall SAFTY "lua.h lua_rawseti" - lua_rawseti :: Lua.State -> StackIndex -> Lua.Integer -> IO () - --- | See -foreign import ccall SAFTY "lua.h lua_setmetatable" - lua_setmetatable :: Lua.State -> StackIndex -> IO () - --- | Wrapper around which catches any @longjmp@s. -foreign import ccall "error-conversion.h hslua_setglobal" - hslua_setglobal :: Lua.State -> CString -> CSize -> IO (Failable ()) - - --------------------------------------------------------------------------------- --- * \'load\' and \'call\' functions (load and run Lua code) - --- lua_call is inherently unsafe, we do not support it. - --- | See -foreign import capi "lua.h lua_pcall" - lua_pcall :: Lua.State -> NumArgs -> NumResults -> StackIndex - -> IO StatusCode - --- | See -foreign import ccall safe "lua.h lua_load" - lua_load :: Lua.State -> Lua.Reader -> Ptr () -> CString -> CString - -> IO StatusCode - --- currently unsupported: --- lua_dump - - ------------------------------------------------------------------------------- --- * Coroutine functions - --- lua_yield / lua_yieldk and lua_resume are currently not supported. - --- | See -foreign import ccall unsafe "lua.h lua_status" - lua_status :: Lua.State -> IO StatusCode - - ------------------------------------------------------------------------------- --- * Garbage-collection functions and options - --- | See -foreign import ccall "lua.h lua_gc" - lua_gc :: Lua.State -> CInt -> CInt -> IO CInt - - ------------------------------------------------------------------------------- --- * Miscellaneous functions - --- lua_error is unsafe, use hslua_error instead. --- lua_next is unsafe, use hslua_next instead. --- lua_concat is unsafe (may trigger a longjmp), use hslua_concat instead. - --- | Replacement for ; it uses the HsLua error signaling convention instead of raw --- @longjmp@. -foreign import ccall "error-conversion.h hslua_error" - hslua_error :: Lua.State -> IO NumResults - --- | Wrapper around which catches any @longjmp@s. -foreign import ccall "error-conversion.h hslua_next" - hslua_next :: Lua.State -> StackIndex -> IO (Failable LuaBool) - --- | Wrapper around which catches any @longjmp@s. -foreign import ccall "error-conversion.h hslua_concat" - hslua_concat :: Lua.State -> NumArgs -> IO (Failable ()) - --- | See -foreign import capi unsafe "lua.h lua_pushglobaltable" - lua_pushglobaltable :: Lua.State -> IO () - - ------------------------------------------------------------------------------- --- * Lua Libraries - --- | See -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/Core/Types.hs b/src/Foreign/Lua/Core/Types.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Lua/Core/Types.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-| +Module : Foreign.Lua.Core.Types +Copyright : © 2007–2012 Gracjan Polak, + 2012–2016 Ömer Sinan Ağacan, + 2017-2020 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. + +This module has mostly been moved to @'Foreign.Lua.Raw.Types'@ and +currently re-exports that module. This module might be removed in +the future. +-} +module Foreign.Lua.Core.Types + ( Lua (..) + , LuaEnvironment (..) + , ErrorConversion (..) + , errorConversion + , State (..) + , Reader + , liftLua + , liftLua1 + , state + , runWithConverter + , unsafeRunWith + , unsafeErrorConversion + , GCCONTROL (..) + , Type (..) + , TypeCode (..) + , fromType + , toType + , liftIO + , CFunction + , LuaBool (..) + , false + , true + , fromLuaBool + , toLuaBool + , Integer (..) + , Number (..) + , StackIndex (..) + , nth + , nthFromBottom + , nthFromTop + , stackTop + , stackBottom + , top + , NumArgs (..) + , NumResults (..) + , RelationalOperator (..) + , fromRelationalOperator + , Status (..) + , StatusCode (..) + , toStatus + -- * References + , Reference (..) + , fromReference + , toReference + ) where + +import Prelude hiding (Integer) + +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) +import Control.Monad.Reader (ReaderT (..), MonadReader, MonadIO, asks, liftIO) +import Foreign.C (CInt) +import Foreign.Lua.Raw.Types +import Foreign.Lua.Raw.Auxiliary + ( Reference (..) + , fromReference + , toReference + ) + +-- | Define the ways in which exceptions and errors are handled. +data ErrorConversion = ErrorConversion + { errorToException :: forall a . State -> IO a + -- ^ Translate Lua errors to Haskell exceptions + , addContextToException :: forall a . String -> Lua a -> Lua a + -- ^ Add information on the current context to an exception. + , alternative :: forall a . Lua a -> Lua a -> Lua a + -- ^ Runs the second computation only if the first fails; returns + -- the result of the first successful computation, if any. + , exceptionToError :: Lua NumResults -> Lua NumResults + -- ^ Translate Haskell exceptions to Lua errors + } + +-- | Environment in which Lua computations are evaluated. +data LuaEnvironment = LuaEnvironment + { luaEnvErrorConversion :: ErrorConversion + -- ^ Functions for error and exception handling and conversion + , luaEnvState :: State + -- ^ Lua interpreter state + } + +-- | A Lua computation. This is the base type used to run Lua programs of any +-- kind. The Lua state is handled automatically, but can be retrieved via +-- @'state'@. +newtype Lua a = Lua { unLua :: ReaderT LuaEnvironment IO a } + deriving + ( Applicative + , Functor + , Monad + , MonadCatch + , MonadIO + , MonadMask + , MonadReader LuaEnvironment + , MonadThrow + ) + +-- | Turn a function of typ @Lua.State -> IO a@ into a monadic Lua operation. +liftLua :: (State -> IO a) -> Lua a +liftLua f = state >>= liftIO . f + +-- | Turn a function of typ @Lua.State -> a -> IO b@ into a monadic Lua operation. +liftLua1 :: (State -> a -> IO b) -> a -> Lua b +liftLua1 f x = liftLua $ \l -> f l x + +-- | Get the Lua state of this Lua computation. +state :: Lua State +state = asks luaEnvState + +-- | Get the error-to-exception function. +errorConversion :: Lua ErrorConversion +errorConversion = asks luaEnvErrorConversion + +-- | Run Lua computation with the given Lua state and error-to-exception +-- converter. Any resulting exceptions are left unhandled. +runWithConverter :: ErrorConversion -> State -> Lua a -> IO a +runWithConverter e2e l s = + runReaderT (unLua s) (LuaEnvironment e2e l) + +-- | Run the given operation, but crash if any Haskell exceptions occur. +unsafeRunWith :: State -> Lua a -> IO a +unsafeRunWith = runWithConverter unsafeErrorConversion + +-- | Unsafe @'ErrorConversion'@; no proper error handling is attempted, +-- any error leads to a crash. +unsafeErrorConversion :: ErrorConversion +unsafeErrorConversion = ErrorConversion + { errorToException = const (error "An unrecoverable Lua error occured.") + , addContextToException = const id + , alternative = const + , exceptionToError = id + } + +-- | Stack index of the nth element from the top of the stack. +nthFromTop :: CInt -> StackIndex +nthFromTop n = StackIndex (-n) +{-# INLINABLE nthFromTop #-} + +-- | Stack index of the nth element from the top of the stack. +nth :: CInt -> StackIndex +nth = nthFromTop +{-# INLINABLE nth #-} + +-- | Stack index of the nth element from the bottom of the stack. +nthFromBottom :: CInt -> StackIndex +nthFromBottom = StackIndex +{-# INLINABLE nthFromBottom #-} + +-- | Top of the stack +top :: StackIndex +top = -1 +{-# INLINABLE top #-} + +-- | Top of the stack +stackTop :: StackIndex +stackTop = top +{-# INLINABLE stackTop #-} + +-- | Bottom of the stack +stackBottom :: StackIndex +stackBottom = 1 +{-# INLINABLE stackBottom #-} diff --git a/src/Foreign/Lua/Core/Types.hsc b/src/Foreign/Lua/Core/Types.hsc deleted file mode 100644 --- a/src/Foreign/Lua/Core/Types.hsc +++ /dev/null @@ -1,422 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RankNTypes #-} -{-| -Module : Foreign.Lua.Core.Types -Copyright : © 2007–2012 Gracjan Polak, - 2012–2016 Ömer Sinan Ağacan, - 2017-2020 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.Core.Types - ( Lua (..) - , LuaEnvironment (..) - , ErrorConversion (..) - , errorConversion - , State (..) - , Reader - , liftLua - , liftLua1 - , state - , runWithConverter - , unsafeRunWith - , unsafeErrorConversion - , GCCONTROL (..) - , Type (..) - , TypeCode (..) - , fromType - , toType - , liftIO - , CFunction - , LuaBool (..) - , false - , true - , fromLuaBool - , toLuaBool - , Integer (..) - , Number (..) - , StackIndex (..) - , nthFromBottom - , nthFromTop - , stackTop - , stackBottom - , NumArgs (..) - , NumResults (..) - , RelationalOperator (..) - , fromRelationalOperator - , Status (..) - , StatusCode (..) - , toStatus - -- * References - , Reference (..) - , fromReference - , toReference - ) where - -#include "lua.h" --- required only for LUA_ERRFILE -#include "lauxlib.h" - -import Prelude hiding (Integer, EQ, LT) - -import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) -import Control.Monad.Reader (ReaderT (..), MonadReader, MonadIO, asks, liftIO) -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) - --- | Define the ways in which exceptions and errors are handled. -data ErrorConversion = ErrorConversion - { errorToException :: forall a . State -> IO a - -- ^ Translate Lua errors to Haskell exceptions - , addContextToException :: forall a . String -> Lua a -> Lua a - -- ^ Add information on the current context to an exception. - , alternative :: forall a . Lua a -> Lua a -> Lua a - -- ^ Runs the second computation only if the first fails; returns - -- the result of the first successful computation, if any. - , exceptionToError :: Lua NumResults -> Lua NumResults - -- ^ Translate Haskell exceptions to Lua errors - } - --- | Environment in which Lua computations are evaluated. -data LuaEnvironment = LuaEnvironment - { luaEnvErrorConversion :: ErrorConversion - -- ^ Functions for error and exception handling and conversion - , luaEnvState :: State - -- ^ Lua interpreter state - } - --- | A Lua computation. This is the base type used to run Lua programs of any --- kind. The Lua state is handled automatically, but can be retrieved via --- @'state'@. -newtype Lua a = Lua { unLua :: ReaderT LuaEnvironment IO a } - deriving - ( Applicative - , Functor - , Monad - , MonadCatch - , MonadIO - , MonadMask - , MonadReader LuaEnvironment - , MonadThrow - ) - --- | Turn a function of typ @Lua.State -> IO a@ into a monadic Lua operation. -liftLua :: (State -> IO a) -> Lua a -liftLua f = state >>= liftIO . f - --- | Turn a function of typ @Lua.State -> a -> IO b@ into a monadic Lua operation. -liftLua1 :: (State -> a -> IO b) -> a -> Lua b -liftLua1 f x = liftLua $ \l -> f l x - --- | Get the Lua state of this Lua computation. -state :: Lua State -state = asks luaEnvState - --- | Get the error-to-exception function. -errorConversion :: Lua ErrorConversion -errorConversion = asks luaEnvErrorConversion - --- | Run Lua computation with the given Lua state and error-to-exception --- converter. Any resulting exceptions are left unhandled. -runWithConverter :: ErrorConversion -> State -> Lua a -> IO a -runWithConverter e2e l s = - runReaderT (unLua s) (LuaEnvironment e2e l) - --- | Run the given operation, but crash if any Haskell exceptions occur. -unsafeRunWith :: State -> Lua a -> IO a -unsafeRunWith = runWithConverter unsafeErrorConversion - --- | Unsafe @'ErrorConversion'@; no proper error handling is attempted, --- any error leads to a crash. -unsafeErrorConversion :: ErrorConversion -unsafeErrorConversion = ErrorConversion - { errorToException = const (error "An unrecoverable Lua error occured.") - , addContextToException = const id - , alternative = const - , exceptionToError = id - } - --- | 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 - - --- --- * 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) - --- | Stack index of the nth element from the top of the stack. -nthFromTop :: CInt -> StackIndex -nthFromTop n = StackIndex (-n) -{-# INLINABLE nthFromTop #-} - --- | Stack index of the nth element from the bottom of the stack. -nthFromBottom :: CInt -> StackIndex -nthFromBottom = StackIndex -{-# INLINABLE nthFromBottom #-} - --- | Top of the stack -stackTop :: StackIndex -stackTop = -1 -{-# INLINABLE stackTop #-} - --- | Bottom of the stack -stackBottom :: StackIndex -stackBottom = 1 -{-# INLINABLE stackBottom #-} - --- --- Number of arguments and return values --- - --- | The number of arguments expected a function. -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) - --- --- References --- - --- | Value signaling that no reference was created. -refnil :: CInt -refnil = #{const LUA_REFNIL} - --- | Reference to a stored value. -data Reference = - Reference CInt -- ^ Reference to a stored value - | RefNil -- ^ Reference to a nil value - deriving (Eq, Show) - --- | 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/FunctionCalling.hsc b/src/Foreign/Lua/FunctionCalling.hsc --- a/src/Foreign/Lua/FunctionCalling.hsc +++ b/src/Foreign/Lua/FunctionCalling.hsc @@ -30,17 +30,17 @@ , registerHaskellFunction ) where -import Data.ByteString (ByteString) import Foreign.C (CInt (..)) import Foreign.Lua.Core as Lua +import Foreign.Lua.Core.Types (liftLua) +import Foreign.Lua.Raw.Call (hslua_pushhsfunction) import Foreign.Lua.Types -import Foreign.Lua.Userdata ( ensureUserdataMetatable, pushAnyWithMetatable - , toAnyWithName ) -import Foreign.Lua.Util (getglobal', popValue, raiseError) +import Foreign.Lua.Util (getglobal', popValue) import Foreign.Ptr (freeHaskellFunPtr) --- | Type of raw Haskell functions that can be made into 'CFunction's. -type PreCFunction = Lua.State -> IO NumResults +-- | Type of raw Haskell functions that can be made into +-- 'CFunction's. +type PreCFunction = State -> IO NumResults -- | Haskell function that can be called from Lua. type HaskellFunction = Lua NumResults @@ -101,7 +101,7 @@ liftIO . mkWrapper . flip (Lua.runWithConverter e2e) . toHaskellFunction $ f -- | Turn a @'PreCFunction'@ into an actual @'CFunction'@. -foreign import ccall "wrapper" +foreign import ccall unsafe "wrapper" mkWrapper :: PreCFunction -> IO CFunction -- | Free function pointer created with @newcfunction@. @@ -146,41 +146,13 @@ pushHaskellFunction :: ToHaskellFunction a => a -> Lua () pushHaskellFunction hsFn = do errConv <- Lua.errorConversion - pushPreCFunction . flip (runWithConverter errConv) $ toHaskellFunction hsFn - -- Convert userdata object into a CFuntion. - pushcclosure hslua_call_hs_ptr 1 - --- | Convert callable userdata at top of stack into a CFunction, translating --- errors to Lua errors. Use with @'pushcclosure'@. -foreign import ccall "error-conversion.h &hslua_call_hs" - hslua_call_hs_ptr :: CFunction - -hsLuaFunctionName :: String -hsLuaFunctionName = "HsLuaFunction" + preCFn <- return . flip (runWithConverter errConv) $ toHaskellFunction hsFn + pushPreCFunction preCFn -- | Converts a pre C function to a Lua function and pushes it to the stack. -- -- Pre C functions collect parameters from the stack and return -- a `CInt` that represents number of return values left on the stack. pushPreCFunction :: PreCFunction -> Lua () -pushPreCFunction f = - let pushMetatable = ensureUserdataMetatable hsLuaFunctionName $ do - -- ensure the userdata will be callable - pushcfunction hslua_call_wrapped_hs_fun_ptr - setfield (-2) "__call" - in pushAnyWithMetatable pushMetatable f - --- | Call the Haskell function stored in the userdata. This function is exported --- as a C function and then re-imported in order to get a C function pointer. -hslua_call_wrapped_hs_fun :: Lua.State -> IO NumResults -hslua_call_wrapped_hs_fun l = do - mbFn <- unsafeRunWith l (toAnyWithName stackBottom hsLuaFunctionName - <* remove stackBottom) - case mbFn of - Just fn -> fn l - Nothing -> unsafeRunWith l - (raiseError ("Could not call function" :: ByteString)) - -foreign export ccall hslua_call_wrapped_hs_fun :: PreCFunction -foreign import ccall "&hslua_call_wrapped_hs_fun" - hslua_call_wrapped_hs_fun_ptr :: CFunction +pushPreCFunction preCFn = liftLua $ \l -> + hslua_pushhsfunction l preCFn diff --git a/src/Foreign/Lua/Module.hs b/src/Foreign/Lua/Module.hs --- a/src/Foreign/Lua/Module.hs +++ b/src/Foreign/Lua/Module.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-| Module : Foreign.Lua.Module Copyright : © 2019-2020 Albert Krewinkel @@ -14,24 +15,41 @@ , addfield , addfunction , create + -- * Module + , Module (..) + , Field (..) + , registerModule + , preloadModule + , pushModule + -- * Documentation + , render ) where -import Control.Monad (unless) +import Control.Monad (unless, forM_) +import Data.Text (Text) +import Foreign.Lua.Call (HaskellFunction) import Foreign.Lua.Core +import Foreign.Lua.Push (pushText) import Foreign.Lua.Types (Pushable, push) -import Foreign.Lua.FunctionCalling (ToHaskellFunction, pushHaskellFunction) +import Foreign.Lua.FunctionCalling + ( ToHaskellFunction + , pushHaskellFunction + ) +import qualified Data.Text as T +import qualified Foreign.Lua.Call as Call --- | Load a module, defined by a Haskell action, under the given name. +-- | Load a module, defined by a Haskell action, under the given +-- name. -- --- Similar to @luaL_required@: After checking "loaded" table, calls --- @pushMod@ to push a module to the stack, and registers the result in --- @package.loaded@ table. +-- Similar to @luaL_required@: After checking "loaded" table, +-- calls @pushMod@ to push a module to the stack, and registers +-- the result in @package.loaded@ table. -- --- The @pushMod@ function must push exactly one element to the top of --- the stack. This is not checked, but failure to do so will lead to --- problems. Lua's @package@ module must have been loaded by the time --- this function is invoked. +-- The @pushMod@ function must push exactly one element to the top +-- of the stack. This is not checked, but failure to do so will +-- lead to problems. Lua's @package@ module must have been loaded +-- by the time this function is invoked. -- -- Leaves a copy of the module on the stack. requirehs :: String -> Lua () -> Lua () @@ -52,8 +70,8 @@ remove (nthFromTop 2) -- remove table of loaded modules --- | Registers a preloading function. Takes an module name and the Lua --- operation which produces the package. +-- | Registers a preloading function. Takes an module name and the +-- Lua operation which produces the package. preloadhs :: String -> Lua NumResults -> Lua () preloadhs name pushMod = do getfield registryindex preloadTableRegistryField @@ -61,15 +79,16 @@ setfield (nthFromTop 2) name pop 1 --- | Add a string-indexed field to the table at the top of the stack. +-- | Add a string-indexed field to the table at the top of the +-- stack. addfield :: Pushable a => String -> a -> Lua () addfield name value = do push name push value rawset (nthFromTop 3) --- | Attach a function to the table at the top of the stack, using the --- given name. +-- | Attach a function to the table at the top of the stack, using +-- the given name. addfunction :: ToHaskellFunction a => String -> a -> Lua () addfunction name fn = do push name @@ -79,3 +98,86 @@ -- | Create a new module (i.e., a Lua table). create :: Lua () create = newtable + +-- | Named and documented Lua module. +data Module = Module + { moduleName :: Text + , moduleDescription :: Text + , moduleFields :: [Field] + , moduleFunctions :: [(Text, HaskellFunction)] + } + +-- | Self-documenting module field +data Field = Field + { fieldName :: Text + , fieldDescription :: Text + , fieldPushValue :: Lua () + } + + +-- | Registers a 'Module'; leaves a copy of the module table on +-- the stack. +registerModule :: Module -> Lua () +registerModule mdl = + requirehs (T.unpack $ moduleName mdl) (pushModule mdl) + +-- | Preload self-documenting module. +preloadModule :: Module -> Lua () +preloadModule mdl = + preloadhs (T.unpack $ moduleName mdl) $ do + pushModule mdl + return (NumResults 1) + +pushModule :: Module -> Lua () +pushModule mdl = do + create + forM_ (moduleFunctions mdl) $ \(name, fn) -> do + pushText name + Call.pushHaskellFunction fn + rawset (nthFromTop 3) + +-- | Renders module documentation as Markdown. +render :: Module -> Text +render mdl = + let fields = moduleFields mdl + in T.unlines + [ "# " <> moduleName mdl + , "" + , moduleDescription mdl + , if null (moduleFields mdl) then "" else renderFields fields + , "## Functions" + , "" + ] + <> T.intercalate "\n" + (map (uncurry renderFunctionDoc) (moduleFunctions mdl)) + +-- | Renders documentation of a function. +renderFunctionDoc :: Text -- ^ name + -> HaskellFunction -- ^ function + -> Text -- ^ function docs +renderFunctionDoc name fn = + case Call.functionDoc fn of + Nothing -> "" + Just fnDoc -> T.intercalate "\n" + [ "### " <> name <> " (" <> renderFunctionParams fnDoc <> ")" + , "" + , Call.render fnDoc + ] + +renderFunctionParams :: Call.FunctionDoc -> Text +renderFunctionParams fd = + T.intercalate ", " + . map Call.parameterName + $ Call.parameterDocs fd + +-- | Render documentation for fields as Markdown. +renderFields :: [Field] -> Text +renderFields fs = + if null fs + then mempty + else T.unlines $ map renderField fs + +-- | Renders documentation for a single field. +renderField :: Field -> Text +renderField f = + "### " <> fieldName f <> "\n\n" <> fieldDescription f <> "\n" diff --git a/src/Foreign/Lua/Peek.hs b/src/Foreign/Lua/Peek.hs --- a/src/Foreign/Lua/Peek.hs +++ b/src/Foreign/Lua/Peek.hs @@ -14,6 +14,8 @@ , PeekError (..) , errorMsg , force + , formatPeekError + , pushMsg , toPeeker -- * Primitives , peekBool @@ -29,6 +31,8 @@ , peekList , peekMap , peekSet + -- * Combinators + , optional ) where import Control.Applicative ((<|>)) @@ -240,3 +244,17 @@ fmap (retrieving "Set" . second (Set.fromList . map fst . filter snd)) . peekKeyValuePairs elementPeeker peekBool + +-- +-- Combinators +-- + +-- | Makes a result optional. Returns 'Nothing' if the Lua value +-- is @nil@; otherwise applies the peeker and returns its result. +optional :: Peeker a -- ^ peeker + -> Peeker (Maybe a) +optional peeker idx = do + noValue <- Lua.isnoneornil idx + if noValue + then return $ Right Nothing + else fmap Just <$> peeker idx diff --git a/src/Foreign/Lua/Raw/Auxiliary.hs b/src/Foreign/Lua/Raw/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Lua/Raw/Auxiliary.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE CPP #-} +{-| +Module : Foreign.Lua.Raw.Auxiliary +Copyright : © 2007–2012 Gracjan Polak, + 2012–2016 Ömer Sinan Ağacan, + 2017-2020 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 + ( c_loaded_table + , c_preload_table + , 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 new file mode 100644 --- /dev/null +++ b/src/Foreign/Lua/Raw/Call.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE CPP #-} +{-| +Module : Foreign.Lua.Raw.Call +Copyright : © 2007–2012 Gracjan Polak, + 2012–2016 Ömer Sinan Ağacan, + 2017-2020 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 new file mode 100644 --- /dev/null +++ b/src/Foreign/Lua/Raw/Constants.hs @@ -0,0 +1,39 @@ +{-| +Module : Foreign.Lua.Raw.Constants +Copyright : © 2007–2012 Gracjan Polak, + 2012–2016 Ömer Sinan Ağacan, + 2017-2020 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 new file mode 100644 --- /dev/null +++ b/src/Foreign/Lua/Raw/Error.hs @@ -0,0 +1,40 @@ +{-| +Module : Foreign.Lua.Raw.Error +Copyright : © 2017-2020 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 new file mode 100644 --- /dev/null +++ b/src/Foreign/Lua/Raw/Functions.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE CPP #-} +{-| +Module : Foreign.Lua.Raw.Functions +Copyright : © 2007–2012 Gracjan Polak, + 2012–2016 Ömer Sinan Ağacan, + 2017-2020 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : ForeignFunctionInterface, CPP + +Haskell bindings to Lua C API functions. +-} +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 + +-- TODO: lua_getallocf, lua_setallocf +-- TODO: Debugger functions + +-- Some of the Lua functions may call a Haskell function, and trigger +-- garbage collection, rescheduling etc. This means we must declare these +-- functions as 'safe'. + + +-------------------------------------------------------------------------------- +-- * State manipulation + +-- lua_newstate is currently not supported. + +-- | See +foreign import ccall safe "lua.h lua_close" + lua_close :: Lua.State -> IO () + +-- lua_newthread is currently not supported. + + +-------------------------------------------------------------------------------- +-- * Basic stack manipulation + +-- | See +foreign import ccall SAFTY "lua.h lua_absindex" + lua_absindex :: Lua.State -> StackIndex -> IO StackIndex + +-- | See +foreign import ccall SAFTY "lua.h lua_gettop" + lua_gettop :: Lua.State -> IO StackIndex + +-- | See +foreign import ccall SAFTY "lua.h lua_settop" + lua_settop :: Lua.State -> StackIndex -> IO () + +-- | See +foreign import ccall SAFTY "lua.h lua_pushvalue" + lua_pushvalue :: Lua.State -> StackIndex -> IO () + +-- | See +foreign import capi SAFTY "lua.h lua_pop" + lua_pop :: Lua.State -> StackIndex -> IO () + +-- | See +foreign import ccall SAFTY "lua.h lua_copy" + lua_copy :: Lua.State -> StackIndex -> StackIndex -> IO () + +-- | See +foreign import capi SAFTY "lua.h lua_remove" + lua_remove :: Lua.State -> StackIndex -> IO () + +-- | See +foreign import capi SAFTY "lua.h lua_insert" + lua_insert :: Lua.State -> StackIndex -> IO () + +-- | See +foreign import capi SAFTY "lua.h lua_replace" + lua_replace :: Lua.State -> StackIndex -> IO () + +-- | See +foreign import capi SAFTY "lua.h lua_checkstack" + lua_checkstack :: Lua.State -> CInt -> IO LuaBool + +-- lua_xmove is currently not supported. + + +-------------------------------------------------------------------------------- +-- * Stack access functions + +-- | See +foreign import ccall SAFTY "lua.h lua_isnumber" + lua_isnumber :: Lua.State -> StackIndex -> IO LuaBool + +-- | See +foreign import ccall SAFTY "lua.h lua_isinteger" + lua_isinteger :: Lua.State -> StackIndex -> IO LuaBool + +-- | See +foreign import ccall SAFTY "lua.h lua_isstring" + lua_isstring :: Lua.State -> StackIndex -> IO LuaBool + +-- | See +foreign import ccall SAFTY "lua.h lua_iscfunction" + lua_iscfunction :: Lua.State -> StackIndex -> IO LuaBool + +-- | See +foreign import ccall SAFTY "lua.h lua_isuserdata" + lua_isuserdata :: Lua.State -> StackIndex -> IO LuaBool + +-- | See +foreign import ccall SAFTY "lua.h lua_type" + lua_type :: Lua.State -> StackIndex -> IO TypeCode + +-- | See +foreign import ccall SAFTY "lua.h lua_typename" + lua_typename :: Lua.State -> TypeCode -> IO CString + +-- lua_compare is unsafe (might cause a longjmp), use hslua_compare instead. + +-- | Wrapper around which catches any @longjmp@s. +foreign import capi safe "hslua.h hslua_compare" + hslua_compare :: Lua.State + -> StackIndex -> StackIndex -> CInt + -> Ptr StatusCode -> IO LuaBool + +-- | See +foreign import ccall SAFTY "lua.h lua_rawequal" + lua_rawequal :: Lua.State -> StackIndex -> StackIndex -> IO LuaBool + +-- +-- Type coercion +-- +-- | See +foreign import capi SAFTY "lua.h lua_toboolean" + lua_toboolean :: Lua.State -> StackIndex -> IO LuaBool + +-- | See +foreign import ccall SAFTY "lua.h lua_tocfunction" + lua_tocfunction :: Lua.State -> StackIndex -> IO CFunction + +-- | See +foreign import ccall SAFTY "lua.h lua_tointegerx" + lua_tointegerx :: Lua.State -> StackIndex -> Ptr LuaBool -> IO Lua.Integer + +-- | See +foreign import ccall SAFTY "lua.h lua_tonumberx" + lua_tonumberx :: Lua.State -> StackIndex -> Ptr LuaBool -> IO Lua.Number + +-- | See +foreign import ccall SAFTY "lua.h lua_tolstring" + lua_tolstring :: Lua.State -> StackIndex -> Ptr CSize -> IO (Ptr CChar) + +-- | See +foreign import ccall SAFTY "lua.h lua_topointer" + lua_topointer :: Lua.State -> StackIndex -> IO (Ptr ()) + +-- | See +foreign import ccall SAFTY "lua.h lua_tothread" + lua_tothread :: Lua.State -> StackIndex -> IO Lua.State + +-- | See +foreign import ccall SAFTY "lua.h lua_touserdata" + lua_touserdata :: Lua.State -> StackIndex -> IO (Ptr a) + + +-- +-- Object size +-- + +-- | See +foreign import ccall SAFTY "lua.h lua_rawlen" + lua_rawlen :: Lua.State -> StackIndex -> IO CSize + + +-------------------------------------------------------------------------------- +-- * Push functions + +-- | See +foreign import ccall SAFTY "lua.h lua_pushnil" + lua_pushnil :: Lua.State -> IO () + +-- | See +foreign import ccall SAFTY "lua.h lua_pushnumber" + lua_pushnumber :: Lua.State -> Lua.Number -> IO () + +-- | See +foreign import ccall SAFTY "lua.h lua_pushinteger" + lua_pushinteger :: Lua.State -> Lua.Integer -> IO () + +-- | See +foreign import ccall SAFTY "lua.h lua_pushlstring" + lua_pushlstring :: Lua.State -> Ptr CChar -> CSize -> IO () + +-- lua_pushstring is currently not supported. It's difficult to use in a haskell +-- context. + +-- | See +foreign import ccall SAFTY "lua.h lua_pushcclosure" + lua_pushcclosure :: Lua.State -> CFunction -> NumArgs -> IO () + +-- | See +foreign import ccall SAFTY "lua.h lua_pushboolean" + lua_pushboolean :: Lua.State -> LuaBool -> IO () + +-- | See +foreign import ccall SAFTY "lua.h lua_pushlightuserdata" + lua_pushlightuserdata :: Lua.State -> Ptr a -> IO () + +-- | See +foreign import ccall SAFTY "lua.h lua_pushthread" + lua_pushthread :: Lua.State -> IO CInt + + +-------------------------------------------------------------------------------- +-- * Get functions + +-- + lua_gettable is unsafe, use hslua_gettable instead. +-- + lua_getglobal is unsafe, use hslua_getglobal instead. +-- + lua_getfield is unsafe, we build something equivallent using pushlstring and +-- gettable. + +-- | Wrapper around which catches any @longjmp@s. +foreign import ccall safe "hslua.h hslua_gettable" + hslua_gettable :: Lua.State -> StackIndex -> Ptr StatusCode -> IO () + +-- | See +foreign import ccall SAFTY "lua.h lua_rawget" + lua_rawget :: Lua.State -> StackIndex -> IO () + +-- | See +foreign import ccall SAFTY "lua.h lua_rawgeti" + lua_rawgeti :: Lua.State -> StackIndex -> Lua.Integer -> IO () + +-- | See +foreign import ccall SAFTY "lua.h lua_createtable" + lua_createtable :: Lua.State -> CInt -> CInt -> IO () + +-- | See +foreign import ccall SAFTY "lua.h lua_newuserdata" + lua_newuserdata :: Lua.State -> CSize -> IO (Ptr ()) + +-- | See +foreign import ccall SAFTY "lua.h lua_getmetatable" + lua_getmetatable :: Lua.State -> StackIndex -> IO LuaBool + +-- | Wrapper around which catches any @longjmp@s. +foreign import ccall safe "hslua.h hslua_getglobal" + hslua_getglobal :: Lua.State -> CString -> CSize -> Ptr StatusCode -> IO () + + +-------------------------------------------------------------------------------- +-- * Set functions + +-- lua_settable is unsafe, use hslua_settable instead. +-- lua_setfield is unsafe, use hslua_setfield instead. +-- lua_setglobal is unsafe, use hslua_setglobal instead. +-- lua_setfenv (5.1 only) is not supported. + +-- | Wrapper around which catches any @longjmp@s. +foreign import ccall safe "hslua.h hslua_settable" + hslua_settable :: Lua.State -> StackIndex -> Ptr StatusCode -> IO () + +-- | See +foreign import ccall SAFTY "lua.h lua_rawset" + lua_rawset :: Lua.State -> StackIndex -> IO () + +-- | See +foreign import ccall SAFTY "lua.h lua_rawseti" + lua_rawseti :: Lua.State -> StackIndex -> Lua.Integer -> IO () + +-- | See +foreign import ccall SAFTY "lua.h lua_setmetatable" + lua_setmetatable :: Lua.State -> StackIndex -> IO () + +-- | Wrapper around which catches any @longjmp@s. +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) + +-- lua_call is inherently unsafe, we do not support it. + +-- | See +foreign import capi safe "lua.h lua_pcall" + lua_pcall :: Lua.State -> NumArgs -> NumResults -> StackIndex + -> IO StatusCode + +-- | See +foreign import ccall safe "lua.h lua_load" + lua_load :: Lua.State -> Lua.Reader -> Ptr () -> CString -> CString + -> IO StatusCode + +-- currently unsupported: +-- lua_dump + + +------------------------------------------------------------------------------ +-- * Coroutine functions + +-- lua_yield / lua_yieldk and lua_resume are currently not supported. + +-- | See +foreign import ccall SAFTY "lua.h lua_status" + lua_status :: Lua.State -> IO StatusCode + + +------------------------------------------------------------------------------ +-- * Garbage-collection functions and options + +-- | See +foreign import ccall safe "lua.h lua_gc" + lua_gc :: Lua.State -> CInt -> CInt -> IO CInt + + +------------------------------------------------------------------------------ +-- * Miscellaneous functions + +-- lua_error is unsafe, use hslua_error instead. +-- lua_next is unsafe, use hslua_next instead. +-- lua_concat is unsafe (may trigger a longjmp), use hslua_concat instead. + +-- | Replacement for ; it uses the HsLua error signaling convention instead of raw +-- @longjmp@. +foreign import ccall SAFTY "hslua.h hslua_error" + hslua_error :: Lua.State -> IO NumResults + +-- | Wrapper around which catches any @longjmp@s. +foreign import ccall safe "hslua.h hslua_next" + hslua_next :: Lua.State -> StackIndex -> Ptr StatusCode -> IO LuaBool + +-- | Wrapper around which catches any @longjmp@s. +foreign import ccall safe "hslua.h hslua_concat" + hslua_concat :: Lua.State -> NumArgs -> Ptr StatusCode -> IO () + +-- | See +foreign import capi SAFTY "lua.h lua_pushglobaltable" + lua_pushglobaltable :: Lua.State -> IO () + + +------------------------------------------------------------------------------ +-- * Lua Libraries + +-- | See +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 new file mode 100644 --- /dev/null +++ b/src/Foreign/Lua/Raw/Types.hsc @@ -0,0 +1,281 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-| +Module : Foreign.Lua.Raw.Types +Copyright : © 2007–2012 Gracjan Polak, + 2012–2016 Ömer Sinan Ağacan, + 2017-2020 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 new file mode 100644 --- /dev/null +++ b/src/Foreign/Lua/Raw/Userdata.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE CPP #-} +{-| +Module : Foreign.Lua.Raw.Userdata +Copyright : © 2017-2020 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/Foreign/Lua/Userdata.hs b/src/Foreign/Lua/Userdata.hs --- a/src/Foreign/Lua/Userdata.hs +++ b/src/Foreign/Lua/Userdata.hs @@ -39,19 +39,20 @@ , metatableName ) where --- import Control.Applicative (empty) import Control.Monad (when) import Data.Data (Data, dataTypeName, dataTypeOf) +import Foreign.C (withCString) import Foreign.Lua.Core (Lua) +import Foreign.Lua.Core.Types (liftLua, fromLuaBool) +import Foreign.Lua.Raw.Userdata + ( hslua_fromuserdata + , hslua_newhsuserdata + , hslua_newudmetatable + ) import Foreign.Lua.Types.Peekable (reportValueOnFailure) import qualified Foreign.Lua.Core as Lua -import qualified Foreign.C as C -import qualified Foreign.Ptr as Ptr -import qualified Foreign.StablePtr as StablePtr -import qualified Foreign.Storable as Storable - -- | Push data by wrapping it into a userdata object. pushAny :: Data a => a @@ -67,9 +68,7 @@ -> a -- ^ object to push to Lua. -> Lua () pushAnyWithMetatable mtOp x = do - xPtr <- Lua.liftIO (StablePtr.newStablePtr x) - udPtr <- Lua.newuserdata (Storable.sizeOf xPtr) - Lua.liftIO $ Storable.poke (Ptr.castPtr udPtr) xPtr + liftLua $ \l -> hslua_newhsuserdata l x mtOp Lua.setmetatable (Lua.nthFromTop 2) return () @@ -84,17 +83,10 @@ -- the stack. -> Lua () ensureUserdataMetatable name modMt = do - mtCreated <- Lua.newmetatable name - when mtCreated $ do - -- Prevent accessing or changing the metatable with - -- getmetatable/setmetatable. - Lua.pushboolean True - Lua.setfield (Lua.nthFromTop 2) "__metatable" - -- Mark objects for finalization when collecting garbage. - Lua.pushcfunction hslua_userdata_gc_ptr - Lua.setfield (Lua.nthFromTop 2) "__gc" - -- Execute additional modifications on metatable - modMt + mtCreated <- liftLua $ \l -> + fromLuaBool <$> withCString name (hslua_newudmetatable l) + -- Execute additional modifications on metatable + when mtCreated modMt -- | Retrieve data which has been pushed with @'pushAny'@. toAny :: Data a => Lua.StackIndex -> Lua (Maybe a) @@ -108,14 +100,8 @@ toAnyWithName :: Lua.StackIndex -> String -- ^ expected metatable name -> Lua (Maybe a) -toAnyWithName idx name = do - l <- Lua.state - udPtr <- Lua.liftIO (C.withCString name (luaL_testudata l idx)) - if udPtr == Ptr.nullPtr - then return Nothing - else - fmap Just . Lua.liftIO $ - Storable.peek (Ptr.castPtr udPtr) >>= StablePtr.deRefStablePtr +toAnyWithName idx name = liftLua $ \l -> + withCString name (hslua_fromuserdata l idx) -- | Retrieve Haskell data which was pushed to Lua as userdata. peekAny :: Data a => Lua.StackIndex -> Lua a @@ -128,14 +114,3 @@ -- the given type as userdata. The argument is never evaluated. metatableName :: Data a => a -> String metatableName x = "HSLUA_" ++ dataTypeName (dataTypeOf x) - --- | Function to free the stable pointer in a userdata, ensuring the Haskell --- value can be garbage collected. This function does not call back into --- Haskell, making is safe to call even from functions imported as unsafe. -foreign import ccall "&hslua_userdata_gc" - hslua_userdata_gc_ptr :: Lua.CFunction - --- | See --- -foreign import ccall "luaL_testudata" - luaL_testudata :: Lua.State -> Lua.StackIndex -> C.CString -> IO (Ptr.Ptr ()) diff --git a/test/Foreign/Lua/CallTests.hs b/test/Foreign/Lua/CallTests.hs new file mode 100644 --- /dev/null +++ b/test/Foreign/Lua/CallTests.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : Foreign.Lua.CallTests +Copyright : © 2020 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : alpha +Portability : OverloadedStrings, TypeApplications + +Tests for calling exposed Haskell functions. +-} +module Foreign.Lua.CallTests (tests) where + +import Foreign.Lua.Core (StackIndex) +import Foreign.Lua.Call +import Foreign.Lua.Peek (peekIntegral, peekText, force) +import Foreign.Lua.Push (pushIntegral) +import Test.HsLua.Util ((=:), shouldBeResultOf) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@=?)) + +import qualified Data.Text as T +import qualified Foreign.Lua as Lua + +-- | Calling Haskell functions from Lua. +tests :: TestTree +tests = testGroup "Call" + [ testGroup "push Haskell function" + [ "HaskellFunction building" =: + 720 + `shouldBeResultOf` do + factLua <- factLuaAtIndex <$> Lua.gettop + Lua.pushinteger 6 + _ <- callFunction factLua + peekIntegral @Integer Lua.stackTop >>= force + + , "error message" =: + mconcat [ "retrieving function argument n" + , "\n\texpected Integral, got 'true' (boolean)"] + `shouldBeResultOf` do + factLua <- factLuaAtIndex <$> Lua.gettop + Lua.pushboolean True + _ <- callFunction factLua + peekText Lua.stackTop >>= force + ] + , testGroup "use as C function" + [ "push factorial" =: + Lua.TypeFunction + `shouldBeResultOf` do + pushHaskellFunction $ factLuaAtIndex 0 + Lua.ltype Lua.stackTop + , "call factorial" =: + 120 + `shouldBeResultOf` do + pushHaskellFunction $ factLuaAtIndex 0 + Lua.pushinteger 5 + Lua.call 1 1 + peekIntegral @Integer Lua.stackTop >>= force + , "use from Lua" =: + 24 + `shouldBeResultOf` do + pushHaskellFunction $ factLuaAtIndex 0 + Lua.setglobal "factorial" + Lua.loadstring "return factorial(4)" *> Lua.call 0 1 + peekIntegral @Integer Lua.stackTop >>= force + ] + , testGroup "documentation" + [ "rendered docs" =: + (T.unlines + [ "Parameters:" + , "" + , "n" + , ": number for which the factorial is computed (integer)" + , "" + , "Returns:" + , "" + , " - factorial (integer)" + ] + @=? + maybe "" render (functionDoc (factLuaAtIndex 0))) + ] + + , testGroup "helpers" + [ "parameter doc" =: + ( ParameterDoc + { parameterName = "test" + , parameterDescription = "test param" + , parameterType = "string" + , parameterIsOptional = False + } + @=? + parameterDoc (parameter peekText "string" "test" "test param") + ) + , "optionalParameter doc" =: + ( ParameterDoc + { parameterName = "test" + , parameterDescription = "test param" + , parameterType = "string" + , parameterIsOptional = True + } + @=? + parameterDoc (optionalParameter peekText "string" "test" "test param") + ) + , "functionResult doc" =: + ( FunctionResultDoc + { functionResultDescription = "int result" + , functionResultType = "integer" + } + @=? + (fnResultDoc . head $ + functionResult (pushIntegral @Int) "integer" "int result") + ) + ] + ] + +factLuaAtIndex :: StackIndex -> HaskellFunction +factLuaAtIndex idx = + toHsFnPrecursorWithStartIndex idx factorial + <#> factorialParam + =#> factorialResult + +-- | Calculate the factorial of a number. +factorial :: Integer -> Integer +factorial n = product [1..n] + +factorialParam :: Parameter Integer +factorialParam = Parameter + { parameterDoc = ParameterDoc + { parameterName = "n" + , parameterType = "integer" + , parameterDescription = "number for which the factorial is computed" + , parameterIsOptional = False + } + , parameterPeeker = peekIntegral @Integer + } + +factorialResult :: FunctionResults Integer +factorialResult = (:[]) $ FunctionResult + (pushIntegral @Integer) + (FunctionResultDoc "integer" "factorial") diff --git a/test/Foreign/Lua/ModuleTests.hs b/test/Foreign/Lua/ModuleTests.hs --- a/test/Foreign/Lua/ModuleTests.hs +++ b/test/Foreign/Lua/ModuleTests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {-| Module : Foreign.Lua.ModuleTests Copyright : © 2019-2020 Albert Krewinkel @@ -12,10 +13,15 @@ module Foreign.Lua.ModuleTests (tests) where import Foreign.Lua (Lua) -import Foreign.Lua.Module (addfield, addfunction, create, preloadhs, requirehs) +import Foreign.Lua.Call hiding (render) +import Foreign.Lua.Module +import Foreign.Lua.Peek (peekIntegral) +import Foreign.Lua.Push (pushIntegral) import Test.HsLua.Util ((=:), pushLuaExpr, shouldBeResultOf) import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@=?)) +import qualified Data.Text as T import qualified Foreign.Lua as Lua -- | Specifications for Attributes parsing functions. @@ -79,4 +85,68 @@ Lua.call 1 1 Lua.peek Lua.stackTop ] + , testGroup "module type" + [ "register module" =: + 1 `shouldBeResultOf` do + Lua.openlibs + old <- Lua.gettop + registerModule mymath + new <- Lua.gettop + return (new - old) + + , "call module function" =: + Right 24 `shouldBeResultOf` do + Lua.openlibs + registerModule mymath + _ <- Lua.dostring $ mconcat + [ "local mymath = require 'mymath'\n" + , "return mymath.factorial(4)" + ] + peekIntegral @Integer Lua.stackTop + ] + , testGroup "documentation" + [ "module docs" =: + (T.intercalate "\n" + [ "# mymath" + , "" + , "A math module." + , "" + , "## Functions" + , "" + , "### factorial (n)" + , "" + , "Parameters:" + , "" + , "n" + , ": number for which the factorial is computed (integer)" + , "" + , "Returns:" + , "" + , " - factorial (integer)\n" + ] @=? + render mymath) + ] ] + +mymath :: Module +mymath = Module + { moduleName = "mymath" + , moduleDescription = "A math module." + , moduleFields = [] + , moduleFunctions = [ ("factorial", factorial)] + } + +factorial :: HaskellFunction +factorial = toHsFnPrecursor (\n -> product [1..n]) + <#> factorialParam + =#> factorialResult + +factorialParam :: Parameter Integer +factorialParam = + parameter (peekIntegral @Integer) "integer" + "n" + "number for which the factorial is computed" + +factorialResult :: FunctionResults Integer +factorialResult = + functionResult (pushIntegral @Integer) "integer" "factorial" diff --git a/test/Foreign/Lua/PeekTests.hs b/test/Foreign/Lua/PeekTests.hs --- a/test/Foreign/Lua/PeekTests.hs +++ b/test/Foreign/Lua/PeekTests.hs @@ -270,4 +270,15 @@ peekMap (peekIntegral @Int) peekText Lua.stackTop ] ] + + , testGroup "combinators" + [ "optional with nil" =: + Right Nothing `shouldBeResultOf` do + Lua.pushnil + optional peekString Lua.top + , "optional with number" =: + Right (Just 23) `shouldBeResultOf` do + Lua.pushinteger 23 + optional (peekIntegral @Int) Lua.top + ] ] diff --git a/test/Foreign/Lua/PushTests.hs b/test/Foreign/Lua/PushTests.hs --- a/test/Foreign/Lua/PushTests.hs +++ b/test/Foreign/Lua/PushTests.hs @@ -142,7 +142,7 @@ tableSize <- run $ Lua.run $ do pushList pushString list Lua.rawlen Lua.stackTop - assert $ fromIntegral tableSize == length list + assert $ tableSize == length list , testSingleElementProperty (pushList pushText) ] diff --git a/test/test-hslua.hs b/test/test-hslua.hs --- a/test/test-hslua.hs +++ b/test/test-hslua.hs @@ -22,6 +22,7 @@ import Test.Tasty (TestTree, defaultMain, testGroup) import qualified Foreign.LuaTests +import qualified Foreign.Lua.CallTests import qualified Foreign.Lua.CoreTests import qualified Foreign.Lua.FunctionCallingTests import qualified Foreign.Lua.ModuleTests @@ -50,6 +51,7 @@ ] , Foreign.Lua.UserdataTests.tests , Foreign.Lua.ModuleTests.tests + , Foreign.Lua.CallTests.tests , Foreign.LuaTests.tests , Foreign.Lua.PeekTests.tests ]