hslua-marshalling 2.0.1 → 2.1.0

raw patch · 14 files changed

+192/−64 lines, 14 filesdep ~hslua-coredep ~textPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: hslua-core, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +47/−14
• LICENSE +1/−1
• hslua-marshalling.cabal +7/−5
• src/HsLua/Marshalling.hs +1/−1
• src/HsLua/Marshalling/Peek.hs +10/−7
• src/HsLua/Marshalling/Peekers.hs +27/−11
• src/HsLua/Marshalling/Push.hs +32/−14
• src/HsLua/Marshalling/Userdata.hs +1/−1
• test/HsLua/Marshalling/PeekTests.hs +6/−2
• test/HsLua/Marshalling/PeekersTests.hs +13/−4
• test/HsLua/Marshalling/PushTests.hs +12/−1
• test/HsLua/Marshalling/UserdataTests.hs +1/−1
• test/HsLua/MarshallingTests.hs +33/−1
• test/test-hslua-marshalling.hs +1/−1

@@ -1,24 +1,57 @@-## Changelog+# Changelog -`hslua-marshalling` uses [PVP Versioning](https://pvp.haskell.org).+`hslua-marshalling` uses [PVP Versioning][]. -### hslua-marshalling 2.0.1+## hslua-marshalling-2.1.0 +Released 29-01-2022.++-   Updated to hslua-core-2.1.0.++-   The `Success` constructor of the `Result` type is now strict;+    the `Failure` constructor remains lazy.++-   The stack is checked before pushing or retrieving nested+    structures: Pushing or peeking a deeply nested structure could+    lead an overflow of the Lua stack. The functions `pushList`,+    `pushSet`, and `pushKeyValuePairs`, as well as `peekList`,+    `peekSet`, and `peekKeyValuePairs` now check that sufficient+    stack space is available before pushing another value to the+    stack.++-   The function `toByteString` now requires a slot on the stack+    if the value at the given index is a number. It checks for+    available space before pushing to the stack, returning+    `Nothing` if no space is left on the stack.++-   The `withContext` function is made more useful and now+    differs from `retrieving`. The string “retrieving” is added+    to the error context by `retrieving`, so `withContext` allows+    to define contexts without this prefix.++-   New convenience function `pushAsTable`, making it easier to+    define a pusher function for values marshaled as tables.++## hslua-marshalling-2.0.1+ Released 2021-11-04. -  - Allow `pushIterator` to skip values: If the function that-    pushes the values of a list item signals that it didn't push any-    values, then that value will be skipped.+-   Allow `pushIterator` to skip values: If the function that+    pushes the values of a list item signals that it didn’t push+    any values, then that value will be skipped. -### hslua-marshalling 2.0.0+## hslua-marshalling-2.0.0  Released 2021-10-21. -- Initially created. Contains modules previously found in the-  modules `Foreign.Lua.Peek` and `Foreign.Lua.Push` from-  `hslua-1.3`.+-   Initially created. Contains modules previously found in the+    modules `Foreign.Lua.Peek` and `Foreign.Lua.Push` from+    `hslua-1.3`. -- Removed most functions from the Userdata module, incl. peekAny,-  pushAny. The functions don't add much value over those in-  `HsLua.Core.Userdata`. Use UDTypes from hslua-packaging for a-  more comfortable method of exposing data via userdata values.+-   Removed most functions from the Userdata module,+    incl. peekAny, pushAny. The functions don’t add much value+    over those in `HsLua.Core.Userdata`. Use UDTypes from+    hslua-packaging for a more comfortable method of exposing data+    via userdata values.++  [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

@@ -1,6 +1,6 @@ cabal-version:       2.2 name:                hslua-marshalling-version:             2.0.1+version:             2.1.0 synopsis:            Marshalling of values between Haskell and Lua. description:         Provides functions to marshal values from Haskell                      to Lua, and /vice versa/.@@ -16,7 +16,7 @@ maintainer:          albert+hslua@zeitkraut.de copyright:           © 2007–2012 Gracjan Polak;                      © 2012–2016 Ömer Sinan Ağacan;-                     © 2017-2021 Albert Krewinkel+                     © 2017-2022 Albert Krewinkel category:            Foreign extra-source-files:  README.md                    , CHANGELOG.md@@ -25,8 +25,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@@ -38,9 +39,9 @@   build-depends:       base              >= 4.8    && < 5                      , bytestring        >= 0.10.2 && < 0.12                      , containers        >= 0.5.9  && < 0.7-                     , hslua-core        >= 2.0    && < 2.1+                     , hslua-core        >= 2.0    && < 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@@ -63,6 +64,7 @@                      , HsLua.Marshalling.Userdata   hs-source-dirs:      src   default-extensions:  LambdaCase+                     , StrictData   other-extensions:    DeriveDataTypeable                      , DeriveFunctor                      , OverloadedStrings

