hslua-objectorientation 2.3.1 → 2.4.0

raw patch · 10 files changed

+886/−675 lines, 10 filesdep −QuickCheckdep −exceptionsdep −lua-arbitrarydep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies removed: QuickCheck, exceptions, lua-arbitrary, mtl, quickcheck-instances, tasty-hunit, tasty-quickcheck

Dependency ranges changed: containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +30/−0
• LICENSE +1/−1
• cbits/hsllist.c +115/−0
• cbits/hslobj.c +19/−98
• cbits/hslobj.h +22/−0
• hslua-objectorientation.cabal +27/−24
• src/HsLua/ObjectOrientation.hs +11/−534
• src/HsLua/ObjectOrientation/Generic.hs +481/−0
• src/HsLua/ObjectOrientation/ListType.hs +166/−0
• test/HsLua/ObjectOrientationTests.hs +14/−18

@@ -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.

@@ -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

@@ -0,0 +1,115 @@+#include <lua.h>+#include <lauxlib.h>+#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);+}

@@ -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;

@@ -0,0 +1,22 @@+#ifndef hslobj_h+#define hslobj_h++#include <lua.h>++/* ***************************************************************+ * 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

@@ -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

@@ -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

@@ -0,0 +1,481 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE OverloadedStrings        #-}+{-# LANGUAGE ScopedTypeVariables      #-}+{-|+Module      : HsLua.ObjectOrientation.Generic+Copyright   : © 2021-2024 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb@hslua.org>++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

@@ -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)

@@ -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