hslua-objectorientation 2.2.1 → 2.3.0

raw patch · 7 files changed

+226/−58 lines, 7 filesdep +hslua-typingdep ~basedep ~hslua-coredep ~hslua-marshallingPVP ok

version bump matches the API change (PVP)

Dependencies added: hslua-typing

Dependency ranges changed: base, hslua-core, hslua-marshalling

API changes (from Hackage documentation)

Files

• CHANGELOG.md +38/−1
• LICENSE +1/−1
• hslua-objectorientation.cabal +10/−10
• src/HsLua/ObjectOrientation.hs +123/−24
• src/HsLua/ObjectOrientation/Operation.hs +2/−2
• test/HsLua/ObjectOrientationTests.hs +50/−18
• test/test-hslua-objectorientation.hs +2/−2

@@ -2,6 +2,43 @@  `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.@@ -24,7 +61,7 @@  ## hslua-objectorientation-2.1.0 -Released 29-01-2022.+Released 2022-01-29.  -   Allow integers as aliases: Aliases can now be of type     `AliasIndex`, so integers can now be defined as aliases for

@@ -1,7 +1,7 @@ Copyright © 1994-2022 Lua.org, PUC-Rio. Copyright © 2007-2012 Gracjan Polak Copyright © 2012-2015 Ömer Sinan Ağacan-Copyright © 2016-2022 Albert Krewinkel+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

@@ -1,6 +1,6 @@ cabal-version:       2.2 name:                hslua-objectorientation-version:             2.2.1+version:             2.3.0 synopsis:            Object orientation tools for HsLua description:         Expose Haskell objects to Lua with an object oriented                      interface.@@ -9,20 +9,19 @@ license:             MIT license-file:        LICENSE author:              Albert Krewinkel-maintainer:          albert+hslua@zeitkraut.de-copyright:           © 2021-2022 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.0.2-                   , GHC == 8.2.2-                   , GHC == 8.4.4+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.3+                   , GHC == 9.2.5+                   , GHC == 9.4.4  source-repository head   type:                git@@ -31,12 +30,13 @@  common common-options   default-language:    Haskell2010-  build-depends:       base              >= 4.8    && < 5+  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.3-                     , hslua-marshalling >= 2.2.1  && < 2.3+                     , 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

@@ -1,13 +1,12 @@-{-# LANGUAGE CPP                 #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications    #-} {-| Module      : HsLua.ObjectOrientation-Copyright   : © 2021-2022 Albert Krewinkel+Copyright   : © 2021-2023 Albert Krewinkel License     : MIT-Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Maintainer  : Albert Krewinkel <tarleb@hslua.org>  This module provides types and functions to use Haskell values as userdata objects in Lua. These objects wrap a Haskell value and provide@@ -19,18 +18,30 @@ module HsLua.ObjectOrientation   ( UDType   , UDTypeWithList (..)+    -- * Defining types   , deftypeGeneric   , deftypeGeneric'+    -- ** Methods   , methodGeneric+    -- ** Properties   , property+  , property'   , possibleProperty+  , possibleProperty'   , readonly+  , readonly'+    -- ** Aliases   , alias-  , peekUD-  , pushUD+    -- * Marshaling+  , peekUDGeneric+  , pushUDGeneric+  , initTypeGeneric+    -- * Type docs+  , udDocs+  , udTypeSpec     -- * Helper types for building   , Member-  , Property+  , Property (..)   , Operation (..)   , ListSpec   , Possible (..)@@ -41,9 +52,6 @@ import Control.Monad ((<$!>), forM_, void, when) 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)@@ -51,6 +59,7 @@ 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@@ -132,6 +141,7 @@   { 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.@@ -162,6 +172,19 @@   = 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@@ -182,7 +205,19 @@   -> (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 $+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@@ -195,24 +230,35 @@         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-         -> 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 $+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@@ -220,11 +266,41 @@       -> 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.-pushUDMetatable :: LuaError e => UDTypeWithList e fn a itemtype -> LuaE e ()-pushUDMetatable ty = do+--+--+-- 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@@ -240,6 +316,7 @@       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@@ -284,7 +361,7 @@   newtable   void $ flip Map.traverseWithKey (udProperties ty) $ \name prop -> do     pushName name-    pushHaskellFunction $ forcePeek (peekUD ty 1) >>= propertyGet prop+    pushHaskellFunction $ forcePeek (peekUDGeneric ty 1) >>= propertyGet prop     rawset (nth 3)  -- | Pushes the metatable's @setters@ field table.@@ -325,7 +402,7 @@ 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)+  obj <- forcePeek $ peekUDGeneric ty (nthBottom 1)   let pushMember = \case         MemberProperty name prop -> do           pushName name@@ -383,10 +460,14 @@ 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+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 ty+  pushUDMetatable pushDocs ty   setmetatable (nth 2)   -- add list as value in caching table   case udListSpec ty of@@ -401,8 +482,8 @@       void (setiuservalue (nth 2) 1)  -- | Retrieves a userdata value of the given type.-peekUD :: LuaError e => UDTypeWithList e fn a itemtype -> Peeker e a-peekUD ty idx = do+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@@ -465,3 +546,21 @@                   (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

@@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} {-| Module      : HsLua.ObjectOrientation.Operation-Copyright   : © 2020-2022 Albert Krewinkel+Copyright   : © 2020-2023 Albert Krewinkel License     : MIT-Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Maintainer  : Albert Krewinkel <tarleb@hslua.org>  Binary and unary object operations. -}

@@ -5,9 +5,9 @@ Module      : HsLua.ObjectOrientationTests Copyright   : © 2007–2012 Gracjan Polak;               © 2012–2016 Ömer Sinan Ağacan;-              © 2017-2022 Albert Krewinkel+              © 2017-2023 Albert Krewinkel License     : MIT-Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Maintainer  : Albert Krewinkel <tarleb@hslua.org> Stability   : beta Portability : non-portable (depends on GHC) @@ -18,6 +18,7 @@ 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@@ -45,7 +46,7 @@     , "peek" =:       Foo 37 "ananas" `shouldBeResultOf` do         pushUD typeFoo $ Foo 37 "ananas"-        forcePeek $ peekUD typeFoo top+        forcePeek $ peekUDGeneric typeFoo top      , "unknown properties have value `nil`" =:       TypeNil `shouldBeResultOf` do@@ -81,7 +82,7 @@         setglobal "foo"         OK <- dostring "foo.num = -1"         TypeUserdata <- getglobal "foo"-        forcePeek $ peekUD typeFoo top+        forcePeek $ peekUDGeneric typeFoo top      , "get string" =:       "lint" `shouldBeResultOf` do@@ -107,7 +108,7 @@         setglobal "foo"         OK <- dostring "bar = foo.str"         _ <- getglobal "foo"-        forcePeek $ peekUD typeFoo top+        forcePeek $ peekUDGeneric typeFoo top      , "cannot change unknown property" =:       "Cannot set unknown property." `shouldBeErrorMessageOf` do@@ -157,7 +158,7 @@         setglobal "bar"         OK <- dostring "table.insert(bar.nums, 8)"         _ <- getglobal "bar"-        forcePeek $ peekUD typeBar top+        forcePeek $ peekUDGeneric typeBar top      , "Use integer index in alias" =:       42 `shouldBeResultOf` do@@ -168,6 +169,27 @@         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@@ -215,7 +237,7 @@         pushUD typeLazyIntList $ LazyIntList [9..17]         setglobal "ninetofive"         _ <- dostring "assert(ninetofive[3] == 11); return ninetofive"-        forcePeek $ peekUD typeLazyIntList top+        forcePeek $ peekUDGeneric typeLazyIntList top      , "List is writable" =:       LazyIntList [1, 4, 9, 16] `shouldBeResultOf` do@@ -223,7 +245,7 @@         pushUD typeLazyIntList $ LazyIntList [0,4,9,16]         setglobal "list"         OK <- dostring "list[1] = 1; return list"-        forcePeek $ peekUD typeLazyIntList top+        forcePeek $ peekUDGeneric typeLazyIntList top      , "List can be extended" =:       LazyIntList [1, 4, 9, 16, 25] `shouldBeResultOf` do@@ -231,7 +253,7 @@         pushUD typeLazyIntList $ LazyIntList [1,4,9,16]         setglobal "list"         OK <- dostring "list[5] = 25; return list"-        forcePeek $ peekUD typeLazyIntList top+        forcePeek $ peekUDGeneric typeLazyIntList top      , "List can be shortened" =:       LazyIntList [1, 9, 27, 81] `shouldBeResultOf` do@@ -239,7 +261,7 @@         pushUD typeLazyIntList $ LazyIntList [1, 9, 27, 81, 243]         setglobal "list"         OK <- dostring "list[5] = nil; return list"-        forcePeek $ peekUD typeLazyIntList top+        forcePeek $ peekUDGeneric typeLazyIntList top      , "Setting element to nil shortenes the list" =:       LazyIntList [1, 9, 27] `shouldBeResultOf` do@@ -247,7 +269,7 @@         pushUD typeLazyIntList $ LazyIntList [1, 9, 27, 81, 243]         setglobal "list"         OK <- dostring "list[4] = nil; return list"-        forcePeek $ peekUD typeLazyIntList top+        forcePeek $ peekUDGeneric typeLazyIntList top      , "Infinite lists are ok" =:       233 `shouldBeResultOf` do@@ -366,6 +388,10 @@          -> 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 = (,)@@ -386,7 +412,7 @@   ]   where     show' = do-      foo <- forcePeek $ peekUD typeFoo (nthBottom 1)+      foo <- forcePeek $ peekUDGeneric typeFoo (nthBottom 1)       pushString (show foo)       return (NumResults 1) @@ -396,7 +422,7 @@  typeBar :: LuaError e => UDType e (HaskellFunction e) Bar typeBar = deftype "Bar" []-  [ property "nums" "some numbers"+  [ property' "nums" (seqType integerType) "some numbers"     (pushList pushIntegral, \(Bar nums) -> nums)     (peekList peekIntegral, \(Bar _) nums -> Bar nums)   , alias "first" "first element" ["nums", IntegerIndex 1]@@ -409,7 +435,7 @@                 => UDTypeWithList e (HaskellFunction e) LazyIntList Int typeLazyIntList = deftype' "LazyIntList"   [ operation Tostring $ do-      lazyList <- forcePeek $ peekUD typeLazyIntList (nthBottom 1)+      lazyList <- forcePeek $ peekUDGeneric typeLazyIntList (nthBottom 1)       pushString (show lazyList)       return (NumResults 1)   ]@@ -441,6 +467,12 @@   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)@@ -448,13 +480,13 @@   return (NumResults 1)  peekQux :: LuaError e => Peeker e Qux-peekQux = peekUD typeQux+peekQux = peekUDGeneric typeQux  typeQux :: LuaError e => UDType e (HaskellFunction e) Qux typeQux = deftype "Qux"   [ operation Tostring showQux ]   [ methodGeneric "show" showQux-  , property "num" "some number"+  , property' "num" integerType "some number"       (pushIntegral, \case           Quux n _ -> n           Quuz _ n -> n)@@ -462,7 +494,7 @@           Quux _ s -> (`Quux` s)           Quuz d _ -> Quuz d) -  , possibleProperty "str" "a string in Quux"+  , possibleProperty' "str" stringType "a string in Quux"     (pushString, \case         Quux _ s -> Actual s         Quuz {}  -> Absent)@@ -470,7 +502,7 @@         Quux n _ -> Actual . Quux n         Quuz {}  -> const Absent) -  , possibleProperty "point" "a point in Quuz"+  , possibleProperty' "point" pointType "a point in Quuz"     (pushPoint, \case         Quuz p _ -> Actual p         Quux {}  -> Absent)

@@ -2,9 +2,9 @@ Module      : Main Copyright   : © 2007–2012 Gracjan Polak;               © 2012–2016 Ömer Sinan Ağacan;-              © 2017-2022 Albert Krewinkel+              © 2017-2023 Albert Krewinkel License     : MIT-Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Maintainer  : Albert Krewinkel <tarleb@hslua.org> Stability   : beta Portability : non-portable (depends on GHC)