@@ -2,7 +2,7 @@ Module      : HsLua.Marshalling 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> 

@@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-| Module      : HsLua.Marshalling.Peek-Copyright   : © 2020-2021 Albert Krewinkel+Copyright   : © 2020-2022 Albert Krewinkel License     : MIT Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de> Stability   : beta@@ -40,20 +40,23 @@ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail (MonadFail (..)) #endif+#if !MIN_VERSION_base(4,12,0)+import Data.Semigroup (Semigroup ((<>)))+#endif import qualified HsLua.Core.Utf8 as Utf8  -- | Record to keep track of failure contexts while retrieving objects -- from the Lua stack. data Result a-  = Success a+  = Success !a   | Failure ByteString [Name]       -- ^ Error message and stack of contexts   deriving (Show, Eq, Functor)  instance Applicative Result where   pure = Success   {-# INLINE pure #-}-  Success f         <*> s = fmap f s-  Failure msg stack <*> _         = Failure msg stack+  Success f         <*> s = f <$!> s+  Failure msg stack <*> _ = Failure msg stack   {-# INLINE (<*>) #-}  instance Monad Result where@@ -133,7 +136,7 @@ -- | Runs the peek action and Lua action in sequence, even if the peek -- action fails. lastly :: Peek e a -> LuaE e b -> Peek e a-lastly p after = Peek $ runPeek p <* after+lastly p after = Peek $! runPeek p <* after {-# INLINABLE lastly #-}  -- | Runs the peek action, resetting the stack top afterwards. This can@@ -155,7 +158,7 @@ -- | Combines the peek failure components into a reportable string. formatPeekFailure :: ByteString -> [Name] -> String formatPeekFailure msg stack =-  intercalate "\n\twhile retrieving " $+  intercalate "\n\twhile " $   map Utf8.toString (msg : map fromName (reverse stack))  -- | Function to retrieve a value from Lua's stack.@@ -180,7 +183,7 @@ retrieving :: Name            -> Peek e a            -> Peek e a-retrieving = withContext+retrieving = withContext . ("retrieving " <>) {-# INLINE retrieving #-}  -- | Force creation of an unwrapped result, throwing an exception if

