hslua-objectorientation 2.0.1 → 2.1.0

raw patch · 8 files changed

+296/−68 lines, 8 filesdep ~hslua-coredep ~hslua-marshallingdep ~textPVP ok

version bump matches the API change (PVP)

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

API changes (from Hackage documentation)

Files

• CHANGELOG.md +36/−8
• LICENSE +1/−1
• cbits/hslobj.c +69/−18
• hslua-objectorientation.cabal +8/−6
• src/HsLua/ObjectOrientation.hs +83/−25
• src/HsLua/ObjectOrientation/Operation.hs +1/−1
• test/HsLua/ObjectOrientationTests.hs +97/−8
• test/test-hslua-objectorientation.hs +1/−1

@@ -1,21 +1,49 @@ # Changelog -`hslua-objectorientation` uses [PVP Versioning][1].+`hslua-objectorientation` uses [PVP Versioning][]. -## hslua-objectorientation 2.0.1+## hslua-objectorientation-2.1.0 -Release 2021-11-04.+Released 29-01-2022. -  - Excludes absent properties from `pairs`: Properties that are+-   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+## hslua-objectorientation-2.0.0 -Release 2021-10-21.+Released 2021-10-21. -- Published without warning.+-   Published without warning. -[1]: https://pvp.haskell.org+  [PVP Versioning]: https://pvp.haskell.org

@@ -1,7 +1,7 @@ Copyright © 1994-2020 Lua.org, PUC-Rio. Copyright © 2007-2012 Gracjan Polak Copyright © 2012-2015 Ömer Sinan Ağacan-Copyright © 2016-2021 Albert Krewinkel+Copyright © 2016-2022 Albert Krewinkel  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the

@@ -89,14 +89,16 @@   }   lua_pushvalue(L, 2);   if (lua_rawget(L, -2) != LUA_TTABLE) {-    return 0;             /* key is not an alias */+    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. */-  for (int i = 1; i <= lua_rawlen(L, -2); i++) {+  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 */@@ -127,16 +129,25 @@ int hsluaO_get_numerical(lua_State *L) {   hsluaO_get_caching_table(L, 1);-  int requested = lua_tointeger(L, 2);+  lua_Integer 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 */+  /* 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 */-    if (luaL_getmetafield(L, 1, "lazylisteval") == LUA_TFUNCTION &&-        lua_getfield(L, 3, "__lazylist") == LUA_TUSERDATA) {+    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 */@@ -168,12 +179,12 @@   lua_settop(L, 2);   /* do numeric lookup for integer keys */   return lua_isinteger(L, 2)-    ? hsluaO_get_numerical(L)+    ? (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));+    : (hsluaO_get_from_cache(L) ||+       hsluaO_get_via_getter(L) ||+       hsluaO_get_via_alias(L)  ||+       hsluaO_get_method(L)); }  /*@@ -193,18 +204,55 @@   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_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, lua_rawlen(L, -2)); /* last element */-  lua_pushvalue(L, 3);    /* new value */+  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@@ -239,6 +287,9 @@ 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);   }

@@ -1,6 +1,6 @@ cabal-version:       2.2 name:                hslua-objectorientation-version:             2.0.1+version:             2.1.0 synopsis:            Object orientation tools for HsLua description:         Expose Haskell objects to Lua with an object oriented                      interface.@@ -10,7 +10,7 @@ license-file:        LICENSE author:              Albert Krewinkel maintainer:          albert+hslua@zeitkraut.de-copyright:           © 2021 Albert Krewinkel+copyright:           © 2021-2022 Albert Krewinkel category:            Foreign build-type:          Simple extra-source-files:  README.md@@ -20,8 +20,9 @@                    , GHC == 8.4.4                    , GHC == 8.6.5                    , GHC == 8.8.4-                   , GHC == 8.10.4+                   , GHC == 8.10.7                    , GHC == 9.0.1+                   , GHC == 9.2.1  source-repository head   type:                git@@ -34,10 +35,10 @@                      , 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.1  && < 2.1+                     , hslua-core        >= 2.1    && < 2.2+                     , hslua-marshalling >= 2.1    && < 2.2                      , mtl               >= 2.2    && < 2.3-                     , text              >= 1.0    && < 1.3+                     , text              >= 1.2    && < 2.1   ghc-options:         -Wall                        -Wincomplete-record-updates                        -Wnoncanonical-monad-instances@@ -59,6 +60,7 @@                      , HsLua.ObjectOrientation.Operation   hs-source-dirs:      src   default-extensions:  LambdaCase+                     , StrictData   other-extensions:    AllowAmbiguousTypes                      , CPP                      , FlexibleInstances

