diff --git a/hslua-examples/CHANGELOG.md b/hslua-examples/CHANGELOG.md index c6529235..f9531154 100644 --- a/hslua-examples/CHANGELOG.md +++ b/hslua-examples/CHANGELOG.md @@ -2,6 +2,12 @@ `hslua-examples` uses [PVP Versioning][]. +## hslua-examples-2.0.3 + +Release pending. + +- Allowed hslua*-2.4. + ## hslua-examples-2.0.2 Released 2023-03-13. diff --git a/hslua-examples/hslua-examples.cabal b/hslua-examples/hslua-examples.cabal index 1362c0d5..ac0bca0a 100644 --- a/hslua-examples/hslua-examples.cabal +++ b/hslua-examples/hslua-examples.cabal @@ -56,20 +56,20 @@ executable run-lua main-is: run-lua.hs hs-source-dirs: run-lua build-depends: bytestring - , hslua >= 2.0 && < 2.4 + , hslua >= 2.0 && < 2.5 executable wishlist import: common-options main-is: wishlist.hs hs-source-dirs: wishlist - build-depends: hslua >= 2.0 && < 2.4 + build-depends: hslua >= 2.0 && < 2.5 , text executable factorial import: common-options main-is: factorial.hs hs-source-dirs: factorial - build-depends: hslua >= 2.0 && < 2.4 + build-depends: hslua >= 2.0 && < 2.5 executable low-level-factorial import: common-options diff --git a/hslua-module-path/CHANGELOG.md b/hslua-module-path/CHANGELOG.md index 65816045..ca8994a7 100644 --- a/hslua-module-path/CHANGELOG.md +++ b/hslua-module-path/CHANGELOG.md @@ -2,6 +2,12 @@ `hslua-module-paths` uses [PVP Versioning][]. +## hslua-module-path-1.1.2 + +Release pending. + +- Relax upper bound for hslua-packaging. + ## hslua-module-path-1.1.1 Released 2024-01-18. diff --git a/hslua-module-path/hslua-module-path.cabal b/hslua-module-path/hslua-module-path.cabal index 7f0f0598..cd35a769 100644 --- a/hslua-module-path/hslua-module-path.cabal +++ b/hslua-module-path/hslua-module-path.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hslua-module-path -version: 1.1.1 +version: 1.1.2 synopsis: Lua module to work with file paths. description: Lua module to work with file paths in a platform independent way. @@ -34,7 +34,7 @@ source-repository head common common-options build-depends: base >= 4.9.1 && < 5 , hslua-core >= 2.1 && < 2.4 - , hslua-packaging >= 2.3 && < 2.4 + , hslua-packaging >= 2.3 && < 2.5 ghc-options: -Wall -Wcpp-undef diff --git a/hslua-module-system/CHANGELOG.md b/hslua-module-system/CHANGELOG.md index 6d6b29fe..65185b8f 100644 --- a/hslua-module-system/CHANGELOG.md +++ b/hslua-module-system/CHANGELOG.md @@ -27,6 +27,8 @@ Release pending. the Lua module, but not exported from the Haskell module. Instead, `HsLua.Core.run` was erroneously reexported. +- Relax upper bound for hslua-packaging. + ## hslua-module-system-1.1.3 Released 2025-05-21. diff --git a/hslua-module-system/hslua-module-system.cabal b/hslua-module-system/hslua-module-system.cabal index 0b46d0a3..1ca7bb1f 100644 --- a/hslua-module-system/hslua-module-system.cabal +++ b/hslua-module-system/hslua-module-system.cabal @@ -39,7 +39,7 @@ common common-options default-language: Haskell2010 build-depends: base >= 4.11 && < 5 , hslua-core >= 2.1 && < 2.4 - , hslua-packaging >= 2.3 && < 2.4 + , hslua-packaging >= 2.3 && < 2.5 default-extensions: LambdaCase , OverloadedStrings diff --git a/hslua-module-text/CHANGELOG.md b/hslua-module-text/CHANGELOG.md index 695ab64d..3b1044b9 100644 --- a/hslua-module-text/CHANGELOG.md +++ b/hslua-module-text/CHANGELOG.md @@ -2,6 +2,12 @@ `hslua-module-text` uses [PVP Versioning][]. +## hslua-module-text-1.1.2 + +Release pending. + +- Relax upper bound for hslua-packaging. + ## hslua-module-text-1.1.1 Released 2024-01-18. diff --git a/hslua-module-text/hslua-module-text.cabal b/hslua-module-text/hslua-module-text.cabal index 1d06d12e..eedf450a 100644 --- a/hslua-module-text/hslua-module-text.cabal +++ b/hslua-module-text/hslua-module-text.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hslua-module-text -version: 1.1.1 +version: 1.1.2 synopsis: Lua module for text description: UTF-8 aware subset of Lua's `string` module. . @@ -37,7 +37,7 @@ common common-options default-language: Haskell2010 build-depends: base >= 4.11 && < 5 , hslua-core >= 2.3 && < 2.4 - , hslua-packaging >= 2.3 && < 2.4 + , hslua-packaging >= 2.3 && < 2.5 ghc-options: -Wall -Wcpp-undef diff --git a/hslua-module-version/CHANGELOG.md b/hslua-module-version/CHANGELOG.md index 537970d2..2f075bb6 100644 --- a/hslua-module-version/CHANGELOG.md +++ b/hslua-module-version/CHANGELOG.md @@ -2,6 +2,12 @@ `hslua-module-version` uses [PVP Versioning][]. +## hslua-module-version-1.1.2 + +Release pending. + +- Require hslua-packaging-2.4.\*. + ## hslua-module-version-1.1.1 Released 2024-01-18. diff --git a/hslua-module-version/hslua-module-version.cabal b/hslua-module-version/hslua-module-version.cabal index 89c8ce90..c34bf7ca 100644 --- a/hslua-module-version/hslua-module-version.cabal +++ b/hslua-module-version/hslua-module-version.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hslua-module-version -version: 1.1.1 +version: 1.1.2 synopsis: Lua module to work with version specifiers. description: Wrapper for the Data.Version.Version Haskell type. homepage: https://hslua.org/ @@ -33,7 +33,7 @@ source-repository head common common-options build-depends: base >= 4.9.1 && < 5 , hslua-core >= 2.3 && < 2.4 - , hslua-packaging >= 2.3 && < 2.4 + , hslua-packaging >= 2.4 && < 2.5 ghc-options: -Wall -Wcpp-undef diff --git a/hslua-module-version/src/HsLua/Module/Version.hs b/hslua-module-version/src/HsLua/Module/Version.hs index 19e33cb0..0716805a 100644 --- a/hslua-module-version/src/HsLua/Module/Version.hs +++ b/hslua-module-version/src/HsLua/Module/Version.hs @@ -78,8 +78,8 @@ typeVersion = deftype' "Version" =#> stringResult "stringified version" ] [ method must_be_at_least ] - (Just ( (pushIntegral, versionBranch) - , (peekIntegral, const makeVersion))) + (ListSpec ( (pushIntegral, versionBranch) + , (peekIntegral, const makeVersion))) where versionComparison f descr = lambda ### liftPure2 f diff --git a/hslua-module-zip/CHANGELOG.md b/hslua-module-zip/CHANGELOG.md index be3b12a0..3f8cafe1 100644 --- a/hslua-module-zip/CHANGELOG.md +++ b/hslua-module-zip/CHANGELOG.md @@ -2,10 +2,12 @@ `hslua-module-zips` uses [PVP Versioning][]. -## Unreleased +## hslua-module-path-1.1.4 Release pending. +- Relax upper bound for hslua-packaging. + - Allowed time-1.4. ## hslua-module-zip-1.1.3 diff --git a/hslua-module-zip/hslua-module-zip.cabal b/hslua-module-zip/hslua-module-zip.cabal index cf3e19e7..dd7e83eb 100644 --- a/hslua-module-zip/hslua-module-zip.cabal +++ b/hslua-module-zip/hslua-module-zip.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hslua-module-zip -version: 1.1.3 +version: 1.1.4 synopsis: Lua module to work with file zips. description: Module with function for creating, modifying, and extracting files from zip archives. @@ -34,7 +34,7 @@ source-repository head common common-options build-depends: base >= 4.11 && < 5 , hslua-core >= 2.3 && < 2.4 - , hslua-packaging >= 2.3 && < 2.4 + , hslua-packaging >= 2.3 && < 2.5 ghc-options: -Wall -Wcpp-undef diff --git a/hslua-objectorientation/CHANGELOG.md b/hslua-objectorientation/CHANGELOG.md index d5ba7da5..4ce5d53d 100644 --- a/hslua-objectorientation/CHANGELOG.md +++ b/hslua-objectorientation/CHANGELOG.md @@ -2,6 +2,22 @@ `hslua-objectorientation` uses [PVP Versioning][]. +## hslua-objectorientation-2.4.0 + +Release pending. + +- Modified the types of userdata type specifiers to make them + more flexible and extensible. The types now take an additional + parameter, which must be an instance of the new typeclass + `UDTypeExtension`. The behavior of UDType objects can be + modified through this parameter and the corresponding + typeclass instances. + + E.g., list types are now types with a `ListSpec` type + extension. See `HsLua.Module.Version` for an example. + +- The code was split and spread across additional submodules. + ## hslua-objectorientation-2.3.1 Released 2024-01-18. diff --git a/hslua-objectorientation/cbits/hsllist.c b/hslua-objectorientation/cbits/hsllist.c new file mode 100644 index 00000000..167c4eba --- /dev/null +++ b/hslua-objectorientation/cbits/hsllist.c @@ -0,0 +1,115 @@ +#include +#include +#include "hslobj.h" + +/* *************************************************************** + * Lazy List object access + * ***************************************************************/ + +/* +** Retrieve a numerical index from this object. The userdata must be in +** position 1, and the key in position 2. +*/ +static int hsluaL_get_numerical(lua_State *L) +{ + hslua_get_caching_table(L, 1); + lua_Integer requested = lua_tointeger(L, 2); + + /* The __lazylistindex is set to `nil` or an integer if part of the + list is still unevaluated. If it's `false`, then all list values are + already in the cache. */ + if (lua_getfield(L, 1, "__lazylistindex") == LUA_TBOOLEAN) { + lua_pop(L, 1); /* remove nil */ + } else { + lua_Integer last_index = lua_tointeger(L, -1); + lua_pop(L, 1); /* pop last-index value */ + + if (requested > last_index && + /* index not in cache, force lazy evaluation of list items */ + luaL_getmetafield(L, 1, "lazylisteval") == LUA_TFUNCTION) { + if (lua_getfield(L, 3, "__lazylist") != LUA_TUSERDATA) { + /* lazy list thunk is missing; that shouldn't happen!! */ + luaL_error(L, "Error while getting numerical index %d: " + "lazy list thunk is missing", requested); + } + lua_pushinteger(L, last_index); + lua_pushinteger(L, requested); + lua_pushvalue(L, 3); /* caching table */ + lua_call(L, 4, 0); /* populate cache with evaled values */ + } + } + lua_rawgeti(L, 3, requested); + return 1; +} + +/* +** Retrieves a key from a Haskell-data holding userdata value. +** +** If the key is an integer, any associated list is evaluated and the +** result is stored in the cache before it is returned. +** +** Otherwise, the default method for key retrieval is used. +*/ +int hslua_list_udindex(lua_State *L) +{ + lua_settop(L, 2); + /* do numeric lookup for integer keys */ + return lua_isinteger(L, 2) + ? (hsluaL_get_numerical(L)) + /* try various sources in order; return 0 if nothing is found. */ + : hslua_udindex(L); +} + +/* +** Sets a numerical index on this object. The userdata must be in +** position 1, the key in position 2, and the new value in position 3. +** Returns 1 on success and 0 otherwise. +*/ +static int hsluaL_set_numerical(lua_State *L) +{ + hslua_get_caching_table(L, 1); + lua_Integer target = lua_tointeger(L, 2); + + /* The `__lazylistindex` field is set to `false` if each list element + has already been evaluated and stored in the cache. Otherwise it + will be either `nil` or an integer. */ + if (lua_getfield(L, 1, "__lazylistindex") == LUA_TBOOLEAN) { + lua_pop(L, 1); /* pop boolean from last-index */ + } else { + /* list is not fully evaluated yet, we may have to evaluate it + further. */ + lua_Integer last_index = lua_tointeger(L, -1); + lua_pop(L, 1); /* pop last-index value */ + + if (target > last_index) { + /* the index we want to assign has not been cached yet. Evaluation + * is forced to avoid any uncertainty about the meaning of + * `nil`-valued indices. */ + lua_pushcfunction(L, &hsluaL_get_numerical); + lua_pushvalue(L, 1); /* userdata object */ + lua_pushvalue(L, 2); /* numerical key */ + lua_call(L, 2, 0); + } + } + lua_pushvalue(L, 3); /* new value */ + lua_rawseti(L, -2, target); /* set in caching table */ + return 1; /* signal success */ +} + +/* +** Sets a value for a list-like object. Behaves like normal element +** access, but also handles (numerical) list indices. +*/ +int hslua_list_udnewindex(lua_State *L) +{ + lua_settop(L, 3); + if (lua_type(L, 2) == LUA_TNUMBER) { + if (hsluaL_set_numerical(L)) { + return 0; + } + lua_pushliteral(L, "Cannot set a numerical value."); + return lua_error(L); + } + + return hslua_udnewindex(L); +} diff --git a/hslua-objectorientation/cbits/hslobj.c b/hslua-objectorientation/cbits/hslobj.c index 0a22004f..14293476 100644 --- a/hslua-objectorientation/cbits/hslobj.c +++ b/hslua-objectorientation/cbits/hslobj.c @@ -13,7 +13,7 @@ ** Creates and sets a new table if none has been attached to the ** userdata yet. */ -static void hsluaO_get_caching_table(lua_State *L, int idx) +void hslua_get_caching_table(lua_State *L, int idx) { if (lua_getuservalue(L, idx) == LUA_TTABLE) { return; @@ -34,10 +34,10 @@ static void hsluaO_get_caching_table(lua_State *L, int idx) ** found and is at the top of the stack, 0 otherwise. Does not clean-up ** on success. */ -static int hsluaO_get_from_cache(lua_State *L) +int hsluaO_get_from_cache(lua_State *L) { /* Use value in caching table if present */ - hsluaO_get_caching_table(L, 1); /* table */ + hslua_get_caching_table(L, 1); /* table */ lua_pushvalue(L, 2); /* key */ if (lua_rawget(L, 3) == LUA_TNIL) { lua_pop(L, 2); /* remove nil, caching table */ @@ -69,7 +69,7 @@ static int hsluaO_get_via_getter(lua_State *L) lua_call(L, 1, 1); /* key found in wrapped userdata, add to caching table */ - hsluaO_get_caching_table(L, 1); /* object's caching table */ + hslua_get_caching_table(L, 1); /* object's caching table */ lua_pushvalue(L, 2); /* key */ lua_pushvalue(L, -3); /* value */ lua_rawset(L, -3); @@ -123,42 +123,6 @@ static int hsluaO_get_method(lua_State *L) return 1; } -/* -** Retrieve a numerical index from this object. The userdata must be in -** position 1, and the key in position 2. -*/ -static int hsluaO_get_numerical(lua_State *L) -{ - hsluaO_get_caching_table(L, 1); - lua_Integer requested = lua_tointeger(L, 2); - - /* The __lazylistindex is set to `nil` or an integer if part of the - list is still unevaluated. If it's `false`, then all list values are - already in the cache. */ - if (lua_getfield(L, 1, "__lazylistindex") == LUA_TBOOLEAN) { - lua_pop(L, 1); /* remove nil */ - } else { - lua_Integer last_index = lua_tointeger(L, -1); - lua_pop(L, 1); /* pop last-index value */ - - if (requested > last_index && - /* index not in cache, force lazy evaluation of list items */ - luaL_getmetafield(L, 1, "lazylisteval") == LUA_TFUNCTION) { - if (lua_getfield(L, 3, "__lazylist") != LUA_TUSERDATA) { - /* lazy list thunk is missing; that shouldn't happen!! */ - luaL_error(L, "Error while getting numerical index %d: " - "lazy list thunk is missing", requested); - } - lua_pushinteger(L, last_index); - lua_pushinteger(L, requested); - lua_pushvalue(L, 3); /* caching table */ - lua_call(L, 4, 0); /* populate cache with evaled values */ - } - } - lua_rawgeti(L, 3, requested); - return 1; -} - /* ** Retrieves a key from a Haskell-data holding userdata value. ** @@ -179,13 +143,12 @@ int hslua_udindex(lua_State *L) { lua_settop(L, 2); /* do numeric lookup for integer keys */ - return lua_isinteger(L, 2) - ? (hsluaO_get_via_alias(L) || hsluaO_get_numerical(L)) - /* try various sources in order; return 0 if nothing is found. */ - : (hsluaO_get_from_cache(L) || - hsluaO_get_via_getter(L) || - hsluaO_get_via_alias(L) || - hsluaO_get_method(L)); + /* try various sources in order; return 0 if nothing is found. */ + return + hsluaO_get_from_cache(L) || + hsluaO_get_via_getter(L) || + hsluaO_get_via_alias(L) || + hsluaO_get_method(L); } /* @@ -217,42 +180,6 @@ static int hsluaO_set_via_alias(lua_State *L) return 1; } -/* -** Sets a numerical index on this object. The userdata must be in -** position 1, the key in position 2, and the new value in position 3. -** Returns 1 on success and 0 otherwise. -*/ -static int hsluaO_set_numerical(lua_State *L) -{ - hsluaO_get_caching_table(L, 1); - lua_Integer target = lua_tointeger(L, 2); - - /* The `__lazylistindex` field is set to `false` if each list element - has already been evaluated and stored in the cache. Otherwise it - will be either `nil` or an integer. */ - if (lua_getfield(L, 1, "__lazylistindex") == LUA_TBOOLEAN) { - lua_pop(L, 1); /* pop boolean from last-index */ - } else { - /* list is not fully evaluated yet, we may have to evaluate it - further. */ - lua_Integer last_index = lua_tointeger(L, -1); - lua_pop(L, 1); /* pop last-index value */ - - if (target > last_index) { - /* the index we want to assign has not been cached yet. Evaluation - * is forced to avoid any uncertainty about the meaning of - * `nil`-valued indices. */ - lua_pushcfunction(L, &hsluaO_get_numerical); - lua_pushvalue(L, 1); - lua_pushvalue(L, 2); - lua_call(L, 2, 0); - } - } - lua_pushvalue(L, 3); /* new value */ - lua_rawseti(L, -2, target); /* set in caching table */ - return 1; -} - /* ** Set value via a property alias. Assumes the stack to be in a state as ** after __newindex is called. Returns 1 on success, 0 if the object is @@ -287,13 +214,6 @@ static int hsluaO_set_via_setter(lua_State *L) */ int hslua_udnewindex(lua_State *L) { - if (lua_type(L, 2) == LUA_TNUMBER) { - if (hsluaO_set_via_alias(L) || hsluaO_set_numerical(L)) { - return 0; - } - lua_pushliteral(L, "Cannot set a numerical value."); - return lua_error(L); - } if (hsluaO_set_via_alias(L) || hsluaO_set_via_setter(L)) { return 0; } @@ -310,7 +230,7 @@ int hslua_udsetter(lua_State *L) { luaL_checkany(L, 3); lua_settop(L, 3); - hsluaO_get_caching_table(L, 1); + hslua_get_caching_table(L, 1); lua_insert(L, 2); lua_rawset(L, 2); return 0; diff --git a/hslua-objectorientation/cbits/hslobj.h b/hslua-objectorientation/cbits/hslobj.h new file mode 100644 index 00000000..8d5c8727 --- /dev/null +++ b/hslua-objectorientation/cbits/hslobj.h @@ -0,0 +1,22 @@ +#ifndef hslobj_h +#define hslobj_h + +#include + +/* *************************************************************** + * Helpers for fast element access + * ***************************************************************/ + +/* Object field getter */ +int hslua_udindex(lua_State *L); + +/* Object field setter */ +int hslua_udnewindex(lua_State *L); + +/* Lazy access to object's caching table */ +int hslua_get_caching_table(lua_State *L, int index); + +/* Get a value from the object's uservalue cache */ +int hsluaO_get_from_cache(lua_State *L); + +#endif diff --git a/hslua-objectorientation/cbits/hslsum.c b/hslua-objectorientation/cbits/hslsum.c new file mode 100644 index 00000000..4c325343 --- /dev/null +++ b/hslua-objectorientation/cbits/hslsum.c @@ -0,0 +1,135 @@ +#include +#include +#include +#include "hslobj.h" +#include "hslsum.h" + +/* *************************************************************** + * Abstract Data Type access + * ***************************************************************/ + +int hslua_gettag(lua_State *L, int idx) +{ + return lua_getiuservalue(L, idx, 2); +} + +int hslua_sum_get_tag(lua_State *L) +{ + if (hslua_gettag(L, 1) == LUA_TSTRING) { + return 1; + } + + lua_pop(L, 1); + return 0; +} + +static int hsluaS_get_constructor_table(lua_State *L, int obj) +{ + if (!lua_getmetatable(L, obj)) /* no metatable? */ + return LUA_TNIL; + else { + hslua_sum_get_tag(L); + int tt = lua_rawget(L, -2); + if (tt != LUA_TTABLE) { + lua_pop(L, 2); /* remove metatable and metafield */ + return LUA_TNIL; + } else { + lua_remove(L, -2); /* remove metatable */ + return tt; /* return metafield type */ + } + } +} + +int hslua_sum_field(lua_State *L, int idx, const char *field) +{ + int tt = hsluaS_get_constructor_table(L, idx); + if (tt != LUA_TTABLE) { /* No constructor table? */ + return tt; + } + + tt = lua_getfield(L, -1, field); + lua_remove(L, -2); /* remove constructor table */ + return tt; /* return constructor field type */ +} + +int hslua_sum_peekers(lua_State *L, int idx) +{ + return hslua_sum_field(L, idx, "peekers"); +} + +static int hsluaS_get_constructor_field(lua_State *L) +{ + luaL_checkstack(L, 5, "hsluaS_get_constructor_field"); + + if (hsluaS_get_constructor_table(L, 1) == LUA_TNIL) { + return 0; /* fail if object has no string tag */ + } + + /* get getter function */ + lua_getfield(L, -1, "getters"); + lua_pushvalue(L, 2); + if (lua_rawget(L, -2) != LUA_TFUNCTION) { + return 0; + } + + /* Call getter. Slow, as it calls into Haskell. */ + lua_pushvalue(L, 1); + lua_call(L, 1, 1); + + /* FIXME: this was copy-pasted, dry it up! */ + /* key found in wrapped userdata, add to caching table */ + hslua_get_caching_table(L, 1); /* object's caching table */ + lua_pushvalue(L, 2); /* key */ + lua_pushvalue(L, -3); /* value */ + lua_rawset(L, -3); + lua_pop(L, 1); /* pop caching table */ + /* return value */ + return 1; +} + +/* +** FIXME +*/ +int hslua_sum_udindex(lua_State *L) +{ + lua_settop(L, 2); + return + hsluaO_get_from_cache(L) || + hsluaS_get_constructor_field(L) || + hslua_udindex(L); +} + +int hsluaS_set_via_setter(lua_State *L) +{ + if (hsluaS_get_constructor_table(L, 1) == LUA_TNIL) { + return 0; + } + + /* get setter function */ + lua_getfield(L, -1, "setters"); + lua_pushvalue(L, 2); + if (lua_rawget(L, -2) != LUA_TFUNCTION) { + return 0; + } + + /* call setter */ + lua_insert(L, 1); + lua_pop(L, 2); /* pop constructor & setter tables */ + lua_call(L, 3, 0); + + return 1; +} + +/* +** The actual assignment is performed by a setter function stored in the +** `setter` metafield. Throws an error if no setter function can be +** found. +*/ +int hslua_sum_udnewindex(lua_State *L) +{ + if (hsluaS_set_via_setter(L) || hslua_udnewindex(L)) { + return 0; + } + + return luaL_error(L, "Cannot set property on sum-type object"); +} diff --git a/hslua-objectorientation/cbits/hslsum.h b/hslua-objectorientation/cbits/hslsum.h new file mode 100644 index 00000000..995b2086 --- /dev/null +++ b/hslua-objectorientation/cbits/hslsum.h @@ -0,0 +1,6 @@ +#ifndef hslsum_h +#define hslsum_h + +const char *hslsum_peekers_field = "peekers"; + +#endif diff --git a/hslua-objectorientation/hslua-objectorientation.cabal b/hslua-objectorientation/hslua-objectorientation.cabal index 47fbdcb4..784ea3d2 100644 --- a/hslua-objectorientation/hslua-objectorientation.cabal +++ b/hslua-objectorientation/hslua-objectorientation.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hslua-objectorientation -version: 2.3.1 +version: 2.4.0 synopsis: Object orientation tools for HsLua description: Expose Haskell objects to Lua with an object oriented interface. @@ -57,8 +57,12 @@ common common-options library import: common-options + build-depends: lua >= 2.3 && < 2.4 exposed-modules: HsLua.ObjectOrientation + , HsLua.ObjectOrientation.Generic + , HsLua.ObjectOrientation.ListType , HsLua.ObjectOrientation.Operation + , HsLua.ObjectOrientation.SumType hs-source-dirs: src build-depends: containers >= 0.5.9 && < 0.9 , text >= 1.2 && < 2.2 @@ -69,7 +73,14 @@ library , FlexibleInstances , MultiParamTypeClasses , ScopedTypeVariables + includes: hslobj.h + , hslsum.h + install-includes: hslobj.h + , hslsum.h + include-dirs: cbits c-sources: cbits/hslobj.c + , cbits/hsllist.c + , cbits/hslsum.c test-suite test-hslua-objectorientation import: common-options @@ -78,6 +89,7 @@ test-suite test-hslua-objectorientation hs-source-dirs: test ghc-options: -threaded -Wno-unused-do-bind other-modules: HsLua.ObjectOrientationTests + , HsLua.ObjectOrientation.SumTypeTests build-depends: hslua-objectorientation , bytestring >= 0.10.2 && < 0.13 , tasty >= 0.11 diff --git a/hslua-objectorientation/src/HsLua/ObjectOrientation.hs b/hslua-objectorientation/src/HsLua/ObjectOrientation.hs index af0cd901..b357b75d 100644 --- a/hslua-objectorientation/src/HsLua/ObjectOrientation.hs +++ b/hslua-objectorientation/src/HsLua/ObjectOrientation.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-| Module : HsLua.ObjectOrientation Copyright : © 2021-2024 Albert Krewinkel @@ -17,85 +16,21 @@ objects/, and to their type as /UD type/. -} module HsLua.ObjectOrientation ( UDType - , UDTypeWithList (..) - -- * Defining types , deftypeGeneric - , deftypeGeneric' - -- ** Methods - , methodGeneric - -- ** Properties - , property - , property' - , possibleProperty - , possibleProperty' - , readonly - , readonly' - -- ** Aliases - , alias - -- * Marshaling - , peekUDGeneric - , pushUDGeneric - , initTypeGeneric - -- * Type docs - , udDocs - , udTypeSpec - -- * Helper types for building - , Member - , Property (..) - , Operation (..) - , ListSpec - , Possible (..) - , Alias - , AliasIndex (..) + , module HsLua.ObjectOrientation.Generic + , module HsLua.ObjectOrientation.ListType ) where -import Control.Monad ((<$!>), forM_, void, when) -import Data.Maybe (mapMaybe) -import Data.Map (Map) -import Data.String (IsString (..)) -import Data.Text (Text) -import Data.Void (Void) -import Foreign.Ptr (FunPtr) -import HsLua.Core as Lua -import HsLua.Marshalling -import HsLua.ObjectOrientation.Operation -import HsLua.Typing ( TypeDocs (..), TypeSpec (..), anyType, userdataType ) -import qualified Data.Map.Strict as Map -import qualified HsLua.Core.Unsafe as Unsafe -import qualified HsLua.Core.Utf8 as Utf8 +import HsLua.Core (Name) +import HsLua.Marshalling (Pusher) +import HsLua.ObjectOrientation.Generic +import HsLua.ObjectOrientation.ListType -- | A userdata type, capturing the behavior of Lua objects that wrap -- Haskell values. The type name must be unique; once the type has been -- used to push or retrieve a value, the behavior can no longer be -- modified through this type. --- --- This type includes methods to define how the object should behave as --- a read-only list of type @itemtype@. -data UDTypeWithList e fn a itemtype = UDTypeWithList - { udName :: Name - , udOperations :: [(Operation, fn)] - , udProperties :: Map Name (Property e a) - , udMethods :: Map Name fn - , udAliases :: Map AliasIndex Alias - , udListSpec :: Maybe (ListSpec e a itemtype) - , udFnPusher :: fn -> LuaE e () - } - --- | Pair of pairs, describing how a type can be used as a Lua list. The --- first pair describes how to push the list items, and how the list is --- extracted from the type; the second pair contains a method to --- retrieve list items, and defines how the list is used to create an --- updated value. -type ListSpec e a itemtype = - ( (Pusher e itemtype, a -> [itemtype]) - , (Peeker e itemtype, a -> [itemtype] -> a) - ) - --- | A userdata type, capturing the behavior of Lua objects that wrap --- Haskell values. The type name must be unique; once the type has been --- used to push or retrieve a value, the behavior can no longer be --- modified through this type. -type UDType e fn a = UDTypeWithList e fn a Void +type UDType e fn a = UDTypeGeneric e fn a () -- | Defines a new type, defining the behavior of objects in Lua. -- Note that the type name must be unique. @@ -105,462 +40,4 @@ deftypeGeneric :: Pusher e fn -- ^ function pusher -> [Member e fn a] -- ^ methods -> UDType e fn a deftypeGeneric pushFunction name ops members = - deftypeGeneric' pushFunction name ops members Nothing - --- | Defines a new type that could also be treated as a list; defines --- the behavior of objects in Lua. Note that the type name must be --- unique. -deftypeGeneric' :: Pusher e fn -- ^ function pusher - -> Name -- ^ type name - -> [(Operation, fn)] -- ^ operations - -> [Member e fn a] -- ^ methods - -> Maybe (ListSpec e a itemtype) -- ^ list access - -> UDTypeWithList e fn a itemtype -deftypeGeneric' pushFunction name ops members mbListSpec = UDTypeWithList - { udName = name - , udOperations = ops - , udProperties = Map.fromList $ mapMaybe mbproperties members - , udMethods = Map.fromList $ mapMaybe mbmethods members - , udAliases = Map.fromList $ mapMaybe mbaliases members - , udListSpec = mbListSpec - , udFnPusher = pushFunction - } - where - mbproperties = \case - MemberProperty n p -> Just (n, p) - _ -> Nothing - mbmethods = \case - MemberMethod n m -> Just (n, m) - _ -> Nothing - mbaliases = \case - MemberAlias n a -> Just (n, a) - _ -> Nothing - --- | A read- and writable property on a UD object. -data Property e a = Property - { propertyGet :: a -> LuaE e NumResults - , propertySet :: Maybe (StackIndex -> a -> LuaE e a) - , propertyDescription :: Text - , propertyType :: TypeSpec - } - --- | Alias for a different property of this or of a nested object. -type Alias = [AliasIndex] - --- | Index types allowed in aliases (strings and integers) -data AliasIndex - = StringIndex Name - | IntegerIndex Lua.Integer - deriving (Eq, Ord) - -instance IsString AliasIndex where - fromString = StringIndex . fromString - --- | A type member, either a method or a variable. -data Member e fn a - = MemberProperty Name (Property e a) - | MemberMethod Name fn - | MemberAlias AliasIndex Alias - --- | Use a documented function as an object method. -methodGeneric :: Name -> fn -> Member e fn a -methodGeneric = MemberMethod - --- | A property or method which may be available in some instances but --- not in others. -data Possible a - = Actual a - | Absent - --- | Declares a new read- and writable typed property. -property' :: LuaError e - => Name -- ^ property name - -> TypeSpec -- ^ property type - -> Text -- ^ property description - -> (Pusher e b, a -> b) -- ^ how to get the property value - -> (Peeker e b, a -> b -> a) -- ^ how to set a new property value - -> Member e fn a -property' name typespec desc (push, get) (peek, set) = - possibleProperty' name typespec desc - (push, Actual . get) - (peek, \a b -> Actual (set a b)) - --- | Declares a new read- and writable property. -property :: LuaError e - => Name -- ^ property name - -> Text -- ^ property description - -> (Pusher e b, a -> b) -- ^ how to get the property value - -> (Peeker e b, a -> b -> a) -- ^ how to set a new property value - -> Member e fn a -property name desc (push, get) (peek, set) = - possibleProperty name desc - (push, Actual . get) - (peek, \a b -> Actual (set a b)) - --- | Declares a new read- and writable property which is not always --- available. -possibleProperty :: LuaError e - => Name -- ^ property name - -> Text -- ^ property description - -> (Pusher e b, a -> Possible b) -- ^ how to get the property value - -> (Peeker e b, a -> b -> Possible a) -- ^ how to set a new property value - -> Member e fn a -possibleProperty name = possibleProperty' name anyType - --- | Declares a new read- and writable property which is not always --- available. -possibleProperty' :: LuaError e - => Name -- ^ property name - -> TypeSpec -- ^ type of the property value - -> Text -- ^ property description - -> (Pusher e b, a -> Possible b) -- ^ how to get the property value - -> (Peeker e b, a -> b -> Possible a) -- ^ how to set a new property value - -> Member e fn a -possibleProperty' name typespec desc (push, get) (peek, set) = - MemberProperty name $ - Property - { propertyGet = \x -> do - case get x of - Actual y -> NumResults 1 <$ push y - Absent -> return (NumResults 0) - , propertySet = Just $ \idx x -> do - value <- forcePeek $ peek idx - case set x value of - Actual y -> return y - Absent -> failLua $ "Trying to set unavailable property " - <> Utf8.toString (fromName name) - <> "." - , propertyType = typespec - , propertyDescription = desc - } - --- | Creates a read-only object property. Attempts to set the value will --- cause an error. -readonly' :: Name -- ^ property name - -> TypeSpec -- ^ property type - -> Text -- ^ property description - -> (Pusher e b, a -> b) -- ^ how to get the property value - -> Member e fn a -readonly' name typespec desc (push, get) = MemberProperty name $ - Property - { propertyGet = \x -> do - push $ get x - return (NumResults 1) - , propertySet = Nothing - , propertyType = typespec - , propertyDescription = desc - } - --- | Creates a read-only object property. Attempts to set the value will --- cause an error. -readonly :: Name -- ^ property name - -> Text -- ^ property description - -> (Pusher e b, a -> b) -- ^ how to get the property value - -> Member e fn a -readonly name = readonly' name anyType - --- | Define an alias for another, possibly nested, property. -alias :: AliasIndex -- ^ property alias - -> Text -- ^ description - -> [AliasIndex] -- ^ sequence of nested properties - -> Member e fn a -alias name _desc = MemberAlias name - --- | Ensures that the type has been fully initialized, i.e., that all --- metatables have been created and stored in the registry. Returns the --- name of the initialized type. --- --- The @hook@ can be used to perform additional setup operations. The --- function is called as the last step after the type metatable has been --- initialized: the fully initialized metatable will be at the top of --- the stack at that point. Note that the hook will /not/ be called if --- the type's metatable already existed before this function was --- invoked. -initTypeGeneric :: LuaError e - => (UDTypeWithList e fn a itemtype -> LuaE e ()) - -> UDTypeWithList e fn a itemtype - -> LuaE e Name -initTypeGeneric hook ty = do - pushUDMetatable hook ty - pop 1 - return (udName ty) - --- | Pushes the metatable for the given type to the Lua stack. Creates --- the new table afresh on the first time it is needed, and retrieves it --- from the registry after that. --- --- --- A @hook@ can be used to perform additional setup operations. The --- function is called as the last step after the type metatable has been --- initialized: the fully initialized metatable will be at the top of --- the stack at that point. Note that the hook will /not/ be called if --- the type's metatable already existed before this function was --- invoked. -pushUDMetatable :: LuaError e - => (UDTypeWithList e fn a itemtype -> LuaE e ()) -- ^ @hook@ - -> UDTypeWithList e fn a itemtype - -> LuaE e () -pushUDMetatable hook ty = do - created <- newudmetatable (udName ty) - when created $ do - add (metamethodName Index) $ pushcfunction hslua_udindex_ptr - add (metamethodName Newindex) $ pushcfunction hslua_udnewindex_ptr - add (metamethodName Pairs) $ pushHaskellFunction (pairsFunction ty) - forM_ (udOperations ty) $ \(op, f) -> do - add (metamethodName op) $ udFnPusher ty f - add "getters" $ pushGetters ty - add "setters" $ pushSetters ty - add "methods" $ pushMethods ty - add "aliases" $ pushAliases ty - case udListSpec ty of - Nothing -> pure () - Just ((pushItem, _), _) -> do - add "lazylisteval" $ pushHaskellFunction (lazylisteval pushItem) - hook ty - where - add :: LuaError e => Name -> LuaE e () -> LuaE e () - add name op = do - pushName name - op - rawset (nth 3) - --- | Retrieves a key from a Haskell-data holding userdata value. --- --- Does the following, in order, and returns the first non-nil result: --- --- - Checks the userdata's uservalue table for the given key; --- --- - Looks up a @getter@ for the key and calls it with the userdata --- and key as arguments; --- --- - Looks up the key in the table in the @methods@ metafield. -foreign import ccall "hslobj.c &hslua_udindex" - hslua_udindex_ptr :: FunPtr (State -> IO NumResults) - --- | Sets a new value in the userdata caching table via a setter --- functions. --- --- The actual assignment is performed by a setter function stored in the --- @setter@ metafield. Throws an error if no setter function can be --- found. -foreign import ccall "hslobj.c &hslua_udnewindex" - hslua_udnewindex_ptr :: FunPtr (State -> IO NumResults) - --- | Sets a value in the userdata's caching table (uservalue). Takes the --- same arguments as a @__newindex@ function. -foreign import ccall "hslobj.c &hslua_udsetter" - hslua_udsetter_ptr :: FunPtr (State -> IO NumResults) - --- | Throws an error nothing that the given key is read-only. -foreign import ccall "hslobj.c &hslua_udreadonly" - hslua_udreadonly_ptr :: FunPtr (State -> IO NumResults) - --- | Pushes the metatable's @getters@ field table. -pushGetters :: LuaError e => UDTypeWithList e fn a itemtype -> LuaE e () -pushGetters ty = do - newtable - void $ flip Map.traverseWithKey (udProperties ty) $ \name prop -> do - pushName name - pushHaskellFunction $ forcePeek (peekUDGeneric ty 1) >>= propertyGet prop - rawset (nth 3) - --- | Pushes the metatable's @setters@ field table. -pushSetters :: LuaError e => UDTypeWithList e fn a itemtype -> LuaE e () -pushSetters ty = do - newtable - void $ flip Map.traverseWithKey (udProperties ty) $ \name prop -> do - pushName name - pushcfunction $ case propertySet prop of - Just _ -> hslua_udsetter_ptr - Nothing -> hslua_udreadonly_ptr - rawset (nth 3) - --- | Pushes the metatable's @methods@ field table. -pushMethods :: LuaError e => UDTypeWithList e fn a itemtype -> LuaE e () -pushMethods ty = do - newtable - void $ flip Map.traverseWithKey (udMethods ty) $ \name fn -> do - pushName name - udFnPusher ty fn - rawset (nth 3) - -pushAliases :: LuaError e => UDTypeWithList e fn a itemtype -> LuaE e () -pushAliases ty = do - newtable - void $ flip Map.traverseWithKey (udAliases ty) $ \name propSeq -> do - pushAliasIndex name - pushList pushAliasIndex propSeq - rawset (nth 3) - -pushAliasIndex :: Pusher e AliasIndex -pushAliasIndex = \case - StringIndex name -> pushName name - IntegerIndex n -> pushIntegral n - --- | Pushes the function used to iterate over the object's key-value --- pairs in a generic *for* loop. -pairsFunction :: forall e fn a itemtype. LuaError e - => UDTypeWithList e fn a itemtype -> LuaE e NumResults -pairsFunction ty = do - obj <- forcePeek $ peekUDGeneric ty (nthBottom 1) - let pushMember = \case - MemberProperty name prop -> do - pushName name - getresults <- propertyGet prop obj - if getresults == 0 - then 0 <$ pop 1 -- property is absent, don't push anything - else return $ getresults + 1 - MemberMethod name f -> do - pushName name - udFnPusher ty f - return 2 - MemberAlias{} -> fail "aliases are not full properties" - pushIterator pushMember $ - map (uncurry MemberProperty) (Map.toAscList (udProperties ty)) ++ - map (uncurry MemberMethod) (Map.toAscList (udMethods ty)) - --- | Evaluate part of a lazy list. Takes the following arguments, in --- this order: --- --- 1. userdata wrapping the unevalled part of the lazy list --- 2. index of the last evaluated element --- 3. index of the requested element --- 4. the caching table -lazylisteval :: forall itemtype e. LuaError e - => Pusher e itemtype -> LuaE e NumResults -lazylisteval pushItem = do - munevaled <- fromuserdata @[itemtype] (nthBottom 1) lazyListStateName - mcurindex <- tointeger (nthBottom 2) - mnewindex <- tointeger (nthBottom 3) - case (munevaled, mcurindex, mnewindex) of - (Just unevaled, Just curindex, Just newindex) -> do - let numElems = fromIntegral $ max (newindex - curindex) 0 - (as, rest) = splitAt numElems unevaled - if null rest - then do - -- no more elements in list; unset variable - pushName "__lazylistindex" - pushBool False - rawset (nthBottom 4) - else do - -- put back remaining unevalled list - void $ putuserdata @[itemtype] (nthBottom 1) lazyListStateName rest - pushName "__lazylistindex" - pushinteger (curindex + fromIntegral (length as)) - rawset (nthBottom 4) - -- push evaluated elements - forM_ (zip [(curindex + 1)..] as) $ \(i, a) -> do - pushItem a - rawseti (nthBottom 4) i - return (NumResults 0) - _ -> pure (NumResults 0) - --- | Name of the metatable used for unevaluated lazy list rema -lazyListStateName :: Name -lazyListStateName = "HsLua unevalled lazy list" - --- | Pushes a userdata value of the given type. -pushUDGeneric :: LuaError e - => (UDTypeWithList e fn a itemtype -> LuaE e ()) -- ^ push docs - -> UDTypeWithList e fn a itemtype -- ^ userdata type - -> a -- ^ value to push - -> LuaE e () -pushUDGeneric pushDocs ty x = do - newhsuserdatauv x 1 - pushUDMetatable pushDocs ty - setmetatable (nth 2) - -- add list as value in caching table - case udListSpec ty of - Nothing -> pure () - Just ((_, toList), _) -> do - newtable - pushName "__lazylist" - newhsuserdatauv (toList x) 1 - void (newudmetatable lazyListStateName) - setmetatable (nth 2) - rawset (nth 3) - void (setiuservalue (nth 2) 1) - --- | Retrieves a userdata value of the given type. -peekUDGeneric :: LuaError e => UDTypeWithList e fn a itemtype -> Peeker e a -peekUDGeneric ty idx = do - let name = udName ty - x <- reportValueOnFailure name (`fromuserdata` name) idx - (`lastly` pop 1) $ liftLua (getiuservalue idx 1) >>= \case - TypeTable -> do - -- set list - xWithList <- maybe pure setList (udListSpec ty) x - liftLua $ do - pushnil - setProperties (udProperties ty) xWithList - _ -> return x - --- | Retrieves object properties from a uservalue table and sets them on --- the given value. Expects the uservalue table at the top of the stack. -setProperties :: LuaError e => Map Name (Property e a) -> a -> LuaE e a -setProperties props x = do - hasNext <- Unsafe.next (nth 2) - if not hasNext - then return x - else ltype (nth 2) >>= \case - TypeString -> do - propName <- forcePeek $ peekName (nth 2) - case Map.lookup propName props >>= propertySet of - Nothing -> pop 1 *> setProperties props x - Just setter -> do - x' <- setter top x - pop 1 - setProperties props x' - _ -> x <$ pop 1 - --- | Gets a list from a uservalue table and sets it on the given value. --- Expects the uservalue (i.e., caching) table to be at the top of the --- stack. -setList :: forall itemtype e a. LuaError e - => ListSpec e a itemtype -> a - -> Peek e a -setList (_pushspec, (peekItem, updateList)) x = (x `updateList`) <$!> do - liftLua (getfield top "__lazylistindex") >>= \case - TypeBoolean -> do - -- list had been fully evaluated - liftLua $ pop 1 - peekList peekItem top - _ -> do - let getLazyList = do - liftLua (getfield top "__lazylist") >>= \case - TypeUserdata -> pure () - _ -> failPeek "unevaled items of lazy list cannot be peeked" - (`lastly` pop 1) $ reportValueOnFailure - lazyListStateName - (\idx -> fromuserdata @[itemtype] idx lazyListStateName) - top - mlastIndex <- liftLua (tointeger top <* pop 1) - let itemsAfter = case mlastIndex of - Nothing -> const getLazyList - Just lastIndex -> \i -> - if i <= lastIndex - then liftLua (rawgeti top i) >>= \case - TypeNil -> [] <$ liftLua (pop 1) - _ -> do - y <- peekItem top `lastly` pop 1 - (y:) <$!> itemsAfter (i + 1) - else getLazyList - itemsAfter 1 - --- --- Typing --- - --- | Returns documentation for this type. -udDocs :: UDTypeWithList e fn a itemtype - -> TypeDocs -udDocs ty = TypeDocs - { typeDescription = mempty - , typeSpec = userdataType - , typeRegistry = Just (udName ty) - } - --- | Type specifier for a UDType -udTypeSpec :: UDTypeWithList e fn a itemtype - -> TypeSpec -udTypeSpec = NamedType . udName + deftypeGeneric' pushFunction name ops members () diff --git a/hslua-objectorientation/src/HsLua/ObjectOrientation/Generic.hs b/hslua-objectorientation/src/HsLua/ObjectOrientation/Generic.hs new file mode 100644 index 00000000..cad77c54 --- /dev/null +++ b/hslua-objectorientation/src/HsLua/ObjectOrientation/Generic.hs @@ -0,0 +1,526 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-| +Module : HsLua.ObjectOrientation.Generic +Copyright : © 2021-2024 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel + +This module provides types and functions to use Haskell values as +userdata objects in Lua. These objects wrap a Haskell value and provide +methods and properties to interact with the Haskell value. + +The terminology in this module refers to the userdata values as /UD +objects/, and to their type as /UD type/. +-} +module HsLua.ObjectOrientation.Generic + ( UDTypeGeneric (..) + , UDTypeExtension (..) + -- * Defining types + , deftypeGeneric' + -- ** Methods + , methodGeneric + -- ** Properties + , property + , property' + , possibleProperty + , possibleProperty' + , readonly + , readonly' + -- ** Aliases + , alias + -- * Marshaling + , peekUDGeneric + , pushUDGeneric + , initTypeGeneric + -- * Type docs + , udDocs + , udTypeSpec + -- * Helper types for building + , Member + , Property (..) + , Operation (..) + , Possible (..) + , Alias + , AliasIndex (..) + -- * Extension helpers + , setProperties + ) where + +import Control.Monad (forM_, void, when) +import Data.Maybe (mapMaybe) +import Data.Map (Map) +import Data.String (IsString (..)) +import Data.Text (Text) +import Foreign.Ptr (FunPtr, castPtr, nullPtr) +import Foreign.StablePtr (deRefStablePtr) +import HsLua.Core as Lua +import HsLua.Marshalling +import HsLua.ObjectOrientation.Operation +import HsLua.Typing ( TypeDocs (..), TypeSpec (..), anyType, userdataType ) +import qualified Data.Map.Strict as Map +import qualified Foreign.Storable as F +import qualified HsLua.Core.Unsafe as Unsafe +import qualified HsLua.Core.Utf8 as Utf8 + +-- | A userdata type, capturing the behavior of Lua objects that wrap +-- Haskell values. The type name must be unique; once the type has been +-- used to push or retrieve a value, the behavior can no longer be +-- modified through this type. +-- +-- This type includes methods to define how the object should behave as +-- a read-only list of type @itemtype@. +data UDTypeGeneric e fn a extension = UDType + { udName :: !Name + , udOperations :: ![(Operation, fn)] + , udProperties :: !(Map Name (Property e a)) + , udMethods :: !(Map Name fn) + , udAliases :: !(Map AliasIndex Alias) + , udExtension :: !extension + , udFnPusher :: !(fn -> LuaE e ()) + } + +-- | Typeclass for data userdata object extensions. +class LuaError e => UDTypeExtension e a extension where + -- | Number of uservalues required for this extension, *including* the + -- uservalue for the default caching table. + extensionUservalues :: UDTypeGeneric e fn a extension -> Int + + -- | Setup a the metatable. + extensionMetatableSetup :: UDTypeGeneric e fn a extension -> LuaE e () + + -- | Peek extra data + extensionPeekUD :: UDTypeGeneric e fn a extension + -> a + -> StackIndex + -> Peek e a + + -- | Push extra data + extensionPushUD :: UDTypeGeneric e fn a extension -> a -> LuaE e () + +-- | Basic instance. +instance LuaError e => UDTypeExtension e a () where + extensionMetatableSetup _ty = return () + {-# INLINEABLE extensionMetatableSetup #-} + + extensionPeekUD _ty x _idx = return x + {-# INLINEABLE extensionPeekUD #-} + + extensionPushUD _ty _x = return () + {-# INLINEABLE extensionPushUD #-} + + extensionUservalues _ty = 1 + +-- | Defines a new "Lua type" and sets the behavior of the Lua object +-- instances. This function is double-generic, in that it allows to add +-- extensions to the default object behavior, while also allowing to +-- customize the way in which Haskell functions are marshaled to Lua. +-- +-- Note that the type name must be unique. +deftypeGeneric' :: Pusher e fn -- ^ function pusher + -> Name -- ^ type name + -> [(Operation, fn)] -- ^ operations + -> [Member e fn a] -- ^ methods + -> extension -- ^ list access + -> UDTypeGeneric e fn a extension +deftypeGeneric' pushFunction name ops members extension = UDType + { udName = name + , udOperations = ops + , udProperties = Map.fromList $ mapMaybe mbproperties members + , udMethods = Map.fromList $ mapMaybe mbmethods members + , udAliases = Map.fromList $ mapMaybe mbaliases members + , udExtension = extension + , udFnPusher = pushFunction + } + where + mbproperties = \case + MemberProperty n p -> Just (n, p) + _ -> Nothing + mbmethods = \case + MemberMethod n m -> Just (n, m) + _ -> Nothing + mbaliases = \case + MemberAlias n a -> Just (n, a) + _ -> Nothing + +-- | A read- and writable property on a UD object. +data Property e a = Property + { propertyGet :: a -> LuaE e NumResults + , propertySet :: Maybe (StackIndex -> a -> LuaE e a) + , propertyDescription :: Text + , propertyType :: TypeSpec + } + +-- | Alias for a different property of this or of a nested object. +type Alias = [AliasIndex] + +-- | Index types allowed in aliases (strings and integers) +data AliasIndex + = StringIndex Name + | IntegerIndex Lua.Integer + deriving (Eq, Ord) + +instance IsString AliasIndex where + fromString = StringIndex . fromString + +-- | A type member, either a method or a variable. +data Member e fn a + = MemberProperty Name (Property e a) + | MemberMethod Name fn + | MemberAlias AliasIndex Alias + +-- | Use a documented function as an object method. +methodGeneric :: Name -> fn -> Member e fn a +methodGeneric = MemberMethod + +-- | A property or method which may be available in some instances but +-- not in others. +data Possible a + = Actual a + | Absent + +-- | Declares a new read- and writable typed property. +property' :: LuaError e + => Name -- ^ property name + -> TypeSpec -- ^ property type + -> Text -- ^ property description + -> (Pusher e b, a -> b) -- ^ how to get the property value + -> (Peeker e b, a -> b -> a) -- ^ how to set a new property value + -> Member e fn a +property' name typespec desc (push, get) (peek, set) = + possibleProperty' name typespec desc + (push, Actual . get) + (peek, \a b -> Actual (set a b)) + +-- | Declares a new read- and writable property. +property :: LuaError e + => Name -- ^ property name + -> Text -- ^ property description + -> (Pusher e b, a -> b) -- ^ how to get the property value + -> (Peeker e b, a -> b -> a) -- ^ how to set a new property value + -> Member e fn a +property name desc (push, get) (peek, set) = + possibleProperty name desc + (push, Actual . get) + (peek, \a b -> Actual (set a b)) + +-- | Declares a new read- and writable property which is not always +-- available. +possibleProperty :: LuaError e + => Name -- ^ property name + -> Text -- ^ property description + -> (Pusher e b, a -> Possible b) -- ^ how to get the property value + -> (Peeker e b, a -> b -> Possible a) -- ^ how to set a new property value + -> Member e fn a +possibleProperty name = possibleProperty' name anyType + +-- | Declares a new read- and writable property which is not always +-- available. +possibleProperty' :: LuaError e + => Name -- ^ property name + -> TypeSpec -- ^ type of the property value + -> Text -- ^ property description + -> (Pusher e b, a -> Possible b) -- ^ how to get the property value + -> (Peeker e b, a -> b -> Possible a) -- ^ how to set a new property value + -> Member e fn a +possibleProperty' name typespec desc (push, get) (peek, set) = + MemberProperty name $ + Property + { propertyGet = \x -> do + case get x of + Actual y -> NumResults 1 <$ push y + Absent -> return (NumResults 0) + , propertySet = Just $ \idx x -> do + value <- forcePeek $ peek idx + case set x value of + Actual y -> return y + Absent -> failLua $ "Trying to set unavailable property " + <> Utf8.toString (fromName name) + <> "." + , propertyType = typespec + , propertyDescription = desc + } + +-- | Creates a read-only object property. Attempts to set the value will +-- cause an error. +readonly' :: Name -- ^ property name + -> TypeSpec -- ^ property type + -> Text -- ^ property description + -> (Pusher e b, a -> b) -- ^ how to get the property value + -> Member e fn a +readonly' name typespec desc (push, get) = MemberProperty name $ + Property + { propertyGet = \x -> do + push $ get x + return (NumResults 1) + , propertySet = Nothing + , propertyType = typespec + , propertyDescription = desc + } + +-- | Creates a read-only object property. Attempts to set the value will +-- cause an error. +readonly :: Name -- ^ property name + -> Text -- ^ property description + -> (Pusher e b, a -> b) -- ^ how to get the property value + -> Member e fn a +readonly name = readonly' name anyType + +-- | Define an alias for another, possibly nested, property. +alias :: AliasIndex -- ^ property alias + -> Text -- ^ description + -> [AliasIndex] -- ^ sequence of nested properties + -> Member e fn a +alias name _desc = MemberAlias name + +-- | Ensures that the type has been fully initialized, i.e., that all +-- metatables have been created and stored in the registry. Returns the +-- name of the initialized type. +-- +-- The @hook@ can be used to perform additional setup operations. The +-- function is called as the last step after the type metatable has been +-- initialized: the fully initialized metatable will be at the top of +-- the stack at that point. Note that the hook will /not/ be called if +-- the type's metatable already existed before this function was +-- invoked. +initTypeGeneric :: (UDTypeExtension e a extension) + => (UDTypeGeneric e fn a extension -> LuaE e ()) + -> UDTypeGeneric e fn a extension + -> LuaE e Name +initTypeGeneric hook ty = do + pushUDMetatable hook ty + pop 1 + return (udName ty) + +-- | Pushes the metatable for the given type to the Lua stack. Creates +-- the new table afresh on the first time it is needed, and retrieves it +-- from the registry after that. +-- +-- +-- A @hook@ can be used to perform additional setup operations. The +-- function is called as the last step after the type metatable has been +-- initialized: the fully initialized metatable will be at the top of +-- the stack at that point. Note that the hook will /not/ be called if +-- the type's metatable already existed before this function was +-- invoked. +pushUDMetatable :: forall e ext fn a. (UDTypeExtension e a ext) + => (UDTypeGeneric e fn a ext -> LuaE e ()) -- ^ @hook@ + -> UDTypeGeneric e fn a ext + -> LuaE e () +pushUDMetatable hook ty = do + created <- newudmetatable (udName ty) + when created $ do + add (metamethodName Index) $ pushcfunction hslua_udindex_ptr + add (metamethodName Newindex) $ pushcfunction hslua_udnewindex_ptr + add (metamethodName Pairs) $ pushHaskellFunction (pairsFunction ty) + forM_ (udOperations ty) $ \(op, f) -> do + add (metamethodName op) $ udFnPusher ty f + add "getters" $ pushGetters ty + add "setters" $ pushSetters ty + add "methods" $ pushMethods ty + add "peekers" $ pushPeekers ty + add "aliases" $ pushAliases ty + extensionMetatableSetup ty + hook ty + where + add :: Name -> LuaE e () -> LuaE e () + add name op = do + pushName name + op + rawset (nth 3) + +-- | Retrieves a key from a Haskell-data holding userdata value. +-- +-- Does the following, in order, and returns the first non-nil result: +-- +-- - Checks the userdata's uservalue table for the given key; +-- +-- - Looks up a @getter@ for the key and calls it with the userdata +-- and key as arguments; +-- +-- - Looks up the key in the table in the @methods@ metafield. +foreign import ccall "hslobj.c &hslua_udindex" + hslua_udindex_ptr :: FunPtr (State -> IO NumResults) + +-- | Sets a new value in the userdata caching table via a setter +-- functions. +-- +-- The actual assignment is performed by a setter function stored in the +-- @setter@ metafield. Throws an error if no setter function can be +-- found. +foreign import ccall "hslobj.c &hslua_udnewindex" + hslua_udnewindex_ptr :: FunPtr (State -> IO NumResults) + +-- | Sets a value in the userdata's caching table (uservalue). Takes the +-- same arguments as a @__newindex@ function. +foreign import ccall "hslobj.c &hslua_udsetter" + hslua_udsetter_ptr :: FunPtr (State -> IO NumResults) + +-- | Throws an error nothing that the given key is read-only. +foreign import ccall "hslobj.c &hslua_udreadonly" + hslua_udreadonly_ptr :: FunPtr (State -> IO NumResults) + +-- | Pushes the metatable's @getters@ field table. +pushGetters + :: (UDTypeExtension e a extension) + => UDTypeGeneric e fn a extension -> LuaE e () +pushGetters ty = do + newtable + void $ flip Map.traverseWithKey (udProperties ty) $ \name prop -> do + pushName name + pushHaskellFunction $ forcePeek (peekUDGeneric ty 1) >>= propertyGet prop + rawset (nth 3) + +-- | Pushes the metatable's @setters@ field table. +pushSetters :: LuaError e => UDTypeGeneric e fn a extension -> LuaE e () +pushSetters ty = do + newtable + void $ flip Map.traverseWithKey (udProperties ty) $ \name prop -> do + pushName name + pushcfunction $ case propertySet prop of + Just _ -> hslua_udsetter_ptr + Nothing -> hslua_udreadonly_ptr + rawset (nth 3) + +pushPeekers :: LuaError e => UDTypeGeneric e fn a extension -> LuaE e () +pushPeekers ty = do + newtable + void $ flip Map.traverseWithKey (udProperties ty) $ \name prop -> do + case propertySet prop of + Just p -> do + pushName name + newhsuserdatauv p 0 + -- newudmetatable "HsLuaOOPeeker" + -- setmetatable (nth 2) + rawset (nth 3) + Nothing -> pure () + +-- | Pushes the metatable's @methods@ field table. +pushMethods :: LuaError e => UDTypeGeneric e fn a extension -> LuaE e () +pushMethods ty = do + newtable + void $ flip Map.traverseWithKey (udMethods ty) $ \name fn -> do + pushName name + udFnPusher ty fn + rawset (nth 3) + +pushAliases :: LuaError e => UDTypeGeneric e fn a itemtype -> LuaE e () +pushAliases ty = do + newtable + void $ flip Map.traverseWithKey (udAliases ty) $ \name propSeq -> do + pushAliasIndex name + pushList pushAliasIndex propSeq + rawset (nth 3) + +pushAliasIndex :: Pusher e AliasIndex +pushAliasIndex = \case + StringIndex name -> pushName name + IntegerIndex n -> pushIntegral n + +-- | Pushes the function used to iterate over the object's key-value +-- pairs in a generic *for* loop. +pairsFunction + :: forall err extension fn a. (UDTypeExtension err a extension) + => UDTypeGeneric err fn a extension -> LuaE err NumResults +pairsFunction ty = do + obj <- forcePeek $ peekUDGeneric ty (nthBottom 1) + let pushMember = \case + MemberProperty name prop -> do + pushName name + getresults <- propertyGet prop obj + if getresults == 0 + then 0 <$ pop 1 -- property is absent, don't push anything + else return $ getresults + 1 + MemberMethod name f -> do + pushName name + udFnPusher ty f + return 2 + MemberAlias{} -> fail "aliases are not full properties" + pushIterator pushMember $ + map (uncurry MemberProperty) (Map.toAscList (udProperties ty)) ++ + map (uncurry MemberMethod) (Map.toAscList (udMethods ty)) + +-- | Pushes a userdata value of the given type. +pushUDGeneric + :: forall e extension fn a. (UDTypeExtension e a extension) + => (UDTypeGeneric e fn a extension -> LuaE e ()) -- ^ push docs + -> UDTypeGeneric e fn a extension -- ^ userdata type + -> a -- ^ value to push + -> LuaE e () +pushUDGeneric pushDocs ty x = do + newhsuserdatauv x (extensionUservalues ty) + pushUDMetatable pushDocs ty + setmetatable (nth 2) + extensionPushUD ty x + +{-# SPECIALIZE pushUDGeneric :: (LuaError e) + => (UDTypeGeneric e fn a () -> LuaE e ()) + -> UDTypeGeneric e fn a () + -> a + -> LuaE e () #-} + +-- | Retrieves a userdata value of the given type. +peekUDGeneric :: forall e extension fn a. (UDTypeExtension e a extension) + => UDTypeGeneric e fn a extension -> Peeker e a +peekUDGeneric ty idx = do + let name = udName ty + absidx <- liftLua (absindex idx) + old <- reportValueOnFailure name (`fromuserdata` name) absidx + -- get caching table and update the Haskell value + updated <- liftLua (getmetafield absidx "peekers") >>= \case + TypeTable -> do + -- pop caching table and peekers table when done + liftLua (getiuservalue absidx 1) >>= (`lastly` pop 2) . \case + TypeTable -> liftLua $ do + pushnil + setProperties old + _other -> pure old + otherType -> liftLua $ do + pop 1 + failLua $ show otherType + extensionPeekUD ty updated absidx + +-- | Retrieves object properties from a uservalue table and sets them on the +-- given value. Expects the uservalue table at the top of the stack, and the +-- @peekers@ table below that. +setProperties :: LuaError e => a -> LuaE e a +setProperties x = do + hasNext <- Unsafe.next (nth 2) + let continue = pop 1 *> setProperties x + if not hasNext + then return x + else ltype (nth 2) >>= \case + TypeString -> do + pushvalue (nth 2) -- property name + -- get property setter from peeker table + rawget (nth 5) >>= \case + TypeUserdata -> (touserdata top <* pop 1) >>= \case + Just udPtr | udPtr /= nullPtr -> do + setter <- liftIO $ F.peek (castPtr udPtr) >>= deRefStablePtr + x' <- setter top x + pop 1 + setProperties x' + _notASetter -> continue + _lty -> pop 1 *> continue + _keyLuaType -> continue + +-- +-- Typing +-- + +-- | Returns documentation for this type. +udDocs :: UDTypeGeneric e fn a itemtype + -> TypeDocs +udDocs ty = TypeDocs + { typeDescription = mempty + , typeSpec = userdataType + , typeRegistry = Just (udName ty) + } + +-- | Type specifier for a UDType +udTypeSpec :: UDTypeGeneric e fn a itemtype + -> TypeSpec +udTypeSpec = NamedType . udName diff --git a/hslua-objectorientation/src/HsLua/ObjectOrientation/ListType.hs b/hslua-objectorientation/src/HsLua/ObjectOrientation/ListType.hs new file mode 100644 index 00000000..0cb4d542 --- /dev/null +++ b/hslua-objectorientation/src/HsLua/ObjectOrientation/ListType.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module HsLua.ObjectOrientation.ListType + ( UDTypeWithList + , ListSpec (..) + ) where + +import Control.Monad ((<$!>), forM_, void) +import Foreign.Ptr (FunPtr) +import HsLua.Core as Lua +import HsLua.Marshalling +import HsLua.ObjectOrientation.Generic +import HsLua.ObjectOrientation.Operation (metamethodName) + +-- | Userdata type that (also) behaves like a list. +type UDTypeWithList e fn a itemtype = + UDTypeGeneric e fn a (ListSpec e a itemtype) + +-- | Pair of pairs, describing how a type can be used as a Lua list. The +-- first pair describes how to push the list items, and how the list is +-- extracted from the type; the second pair contains a method to +-- retrieve list items, and defines how the list is used to create an +-- updated value. +newtype ListSpec e a itemtype = ListSpec + ( (Pusher e itemtype, a -> [itemtype]) + , (Peeker e itemtype, a -> [itemtype] -> a) + ) + +instance LuaError e => UDTypeExtension e a (ListSpec e a itemtype) where + extensionMetatableSetup ty = do + let ListSpec ((pushItem, _), _) = udExtension ty + pushName "lazylisteval" + pushHaskellFunction (lazylisteval pushItem) + rawset (nth 3) + -- Use different field getter + pushName (metamethodName Index) + pushcfunction hslua_list_udindex_ptr + rawset (nth 3) + -- Use different field setter + pushName (metamethodName Newindex) + pushcfunction hslua_list_udnewindex_ptr + rawset (nth 3) + + extensionPeekUD ty x idx = + (`lastly` pop 1) $ liftLua (getiuservalue idx 1) >>= \case + TypeTable -> setList (udExtension ty) x + _other -> pure x + {-# INLINEABLE extensionPeekUD #-} + + extensionPushUD ty x = do + let ListSpec ((_peekList, toList), _pushSpec) = udExtension ty + newtable + pushName "__lazylist" + newhsuserdatauv (toList x) 1 + void (newudmetatable lazyListStateName) + setmetatable (nth 2) + rawset (nth 3) + void (setiuservalue (nth 2) 1) + {-# INLINEABLE extensionPushUD #-} + + extensionUservalues _ty = 1 + + +-- | Evaluate part of a lazy list. Takes the following arguments, in +-- this order: +-- +-- 1. userdata wrapping the unevalled part of the lazy list +-- 2. index of the last evaluated element +-- 3. index of the requested element +-- 4. the caching table +lazylisteval :: forall itemtype e. LuaError e + => Pusher e itemtype -> LuaE e NumResults +lazylisteval pushItem = do + munevaled <- fromuserdata @[itemtype] (nthBottom 1) lazyListStateName + mcurindex <- tointeger (nthBottom 2) + mnewindex <- tointeger (nthBottom 3) + case (munevaled, mcurindex, mnewindex) of + (Just unevaled, Just curindex, Just newindex) -> do + let numElems = fromIntegral $ max (newindex - curindex) 0 + (as, rest) = splitAt numElems unevaled + if null rest + then do + -- no more elements in list; unset variable + pushName "__lazylistindex" + pushBool False + rawset (nthBottom 4) + else do + -- put back remaining unevalled list + void $ putuserdata @[itemtype] (nthBottom 1) lazyListStateName rest + pushName "__lazylistindex" + pushinteger (curindex + fromIntegral (length as)) + rawset (nthBottom 4) + -- push evaluated elements + forM_ (zip [(curindex + 1)..] as) $ \(i, a) -> do + pushItem a + rawseti (nthBottom 4) i + return (NumResults 0) + _ -> pure (NumResults 0) + +-- | Name of the metatable used for unevaluated lazy list rema +lazyListStateName :: Name +lazyListStateName = "HsLua unevalled lazy list" + +-- | Gets a list from a uservalue table and sets it on the given value. +-- Expects the uservalue (i.e., caching) table to be at the top of the +-- stack. +setList :: forall itemtype a e. LuaError e + => ListSpec e a itemtype -> a + -> Peek e a +setList (ListSpec (_pushspec, (peekItem, updateList))) x = (x `updateList`) <$!> do + liftLua (getfield top "__lazylistindex") >>= \case + TypeBoolean -> do + -- list had been fully evaluated + liftLua $ pop 1 + peekList peekItem top + _ -> do + let getLazyList = do + liftLua (getfield top "__lazylist") >>= \case + TypeUserdata -> pure () + otherType -> do + tyname <- liftLua $ typename otherType + failPeek $ + "unevaled items of lazy list cannot be peeked: got " <> + tyname + (`lastly` pop 1) $ reportValueOnFailure + lazyListStateName + (\idx -> fromuserdata @[itemtype] idx lazyListStateName) + top + mlastIndex <- liftLua (tointeger top <* pop 1) + let itemsAfter = case mlastIndex of + Nothing -> const getLazyList + Just lastIndex -> \i -> + if i <= lastIndex + then liftLua (rawgeti top i) >>= \case + TypeNil -> [] <$ liftLua (pop 1) + _ -> do + y <- peekItem top `lastly` pop 1 + (y:) <$!> itemsAfter (i + 1) + else getLazyList + itemsAfter 1 + + +-- | Sets a new value in the userdata caching table via a setter +-- functions; numerical values are treated as list indices. +foreign import ccall "hslobj.c &hslua_list_udindex" + hslua_list_udindex_ptr :: FunPtr (State -> IO NumResults) + +-- | Sets a new value in the userdata caching table via a setter +-- functions; numerical values are treated as list indices. +foreign import ccall "hslobj.c &hslua_list_udnewindex" + hslua_list_udnewindex_ptr :: FunPtr (State -> IO NumResults) diff --git a/hslua-objectorientation/src/HsLua/ObjectOrientation/SumType.hs b/hslua-objectorientation/src/HsLua/ObjectOrientation/SumType.hs new file mode 100644 index 00000000..a8337533 --- /dev/null +++ b/hslua-objectorientation/src/HsLua/ObjectOrientation/SumType.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-| +Module : HsLua.ObjectOrientation.SumType +Copyright : © 2024 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel + +Types and functions to use Abstract Data Types in Lua, and to change the +object behavior depending on the underlying constructor. +-} +module HsLua.ObjectOrientation.SumType + ( UDSumTypeGeneric + , OOSumType (..) + , Constructor (..) + -- * Defining types + , defsumtypeGeneric + , defconstructor + , constructorProperty + ) where + +import Control.Monad (forM_, void) +import Data.Map (Map) +import Data.Text (Text) +import Foreign.C (CInt(CInt)) +import Foreign.Ptr (FunPtr) +import HsLua.Core as Lua +import HsLua.Marshalling +import HsLua.ObjectOrientation.Generic +import HsLua.ObjectOrientation.Operation +import HsLua.Typing ( TypeSpec (..) ) +import Lua.Constants +import Lua.Types (TypeCode (..)) +import qualified Data.Map.Strict as Map +import qualified HsLua.Core.Utf8 as Utf8 + +-- | A sum type. +type UDSumTypeGeneric e fn a = + UDTypeGeneric e fn a (OOSumType e a) + +-- | Object extension to add constructor-specific behavior to objects. +data OOSumType e a = OOSumType + { ooSumConstructors :: !(Map Name (Constructor e a)) + , ooSumTag :: !(a -> Name) + } + +-- | Constructor for a summand in a sum type. +data Constructor e a = Constr + { constrName :: !Name + , constrDescription :: !Text + , constrProperties :: !(Map Name (Property e a)) + } + +defconstructor :: Name -> Text -> [(Name, Property e a)] -> Constructor e a +defconstructor name descr prop = + Constr name descr (Map.fromList prop) + +constructorProperty + :: LuaError e + => Name -- ^ property name + -> TypeSpec -- ^ type of the property value + -> Text -- ^ property description + -> (Pusher e b, a -> Possible b) -- ^ how to get the property value + -> (Peeker e b, a -> b -> Possible a) -- ^ how to set a new property value + -> (Name, Property e a) +constructorProperty name typespec desc (push, get) (peek, set) = + ( name + , Property + { propertyGet = \x -> do + case get x of + Actual y -> NumResults 1 <$ push y + Absent -> return (NumResults 0) + , propertySet = Just $ \idx x -> do + value <- forcePeek $ peek idx + case set x value of + Actual y -> return y + Absent -> failLua $ "Trying to set unavailable property " + <> Utf8.toString (fromName name) + <> "." + , propertyType = typespec + , propertyDescription = desc + } + ) + +-- | Defines a new type that could also be treated as a list; defines +-- the behavior of objects in Lua. Note that the type name must be +-- unique. +defsumtypeGeneric + :: Pusher e fn -- ^ function pusher + -> Name -- ^ type name + -> [(Operation, fn)] -- ^ operations + -> [Member e fn a] -- ^ methods + -> (a -> Name) + -> [Constructor e a] + -> UDSumTypeGeneric e fn a +defsumtypeGeneric fn name ops members tagName constrs = + deftypeGeneric' fn name ops members $ + OOSumType + { ooSumConstructors = + Map.fromList $ map (\c -> (constrName c, c)) constrs + , ooSumTag = tagName + } + +instance (LuaError e) => UDTypeExtension e a (OOSumType e a) where + extensionMetatableSetup ty = do + addOp Index $ pushcfunction hslua_sum_udindex_ptr + addOp Newindex $ pushcfunction hslua_sum_udnewindex_ptr + _ <- getfield top "getters" + addField "tag" $ pushcfunction hslua_sum_get_tag_ptr + pop 1 -- getters table + forM_ (ooSumConstructors $ udExtension ty) $ \constr -> do + addField (constrName constr) $ do + newtable + addField "getters" $ do + let fn p = forcePeek (peekUDGeneric ty 1) >>= propertyGet p + pushMap pushName (pushHaskellFunction . fn) (constrProperties constr) + addField "setters" $ do + let pushSetter = const $ pushcfunction hslua_udsetter_ptr + pushMap pushName pushSetter (constrProperties constr) + + addField "peekers" $ do + newtable + let props = constrProperties constr + void $ flip Map.traverseWithKey props $ \name prop -> do + case propertySet prop of + Just p -> do + pushName name + newhsuserdatauv p 0 + -- newudmetatable "HsLuaOOPeeker" + -- setmetatable (nth 2) + rawset (nth 3) + Nothing -> pure () + + extensionPeekUD _ty x idx = do + absidx <- liftLua $ absindex idx + let getpeekers idx' = do + l <- state + liftIO $ hslua_sum_peekers l idx' + liftLua (getpeekers absidx) >>= \case + LUA_TTABLE -> do + liftLua (getiuservalue absidx 1) >>= (`lastly` pop 2) . \case + TypeTable -> liftLua $ do + pushnil + setProperties x + _otherwise -> + -- no caching table + pure x + _typeCode -> liftLua $ do + -- no peekers table, so nothing to do + pop 1 + -- failLua $ "Could not get peekers table, got: " <> show otherType + pure x + + extensionPushUD ty x = do + let tag = (ooSumTag $ udExtension ty) x + pushName tag + setiuservalue (nth 2) 2 >>= \case + True -> pure () + False -> failLua "Couldn't set tag, object has no second uservalue." + + extensionUservalues _ty = 2 + +-- | Sets field @name@ in the table at the top of the stack to the value +-- pushed by @pushValue@. The @pushValue@ action must push exactly one +-- value to the Lua stack. +addField :: LuaError e + => Name -- ^ name + -> LuaE e () -- ^ pushValue + -> LuaE e () +addField name pushValue = do + pushName name + pushValue + rawset (nth 3) + +-- | Like 'addField', but adds the table function that governs +-- @operation@. The @pushFn@ action must push exactly one value to the +-- Lua stack. +addOp :: LuaError e + => Operation -- ^ operation + -> LuaE e () -- ^ pushFn + -> LuaE e () +addOp op = addField (metamethodName op) + +-- | Retrieves a key from a Haskell-data holding userdata value. +-- +-- Does the following, in order, and returns the first non-nil result: +-- +-- - Checks the userdata's caching table for the given key; +-- +-- - Checks whether the constructor corresponding to the wrapped +-- element has a getter for this value and uses that. +-- +-- - Falls back to the default @__index@ lookup for objects. +foreign import ccall "hslsum.c &hslua_sum_udindex" + hslua_sum_udindex_ptr :: FunPtr (State -> IO NumResults) + +-- | Sets a new value in the userdata caching table via a setter +-- functions. +-- +-- Delegates the caching assignment to a function either in the +-- constructor-specific @setters@ table or the global @setters@ table. +foreign import ccall "hslsum.c &hslua_sum_udnewindex" + hslua_sum_udnewindex_ptr :: FunPtr (State -> IO NumResults) + +-- | Get the sum-type's @tag@, i.e., the constructor name. +foreign import ccall "hslsum.c &hslua_sum_get_tag" + hslua_sum_get_tag_ptr :: FunPtr (State -> IO NumResults) + +-- | Sets a value in the caching table. +foreign import ccall "hslobj.c &hslua_udsetter" + hslua_udsetter_ptr :: FunPtr (State -> IO NumResults) + +-- | Get a constructor subtable field +foreign import ccall "hslsum.c hslua_sum_peekers" + hslua_sum_peekers :: State -> StackIndex -> IO TypeCode diff --git a/hslua-objectorientation/test/HsLua/ObjectOrientation/SumTypeTests.hs b/hslua-objectorientation/test/HsLua/ObjectOrientation/SumTypeTests.hs new file mode 100644 index 00000000..c8f8bec9 --- /dev/null +++ b/hslua-objectorientation/test/HsLua/ObjectOrientation/SumTypeTests.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : HsLua.ObjectOrientation.SumTypeTests +Copyright : © 2024 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +-} +module HsLua.ObjectOrientation.SumTypeTests (tests) where + +import HsLua.Core +import HsLua.ObjectOrientation +import HsLua.ObjectOrientation.SumType +import HsLua.Marshalling +import HsLua.Typing +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HsLua ((=:), shouldBeResultOf) + +-- | Tests for HsLua object orientation. +tests :: TestTree +tests = testGroup "Sample sum type" + [ "element tag" =: + "Quux" `shouldBeResultOf` do + openlibs + pushUD typeQux $ Quux 11 + getfield top "tag" + forcePeek $ peekText top + + , "get property" =: + 17 `shouldBeResultOf` do + pushUD typeQux $ Quux 17 + getfield top "int" + forcePeek $ peekIntegral @Int top + + , "peek element" =: + Quux 19 `shouldBeResultOf` do + pushUD typeQux $ Quux 7 + pushinteger 19 + setfield (nth 2) "int" + forcePeek $ peekQux top + + , "modify nested element" =: + Quuy Quuz `shouldBeResultOf` do + pushUD typeQux $ Quuy (Quux 5) + pushQux Quuz + setfield (nth 2) "qux" + forcePeek $ peekQux top + + , "repeated modifications" =: + Quuy Quuz `shouldBeResultOf` do + pushUD typeQux $ Quuy (Quux 1) + pushQux $ Quux 2 + setfield (nth 2) "qux" + pushQux Quuz + setfield (nth 2) "qux" + forcePeek $ peekQux top + + , testGroup "stack usage" + [ "initializing does not affect the stack" =: + 0 `shouldBeResultOf` do + openlibs + before <- gettop + _ <- initTypeGeneric (\_ -> pure ()) typeQux + after <- gettop + return $ after - before + + , "pushing adds one element to the stack" =: + 1 `shouldBeResultOf` do + before <- gettop + pushUD typeQux $ Quuy (Quux 1) + after <- gettop + return $ after - before + + , "getting a field adds one element" =: + 1 `shouldBeResultOf` do + pushUD typeQux $ Quuy (Quux 1) + before <- gettop + getfield top "qux" + after <- gettop + return $ after - before + + , "modifying a field does not affect the stack" =: + 0 `shouldBeResultOf` do + pushUD typeQux $ Quuy (Quux 1) + before <- gettop + pushQux Quuz + setfield (nth 2) "qux" + after <- gettop + return $ after - before + + , "peeking does not affect the stack" =: + 0 `shouldBeResultOf` do + openlibs + -- Create object with fields in caching table + pushUD typeQux $ Quuy (Quux 1) + pushQux Quuz + setfield (nth 2) "qux" + + before <- gettop + _ <- forcePeek $ peekQux top + after <- gettop + return $ after - before + + , "peeking unmodified element does not affect the stack" =: + 0 `shouldBeResultOf` do + openlibs + pushUD typeQux $ Quuy (Quux 1) + + before <- gettop + _ <- forcePeek $ peekQux top + after <- gettop + return $ after - before + ] + ] + +-- | Pushes a userdata value of the given type. +pushUD + :: UDTypeExtension e a extension + => UDTypeGeneric e fn a extension -> a -> LuaE e () +pushUD = pushUDGeneric (const (pure ())) + +-- +-- Sample sum type +-- +data Qux + = Quux Int + | Quuy Qux + | Quuz + deriving (Eq, Show) + +peekQux :: LuaError e => Peeker e Qux +peekQux = peekUDGeneric typeQux + +pushQux :: LuaError e => Pusher e Qux +pushQux = pushUD typeQux + +typeQux :: LuaError e => UDSumTypeGeneric e (HaskellFunction e) Qux +typeQux = defsumtypeGeneric pushHaskellFunction "Qux" + [] + [] + (\case + Quux{} -> "Quux" + Quuy{} -> "Quuy" + Quuz{} -> "Quuz") + [ defconstructor "Quux" + "integer container" + [ constructorProperty "int" + integerType + "some integer property" + (pushIntegral, \case + Quux int -> Actual int + Quuy _ -> Absent + Quuz -> Absent) + (peekIntegral, \case + Quux _ -> Actual . Quux + Quuy _ -> const Absent + Quuz -> const Absent) + ] + + , defconstructor "Quuy" + "nested Qux" + [ constructorProperty "qux" + "Qux" + "nested Qux" + (pushUD typeQux, \case + Quux _ -> Absent + Quuy qx -> Actual qx + Quuz -> Absent) + (peekQux, \case + Quux _ -> const Absent + Quuy _ -> Actual . Quuy + Quuz -> const Absent) + ] + + , defconstructor "Quuz" + "property-less element" + [] + ] diff --git a/hslua-objectorientation/test/HsLua/ObjectOrientationTests.hs b/hslua-objectorientation/test/HsLua/ObjectOrientationTests.hs index 64c3de1a..1077749e 100644 --- a/hslua-objectorientation/test/HsLua/ObjectOrientationTests.hs +++ b/hslua-objectorientation/test/HsLua/ObjectOrientationTests.hs @@ -373,6 +373,7 @@ tests = testGroup "Object Orientation" ] ] +-- | Define a default UDType without bells and whistles. deftype :: LuaError e => Name -- ^ type name -> [(Operation, HaskellFunction e)] -- ^ operations @@ -380,16 +381,10 @@ deftype :: LuaError e -> UDType e (HaskellFunction e) a deftype = deftypeGeneric pushHaskellFunction -deftype' :: LuaError e - => Name -- ^ type name - -> [(Operation, HaskellFunction e)] -- ^ operations - -> [Member e (HaskellFunction e) a] -- ^ methods - -> Maybe (ListSpec e a itemtype) -- ^ list access - -> UDTypeWithList e (HaskellFunction e) a itemtype -deftype' = deftypeGeneric' pushHaskellFunction - -- | Pushes a userdata value of the given type. -pushUD :: LuaError e => UDTypeWithList e fn a itemtype -> a -> LuaE e () +pushUD + :: UDTypeExtension e a extension + => UDTypeGeneric e fn a extension -> a -> LuaE e () pushUD = pushUDGeneric (const (pure ())) -- | Define a (meta) operation on a type. @@ -433,14 +428,15 @@ newtype LazyIntList = LazyIntList { fromLazyIntList :: [Int] } typeLazyIntList :: LuaError e => UDTypeWithList e (HaskellFunction e) LazyIntList Int -typeLazyIntList = deftype' "LazyIntList" +typeLazyIntList = deftypeGeneric' pushHaskellFunction "LazyIntList" [ operation Tostring $ do lazyList <- forcePeek $ peekUDGeneric typeLazyIntList (nthBottom 1) pushString (show lazyList) return (NumResults 1) ] [ alias "seq" "sequence" [] ] - (Just ( (pushIntegral, fromLazyIntList) + (ListSpec + ( (pushIntegral, fromLazyIntList) , (peekIntegral, \_ lst -> LazyIntList lst) )) diff --git a/hslua-objectorientation/test/test-hslua-objectorientation.hs b/hslua-objectorientation/test/test-hslua-objectorientation.hs index 38e2eebf..757d474f 100644 --- a/hslua-objectorientation/test/test-hslua-objectorientation.hs +++ b/hslua-objectorientation/test/test-hslua-objectorientation.hs @@ -15,10 +15,14 @@ module Main (main) where import Test.Tasty (TestTree, defaultMain, testGroup) import qualified HsLua.ObjectOrientationTests +import qualified HsLua.ObjectOrientation.SumTypeTests main :: IO () main = defaultMain $ testGroup "hslua-objectorientation" tests -- | HSpec tests tests :: [TestTree] -tests = [ HsLua.ObjectOrientationTests.tests ] +tests = + [ HsLua.ObjectOrientationTests.tests + , HsLua.ObjectOrientation.SumTypeTests.tests + ] diff --git a/hslua-packaging/CHANGELOG.md b/hslua-packaging/CHANGELOG.md index 1610cfc2..4b996ae1 100644 --- a/hslua-packaging/CHANGELOG.md +++ b/hslua-packaging/CHANGELOG.md @@ -2,6 +2,14 @@ `hslua-packaging` uses [PVP Versioning][]. +## hslua-packaging-2.4.0 + +Release pending. + +- Use hslua-objectorientation-2.4, which large parts of which + are re-exported. See the changelog there for the relevant + changes. + ## hslua-packaging-2.3.1 Released 2024-01-18. diff --git a/hslua-packaging/hslua-packaging.cabal b/hslua-packaging/hslua-packaging.cabal index 82dcab39..8614ff04 100644 --- a/hslua-packaging/hslua-packaging.cabal +++ b/hslua-packaging/hslua-packaging.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hslua-packaging -version: 2.3.1 +version: 2.4.0 synopsis: Utilities to build Lua modules. description: Utilities to package up Haskell functions and values into a Lua module. @@ -71,7 +71,7 @@ library other-extensions: DeriveFunctor , OverloadedStrings build-depends: containers >= 0.5.9 && < 0.9 - , hslua-objectorientation >= 2.3 && < 2.4 + , hslua-objectorientation >= 2.4 && < 2.5 , hslua-typing >= 0.1 && < 0.2 test-suite test-hslua-packaging diff --git a/hslua-packaging/src/HsLua/Packaging/UDType.hs b/hslua-packaging/src/HsLua/Packaging/UDType.hs index f0e235d1..ddd34567 100644 --- a/hslua-packaging/src/HsLua/Packaging/UDType.hs +++ b/hslua-packaging/src/HsLua/Packaging/UDType.hs @@ -15,6 +15,7 @@ objects/, and to their type as /UD type/. module HsLua.Packaging.UDType ( DocumentedType , DocumentedTypeWithList + , ListSpec (..) , deftype , deftype' , method @@ -45,7 +46,7 @@ import Data.Text (Text) import HsLua.Core import HsLua.Marshalling import HsLua.ObjectOrientation -import HsLua.ObjectOrientation.Operation (metamethodName) +import HsLua.ObjectOrientation.Operation import HsLua.Packaging.Function import HsLua.Typing (pushTypeSpec) import qualified Data.Map as Map @@ -53,6 +54,10 @@ import qualified Data.Map as Map -- | Type definitions containing documented functions. type DocumentedType e a = UDType e (DocumentedFunction e) a +-- | Type definition with documented functions and type extensions. +type DocumentedType' e a extension = + UDTypeGeneric e (DocumentedFunction e) a extension + -- | A userdata type, capturing the behavior of Lua objects that wrap -- Haskell values. The type name must be unique; once the type has been -- used to push or retrieve a value, the behavior can no longer be @@ -69,15 +74,15 @@ deftype :: LuaError e -> DocumentedType e a deftype = deftypeGeneric pushDocumentedFunction --- | Defines a new type that could also be treated as a list; defines --- the behavior of objects in Lua. Note that the type name must be --- unique. -deftype' :: LuaError e - => Name -- ^ type name - -> [(Operation, DocumentedFunction e)] -- ^ operations - -> [Member e (DocumentedFunction e) a] -- ^ methods - -> Maybe (ListSpec e a itemtype) -- ^ list access - -> DocumentedTypeWithList e a itemtype +-- | Defines a new type, defining the behavior of objects in Lua. +-- Note that the type name must be unique. +deftype' + :: UDTypeExtension e a extension + => Name -- ^ type name + -> [(Operation, DocumentedFunction e)] -- ^ operations + -> [Member e (DocumentedFunction e) a] -- ^ methods + -> extension + -> DocumentedType' e a extension deftype' = deftypeGeneric' pushDocumentedFunction -- | Use a documented function as an object method. @@ -92,39 +97,43 @@ operation :: Operation -- ^ the kind of operation operation op f = (,) op $ setName (metamethodName op) f -- | Defines a function parameter that takes the given type. -udparam :: LuaError e - => DocumentedTypeWithList e a itemtype -- ^ expected type +udparam :: UDTypeExtension e a ext + => DocumentedType' e a ext -- ^ expected type -> Text -- ^ parameter name -> Text -- ^ parameter description -> Parameter e a udparam ty = parameter (peekUDGeneric ty) (udTypeSpec ty) -- | Defines a function result of the given type. -udresult :: LuaError e - => DocumentedTypeWithList e a itemtype -- ^ result type +udresult :: UDTypeExtension e a ext + => DocumentedType' e a ext -- ^ result type -> Text -- ^ result description -> FunctionResults e a udresult ty = functionResult (pushUD ty) (udTypeSpec ty) -- | Pushes a userdata value of the given type. -pushUD :: LuaError e => DocumentedTypeWithList e a itemtype -> a -> LuaE e () +pushUD :: UDTypeExtension e a extension + => DocumentedType' e a extension + -> a + -> LuaE e () pushUD = pushUDGeneric pushUDTypeDocs -- | Retrieves a userdata value of the given type. -peekUD :: LuaError e => DocumentedTypeWithList e a itemtype -> Peeker e a +peekUD :: UDTypeExtension e a extension + => DocumentedType' e a extension -> Peeker e a peekUD = peekUDGeneric -- | Ensures that the type has been fully initialized, i.e., that all -- metatables have been created and stored in the registry. Returns the -- name of the initialized type. -initType :: LuaError e - => DocumentedTypeWithList e a itemtype +initType :: UDTypeExtension e a extension + => DocumentedType' e a extension -> LuaE e Name initType = initTypeGeneric pushUDTypeDocs -- | Pushes a documentation table for the given UD type. -pushUDTypeDocs :: LuaError e - => DocumentedTypeWithList e a itemtype +pushUDTypeDocs :: UDTypeExtension e a extension + => DocumentedType' e a extension -> LuaE e () pushUDTypeDocs ty = do -- metadata table is at the top of the stack diff --git a/hslua/CHANGELOG.md b/hslua/CHANGELOG.md index a8129f24..9e2bdcaf 100644 --- a/hslua/CHANGELOG.md +++ b/hslua/CHANGELOG.md @@ -6,6 +6,8 @@ Release pending. +- Require versions 2.4.* of HsLua packages. + - Provide a full Lua app with Haskell-defined modules preloaded. The app is only built if the `executable` flag is enabled. diff --git a/hslua/hslua.cabal b/hslua/hslua.cabal index 3d42b59b..a1b0bfc8 100644 --- a/hslua/hslua.cabal +++ b/hslua/hslua.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hslua -version: 2.3.1 +version: 2.4.0 synopsis: Bindings to Lua, an embeddable scripting language description: HsLua provides wrappers and helpers to bridge Haskell and . @@ -87,8 +87,8 @@ library , hslua-classes >= 2.2.1 && < 2.4 , hslua-core >= 2.3.2 && < 2.4 , hslua-marshalling >= 2.3.1 && < 2.4 - , hslua-objectorientation >= 2.3.1 && < 2.4 - , hslua-packaging >= 2.3.1 && < 2.4 + , hslua-objectorientation >= 2.4 && < 2.5 + , hslua-packaging >= 2.3.1 && < 2.5 , hslua-typing >= 0.1.1 && < 0.2 test-suite test-hslua