@@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-| Module      : HsLua.Marshalling.Peekers-Copyright   : © 2020-2021 Albert Krewinkel+Copyright   : © 2020-2022 Albert Krewinkel License     : MIT Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de> Stability   : beta@@ -47,7 +47,7 @@   ) where  import Control.Applicative (Alternative (..))-import Control.Monad ((<$!>), (>=>))+import Control.Monad ((<$!>), (>=>), void) import Data.ByteString (ByteString) import Data.Map (Map) import Data.Set (Set)@@ -133,11 +133,20 @@  -- | Like 'tostring', but ensures that the value at the given index is -- not silently converted to a string, as would happen with numbers.+-- Also returns 'Nothing' if the value is a number and there is no stack+-- slot left on the Lua stack, which would be needed to convert the+-- number to a string without changing the original slot. toByteString :: StackIndex -> LuaE e (Maybe ByteString) toByteString idx = do-  -- copy value, as tostring converts numbers to strings *in-place*.-  pushvalue idx-  tostring top <* pop 1+  -- Do an explicit type check, as @tostring@ converts numbers strings+  -- /in-place/, which we need to avoid.+  ltype idx >>= \case+    TypeString -> tostring idx+    _          -> checkstack 1 >>= \case+      False -> pure Nothing+      True  ->  do+        pushvalue idx+        tostring top <* pop 1 {-# INLINABLE toByteString #-}  -- | Retrieves a 'ByteString' as a raw string.@@ -219,6 +228,7 @@ peekList :: forall a e. LuaError e => Peeker e a -> Peeker e [a] peekList peekElement = fmap (retrieving "list") .   typeChecked "table" istable $ \idx -> do+  liftLua $ checkstack' 1 "retrieving a list"   let elementsAt [] = return []       elementsAt (i : is) = do         x  <- retrieving ("index " <> showInt i) $@@ -230,15 +240,18 @@   elementsAt [1..fromIntegral listLength]  -- | Retrieves a key-value Lua table as 'Map'.-peekMap :: Ord a => Peeker e a -> Peeker e b -> Peeker e (Map a b)+peekMap :: (LuaError e, Ord a)+        => Peeker e a -> Peeker e b -> Peeker e (Map a b) peekMap keyPeeker valuePeeker = retrieving "Map"   . fmap Map.fromList   . peekKeyValuePairs keyPeeker valuePeeker  -- | Read a table into a list of pairs.-peekKeyValuePairs :: Peeker e a -> Peeker e b -> Peeker e [(a, b)]+peekKeyValuePairs :: LuaError e+                  => Peeker e a -> Peeker e b -> Peeker e [(a, b)] peekKeyValuePairs keyPeeker valuePeeker =   typeChecked "table" istable $ \idx -> cleanup $ do+    liftLua $ checkstack' 2 "retrieving key-value pairs"     idx' <- liftLua $ absindex idx     let remainingPairs = nextPair keyPeeker valuePeeker idx' >>= \case           Nothing -> return []@@ -267,8 +280,8 @@ -- | Retrieves a 'Set' from an idiomatic Lua representation. A -- set in Lua is idiomatically represented as a table with the -- elements as keys. Elements with falsy values are omitted.-peekSet :: Ord a => Peeker e a -> Peeker e (Set a)-peekSet elementPeeker = withContext "Set"+peekSet :: (LuaError e, Ord a) => Peeker e a -> Peeker e (Set a)+peekSet elementPeeker = retrieving "Set"   . fmap (Set.fromList . map fst . filter snd)   . peekKeyValuePairs elementPeeker peekBool @@ -281,9 +294,10 @@ peekFieldRaw peeker name idx =   retrieving ("raw field '" <> name <> "'") $! do     liftLua $ do+      checkstack' 1 "peekFieldRaw"       absidx <- Lua.absindex idx       pushstring $ fromName name-      rawget absidx+      void (rawget absidx)     peeker top `lastly` Lua.pop 1 {-# INLINABLE peekFieldRaw #-} @@ -292,7 +306,7 @@ peekIndexRaw i peeker idx = do   let showInt (Lua.Integer x) = fromString $ show x   retrieving (fromString $ "raw index '" <> showInt i <> "'") $! do-    liftLua $ rawgeti idx i+    liftLua . void $ rawgeti idx i     peeker top `lastly` Lua.pop 1 {-# INLINABLE peekIndexRaw #-} @@ -302,6 +316,7 @@          => Peeker e a -> Peeker e b          -> Peeker e (a, b) peekPair peekA peekB idx = cleanup $ do+  liftLua $ checkstack' 2 "retrieving a pair"   idx' <- liftLua $ absindex idx   a <- liftLua (rawgeti idx' 1) *> peekA top   b <- liftLua (rawgeti idx' 2) *> peekB top@@ -313,6 +328,7 @@            => Peeker e a -> Peeker e b -> Peeker e c            -> Peeker e (a, b, c) peekTriple peekA peekB peekC idx = cleanup $ do+  liftLua $ checkstack' 3 "retrieving a triple"   idx' <- liftLua $ absindex idx   a <- liftLua (rawgeti idx' 1) *> peekA top   b <- liftLua (rawgeti idx' 2) *> peekB top

@@ -1,6 +1,6 @@ {-| Module      : HsLua.Marshalling.Push-Copyright   : © 2020-2021 Albert Krewinkel+Copyright   : © 2020-2022 Albert Krewinkel License     : MIT Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de> Stability   : beta@@ -28,9 +28,10 @@   -- * Combinators   , pushPair   , pushTriple+  , pushAsTable   ) where -import Control.Monad (zipWithM_)+import Control.Monad (forM_, zipWithM_) import Data.ByteString (ByteString) import Data.Map (Map, toList) import Data.Set (Set)@@ -97,17 +98,21 @@ -- | Push list of pairs as default key-value Lua table. pushKeyValuePairs :: LuaError e                   => Pusher e a -> Pusher e b -> Pusher e [(a,b)]-pushKeyValuePairs pushKey pushValue m = do-  let addValue (k, v) = pushKey k *> pushValue v *> rawset (-3)-  newtable-  mapM_ addValue m+pushKeyValuePairs pushKey pushValue m = checkstack 3 >>= \case+  False -> failLua "stack overflow while pushing key-value pairs"+  True  -> do+    let addValue (k, v) = pushKey k *> pushValue v *> rawset (-3)+    newtable+    mapM_ addValue m  -- | Push list as numerically indexed table. pushList :: LuaError e => Pusher e a -> [a] -> LuaE e ()-pushList push xs = do-  let setField i x = push x *> rawseti (-2) i-  newtable-  zipWithM_ setField [1..] xs+pushList push xs = checkstack 2 >>= \case+  False -> failLua "stack overflow while pushing a list"+  True  -> do+    let setField i x = push x *> rawseti (-2) i+    newtable+    zipWithM_ setField [1..] xs  -- | Push 'Map' as default key-value Lua table. pushMap :: LuaError e => Pusher e a -> Pusher e b -> Pusher e (Map a b)@@ -116,14 +121,27 @@ -- | Push a 'Set' as idiomatic Lua set, i.e., as a table with the set -- elements as keys and @true@ as values. pushSet :: LuaError e => Pusher e a -> Pusher e (Set a)-pushSet pushElement set = do-  let addItem item = pushElement item *> pushboolean True *> rawset (-3)-  newtable-  mapM_ addItem set+pushSet pushElement set = checkstack 3 >>= \case+  False -> failLua "stack overflow while pushing a set"+  True  -> do+    let addItem item = pushElement item *> pushboolean True *> rawset (-3)+    newtable+    mapM_ addItem set  -- -- Combinators --+-- | Pushes an object as a table, defined by a list of+-- field-names/push-function pairs.+pushAsTable :: LuaError e+            => [(Name, a -> LuaE e ())]+            -> a -> LuaE e ()+pushAsTable props obj = do+  createtable 0 (length props)+  forM_ props $ \(name, pushValue) -> do+    pushName name+    pushValue obj+    rawset (nth 3)  -- | Pushes a pair of values as a two element list. pushPair :: LuaError e

@@ -5,7 +5,7 @@ Module      : HsLua.Marshalling.Userdata 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

@@ -2,7 +2,7 @@ {-# LANGUAGE TypeApplications #-} {-| Module      : HsLua.Marshalling.PeekTests-Copyright   : © 2020-2021 Albert Krewinkel+Copyright   : © 2020-2022 Albert Krewinkel License     : MIT Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de> Stability   : alpha@@ -25,8 +25,12 @@ tests = testGroup "Peek"   [ testGroup "helper"     [ "retrieving" =:-      Failure @() "message" ["context"] `shouldBeResultOf`+      Failure @() "message" ["retrieving context"] `shouldBeResultOf`       runPeek (retrieving "context" $ failPeek "message")++    , "withContext" =:+      Failure @() "message" ["context"] `shouldBeResultOf`+      runPeek (withContext "context" $ failPeek "message")      , let firstindex idx = do             Lua.rawgeti idx 1

@@ -2,7 +2,7 @@ {-# LANGUAGE TypeApplications #-} {-| Module      : HsLua.Marshalling.PeekersTests-Copyright   : © 2020-2021 Albert Krewinkel+Copyright   : © 2020-2022 Albert Krewinkel License     : MIT Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de> @@ -300,7 +300,10 @@           runPeek $ peekSet (peekIntegral @Int) Lua.top        , "fails if element peeker fails" =:-        let errorStack = [ "Set", "key-value pair", "key"]+        let errorStack = [ "retrieving Set"+                         , "retrieving key-value pair"+                         , "retrieving key"+                         ]             errorMsg = "string expected, got boolean"         in Failure errorMsg errorStack `shouldBeResultOf` do           pushLuaExpr "{ NaN = true, [true] = false }"@@ -319,14 +322,20 @@           runPeek $ peekMap peekText (peekIntegral @Int) Lua.top        , "fails if key peeker fails" =:-        let errorStack = [ "Map", "key-value pair" , "key" ]+        let errorStack = [ "retrieving Map"+                         , "retrieving key-value pair"+                         , "retrieving key"+                         ]             errorMsg = "Integral expected, got string"         in Failure errorMsg errorStack `shouldBeResultOf` do           pushLuaExpr "{ NaN = true }"           runPeek $ peekMap (peekIntegral @Int) peekBool Lua.top        , "fails if value peeker fails" =:-        let errorStack = [ "Map", "key-value pair", "value" ]+        let errorStack = [ "retrieving Map"+                         , "retrieving key-value pair"+                         , "retrieving value"+                         ]             errorMsg = "string expected, got boolean"         in Failure errorMsg errorStack `shouldBeResultOf` do           pushLuaExpr "{ [42] = true }"

@@ -4,7 +4,7 @@ {-# LANGUAGE TypeApplications #-} {-| Module      : HsLua.Marshalling.PushTests-Copyright   : © 2020-2021 Albert Krewinkel+Copyright   : © 2020-2022 Albert Krewinkel License     : MIT Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de> Stability   : alpha@@ -234,6 +234,17 @@           mc <- Lua.rawgeti Lua.top 3 *> Lua.tonumber Lua.top  <* Lua.pop 1           return $ (,,) <$> ma <*> mb <*> mc         assert (mpair == Just (a, b, c))++    , testProperty "pushAsTable" $ \(a, b) -> monadicIO $ do+        mpair <- run $ Lua.run @Lua.Exception $ do+          let fields = [ ("int", Lua.pushinteger . fst)+                       , ("str", Lua.pushstring . snd)+                       ]+          pushAsTable fields (a, b)+          ma <- Lua.getfield Lua.top "int" *> Lua.tointeger Lua.top <* Lua.pop 1+          mb <- Lua.getfield Lua.top "str" *> Lua.tostring Lua.top  <* Lua.pop 1+          return $ (,) <$> ma <*> mb+        assert (mpair == Just (a, b))     ]   ] 

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

@@ -1,6 +1,8 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-} {-| Module      : HsLua.MarshallingTests-Copyright   : © 2020-2021 Albert Krewinkel+Copyright   : © 2020-2022 Albert Krewinkel License     : MIT Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de> Stability   : alpha@@ -10,7 +12,13 @@ -} module HsLua.MarshallingTests (tests) where +import Control.Monad ((<$!>))+import HsLua.Core+import HsLua.Marshalling.Peek+import HsLua.Marshalling.Peekers+import HsLua.Marshalling.Push import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HsLua ((=:), shouldBeResultOf) import qualified HsLua.Marshalling.PeekTests import qualified HsLua.Marshalling.PeekersTests import qualified HsLua.Marshalling.PushTests@@ -23,4 +31,28 @@   , HsLua.Marshalling.PeekersTests.tests   , HsLua.Marshalling.PushTests.tests   , HsLua.Marshalling.UserdataTests.tests+  , testGroup "nested"+    [ "deeply nested list" =:+      Success (mkDeeplyNested 500) `shouldBeResultOf` do+        pushNested (mkDeeplyNested 500)+        runPeek $ peekNested top+    ]   ]++mkDeeplyNested :: Int -> Nested+mkDeeplyNested i = foldr (\_ n -> List [n]) (Element i) [1..i]++pushNested :: LuaError e => Pusher e Nested+pushNested = \case+  Element i   -> pushIntegral i+  List nested -> pushList pushNested nested++peekNested :: LuaError e => Peeker e Nested+peekNested idx = do+  liftLua (ltype idx) >>= \case+    TypeNumber  -> Element <$!> peekIntegral idx+    TypeTable   -> (List   <$!> peekList peekNested idx)+    _           -> failPeek "you dun goofed"++data Nested = Element Int | List [Nested]+  deriving (Eq, Show)

@@ -1,6 +1,6 @@ {-| Module      : Main-Copyright   : © 2017-2021 Albert Krewinkel+Copyright   : © 2017-2022 Albert Krewinkel License     : MIT Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>