@@ -5,7 +5,7 @@ {-# LANGUAGE TypeApplications    #-} {-| Module      : HsLua.ObjectOrientation-Copyright   : © 2021 Albert Krewinkel+Copyright   : © 2021-2022 Albert Krewinkel License     : MIT Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de> @@ -34,6 +34,7 @@   , Operation (..)   , ListSpec   , Possible (..)+  , Alias   , AliasIndex (..)   ) where @@ -58,18 +59,33 @@ -- 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 Name Alias+  , udAliases       :: Map AliasIndex Alias   , udListSpec      :: Maybe (ListSpec e a itemtype)   , udFnPusher      :: fn -> LuaE e ()   } -type ListSpec e a itemtype = (a -> [itemtype], Pusher e itemtype)+-- | 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.@@ -125,6 +141,7 @@ data AliasIndex   = StringIndex Name   | IntegerIndex Lua.Integer+  deriving (Eq, Ord)  instance IsString AliasIndex where   fromString = StringIndex . fromString@@ -133,7 +150,7 @@ data Member e fn a   = MemberProperty Name (Property e a)   | MemberMethod Name fn-  | MemberAlias Name Alias+  | MemberAlias AliasIndex Alias  -- | Use a documented function as an object method. methodGeneric :: Name -> fn -> Member e fn a@@ -197,9 +214,9 @@   }  -- | Define an alias for another, possibly nested, property.-alias :: Name  -- ^ property alias-      -> Text  -- ^ description-      -> [AliasIndex] -- ^ sequence of nested properties+alias :: AliasIndex    -- ^ property alias+      -> Text          -- ^ description+      -> [AliasIndex]  -- ^ sequence of nested properties       -> Member e fn a alias name _desc = MemberAlias name @@ -221,7 +238,7 @@     add "aliases" $ pushAliases ty     case udListSpec ty of       Nothing -> pure ()-      Just (_, pushItem) -> do+      Just ((pushItem, _), _) -> do         add "lazylisteval" $ pushHaskellFunction (lazylisteval pushItem)   where     add :: LuaError e => Name -> LuaE e () -> LuaE e ()@@ -294,7 +311,7 @@ pushAliases ty = do   newtable   void $ flip Map.traverseWithKey (udAliases ty) $ \name propSeq -> do-    pushName name+    pushAliasIndex name     pushList pushAliasIndex propSeq     rawset (nth 3) @@ -330,7 +347,7 @@ -- -- 1. userdata wrapping the unevalled part of the lazy list -- 2. index of the last evaluated element--- 3. index of the last requested element+-- 3. index of the requested element -- 4. the caching table lazylisteval :: forall itemtype e. LuaError e              => Pusher e itemtype -> LuaE e NumResults@@ -342,16 +359,22 @@     (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+      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-      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) @@ -368,7 +391,7 @@   -- add list as value in caching table   case udListSpec ty of     Nothing -> pure ()-    Just (toList, _) -> do+    Just ((_, toList), _) -> do       newtable       pushName "__lazylist"       newhsuserdata (toList x)@@ -382,16 +405,17 @@ peekUD ty idx = do   let name = udName ty   x <- reportValueOnFailure name (`fromuserdata` name) idx-  liftLua $ do-    result <- getuservalue idx >>= \case-      TypeTable -> do+  (`lastly` pop 1) $ liftLua (getuservalue idx) >>= \case+    TypeTable -> do+      -- set list+      xWithList <- maybe pure setList (udListSpec ty) x+      liftLua $ do         pushnil-        setProperties (udProperties ty) x-      _ -> do-        return x-    pop 1          -- uservalue (caching) table-    return result+        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)@@ -407,3 +431,37 @@             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

@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-| Module      : HsLua.ObjectOrientation.Operation-Copyright   : © 2020-2021 Albert Krewinkel+Copyright   : © 2020-2022 Albert Krewinkel License     : MIT Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de> 

@@ -5,7 +5,7 @@ Module      : HsLua.ObjectOrientationTests Copyright   : © 2007–2012 Gracjan Polak;               © 2012–2016 Ömer Sinan Ağacan;-              © 2017-2021 Albert Krewinkel+              © 2017-2022 Albert Krewinkel License     : MIT Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de> Stability   : beta@@ -193,14 +193,71 @@         _ <- dostring "return list[0], list[5]"         (,) <$> ltype (nth 1) <*> ltype (nth 2) -    , "List is read-only" =:-      (ErrRun, "Cannot set a numerical value.") `shouldBeResultOf` do+    , "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 $ peekUD 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 $ peekUD typeLazyIntList top++    , "List can be extended" =:+      LazyIntList [1, 4, 9, 16, 25] `shouldBeResultOf` do+        openlibs         pushUD typeLazyIntList $ LazyIntList [1,4,9,16]         setglobal "list"-        statusCode <- dostring "list[1] = 2"-        err <- forcePeek $ peekString top-        pure (statusCode, err)+        OK <- dostring "list[5] = 25; return list"+        forcePeek $ peekUD 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 $ peekUD 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 $ peekUD 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"@@ -253,6 +310,27 @@           -- 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@@ -261,6 +339,14 @@           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)       ]     ]   ]@@ -327,8 +413,10 @@       pushString (show lazyList)       return (NumResults 1)   ]-  []-  (Just (fromLazyIntList, pushIntegral))+  [ alias "seq" "sequence" [] ]+  (Just ( (pushIntegral, fromLazyIntList)+        , (peekIntegral, \_ lst -> LazyIntList lst)+        ))  -- -- Sample sum type@@ -391,4 +479,5 @@         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"]   ]

@@ -2,7 +2,7 @@ Module      : Main Copyright   : © 2007–2012 Gracjan Polak;               © 2012–2016 Ömer Sinan Ağacan;-              © 2017-2021 Albert Krewinkel+              © 2017-2022 Albert Krewinkel License     : MIT Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de> Stability   : beta