diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,36 @@ `hslua-objectorientation` uses [PVP Versioning][]. +## hslua-objectorientation-2.4.0 + +Released 2025-06-23. + +- The code has been reorganized: the new submodules + `HsLua.ObjectOrientation.Generic` and + `HsLua.ObjectOrientation.ListType` have been added. + +- The `UDTypeGeneric` type has been updated, the definitions for + Lua types can now contain additional hooks to modify the + behavior when initializing the type and when pushing and + pulling objects to and from Lua. + +- The function `pushUDGeneric` is modified and no longer takes a + `pushDocs` parameter. Use the new type hooks instead. + +- Removed the extra hook from `initTypeGeneric` and renamed it + to `initType`. The hook, if one is needed, must now be part of + the UDTypeGeneric object. + +- The default `__index` and `__newindex` functions have been + simplified and no longer handle integer keys. Consequently, + list-like types now need their own `__index` and `__newindex` + functions. These can handle numerical indices and fall back to + the default functions for other keys. + + The new file `hslobj.h` contains the headers of the default + access functions. It is added to the `install-includes` cabal + field. + ## hslua-objectorientation-2.3.1 Released 2024-01-18. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright © 1994-2022 Lua.org, PUC-Rio. +Copyright © 1994-2023 Lua.org, PUC-Rio. Copyright © 2007-2012 Gracjan Polak Copyright © 2012-2015 Ömer Sinan Ağacan Copyright © 2016-2024 Albert Krewinkel diff --git a/cbits/hsllist.c b/cbits/hsllist.c new file mode 100644 --- /dev/null +++ b/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)) + /* Fall back to the default hslua index method for non-integer keys */ + : 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/cbits/hslobj.c b/cbits/hslobj.c --- a/cbits/hslobj.c +++ b/cbits/hslobj.c @@ -13,18 +13,19 @@ ** Creates and sets a new table if none has been attached to the ** userdata yet. */ -void hsluaO_get_caching_table(lua_State *L, int idx) +void hslua_get_caching_table(lua_State *L, int idx) { - int absidx = lua_absindex(L, idx); if (lua_getuservalue(L, idx) == LUA_TTABLE) { return; } /* No caching table set yet; create table and add to object. */ lua_pop(L, 1); /* remove nil */ + + int absidx = lua_absindex(L, idx); lua_createtable(L, 0, 0); lua_pushvalue(L, -1); - lua_setuservalue(L, idx); + lua_setuservalue(L, absidx); } /* @@ -33,10 +34,10 @@ ** found and is at the top of the stack, 0 otherwise. Does not clean-up ** on success. */ -int hsluaO_get_from_cache(lua_State *L) +int hslua_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 */ @@ -51,7 +52,7 @@ ** Retrieve a value from the wrapped userdata project. ** The userdata must be in position 1, and the key in position 2. */ -int hsluaO_get_via_getter(lua_State *L) +static int hsluaO_get_via_getter(lua_State *L) { /* Bail if there are no getterns, or no getter for the given key. */ if (luaL_getmetafield(L, 1, "getters") != LUA_TTABLE) { @@ -68,7 +69,7 @@ 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); @@ -82,7 +83,7 @@ ** property. The userdata must be in position 1, and the key in position ** 2. */ -int hsluaO_get_via_alias(lua_State *L) +static int hsluaO_get_via_alias(lua_State *L) { if (luaL_getmetafield(L, 1, "aliases") != LUA_TTABLE) { return 0; /* no aliases available */ @@ -111,7 +112,7 @@ ** Retrieve a method for this object. The userdata must be in position ** 1, and the key in position 2. */ -int hsluaO_get_method(lua_State *L) +static int hsluaO_get_method(lua_State *L) { if (luaL_getmetafield(L, 1, "methods") != LUA_TTABLE) { lua_pop(L, 1); @@ -123,42 +124,6 @@ } /* -** Retrieve a numerical index from this object. The userdata must be in -** position 1, and the key in position 2. -*/ -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. ** ** If the key is an integer, any associated list is evaluated and the @@ -178,20 +143,19 @@ { 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 + hslua_get_from_cache(L) || + hsluaO_get_via_getter(L) || + hsluaO_get_via_alias(L) || + hsluaO_get_method(L); } /* ** Set value via a property alias. Assumes the stack to be in a state as ** after __newindex is called. Returns 1 on success, and 0 otherwise. */ -int hsluaO_set_via_alias(lua_State *L) +static int hsluaO_set_via_alias(lua_State *L) { if (luaL_getmetafield(L, 1, "aliases") != LUA_TTABLE) { return 0; @@ -217,48 +181,12 @@ } /* -** 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. -*/ -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 ** readonly, and throws an error if there is no setter for the given ** key. */ -int hsluaO_set_via_setter(lua_State *L) +static int hsluaO_set_via_setter(lua_State *L) { if (luaL_getmetafield(L, 1, "setters") != LUA_TTABLE) return 0; @@ -286,13 +214,6 @@ */ 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; } @@ -309,7 +230,7 @@ { 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/cbits/hslobj.h b/cbits/hslobj.h new file mode 100644 --- /dev/null +++ b/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 hslua_get_from_cache(lua_State *L); + +#endif diff --git a/hslua-objectorientation.cabal b/hslua-objectorientation.cabal --- a/hslua-objectorientation.cabal +++ b/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. @@ -15,15 +15,15 @@ build-type: Simple extra-source-files: README.md , CHANGELOG.md -tested-with: GHC == 8.4.4 - , GHC == 8.6.5 - , GHC == 8.8.4 +tested-with: GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.8 - , GHC == 9.6.3 - , GHC == 9.8.1 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.2 + , GHC == 9.12.2 source-repository head type: git @@ -33,34 +33,37 @@ common common-options default-language: Haskell2010 build-depends: base >= 4.11 && < 5 - , bytestring >= 0.10.2 && < 0.13 - , containers >= 0.5.9 && < 0.8 - , exceptions >= 0.8 && < 0.11 , hslua-core >= 2.2.1 && < 2.4 , hslua-marshalling >= 2.2.1 && < 2.4 , hslua-typing >= 0.1 && < 0.2 - , mtl >= 2.2 && < 2.4 - , text >= 1.2 && < 2.2 + ghc-options: -Wall + -Wcpp-undef + -Werror=missing-home-modules + -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wnoncanonical-monad-instances + -Wpartial-fields -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 + -fhide-source-paths + if impl(ghc >= 8.10) + ghc-options: -Wunused-packages + if impl(ghc >= 9.0) + ghc-options: -Winvalid-haddock + other-extensions: OverloadedStrings , TypeApplications library import: common-options exposed-modules: HsLua.ObjectOrientation + , HsLua.ObjectOrientation.Generic + , HsLua.ObjectOrientation.ListType , HsLua.ObjectOrientation.Operation hs-source-dirs: src + build-depends: containers >= 0.5.9 && < 0.9 + , text >= 1.2 && < 2.2 default-extensions: LambdaCase , StrictData other-extensions: AllowAmbiguousTypes @@ -68,7 +71,11 @@ , FlexibleInstances , MultiParamTypeClasses , ScopedTypeVariables + includes: hslobj.h + install-includes: hslobj.h + include-dirs: cbits c-sources: cbits/hslobj.c + , cbits/hsllist.c test-suite test-hslua-objectorientation import: common-options @@ -78,10 +85,6 @@ ghc-options: -threaded -Wno-unused-do-bind other-modules: HsLua.ObjectOrientationTests build-depends: hslua-objectorientation - , lua-arbitrary >= 1.0 - , QuickCheck >= 2.7 - , quickcheck-instances >= 0.3 + , bytestring >= 0.10.2 && < 0.13 , tasty >= 0.11 , tasty-hslua >= 1.0 - , tasty-hunit >= 0.9 - , tasty-quickcheck >= 0.8 diff --git a/src/HsLua/ObjectOrientation.hs b/src/HsLua/ObjectOrientation.hs --- a/src/HsLua/ObjectOrientation.hs +++ b/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 @@ -} 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 - --- | 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) - ) +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. -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 @@ -> [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 emptyHooks diff --git a/src/HsLua/ObjectOrientation/Generic.hs b/src/HsLua/ObjectOrientation/Generic.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/ObjectOrientation/Generic.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# 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 (..) + -- * Defining types + , deftypeGeneric' + -- ** Methods + , methodGeneric + -- ** Properties + , property + , property' + , possibleProperty + , possibleProperty' + , readonly + , readonly' + -- ** Aliases + , alias + -- ** Type extension + , UDTypeHooks (..) + , emptyHooks + -- * Marshaling + , peekUDGeneric + , pushUDGeneric + , initType + -- * Type docs + , udDocs + , udTypeSpec + -- * Helper types for building + , Member + , Property (..) + , Operation (..) + , Possible (..) + , Alias + , AliasIndex (..) + ) 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) +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 + +-- | 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 = UDType + { udName :: Name + , udOperations :: [(Operation, fn)] + , udProperties :: Map Name (Property e a) + , udMethods :: Map Name fn + , udAliases :: Map AliasIndex Alias + , udHooks :: UDTypeHooks e fn a + , udFnPusher :: fn -> LuaE e () + } + +-- | Extensions for userdata types. +data UDTypeHooks e fn a = + UDTypeHooks + { hookUservalues :: Int + -- ^ Number of uservalues required for this extension, *including* the + -- uservalue for the default caching table. + + , hookMetatableSetup :: LuaE e () + -- ^ Run after the metatable has been set up; the new metatable is + -- at the top of the stack when this hook is run. + + , hookPeekUD :: a + -> StackIndex + -> Peek e a + -- ^ Peek extra data and modify the peeked object + + , hookPushUD :: a -> LuaE e () + -- ^ Push extra data + } + +-- | No extension. +emptyHooks :: UDTypeHooks e fn a +emptyHooks = UDTypeHooks + { hookMetatableSetup = return () + + , hookPeekUD = \x _idx -> return x + + , hookPushUD = \_x -> return () + + , hookUservalues = 1 + } + +-- | Defines a new "Lua type" and sets the behavior of the Lua object +-- instances. It's possible to pass custom type extensions, which modify +-- the default object behavior. Furthermore, the /function pusher/ +-- parameter controls how 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 + -> UDTypeHooks e fn a -- ^ behavior modifying hooks + -> UDTypeGeneric e fn a +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 + , udHooks = 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. +initType :: LuaError e + => UDTypeGeneric e fn a + -> LuaE e Name +initType ty = do + pushUDMetatable 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 fn a. LuaError e + => UDTypeGeneric e fn a + -> LuaE e () +pushUDMetatable 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 + hookMetatableSetup (udHooks 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 + :: LuaError e + => UDTypeGeneric e fn a -> 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 -> 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 => UDTypeGeneric e fn a -> 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 -> 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 + :: LuaError err + => UDTypeGeneric err fn a -> 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 + :: LuaError e + => UDTypeGeneric e fn a -- ^ userdata type + -> a -- ^ value to push + -> LuaE e () +pushUDGeneric ty x = do + newhsuserdatauv x (hookUservalues (udHooks ty)) + pushUDMetatable ty + setmetatable (nth 2) + hookPushUD (udHooks ty) x + +-- | Retrieves a userdata value of the given type. +peekUDGeneric :: LuaError e + => UDTypeGeneric e fn a -> Peeker e a +peekUDGeneric ty idx = do + let name = udName ty + old <- reportValueOnFailure name (`fromuserdata` name) idx + -- get caching table and update the Haskell value + updated <- liftLua (getiuservalue idx 1) >>= \case + TypeTable -> liftLua $ do + pushnil + setProperties (udProperties ty) old + _other -> return old + liftLua $ pop 1 -- pop caching table + hookPeekUD (udHooks ty) updated idx + +-- | 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) + let continue value = pop 1 *> setProperties props value + 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 -> continue x + Just setter -> do + x' <- setter top x + continue x' + _ -> continue x + +-- +-- Typing +-- + +-- | Returns documentation for this type. +udDocs :: UDTypeGeneric e fn a + -> TypeDocs +udDocs ty = TypeDocs + { typeDescription = mempty + , typeSpec = userdataType + , typeRegistry = Just (udName ty) + } + +-- | Type specifier for a UDType +udTypeSpec :: UDTypeGeneric e fn a + -> TypeSpec +udTypeSpec = NamedType . udName diff --git a/src/HsLua/ObjectOrientation/ListType.hs b/src/HsLua/ObjectOrientation/ListType.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/ObjectOrientation/ListType.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module HsLua.ObjectOrientation.ListType + ( UDTypeWithList + , ListSpec + , listExtension + ) 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 +{-# DEPRECATED UDTypeWithList "Use UDTypeGeneric instead" #-} + +-- | 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) + ) + +listExtension + :: LuaError e + => ListSpec e a itemtype + -> UDTypeHooks e fn a +listExtension ((pushItem, toList), (peekItem, updateList)) = + UDTypeHooks + { hookMetatableSetup = do + -- Add a function to evaluate the necessary parts of a lazy list. + 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) + + , hookPeekUD = \x idx -> + (`lastly` pop 1) $ liftLua (getiuservalue idx 1) >>= \case + TypeTable -> setList peekItem updateList x + _other -> pure x + + , hookPushUD = \x -> do + -- Add a field containing the thunk with the unevaluated part of + -- the lazy list. + newtable + pushName "__lazylist" + newhsuserdatauv (toList x) 1 + void (newudmetatable lazyListStateName) + setmetatable (nth 2) + rawset (nth 3) + void (setiuservalue (nth 2) 1) + + , hookUservalues = 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 + => Peeker e itemtype + -> (a -> [itemtype] -> a) + -> a + -> Peek e a +setList 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 + + +-- | Gets a new value in the userdata caching table via a getter +-- functions; this function differs from the normal getter in that it +-- treats numerical values 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; this function differs from the normal setter in that it +-- treats numerical values as list indices. +foreign import ccall "hslobj.c &hslua_list_udnewindex" + hslua_list_udnewindex_ptr :: FunPtr (State -> IO NumResults) diff --git a/test/HsLua/ObjectOrientationTests.hs b/test/HsLua/ObjectOrientationTests.hs --- a/test/HsLua/ObjectOrientationTests.hs +++ b/test/HsLua/ObjectOrientationTests.hs @@ -173,7 +173,7 @@ [ "type table is added to the registry" =: TypeTable `shouldBeResultOf` do openlibs - name <- initTypeGeneric (\_ -> pure ()) typeBar + name <- initType typeBar getfield registryindex name , "type table is not in registry when uninitialized" =: @@ -185,7 +185,7 @@ 0 `shouldBeResultOf` do openlibs before <- gettop - _ <- initTypeGeneric (\_ -> pure ()) typeBar + _ <- initType typeBar after <- gettop return $ after - before ] @@ -274,7 +274,7 @@ , "Infinite lists are ok" =: 233 `shouldBeResultOf` do openlibs - let fibs = 0 : 1 : zipWith (+) fibs (tail fibs) + let fibs = 0 : 1 : zipWith (+) fibs (drop 1 fibs) pushUD typeLazyIntList $ LazyIntList fibs setglobal "fibs" dostring "return fibs[14]" >>= \case @@ -373,6 +373,7 @@ ] ] +-- | Define a default UDType without bells and whistles. deftype :: LuaError e => Name -- ^ type name -> [(Operation, HaskellFunction e)] -- ^ operations @@ -380,17 +381,11 @@ -> 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 = pushUDGeneric (const (pure ())) +pushUD + :: LuaError e + => UDTypeGeneric e fn a -> a -> LuaE e () +pushUD = pushUDGeneric -- | Define a (meta) operation on a type. operation :: Operation -> HaskellFunction e -> (Operation, HaskellFunction e) @@ -432,17 +427,18 @@ deriving (Eq, Show) typeLazyIntList :: LuaError e - => UDTypeWithList e (HaskellFunction e) LazyIntList Int -typeLazyIntList = deftype' "LazyIntList" + => UDTypeGeneric e (HaskellFunction e) 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) - , (peekIntegral, \_ lst -> LazyIntList lst) - )) + (listExtension + ( (pushIntegral, fromLazyIntList) + , (peekIntegral, \_ lst -> LazyIntList lst) + )) -- -- Sample sum type