diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog + +`hslua-objectorientation` uses [PVP Versioning][1]. + +## hslua-objectorientation 1.0.0 + +Release pending. + +- Published without warning. + +[1]: https://pvp.haskell.org diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,23 @@ +Copyright © 1994-2020 Lua.org, PUC-Rio. +Copyright © 2007-2012 Gracjan Polak +Copyright © 2012-2015 Ömer Sinan Ağacan +Copyright © 2016-2021 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +# 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 diff --git a/cbits/hslobj.c b/cbits/hslobj.c new file mode 100644 --- /dev/null +++ b/cbits/hslobj.c @@ -0,0 +1,280 @@ +#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) { + return 0; /* key is not an alias */ + } + + /* 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. */ + for (int i = 1; i <= lua_rawlen(L, -2); i++) { + lua_rawgeti(L, -2, i); + lua_gettable(L, -2); /* get property */ + lua_remove(L, -2); /* remove previous object */ + } + 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); + int requested = lua_tointeger(L, 2); + + lua_getfield(L, 1, "__lazylistindex"); + int 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 */ + if (luaL_getmetafield(L, 1, "lazylisteval") == LUA_TFUNCTION && + lua_getfield(L, 3, "__lazylist") == LUA_TUSERDATA) { + 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_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. */ + for (int i = 1; i < lua_rawlen(L, -2); i++) { + lua_rawgeti(L, -2, i); + lua_gettable(L, -2); /* get property */ + lua_remove(L, -2); /* remove previous object */ + } + lua_rawgeti(L, -2, lua_rawlen(L, -2)); /* last element */ + lua_pushvalue(L, 3); /* new value */ + lua_settable(L, -3); + 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) { + 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); +} diff --git a/hslua-objectorientation.cabal b/hslua-objectorientation.cabal new file mode 100644 --- /dev/null +++ b/hslua-objectorientation.cabal @@ -0,0 +1,83 @@ +cabal-version: 2.2 +name: hslua-objectorientation +version: 2.0.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: albert+hslua@zeitkraut.de +copyright: © 2021 Albert Krewinkel +category: Foreign +build-type: Simple +extra-source-files: README.md + , CHANGELOG.md +tested-with: GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.4 + , GHC == 9.0.1 + +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.8 && < 5 + , bytestring >= 0.10.2 && < 0.12 + , containers >= 0.5.9 && < 0.7 + , exceptions >= 0.8 && < 0.11 + , hslua-core >= 2.0 && < 2.1 + , hslua-marshalling >= 2.0 && < 2.1 + , mtl >= 2.2 && < 2.3 + , text >= 1.0 && < 1.3 + 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 + 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 diff --git a/src/HsLua/ObjectOrientation.hs b/src/HsLua/ObjectOrientation.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/ObjectOrientation.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : HsLua.ObjectOrientation +Copyright : © 2021 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 (..) + , deftypeGeneric + , deftypeGeneric' + , methodGeneric + , property + , possibleProperty + , readonly + , alias + , peekUD + , pushUD + -- * Helper types for building + , Member + , Property + , Operation (..) + , ListSpec + , Possible (..) + , AliasIndex (..) + ) where + +import Control.Monad.Except +import Foreign.Ptr (FunPtr) +import Data.Maybe (mapMaybe) +import Data.Map (Map) +#if !MIN_VERSION_base(4,12,0) +import Data.Semigroup (Semigroup ((<>))) +#endif +import Data.String (IsString (..)) +import Data.Text (Text) +import Data.Void (Void) +import HsLua.Core as Lua +import HsLua.Marshalling +import HsLua.ObjectOrientation.Operation +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. +data UDTypeWithList e fn a itemtype = UDTypeWithList + { udName :: Name + , udOperations :: [(Operation, fn)] + , udProperties :: Map Name (Property e a) + , udMethods :: Map Name fn + , udAliases :: Map Name Alias + , udListSpec :: Maybe (ListSpec e a itemtype) + , udFnPusher :: fn -> LuaE e () + } + +type ListSpec e a itemtype = (a -> [itemtype], Pusher e itemtype) + +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 + } + +-- | 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 + +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 Name 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 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 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) + <> "." + , 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 desc (push, get) = MemberProperty name $ + Property + { propertyGet = \x -> do + push $ get x + return (NumResults 1) + , propertySet = Nothing + , propertyDescription = desc + } + +-- | Define an alias for another, possibly nested, property. +alias :: Name -- ^ property alias + -> Text -- ^ description + -> [AliasIndex] -- ^ sequence of nested properties + -> Member e fn a +alias name _desc = MemberAlias name + +-- | 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. +pushUDMetatable :: LuaError e => UDTypeWithList e fn a itemtype -> 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 + case udListSpec ty of + Nothing -> pure () + Just (_, pushItem) -> do + add "lazylisteval" $ pushHaskellFunction (lazylisteval pushItem) + 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 (peekUD 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 + pushName 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 $ peekUD ty (nthBottom 1) + let pushMember = \case + MemberProperty name prop -> do + pushName name + getresults <- propertyGet prop obj + 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 last 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 + -- put back remaining unevalled list + _ <- putuserdata @[itemtype] (nthBottom 1) lazyListStateName rest + -- push evaluated elements + settop 4 -- ensure caching table is at the top of the stack + forM_ (zip [(curindex + 1)..] as) $ \(i, a) -> do + pushItem a + rawseti (nthBottom 4) i + pushName "__lazylistindex" + pushinteger (curindex + fromIntegral (length as)) + rawset (nthBottom 4) + 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. +pushUD :: LuaError e => UDTypeWithList e fn a itemtype -> a -> LuaE e () +pushUD ty x = do + newhsuserdata x + pushUDMetatable ty + setmetatable (nth 2) + -- add list as value in caching table + case udListSpec ty of + Nothing -> pure () + Just (toList, _) -> do + newtable + pushName "__lazylist" + newhsuserdata (toList x) + void (newudmetatable lazyListStateName) + setmetatable (nth 2) + rawset (nth 3) + setuservalue (nth 2) + +-- | Retrieves a userdata value of the given type. +peekUD :: LuaError e => UDTypeWithList e fn a itemtype -> Peeker e a +peekUD ty idx = do + let name = udName ty + x <- reportValueOnFailure name (`fromuserdata` name) idx + liftLua $ do + result <- getuservalue idx >>= \case + TypeTable -> do + pushnil + setProperties (udProperties ty) x + _ -> do + return x + pop 1 -- uservalue (caching) table + return result + +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 diff --git a/src/HsLua/ObjectOrientation/Operation.hs b/src/HsLua/ObjectOrientation/Operation.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/ObjectOrientation/Operation.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : HsLua.ObjectOrientation.Operation +Copyright : © 2020-2021 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 diff --git a/test/HsLua/ObjectOrientationTests.hs b/test/HsLua/ObjectOrientationTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/ObjectOrientationTests.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : HsLua.ObjectOrientationTests +Copyright : © 2007–2012 Gracjan Polak; + © 2012–2016 Ömer Sinan Ağacan; + © 2017-2021 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 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 $ peekUD 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 $ peekUD 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 $ peekUD 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 + ] + + , 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 $ peekUD 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 "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) + + , "List is read-only" =: + (ErrRun, "Cannot set a numerical value.") `shouldBeResultOf` do + openlibs + pushUD typeLazyIntList $ LazyIntList [1,4,9,16] + setglobal "list" + statusCode <- dostring "list[1] = 2" + err <- forcePeek $ peekString top + pure (statusCode, err) + ] + + , 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 + ] + ] + ] + +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 + +-- | 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 $ peekUD 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" "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 $ peekUD typeLazyIntList (nthBottom 1) + pushString (show lazyList) + return (NumResults 1) + ] + [] + (Just (fromLazyIntList, pushIntegral)) + +-- +-- 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 + +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 = peekUD typeQux + +typeQux :: LuaError e => UDType e (HaskellFunction e) Qux +typeQux = deftype "Qux" + [ operation Tostring showQux ] + [ methodGeneric "show" showQux + , property "num" "some number" + (pushIntegral, \case + Quux n _ -> n + Quuz _ n -> n) + (peekIntegral, \case + Quux _ s -> (`Quux` s) + Quuz d _ -> Quuz d) + + , possibleProperty "str" "a string in Quux" + (pushString, \case + Quux _ s -> Actual s + Quuz {} -> Absent) + (peekString, \case + Quux n _ -> Actual . Quux n + Quuz {} -> const Absent) + + , possibleProperty "point" "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"] + ] diff --git a/test/test-hslua-objectorientation.hs b/test/test-hslua-objectorientation.hs new file mode 100644 --- /dev/null +++ b/test/test-hslua-objectorientation.hs @@ -0,0 +1,24 @@ +{-| +Module : Main +Copyright : © 2007–2012 Gracjan Polak; + © 2012–2016 Ömer Sinan Ağacan; + © 2017-2021 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 ]