hslua-objectorientation-2.3.0/0000755000000000000000000000000007346545000014541 5ustar0000000000000000hslua-objectorientation-2.3.0/CHANGELOG.md0000644000000000000000000000643407346545000016361 0ustar0000000000000000# Changelog `hslua-objectorientation` uses [PVP Versioning][]. ## hslua-objectorientation-2.3.0 Released 2023-03-13. - Export all constructors and functions of type `Property`. - Renamed `peekUD` to `peekUDGeneric` and `pushUD` to `pushUDGeneric`. Functions with the old names are now now defined hslua-packaging. - Hook for udtype metatable initializer. The function `pushUDGeneric` takes an additional `hook` parameter. The hook operation can be used to perform additional setup operations, e.g., for documentation. The old `pushUD` function can be recovered with pushUD = pushUDGeneric (\_ -> pure ()) The `hslua-packaging` now exports a `pushUD` functions that is specialized to documented types. - Export new function `initTypeGeneric`: The function ensures that a type's metatable is initialized and available from the registry. Just like with `pushUDGeneric`, a hook can be used to augment the initialization. - Type info for properties: Properties are amended with information on the property's type. The functions `property`, `possibleProperty`, and `readonly` each now come with typed version `property'`, `possibleProperty'`, and `readonly`'. This allows to specify the type of a property value. - Functions for object typing info: The functions `udDocs` and `udTypeSpec` are added, enabling the generation of typing information for UDType objects. ## hslua-objectorientation-2.2.1 Released 2022-06-19. - Require hslua-core-2.2.1. - Require hslua-marshalling-2.2.1. ## hslua-objectorientation-2.2.0.1 Released 2022-05-20. - Relax upper bound for mtl, allow mtl-2.3. ## hslua-objectorientation-2.2.0 Released 2022-02-19. - Require version 2.2 of hslua-core and hslua-marshalling. ## hslua-objectorientation-2.1.0 Released 2022-01-29. - Allow integers as aliases: Aliases can now be of type `AliasIndex`, so integers can now be defined as aliases for other properties. The function `alias` now takes an `AliasIndex` instead of a `Name`; the change entails modifications to the types `UDTypeWithList`, `UDType`, and `Member`. Also, `AliasIndex` is made into an instance of the Eq and Ord type classes. - Reworked list representation of objects, allowing write access to list components. The `ListSpec` type has been updated and contains now a pair of pairs, where the inner pairs define how to push and retrieve lists, respectively. Users of the `deftypeGeneric'` function will have to update their code. - Fixed some integer type declarations in C code. Some variables had been given incorrect types, like `int` instead of `lua_Integer`. They are usually the same, but may differ in some setups. - Require hslua-core-2.1.0 and hslua-marshalling-2.1.0, or later. ## hslua-objectorientation-2.0.1 Released 2021-11-04. - Excludes absent properties from `pairs`: Properties that are optional and not present in a sum-type value are no longer included in the iterator output produced by `pairs` (i.e., the `__pairs` metamethod). Previously, the names of absent properties were pushed with a `nil` value. ## hslua-objectorientation-2.0.0 Released 2021-10-21. - Published without warning. [PVP Versioning]: https://pvp.haskell.org hslua-objectorientation-2.3.0/LICENSE0000644000000000000000000000224107346545000015545 0ustar0000000000000000Copyright © 1994-2022 Lua.org, PUC-Rio. Copyright © 2007-2012 Gracjan Polak Copyright © 2012-2015 Ömer Sinan Ağacan Copyright © 2016-2023 Albert Krewinkel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. hslua-objectorientation-2.3.0/README.md0000644000000000000000000000116207346545000016020 0ustar0000000000000000# hslua-objectorientation [![Build status][GitHub Actions badge]][GitHub Actions] [![AppVeyor Status]](https://ci.appveyor.com/project/tarleb/hslua-r2y18) [![Hackage]](https://hackage.haskell.org/package/hslua-objectorientation) Expose Haskell data to Lua with an object oriented interface. [GitHub Actions badge]: https://img.shields.io/github/workflow/status/hslua/hslua/CI.svg?logo=github [GitHub Actions]: https://github.com/hslua/hslua/actions [AppVeyor Status]: https://ci.appveyor.com/api/projects/status/ldutrilgxhpcau94/branch/main?svg=true [Hackage]: https://img.shields.io/hackage/v/hslua-objectorientation.svg hslua-objectorientation-2.3.0/cbits/0000755000000000000000000000000007346545000015645 5ustar0000000000000000hslua-objectorientation-2.3.0/cbits/hslobj.c0000644000000000000000000002373407346545000017303 0ustar0000000000000000#include #include #include #include /* *************************************************************** * Helpers for fast element access * ***************************************************************/ /* ** Pushes the caching table of the userdata at index `idx` to the stack. ** ** 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) { 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 */ lua_createtable(L, 0, 0); lua_pushvalue(L, -1); lua_setuservalue(L, idx); } /* ** Retrieve a value from the wrapped userdata project. The userdata must ** be in position 1, and the key in position 2. Returns 1 if a value was ** 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) { /* Use value in caching table if present */ hsluaO_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 */ return 0; } /* found the key in the cache */ return 1; } /* ** 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) { /* Bail if there are no getterns, or no getter for the given key. */ if (luaL_getmetafield(L, 1, "getters") != LUA_TTABLE) { return 0; } lua_pushvalue(L, 2); /* key */ if (lua_rawget(L, -2) == LUA_TNIL) { lua_pop(L, 1); return 0; } /* Call getter. Slow, as it calls into Haskell. */ lua_pushvalue(L, 1); lua_call(L, 1, 1); /* key found in wrapped userdata, add to caching table */ hsluaO_get_caching_table(L, 1); /* object's caching table */ lua_pushvalue(L, 2); /* key */ lua_pushvalue(L, -3); /* value */ lua_rawset(L, -3); lua_pop(L, 1); /* pop caching table */ /* return value */ return 1; } /* ** Retrieve a value by using the key as the alias for a different ** property. The userdata must be in position 1, and the key in position ** 2. */ int hsluaO_get_via_alias(lua_State *L) { if (luaL_getmetafield(L, 1, "aliases") != LUA_TTABLE) { return 0; /* no aliases available */ } lua_pushvalue(L, 2); if (lua_rawget(L, -2) != LUA_TTABLE) { lua_pop(L, 2); /* key is not an alias */ return 0; /* try a different method */ } /* key is an alias */ lua_pushvalue(L, 1); /* start with the original object */ /* Iterate over properties; last object is on top of stack, * list of properties is the second object. */ lua_Integer len = (lua_Integer) lua_rawlen(L, -2); for (lua_Integer i = 1; i <= len; i++) { lua_rawgeti(L, -2, i); int objtype = lua_gettable(L, -2); /* get property */ lua_remove(L, -2); /* remove previous object */ if (!objtype) break; /* abort if this property of the alias is absent */ } return 1; } /* ** 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) { if (luaL_getmetafield(L, 1, "methods") != LUA_TTABLE) { lua_pop(L, 1); return 0; } lua_pushvalue(L, 2); lua_rawget(L, -2); return 1; } /* ** 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 ** result is stored in the cache before it is returned. ** ** For non-integer keys, it tries 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; ** + tries to lookup the key as an alias and retrieves the value of the ** alias; ** + looks up the key in the table in the `methods` metafield. */ int hslua_udindex(lua_State *L) { lua_settop(L, 2); /* do numeric lookup for integer keys */ return lua_isinteger(L, 2) ? (hsluaO_get_via_alias(L) || hsluaO_get_numerical(L)) /* try various sources in order; return 0 if nothing is found. */ : (hsluaO_get_from_cache(L) || hsluaO_get_via_getter(L) || hsluaO_get_via_alias(L) || hsluaO_get_method(L)); } /* ** 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) { if (luaL_getmetafield(L, 1, "aliases") != LUA_TTABLE) { return 0; } lua_pushvalue(L, 2); if (lua_rawget(L, -2) != LUA_TTABLE) { /* key is an alias */ lua_pop(L, 2); return 0; } lua_pushvalue(L, 1); /* start with the original object */ /* Iterate over properties; last object is on top of stack, * list of properties is the second object. */ lua_Integer len = (lua_Integer) lua_rawlen(L, -2); for (int i = 1; i < len; i++) { lua_rawgeti(L, -2, i); lua_gettable(L, -2); /* get property */ lua_remove(L, -2); /* remove previous object */ } lua_rawgeti(L, -2, len); /* last element */ lua_pushvalue(L, 3); /* new value */ lua_settable(L, -3); return 1; } /* ** Sets a numerical index on this object. The userdata must be in ** position 1, the key in position 2, and the new value in position 3. ** Returns 1 on success and 0 otherwise. */ 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) { if (luaL_getmetafield(L, 1, "setters") != LUA_TTABLE) return 0; lua_pushvalue(L, 2); /* key */ if (lua_rawget(L, -2) != LUA_TFUNCTION) { lua_pop(L, 1); lua_pushliteral(L, "Cannot set unknown property."); return lua_error(L); } lua_insert(L, 1); lua_settop(L, 4); /* 1: setter, 2: ud, 3: key, 4: value */ lua_call(L, 3, 0); return 1; } /* ** 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. */ 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; } lua_pushliteral(L, "Cannot modify read-only object."); return lua_error(L); } /* ** Sets a value in the userdata's caching table (uservalue). Takes the ** same arguments as a `__newindex` function. */ int hslua_udsetter(lua_State *L) { luaL_checkany(L, 3); lua_settop(L, 3); hsluaO_get_caching_table(L, 1); lua_insert(L, 2); lua_rawset(L, 2); return 0; } /* ** Throws an error noting that the given key is read-only. */ int hslua_udreadonly(lua_State *L) { if (lua_type(L, 2) == LUA_TSTRING && lua_checkstack(L, 3)) { lua_pushliteral(L, "'"); lua_pushvalue(L, 2); lua_pushliteral(L, "' is a read-only property."); lua_concat(L, 3); } else { lua_pushliteral(L, "Cannot set read-only value."); } return lua_error(L); } hslua-objectorientation-2.3.0/hslua-objectorientation.cabal0000644000000000000000000000654107346545000022367 0ustar0000000000000000cabal-version: 2.2 name: hslua-objectorientation version: 2.3.0 synopsis: Object orientation tools for HsLua description: Expose Haskell objects to Lua with an object oriented interface. homepage: https://hslua.org/ bug-reports: https://github.com/hslua/hslua/issues license: MIT license-file: LICENSE author: Albert Krewinkel maintainer: tarleb@hslua.org copyright: © 2021-2023 Albert Krewinkel category: Foreign build-type: Simple extra-source-files: README.md , CHANGELOG.md tested-with: GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.5 , GHC == 9.4.4 source-repository head type: git location: https://github.com/hslua/hslua.git subdir: hslua-objectorientation common common-options default-language: Haskell2010 build-depends: base >= 4.11 && < 5 , bytestring >= 0.10.2 && < 0.12 , containers >= 0.5.9 && < 0.7 , 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.1 ghc-options: -Wall -Wincomplete-record-updates -Wnoncanonical-monad-instances -Wredundant-constraints if impl(ghc >= 8.2) ghc-options: -Wcpp-undef -Werror=missing-home-modules if impl(ghc >= 8.4) ghc-options: -Widentities -Wincomplete-uni-patterns -Wpartial-fields -fhide-source-paths other-extensions: OverloadedStrings , TypeApplications library import: common-options exposed-modules: HsLua.ObjectOrientation , HsLua.ObjectOrientation.Operation hs-source-dirs: src default-extensions: LambdaCase , StrictData other-extensions: AllowAmbiguousTypes , CPP , FlexibleInstances , MultiParamTypeClasses , ScopedTypeVariables c-sources: cbits/hslobj.c test-suite test-hslua-objectorientation import: common-options type: exitcode-stdio-1.0 main-is: test-hslua-objectorientation.hs hs-source-dirs: test 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 , tasty >= 0.11 , tasty-hslua >= 1.0 , tasty-hunit >= 0.9 , tasty-quickcheck >= 0.8 hslua-objectorientation-2.3.0/src/HsLua/0000755000000000000000000000000007346545000016344 5ustar0000000000000000hslua-objectorientation-2.3.0/src/HsLua/ObjectOrientation.hs0000644000000000000000000005006107346545000022324 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-| Module : HsLua.ObjectOrientation Copyright : © 2021-2023 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 ( 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 (..) ) 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) ) -- | 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 -- | Defines a new type, defining 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 -> 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 hslua-objectorientation-2.3.0/src/HsLua/ObjectOrientation/0000755000000000000000000000000007346545000021766 5ustar0000000000000000hslua-objectorientation-2.3.0/src/HsLua/ObjectOrientation/Operation.hs0000644000000000000000000001506507346545000024271 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-| Module : HsLua.ObjectOrientation.Operation Copyright : © 2020-2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Binary and unary object operations. -} module HsLua.ObjectOrientation.Operation ( Operation (..) , metamethodName ) where import HsLua.Core (Name) -- | Lua metadata operation types. data Operation = Add -- ^ the addition (@+@) operation. If any operand for an -- addition is not a number (nor a string coercible to a -- number), Lua will try to call a metamethod. First, Lua will -- check the first operand (even if it is valid). If that -- operand does not define a metamethod for @__add@, then Lua -- will check the second operand. If Lua can find a -- metamethod, it calls the metamethod with the two operands -- as arguments, and the result of the call (adjusted to one -- value) is the result of the operation. Otherwise, it raises -- an error. | Sub -- ^ the subtraction (@-@) operation. Behavior similar to the -- addition operation. | Mul -- ^ the multiplication (@*@) operation. Behavior similar to the -- addition operation. | Div -- ^ the division (@/@) operation. Behavior similar to the -- addition operation. | Mod -- ^ the modulo (@%@) operation. Behavior similar to the -- addition operation. | Pow -- ^ the exponentiation (@^@) operation. Behavior similar to the -- addition operation. | Unm -- ^ the negation (unary @-@) operation. Behavior similar to the -- addition operation. | Idiv -- ^ the floor division (@//@) operation. Behavior similar to -- the addition operation. | Band -- ^ the bitwise AND (@&@) operation. Behavior similar to the -- addition operation, except that Lua will try a metamethod -- if any operand is neither an integer nor a value coercible -- to an integer (see §3.4.3). | Bor -- ^ the bitwise OR (@|@) operation. Behavior similar to the -- bitwise AND operation. | Bxor -- ^ the bitwise exclusive OR (binary @~@) operation. Behavior -- similar to the bitwise AND operation. | Bnot -- ^ the bitwise NOT (unary @~@) operation. Behavior similar to -- the bitwise AND operation. | Shl -- ^ the bitwise left shift (@<<@) operation. Behavior similar -- to the bitwise AND operation. | Shr -- ^ the bitwise right shift (@>>@) operation. Behavior -- similar to the bitwise AND operation. | Concat -- ^ the concatenation (@..@) operation. Behavior similar to -- the addition operation, except that Lua will try a -- metamethod if any operand is neither a string nor a number -- (which is always coercible to a string). | Len -- ^ the length (@#@) operation. If the object is not a string, -- Lua will try its metamethod. If there is a metamethod, Lua -- calls it with the object as argument, and the result of the -- call (always adjusted to one value) is the result of the -- operation. If there is no metamethod but the object is a -- table, then Lua uses the table length operation (see -- §3.4.7). Otherwise, Lua raises an error. | Eq -- ^ the equal (@==@) operation. Behavior similar to the -- addition operation, except that Lua will try a metamethod -- only when the values being compared are either both tables -- or both full userdata and they are not primitively equal. -- The result of the call is always converted to a boolean. | Lt -- ^ the less than (@<@) operation. Behavior similar to the -- addition operation, except that Lua will try a metamethod -- only when the values being compared are neither both -- numbers nor both strings. The result of the call is always -- converted to a boolean. | Le -- ^ the less equal (@<=@) operation. Unlike other operations, -- the less-equal operation can use two different events. -- First, Lua looks for the @__le@ metamethod in both -- operands, like in the less than operation. If it cannot -- find such a metamethod, then it will try the @__lt@ -- metamethod, assuming that a <= b is equivalent to not (b < -- a). As with the other comparison operators, the result is -- always a boolean. (This use of the @__lt@ event can be -- removed in future versions; it is also slower than a real -- __le metamethod.) | Index -- ^ The indexing access operation @table[key]@. This event -- happens when table is not a table or when key is not -- present in table. The metamethod is looked up in table. | Newindex -- ^ The indexing assignment @table[key] = value@. Like the -- index event, this event happens when table is not a table -- or when key is not present in table. The metamethod is -- looked up in table. | Call -- ^ The call operation @func(args)@. This event happens when -- Lua tries to call a non-function value (that is, func is -- not a function). The metamethod is looked up in func. If -- present, the metamethod is called with func as its first -- argument, followed by the arguments of the original call -- (args). All results of the call are the result of the -- operation. (This is the only metamethod that allows -- multiple results.) | Tostring -- ^ The operation used to create a string representation of -- the object. | Pairs -- ^ the operation of iterating over the object's key-value -- pairs. | CustomOperation Name -- ^ a custom operation, with the metamethod name as -- parameter. deriving (Eq, Ord, Show) -- | Returns the metamethod name used to control this operation. metamethodName :: Operation -> Name metamethodName = \case Add -> "__add" Sub -> "__sub" Mul -> "__mul" Div -> "__div" Mod -> "__mod" Pow -> "__pow" Unm -> "__unm" Idiv -> "__idiv" Band -> "__band" Bor -> "__bor" Bxor -> "__bxor" Bnot -> "__bnot" Shl -> "__shl" Shr -> "__shr" Concat -> "__concat" Len -> "__len" Eq -> "__eq" Lt -> "__lt" Le -> "__le" Index -> "__index" Newindex -> "__newindex" Call -> "__call" Tostring -> "__tostring" Pairs -> "__pairs" CustomOperation x -> x hslua-objectorientation-2.3.0/test/HsLua/0000755000000000000000000000000007346545000016534 5ustar0000000000000000hslua-objectorientation-2.3.0/test/HsLua/ObjectOrientationTests.hs0000644000000000000000000004052707346545000023545 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-| Module : HsLua.ObjectOrientationTests Copyright : © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : beta Portability : non-portable (depends on GHC) Test that conversions from and to the Lua stack are isomorphisms. -} module HsLua.ObjectOrientationTests (tests) where import HsLua.Core import HsLua.ObjectOrientation import HsLua.Marshalling import HsLua.Typing import Test.Tasty (TestTree, testGroup) import Test.Tasty.HsLua ((=:), shouldBeResultOf, shouldBeErrorMessageOf) import qualified Data.ByteString.Char8 as Char8 -- | Tests for HsLua object orientation. tests :: TestTree tests = testGroup "Object Orientation" [ testGroup "Sample product type" [ "tostring" =: "Foo 7 \"seven\"" `shouldBeResultOf` do openlibs pushUD typeFoo $ Foo 7 "seven" setglobal "foo" _ <- dostring "return tostring(foo)" forcePeek $ peekText top , "show" =: "Foo 5 \"five\"" `shouldBeResultOf` do openlibs pushUD typeFoo $ Foo 5 "five" setglobal "foo" _ <- dostring "return foo:show()" forcePeek $ peekText top , "peek" =: Foo 37 "ananas" `shouldBeResultOf` do pushUD typeFoo $ Foo 37 "ananas" forcePeek $ peekUDGeneric typeFoo top , "unknown properties have value `nil`" =: TypeNil `shouldBeResultOf` do openlibs pushUD typeFoo $ Foo (-1) "a" setglobal "foo" dostring "return foo.does_not_exist" >>= \case OK -> ltype top _ -> throwErrorAsException , "get number" =: (-1) `shouldBeResultOf` do openlibs pushUD typeFoo $ Foo (-1) "a" setglobal "foo" dostring "return foo.num" >>= \case OK -> forcePeek $ peekIntegral @Int top _ -> throwErrorAsException , "get number twice" =: 8 `shouldBeResultOf` do openlibs pushUD typeFoo $ Foo 4 "d" setglobal "foo" dostring "return foo.num + foo.num" >>= \case OK -> forcePeek $ peekIntegral @Int top _ -> throwErrorAsException , "modify number" =: Foo (-1) "a" `shouldBeResultOf` do openlibs pushUD typeFoo $ Foo 1 "a" setglobal "foo" OK <- dostring "foo.num = -1" TypeUserdata <- getglobal "foo" forcePeek $ peekUDGeneric typeFoo top , "get string" =: "lint" `shouldBeResultOf` do openlibs pushUD typeFoo $ Foo 0 "lint" setglobal "foo" dostring "return foo.str" >>= \case OK -> forcePeek $ peekText top _ -> throwErrorAsException , "cannot change readonly string" =: "'str' is a read-only property." `shouldBeErrorMessageOf` do openlibs pushUD typeFoo $ Foo 2 "b" setglobal "foo" ErrRun <- dostring "foo.str = 'c'" throwErrorAsException :: Lua () , "Can peek after getting read-only property" =: Foo 144 "gros" `shouldBeResultOf` do openlibs pushUD typeFoo $ Foo 144 "gros" setglobal "foo" OK <- dostring "bar = foo.str" _ <- getglobal "foo" forcePeek $ peekUDGeneric typeFoo top , "cannot change unknown property" =: "Cannot set unknown property." `shouldBeErrorMessageOf` do openlibs pushUD typeFoo $ Foo 11 "eleven" setglobal "foo" ErrRun <- dostring "foo.does_not_exist = nil" throwErrorAsException :: Lua () , "pairs iterates over properties" =: ["num", "5", "str", "echo", "show", "function"] `shouldBeResultOf` do openlibs pushUD typeFoo $ Foo 5 "echo" setglobal "echo" OK <- dostring $ Char8.unlines [ "local result = {}" , "for k, v in pairs(echo) do" , " table.insert(result, k)" , " table.insert(" , " result," , " type(v) == 'function' and 'function' or tostring(v)" , " )" , "end" , "return result" ] forcePeek $ peekList peekText top , "absent properties are not included in `pairs`" =: [("num", "number"), ("str", "string"), ("show", "function")] `shouldBeResultOf` do openlibs pushUD typeQux $ Quux 1 "a" setglobal "a" OK <- dostring $ Char8.unlines [ "local result = {}" , "for k, v in pairs(a) do result[#result+1] = {k, type(v)} end" , "return result" ] forcePeek $ peekList (peekPair peekText peekText) top ] , testGroup "Bar type" [ "Modifying a table modifies the object" =: Bar [7, 8] `shouldBeResultOf` do openlibs pushUD typeBar $ Bar [7] setglobal "bar" OK <- dostring "table.insert(bar.nums, 8)" _ <- getglobal "bar" forcePeek $ peekUDGeneric typeBar top , "Use integer index in alias" =: 42 `shouldBeResultOf` do openlibs pushUD typeBar $ Bar [42, 5, 23] setglobal "bar" OK <- dostring "return bar.first" forcePeek $ peekIntegral @Int top ] , testGroup "initType" [ "type table is added to the registry" =: TypeTable `shouldBeResultOf` do openlibs name <- initTypeGeneric (\_ -> pure ()) typeBar getfield registryindex name , "type table is not in registry when uninitialized" =: TypeNil `shouldBeResultOf` do openlibs getfield registryindex (udName (typeBar @HsLua.Core.Exception)) , "initializing does not affect the stack" =: 0 `shouldBeResultOf` do openlibs before <- gettop _ <- initTypeGeneric (\_ -> pure ()) typeBar after <- gettop return $ after - before ] , testGroup "lazy list" [ "Access an element of a lazy list stub" =: 3 `shouldBeResultOf` do openlibs pushUD typeLazyIntList $ LazyIntList [1,1,2,3,5,8] setglobal "list" _ <- dostring "return (list[4])" forcePeek $ peekIntegral @Int top , "Remaining list is not evaluated" =: 2 `shouldBeResultOf` do openlibs pushUD typeLazyIntList $ LazyIntList [1,1,2, Prelude.error "CRASH!"] setglobal "list" _ <- dostring "return (list[3])" forcePeek $ peekIntegral @Int top , "Out-of-bounds indices return nil" =: (TypeNil, TypeNil) `shouldBeResultOf` do openlibs pushUD typeLazyIntList $ LazyIntList [1,4,9,16] setglobal "list" _ <- dostring "return list[0], list[5]" (,) <$> ltype (nth 1) <*> ltype (nth 2) , "Last evaled index is available in __lazylistindex" =: 3 `shouldBeResultOf` do openlibs pushUD typeLazyIntList $ LazyIntList [9..17] setglobal "quuz" _ <- dostring "local foo = quuz[3]; return quuz.__lazylistindex" forcePeek $ peekIntegral @Int top , "__lazylistindex becomes `false` when all items are evaled" =: False `shouldBeResultOf` do openlibs pushUD typeLazyIntList $ LazyIntList [1..3] setglobal "quuz" _ <- dostring "local foo = quuz[3]; return quuz.__lazylistindex" forcePeek $ peekBool top , "Input can be retrieved unchanged" =: LazyIntList [9..17] `shouldBeResultOf` do openlibs pushUD typeLazyIntList $ LazyIntList [9..17] setglobal "ninetofive" _ <- dostring "assert(ninetofive[3] == 11); return ninetofive" forcePeek $ peekUDGeneric typeLazyIntList top , "List is writable" =: LazyIntList [1, 4, 9, 16] `shouldBeResultOf` do openlibs pushUD typeLazyIntList $ LazyIntList [0,4,9,16] setglobal "list" OK <- dostring "list[1] = 1; return list" forcePeek $ peekUDGeneric typeLazyIntList top , "List can be extended" =: LazyIntList [1, 4, 9, 16, 25] `shouldBeResultOf` do openlibs pushUD typeLazyIntList $ LazyIntList [1,4,9,16] setglobal "list" OK <- dostring "list[5] = 25; return list" forcePeek $ peekUDGeneric typeLazyIntList top , "List can be shortened" =: LazyIntList [1, 9, 27, 81] `shouldBeResultOf` do openlibs pushUD typeLazyIntList $ LazyIntList [1, 9, 27, 81, 243] setglobal "list" OK <- dostring "list[5] = nil; return list" forcePeek $ peekUDGeneric typeLazyIntList top , "Setting element to nil shortenes the list" =: LazyIntList [1, 9, 27] `shouldBeResultOf` do openlibs pushUD typeLazyIntList $ LazyIntList [1, 9, 27, 81, 243] setglobal "list" OK <- dostring "list[4] = nil; return list" forcePeek $ peekUDGeneric typeLazyIntList top , "Infinite lists are ok" =: 233 `shouldBeResultOf` do openlibs let fibs = 0 : 1 : zipWith (+) fibs (tail fibs) pushUD typeLazyIntList $ LazyIntList fibs setglobal "fibs" dostring "return fibs[14]" >>= \case OK -> forcePeek $ peekIntegral @Int top _ -> failLua =<< forcePeek (peekString top) ] , testGroup "possible properties" [ "tostring Quux" =: "Quux 11 \"eleven\"" `shouldBeResultOf` do openlibs pushUD typeQux $ Quux 11 "eleven" setglobal "quux" _ <- dostring "return tostring(quux)" forcePeek $ peekText top , "show Quux" =: "Quux 11 \"eleven\"" `shouldBeResultOf` do openlibs pushUD typeQux $ Quux 11 "eleven" setglobal "quux" _ <- dostring "return quux:show()" forcePeek $ peekText top , "access Quux.num" =: "12" `shouldBeResultOf` do openlibs pushUD typeQux $ Quux 12 "twelve" setglobal "quux" _ <- dostring "return quux.num" forcePeek $ peekText top , "access Quux.str" =: "thirteen!" `shouldBeResultOf` do openlibs pushUD typeQux $ Quux 13 "thirteen" setglobal "quux" _ <- dostring "return quux.num" _ <- dostring "quux.str = quux.str .. '!'; return quux.str" forcePeek $ peekText top , testGroup "alias" [ "read subelement via alias" =: 13.37 `shouldBeResultOf` do openlibs pushUD typeQux $ Quuz (Point 13.37 0) undefined setglobal "quuz" _ <- dostring "return quuz.x" forcePeek $ peekRealFloat @Double top , "set subelement via alias" =: Point 42 1 `shouldBeResultOf` do openlibs pushUD typeQux $ Quuz (Point 1 1) undefined setglobal "quuz" _ <- dostring "quuz.x = 42; return quuz.point" -- msg <- forcePeek $ peekString top -- liftIO $ putStrLn msg forcePeek $ peekPoint top , "read subelement via integer alias" =: 13.37 `shouldBeResultOf` do openlibs pushUD typeQux $ Quuz (Point 13.37 0) undefined setglobal "quuz" _ <- dostring "return quuz[1]" forcePeek $ peekRealFloat @Double top , "set subelement via integer alias" =: Point 42 1 `shouldBeResultOf` do openlibs pushUD typeQux $ Quuz (Point 1 1) undefined setglobal "quuz" _ <- dostring "quuz[1] = 42; return quuz.point" forcePeek $ peekPoint top , "non-aliased integer fields are nil" =: TypeNil `shouldBeResultOf` do openlibs pushUD typeQux (Quuz undefined undefined) setglobal "quuz" _ <- dostring "return quuz[3]" ltype top , "absent alias returns `nil`" =: TypeNil `shouldBeResultOf` do openlibs pushUD typeQux (Quux 9 "to five") setglobal "quux" dostring "return quux.x" >>= \case OK -> ltype top _ -> failLua =<< forcePeek (peekString top) , "alias can point to the element itself" =: 9 `shouldBeResultOf` do openlibs pushUD typeLazyIntList (LazyIntList [1, 1, 1, 3, 5, 9, 17, 31]) setglobal "tribonacci" dostring "return tribonacci.seq[6]" >>= \case OK -> forcePeek $ peekIntegral @Int top _ -> failLua =<< forcePeek (peekString top) ] ] ] deftype :: LuaError e => Name -- ^ type name -> [(Operation, HaskellFunction e)] -- ^ operations -> [Member e (HaskellFunction e) a] -- ^ methods -> 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 ())) -- | Define a (meta) operation on a type. operation :: Operation -> HaskellFunction e -> (Operation, HaskellFunction e) operation = (,) -- | Sample product type data Foo = Foo Int String deriving (Eq, Show) -- | Specify behavior of Foo values in Lua. typeFoo :: LuaError e => UDType e (HaskellFunction e) Foo typeFoo = deftype "Foo" [ operation Tostring show' ] [ property "num" "some number" (pushIntegral, \(Foo n _) -> n) (peekIntegral, \(Foo _ s) n -> Foo n s) , readonly "str" "some string" (pushString, \(Foo _ s) -> s) , methodGeneric "show" show' ] where show' = do foo <- forcePeek $ peekUDGeneric typeFoo (nthBottom 1) pushString (show foo) return (NumResults 1) newtype Bar = Bar [Int] deriving (Eq, Show) typeBar :: LuaError e => UDType e (HaskellFunction e) Bar typeBar = deftype "Bar" [] [ property' "nums" (seqType integerType) "some numbers" (pushList pushIntegral, \(Bar nums) -> nums) (peekList peekIntegral, \(Bar _) nums -> Bar nums) , alias "first" "first element" ["nums", IntegerIndex 1] ] newtype LazyIntList = LazyIntList { fromLazyIntList :: [Int] } deriving (Eq, Show) typeLazyIntList :: LuaError e => UDTypeWithList e (HaskellFunction e) LazyIntList Int typeLazyIntList = deftype' "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) )) -- -- Sample sum type -- data Qux = Quux Int String | Quuz Point Int deriving (Eq, Show) data Point = Point Double Double deriving (Eq, Show) pushPoint :: LuaError e => Pusher e Point pushPoint (Point x y) = do newtable pushName "x" *> pushRealFloat x *> rawset (nth 3) pushName "y" *> pushRealFloat y *> rawset (nth 3) peekPoint :: LuaError e => Peeker e Point peekPoint idx = do x <- peekFieldRaw peekRealFloat "x" idx y <- peekFieldRaw peekRealFloat "y" idx return $ x `seq` y `seq` Point x y pointType :: TypeSpec pointType = recType [ ("x", numberType) , ("y", numberType) ] showQux :: LuaError e => HaskellFunction e showQux = do qux <- forcePeek $ peekQux (nthBottom 1) pushString $ show qux return (NumResults 1) peekQux :: LuaError e => Peeker e Qux peekQux = peekUDGeneric typeQux typeQux :: LuaError e => UDType e (HaskellFunction e) Qux typeQux = deftype "Qux" [ operation Tostring showQux ] [ methodGeneric "show" showQux , property' "num" integerType "some number" (pushIntegral, \case Quux n _ -> n Quuz _ n -> n) (peekIntegral, \case Quux _ s -> (`Quux` s) Quuz d _ -> Quuz d) , possibleProperty' "str" stringType "a string in Quux" (pushString, \case Quux _ s -> Actual s Quuz {} -> Absent) (peekString, \case Quux n _ -> Actual . Quux n Quuz {} -> const Absent) , possibleProperty' "point" pointType "a point in Quuz" (pushPoint, \case Quuz p _ -> Actual p Quux {} -> Absent) (peekPoint, \case Quuz _ n -> Actual . (`Quuz` n) Quux {} -> const Absent) , alias "x" "The x coordinate of a point in Quuz" ["point", "x"] , alias (IntegerIndex 1) "The x coordinate of a point in Quuz" ["point", "x"] ] hslua-objectorientation-2.3.0/test/0000755000000000000000000000000007346545000015520 5ustar0000000000000000hslua-objectorientation-2.3.0/test/test-hslua-objectorientation.hs0000644000000000000000000000120107346545000023657 0ustar0000000000000000{-| Module : Main Copyright : © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : beta Portability : non-portable (depends on GHC) Test marshaling/unmarshaling from and to the Lua stack. -} module Main (main) where import Test.Tasty (TestTree, defaultMain, testGroup) import qualified HsLua.ObjectOrientationTests main :: IO () main = defaultMain $ testGroup "hslua-objectorientation" tests -- | HSpec tests tests :: [TestTree] tests = [ HsLua.ObjectOrientationTests.tests ]