hslua 1.1.0 → 1.1.1

raw patch · 20 files changed

+1017/−335 lines, 20 filesdep −criteriondep −deepseqdep ~basedep ~containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: criterion, deepseq

Dependency ranges changed: base, containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +28/−0
• benchmark/benchmark-functions.c +0/−40
• benchmark/benchmark-functions.h +0/−5
• benchmark/benchmark-hslua.hsc +0/−103
• hslua.cabal +7/−21
• src/Foreign/Lua/Core/Auxiliary.hsc +29/−26
• src/Foreign/Lua/Core/Functions.hs +29/−21
• src/Foreign/Lua/Core/RawBindings.hsc +3/−1
• src/Foreign/Lua/Core/Types.hsc +22/−19
• src/Foreign/Lua/FunctionCalling.hsc +3/−3
• src/Foreign/Lua/Peek.hs +242/−0
• src/Foreign/Lua/Push.hs +108/−0
• src/Foreign/Lua/Types/Peekable.hs +16/−38
• src/Foreign/Lua/Types/Pushable.hs +12/−50
• src/Foreign/Lua/Userdata.hs +3/−2
• src/Foreign/Lua/Utf8.hs +7/−4
• src/Foreign/Lua/Util.hs +2/−2
• test/Foreign/Lua/PeekTests.hs +273/−0
• test/Foreign/Lua/PushTests.hs +229/−0
• test/test-hslua.hs +4/−0

@@ -1,5 +1,33 @@ ## Changelog +### 1.1.1++Released 2020-06-02++- New module Foreign.Lua.Push: provides functions which marshal+  and push Haskell values onto Lua's stack.++  Most functions in Foreign.Lua.Types.Pushable are now defined+  using functions from this module.++- New module Foreign.Lua.Peek: provides functions which unmarshal+  and retrieve Haskell values from Lua's stack. Contrary to `peek`+  from Foreign.Lua.Types.Peekable, the peeker functions in this+  module will never throw errors, but use an `Either` type to+  signal retrieval failure.++  The error type `PeekError` should not be considered final and+  will likely be subject to change in later versions.++- Module Foreign.Lua.Utf8: never throw errors when decoding UTF-8+  strings. Invalid UTF-8 input bytes no longer cause exceptions,+  but are replaced with the Unicode replacement character U+FFFD.++- Fixed missing and faulty Haddock documentation.++- Fixed a bug which caused unnecessary use of strings to represent+  floating point numbers under certain configurations.+ ### 1.1.0  Released 2020-03-25.

@@ -1,40 +0,0 @@-#include <string.h>-#include "benchmark-functions.h"--/*-** getlfield-*/-int hslua__getlfield(lua_State *L)-{-  lua_gettable(L, 1);-  return 1;-}--int hslua_getlfield(lua_State *L, int index, const char *k, size_t len)-{-  lua_pushvalue(L, index);-  lua_pushlstring(L, k, len);-  lua_pushcfunction(L, hslua__getlfield);-  lua_insert(L, -3);-  return -lua_pcall(L, 2, 1, 0);-}--/*-** setfield-*/-int hslua__setfield(lua_State *L)-{-  const char *k = lua_tostring(L, 3);-  lua_pushvalue(L, 1);-  lua_setfield(L, 2, k);-  return 0;-}--int hslua_setfield(lua_State *L, int index, const char *k)-{-  lua_pushvalue(L, index);-  lua_pushstring(L, k);-  lua_pushcfunction(L, hslua__setfield);-  lua_insert(L, -4);-  return -lua_pcall(L, 3, 0, 0);-}

@@ -1,5 +0,0 @@-#include "lua.h"--int hslua_getlfield(lua_State *L, int index, const char *k, size_t len);--int hslua_setfield(lua_State *L, int index, const char *k);

@@ -1,103 +0,0 @@-{--Copyright © 2018-2020 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.--}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE OverloadedStrings #-}--import Control.DeepSeq-import Control.Monad (void)-import Criterion.Main-import Criterion.Types (Config(..))-import Data.ByteString (ByteString)-import Foreign.C (CString (..), CSize (..), CInt (..))-import Foreign.Lua (Lua, StackIndex)--import qualified Foreign.Lua as Lua-import qualified Data.ByteString as B-import qualified Data.ByteString.Unsafe as B--#include "benchmark-functions.h"--luaBench :: NFData b-         => String-         -> Lua a    -- ^ Setup-         -> Lua b    -- ^ Operation to benchmark-         -> Benchmark-luaBench name setupOp benchOp = do-  bench name .-    perRunEnvWithCleanup (setupLua setupOp) teardownLua $ \l ->-      Lua.runWith l benchOp--setupLua :: Lua a -> IO Lua.State-setupLua setupOp = do-  l <- Lua.newstate-  _ <- Lua.runWith l setupOp-  return l--teardownLua :: Lua.State -> IO ()-teardownLua = Lua.close--setupTableWithFooField :: Lua ()-setupTableWithFooField = do-  Lua.newtable-  Lua.pushstring "foo"-  Lua.setfield (Lua.nthFromTop 2) "bar"--main :: IO ()-main = defaultMain-  [ luaBench "getfield" setupTableWithFooField (Lua.getfield Lua.stackTop "foo")-  , luaBench "getlfield" setupTableWithFooField (getlfield Lua.stackTop "foo")-  , luaBench "setfield"-             (Lua.newtable *> Lua.pushboolean True)-             (Lua.setfield (Lua.nthFromTop 2) "foo")-  , luaBench "setfield_old"-             (Lua.newtable *> Lua.pushboolean True)-             (setfield_old (Lua.nthFromTop 2) "foo")-  , luaBench "getglobal" (return ()) (Lua.getglobal "foo")-  , luaBench "setglobal" (Lua.pushboolean True) (Lua.setglobal "foo")-  , luaBench "setraw"-             (Lua.newtable *> Lua.pushstring "foo" *> Lua.pushboolean True)-             (Lua.rawset (Lua.nthFromTop 3))-  ]--instance NFData Lua.State----- Functions for comparison---- | Getting a string field with lua_pushlstring and lua_gettable-foreign import ccall "hslua_getlfield"-  hslua_getlfield :: Lua.State -> StackIndex -> CString -> CSize -> IO CInt--getlfield :: StackIndex -> ByteString -> Lua CInt-getlfield i s = do-  l <- Lua.state-  Lua.liftIO $ B.unsafeUseAsCStringLen s $ \(strPtr, len) ->-    hslua_getlfield l i strPtr (fromIntegral len)---- | Getting a string field with lua_pushlstring and lua_gettable-foreign import ccall "hslua_setfield"-  hslua_setfield :: Lua.State -> StackIndex -> CString -> IO CInt--setfield_old :: StackIndex -> ByteString -> Lua CInt-setfield_old i s = do-  l <- Lua.state-  Lua.liftIO $ B.useAsCString s (hslua_setfield l i)

@@ -1,5 +1,5 @@ name:                hslua-version:             1.1.0+version:             1.1.1 synopsis:            Bindings to Lua, an embeddable scripting language description:         HsLua provides bindings, wrappers, types, and helper                      functions to bridge Haskell and <https://www.lua.org/ Lua>.@@ -23,14 +23,11 @@ build-type:          Simple extra-source-files:  cbits/lua-5.3.5/*.h                      cbits/error-conversion/*.h-                     benchmark/benchmark-functions.h-                     benchmark/benchmark-functions.c                      README.md                      CHANGELOG.md                      test/lua/*.lua cabal-version:       >=1.10-tested-with:         GHC == 7.10.3-                   , GHC == 8.0.2+tested-with:         GHC == 8.0.2                    , GHC == 8.2.2                    , GHC == 8.4.3                    , GHC == 8.6.5@@ -95,6 +92,8 @@                      , Foreign.Lua.Core.Types                      , Foreign.Lua.FunctionCalling                      , Foreign.Lua.Module+                     , Foreign.Lua.Peek+                     , Foreign.Lua.Push                      , Foreign.Lua.Types                      , Foreign.Lua.Types.Peekable                      , Foreign.Lua.Types.Pushable@@ -213,6 +212,8 @@                      , Foreign.Lua.Core.ErrorTests                      , Foreign.Lua.FunctionCallingTests                      , Foreign.Lua.ModuleTests+                     , Foreign.Lua.PeekTests+                     , Foreign.Lua.PushTests                      , Foreign.Lua.TypesTests                      , Foreign.Lua.Types.PeekableTests                      , Foreign.Lua.Types.PushableTests@@ -222,7 +223,7 @@                      , Test.HsLua.Util   build-depends:       base                 >= 4.8    && < 5                      , bytestring           >= 0.10.2 && < 0.11-                     , containers           >= 0.5    && < 0.7+                     , containers           >= 0.5.9  && < 0.7                      , exceptions           >= 0.8    && < 0.11                      , mtl                  >= 2.2    && < 2.3                      , text                 >= 1.0    && < 1.3@@ -241,18 +242,3 @@     build-depends:       base-compat          >= 0.10     hs-source-dirs:      prelude     other-modules:       Prelude---benchmark benchmark-hslua-  type:                exitcode-stdio-1.0-  main-is:             benchmark-hslua.hs-  hs-source-dirs:      benchmark-  default-language:    Haskell2010-  build-depends:       hslua-                     , base                 >= 4.8-                     , bytestring           >= 0.10.2 && < 0.11-                     , criterion            >= 1.0    && < 1.6-                     , deepseq              >= 1.4.1  && < 1.5-  c-sources:           benchmark/benchmark-functions.c-  include-dirs:        benchmark-                     , cbits/lua-5.3.5

@@ -90,8 +90,8 @@  -- | Loads and runs the given string. ----- Returns @'OK'@ on success, or an error if either loading of the string or--- calling of the thunk failed.+-- Returns 'Lua.OK' on success, or an error if either loading of the+-- string or calling of the thunk failed. dostring :: ByteString -> Lua Status dostring s = do   loadRes <- loadstring s@@ -158,9 +158,9 @@  -- | Loads a ByteString as a Lua chunk. ----- This function returns the same results as @'load'@. @name@ is the chunk name,--- used for debug information and error messages. Note that @name@ is used as a--- C string, so it may not contain null-bytes.+-- This function returns the same results as @'Lua.load'@. @name@ is the+-- chunk name, used for debug information and error messages. Note that+-- @name@ is used as a C string, so it may not contain null-bytes. -- -- See <https://www.lua.org/manual/5.3/manual.html#luaL_loadbuffer luaL_loadbuffer>. loadbuffer :: ByteString -- ^ Program to load@@ -176,17 +176,18 @@                   -> IO Lua.StatusCode  --- | Loads a file as a Lua chunk. This function uses @lua_load@ (see @'load'@)--- to load the chunk in the file named filename. The first line in the file is--- ignored if it starts with a @#@.+-- | Loads a file as a Lua chunk. This function uses @lua_load@ (see+-- @'Lua.load'@) to load the chunk in the file named filename. The first+-- line in the file is ignored if it starts with a @#@. ----- The string mode works as in function @'load'@.+-- The string mode works as in function @'Lua.load'@. ----- This function returns the same results as @'load'@, but it has an extra error--- code @'ErrFile'@ for file-related errors (e.g., it cannot open or read the--- file).+-- This function returns the same results as @'Lua.load'@, but it has an+-- extra error code @'Lua.ErrFile'@ for file-related errors (e.g., it+-- cannot open or read the file). ----- As @'load'@, this function only loads the chunk; it does not run it.+-- As @'Lua.load'@, this function only loads the chunk; it does not run+-- it. -- -- Note that the file is opened by Haskell, not Lua. --@@ -203,13 +204,15 @@   contentOrError = try (B.readFile fp)  --- | Loads a string as a Lua chunk. This function uses @lua_load@ to load the--- chunk in the given ByteString. The given string may not contain any NUL--- characters.+-- | Loads a string as a Lua chunk. This function uses @lua_load@ to+-- load the chunk in the given ByteString. The given string may not+-- contain any NUL characters. ----- This function returns the same results as @lua_load@ (see @'load'@).+-- This function returns the same results as @lua_load@ (see+-- @'Lua.load'@). ----- Also as @'load'@, this function only loads the chunk; it does not run it.+-- Also as @'Lua.load'@, this function only loads the chunk; it does not+-- run it. -- -- See <https://www.lua.org/manual/5.3/manual.html#luaL_loadstring luaL_loadstring>. loadstring :: ByteString -> Lua Status@@ -238,11 +241,11 @@   luaL_newmetatable :: Lua.State -> CString -> IO Lua.LuaBool  --- | Creates a new Lua state. It calls @'lua_newstate'@ with an allocator based--- on the standard C @realloc@ function and then sets a panic function (see--- <https://www.lua.org/manual/5.3/manual.html#4.6 §4.6> of the Lua 5.3--- Reference Manual) that prints an error message to the standard error output--- in case of fatal errors.+-- | Creates a new Lua state. It calls @lua_newstate@ with an allocator+-- based on the standard C @realloc@ function and then sets a panic+-- function (see <https://www.lua.org/manual/5.3/manual.html#4.6 §4.6>+-- of the Lua 5.3 Reference Manual) that prints an error message to the+-- standard error output in case of fatal errors. -- -- See also: -- <https://www.lua.org/manual/5.3/manual.html#luaL_newstate luaL_newstate>.@@ -267,9 +270,9 @@ -- @rawgeti t r@. Function @'unref'@ frees a reference and its associated -- object. ----- If the object at the top of the stack is nil, @'ref'@ returns the constant--- @'refnil'@. The constant @'noref'@ is guaranteed to be different from any--- reference returned by @'ref'@.+-- If the object at the top of the stack is nil, @'ref'@ returns the+-- constant @'Lua.refnil'@. The constant @'Lua.noref'@ is guaranteed to+-- be different from any reference returned by @'ref'@. -- -- See also: <https://www.lua.org/manual/5.3/manual.html#luaL_ref luaL_ref>. ref :: StackIndex -> Lua Reference

@@ -133,11 +133,11 @@ -- metamethods). Otherwise returns @False@. Also returns @False@ if any of the -- indices is not valid. ----- The value of op must be of type @'LuaComparerOp'@:+-- The value of op must be of type @RelationalOperator@: -----    OpEQ: compares for equality (==)---    OpLT: compares for less than (<)---    OpLE: compares for less or equal (<=)+--    EQ: compares for equality (==)+--    LT: compares for less than (<)+--    LE: compares for less or equal (<=) -- -- This is a wrapper function of -- <https://www.lua.org/manual/5.3/manual.html#lua_compare lua_compare>.@@ -181,17 +181,21 @@  -- TODO: implement dump --- | Returns @True@ if the two values in acceptable indices index1 and index2--- are equal, following the semantics of the Lua @==@ operator (that is, may--- call metamethods). Otherwise returns False. Also returns False if any of the--- indices is non valid. Uses @'compare'@ internally.-equal :: StackIndex -> StackIndex -> Lua Bool+-- | Returns @True@ if the two values in acceptable indices index1 and+-- index2 are equal, following the semantics of the Lua @==@ operator+-- (that is, may call metamethods). Otherwise returns @False@. Also+-- returns @False@ if any of the indices is non valid. Uses @'compare'@+-- internally.+equal :: StackIndex  -- ^ index1+      -> StackIndex  -- ^ index2+      -> Lua Bool equal index1 index2 = compare index1 index2 EQ --- | This is a convenience function to implement error propagation convention--- described in [Error handling in hslua](#g:1). hslua doesn't implement--- `lua_error` function from Lua C API because it's never safe to use. (see--- [Error handling in hslua](#g:1) for details)+-- | This is a convenience function to implement error propagation+-- convention described in [Error handling in hslua](#g:1). hslua+-- doesn't implement the @lua_error@ function from Lua C API because+-- it's never safe to use. (see [Error handling in hslua](#g:1) for+-- details) error :: Lua NumResults error = liftLua hslua_error @@ -602,6 +606,10 @@ pushcfunction :: CFunction -> Lua () pushcfunction f = pushcclosure f 0 +-- | Pushes the global environment onto the stack.+--+-- Wraps <https://www.lua.org/manual/5.3/manual.html#lua_pushglobaltable \+-- lua_pushglobaltable>. pushglobaltable :: Lua () pushglobaltable = liftLua lua_pushglobaltable @@ -689,7 +697,7 @@  -- | Returns the raw "length" of the value at the given index: for strings, this -- is the string length; for tables, this is the result of the length operator--- ('#') with no metamethods; for userdata, this is the size of the block of+-- (@#@) with no metamethods; for userdata, this is the size of the block of -- memory allocated for the userdata; for other values, it is 0. -- -- See also:@@ -807,13 +815,13 @@  -- |  Returns the status of this Lua thread. ----- The status can be @'OK'@ for a normal thread, an error value if the thread--- finished the execution of a @'lua_resume'@ with an error, or @'Yield'@ if--- the thread is suspended.+-- The status can be 'OK' for a normal thread, an error value if the+-- thread finished the execution of a @lua_resume@ with an error, or+-- 'Yield' if the thread is suspended. ----- You can only call functions in threads with status @'OK'@. You can resume--- threads with status @'OK'@ (to start a new coroutine) or @'Yield'@ (to--- resume a coroutine).+-- You can only call functions in threads with status 'OK'. You can+-- resume threads with status 'OK' (to start a new coroutine) or 'Yield'+-- (to resume a coroutine). -- -- See also: <https://www.lua.org/manual/5.3/manual.html#lua_status lua_status>. status :: Lua Status@@ -840,7 +848,7 @@   return (if fnPtr == nullFunPtr then Nothing else Just fnPtr)  -- | Converts the Lua value at the given acceptable index to the signed integral--- type @'lua_Integer'@. The Lua value must be an integer, a number or a string+-- type 'Lua.Integer'. The Lua value must be an integer, a number or a string -- convertible to an integer (see -- <https://www.lua.org/manual/5.3/manual.html#3.4.3 §3.4.3> of the Lua 5.3 -- Reference Manual); otherwise, @tointeger@ returns @Nothing@.

@@ -284,7 +284,7 @@   ----------------------------------------------------------------------------------- * 'load' and 'call' functions (load and run Lua code)+-- * \'load\' and \'call\' functions (load and run Lua code)  -- lua_call is inherently unsafe, we do not support it. @@ -343,6 +343,8 @@ foreign import ccall "error-conversion.h hslua_concat"   hslua_concat :: Lua.State -> NumArgs -> IO (Failable ()) +-- | See <https://www.lua.org/manual/5.3/manual.html#lua_pushglobaltable \+-- lua_pushglobaltable> foreign import capi unsafe "lua.h lua_pushglobaltable"   lua_pushglobaltable :: Lua.State -> IO () 

@@ -155,27 +155,30 @@ -- |  Type for C functions. -- -- In order to communicate properly with Lua, a C function must use the--- following protocol, which defines the way parameters and results are passed:--- a C function receives its arguments from Lua in its stack in direct order--- (the first argument is pushed first). So, when the function starts,--- @'gettop'@ returns the number of arguments received by the function. The--- first argument (if any) is at index 1 and its last argument is at index--- @gettop@. To return values to Lua, a C function just pushes them onto the--- stack, in direct order (the first result is pushed first), and returns the--- number of results. Any other value in the stack below the results will be--- properly discarded by Lua. Like a Lua function, a C function called by Lua--- can also return many results.+-- following protocol, which defines the way parameters and results are+-- passed: a C function receives its arguments from Lua in its stack in+-- direct order (the first argument is pushed first). So, when the+-- function starts, @'Foreign.Lua.Core.Functions.gettop'@ returns the+-- number of arguments received by the function. The first argument (if+-- any) is at index 1 and its last argument is at index+-- @'Foreign.Lua.Core.Functions.gettop'@. To return values to Lua, a C+-- function just pushes them onto the stack, in direct order (the first+-- result is pushed first), and returns the number of results. Any other+-- value in the stack below the results will be properly discarded by+-- Lua. Like a Lua function, a C function called by Lua can also return+-- many results. -- -- See <https://www.lua.org/manual/5.3/manual.html#lua_CFunction lua_CFunction>. type CFunction = FunPtr (State -> IO NumResults) --- | The reader function used by @'lua_load'@. Every time it needs another piece--- of the chunk, lua_load calls the reader, passing along its data parameter.--- The reader must return a pointer to a block of memory with a new piece of the--- chunk and set size to the block size. The block must exist until the reader--- function is called again. To signal the end of the chunk, the reader must--- return @NULL@ or set size to zero. The reader function may return pieces of any--- size greater than zero.+-- | The reader function used by @'Foreign.Lua.Core.Functions.load'@.+-- Every time it needs another piece of the chunk, lua_load calls the+-- reader, passing along its data parameter. The reader must return a+-- pointer to a block of memory with a new piece of the chunk and set+-- size to the block size. The block must exist until the reader+-- function is called again. To signal the end of the chunk, the reader+-- must return @NULL@ or set size to zero. The reader function may+-- return pieces of any size greater than zero. -- -- See <https://www.lua.org/manual/5.3/manual.html#lua_Reader lua_Reader>. type Reader = FunPtr (State -> Ptr () -> Ptr CSize -> IO (Ptr CChar))@@ -320,7 +323,7 @@   | ErrFile   -- ^ opening or reading a file failed.   deriving (Eq, Show) --- | Convert C integer constant to @'LuaStatus'@.+-- | Convert C integer constant to @'Status'@. toStatus :: StatusCode -> Status toStatus (StatusCode c) = case c of   #{const LUA_OK}        -> OK@@ -331,7 +334,7 @@   #{const LUA_ERRGCMM}   -> ErrGcmm   #{const LUA_ERRERR}    -> ErrErr   #{const LUA_ERRFILE}   -> ErrFile-  n -> error $ "Cannot convert (" ++ show n ++ ") to LuaStatus"+  n -> error $ "Cannot convert (" ++ show n ++ ") to Status" {-# INLINABLE toStatus #-}  -- | Integer code used to signal the status of a thread or computation.

@@ -80,9 +80,9 @@ -- @'Lua.Exception'@; exception handling must be done by the converted -- Haskell function. Failure to do so will cause the program to crash. ----- E.g., the following code could be used to handle an Exception of type--- FooException, if that type is an instance of @'MonadCatch'@ and--- @'Pushable'@:+-- E.g., the following code could be used to handle an Exception+-- of type FooException, if that type is an instance of+-- 'Control.Monad.Catch.MonadCatch' and 'Pushable': -- -- > toHaskellFunction (myFun `catchM` (\e -> raiseError (e :: FooException))) --

@@ -0,0 +1,242 @@+{-# LANGUAGE OverloadedStrings #-}+{-|+Module      : Foreign.Lua.Peek+Copyright   : © 2020 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Stability   : beta+Portability : Portable++Functions which unmarshal and retrieve Haskell values from Lua's stack.+-}+module Foreign.Lua.Peek+  ( Peeker+  , PeekError (..)+  , errorMsg+  , force+  , toPeeker+  -- * Primitives+  , peekBool+  , peekIntegral+  , peekRealFloat+  -- * Strings+  , peekByteString+  , peekLazyByteString+  , peekString+  , peekText+  -- * Collections+  , peekKeyValuePairs+  , peekList+  , peekMap+  , peekSet+  ) where++import Control.Applicative ((<|>))+import Data.Bifunctor (first, second)+import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty (..), (<|))+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import Data.Text (Text)+import Foreign.Lua.Core as Lua+import Text.Read (readMaybe)++import qualified Data.ByteString.Lazy as BL+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Foreign.Lua.Utf8 as Utf8++-- | List of errors which occurred while retrieving a value from+-- the stack.+newtype PeekError = PeekError { fromPeekError :: NonEmpty Text }+  deriving (Eq, Show)++formatPeekError :: PeekError -> String+formatPeekError (PeekError msgs) = T.unpack $+  T.intercalate "\n\t" (NonEmpty.toList msgs)++-- | Function to retrieve a value from Lua's stack.+type Peeker a = StackIndex -> Lua (Either PeekError a)++-- | Create a peek error from an error message.+errorMsg :: Text -> PeekError+errorMsg  = PeekError . pure++-- | Add a message to the peek traceback stack.+pushMsg :: Text -> PeekError -> PeekError+pushMsg msg (PeekError lst) = PeekError $ msg <| lst++-- | Add context information to the peek traceback stack.+retrieving :: Text -> Either PeekError a -> Either PeekError a+retrieving msg = first $ pushMsg ("retrieving " <> msg)++-- | Force creation of a result, throwing an exception if that's+-- not possible.+force :: Either PeekError a -> Lua a+force = either (throwMessage . formatPeekError) return++-- | Convert an old peek funtion to a 'Peeker'.+toPeeker :: (StackIndex -> Lua a)+         -> Peeker a+toPeeker op idx =+  (Right <$> op idx) <|> return (Left $ errorMsg "retrieving failed")++-- | Use @test@ to check whether the value at stack index @n@ has+-- the correct type and use @peekfn@ to convert it to a Haskell+-- value if possible. A successfully received value is wrapped+-- using the 'Right' constructor, while a type mismatch results+-- in @Left PeekError@ with the given error message.+typeChecked :: Text                      -- ^ expected type+            -> (StackIndex -> Lua Bool)  -- ^ pre-condition checker+            -> Peeker a+            -> Peeker a+typeChecked expectedType test peekfn idx = do+  v <- test idx+  if v+    then peekfn idx+    else Left <$> mismatchError expectedType idx++-- | Report the expected and actual type of the value under the given index if+-- conversion failed.+reportValueOnFailure :: Text+                     -> (StackIndex -> Lua (Maybe a))+                     -> Peeker a+reportValueOnFailure expected peekMb idx = do+  res <- peekMb idx+  case res of+    Just x  -> return $ Right x+    Nothing -> Left  <$> mismatchError expected idx++-- | Return a Result error containing a message about the assertion failure.+mismatchError :: Text -> StackIndex -> Lua PeekError+mismatchError expected idx = do+  actualType  <- ltype idx >>= typename+  actualValue <- Utf8.toText <$> tostring' idx <* pop 1+  return . errorMsg $+    "expected " <> expected <> ", got '" <>+    actualValue <> "' (" <> T.pack actualType <> ")"++-- | Retrieves a 'Bool' as a Lua boolean.+peekBool :: Peeker Bool+peekBool = fmap Right . toboolean++--+-- Strings+--++-- | Like @'tostring', but ensures that the value at the given index is+-- not silently converted to a string, as would happen with numbers.+toByteString :: StackIndex -> Lua (Maybe ByteString)+toByteString idx = do+  -- copy value, as tostring converts numbers to strings *in-place*.+  pushvalue idx+  tostring stackTop <* pop 1++-- | Retrieves a 'ByteString' as a raw string.+peekByteString :: Peeker ByteString+peekByteString = reportValueOnFailure "string" toByteString++-- | Retrieves a lazy 'BL.ByteString' as a raw string.+peekLazyByteString :: Peeker BL.ByteString+peekLazyByteString = fmap (second BL.fromStrict) . peekByteString++-- | Retrieves a 'String' as an UTF-8 encoded Lua string.+peekString :: Peeker String+peekString = fmap (second Utf8.toString) . peekByteString++-- | Retrieves a 'T.Text' value as an UTF-8 encoded string.+peekText :: Peeker T.Text+peekText = fmap (second Utf8.toText) . peekByteString++--+-- Numbers+--++-- | Retrieves an 'Integral' value from the Lua stack.+peekIntegral :: (Integral a, Read a) => Peeker a+peekIntegral idx =+  ltype idx >>= \case+    TypeNumber  -> second fromIntegral <$>+                   reportValueOnFailure "Integral" tointeger idx+    TypeString  -> do+      str <- Utf8.toString .+             fromMaybe (Prelude.error "programming error in peekIntegral")+             <$> tostring idx+      let msg = "expected Integral, got '" <> T.pack str <> "' (string)"+      return $ maybe (Left $ errorMsg msg) Right $ readMaybe str+    _ -> Left <$> mismatchError "Integral" idx++-- | Retrieve a 'RealFloat' (e.g., 'Float' or 'Double') from the stack.+peekRealFloat :: (RealFloat a, Read a) => Peeker a+peekRealFloat idx =+  ltype idx >>= \case+    TypeString  -> do+      str <- Utf8.toString .+             fromMaybe (Prelude.error "programming error in peekRealFloat")+             <$> tostring idx+      let msg = "expected RealFloat, got '" <> T.pack str <> "' (string)"+      return $ maybe (Left $ errorMsg msg) Right $ readMaybe str+    _ -> second realToFrac <$>+         reportValueOnFailure "RealFloat" tonumber idx++-- | Reads a numerically indexed table @t@ into a list, where the 'length' of+-- the list is equal to @#t@. The operation will fail if a numerical field @n@+-- with @1 ≤ n < #t@ is missing.+peekList :: Peeker a -> Peeker [a]+peekList peekElement = typeChecked "table" istable $ \idx -> do+  let elementsAt [] = return (Right [])+      elementsAt (i : is) = do+        eitherX <- rawgeti idx i *> peekElement (nthFromTop 1) <* pop 1+        case eitherX of+          Right x  -> second (x:) <$> elementsAt is+          Left err -> return . Left $+                      pushMsg ("in field " <> T.pack (show i)) err+  listLength <- fromIntegral <$> rawlen idx+  elementsAt [1..listLength]++-- | Retrieves a key-value Lua table as 'Map'.+peekMap :: Ord a => Peeker a -> Peeker b -> Peeker (Map a b)+peekMap keyPeeker valuePeeker =+    fmap (retrieving "Map" . second Map.fromList)+  . peekKeyValuePairs keyPeeker valuePeeker++-- | Read a table into a list of pairs.+peekKeyValuePairs :: Peeker a -> Peeker b -> Peeker [(a, b)]+peekKeyValuePairs keyPeeker valuePeeker =+  typeChecked "table" istable $ \idx -> do+    idx' <- absindex idx+    let remainingPairs = do+          res <- nextPair keyPeeker valuePeeker idx'+          case res of+            Left err       -> return $ Left err+            Right Nothing  -> return $ Right []+            Right (Just a) -> second (a:) <$> remainingPairs+    pushnil+    remainingPairs++-- | Get the next key-value pair from a table. Assumes the last+-- key to be on the top of the stack and the table at the given+-- index @idx@. The next key, if it exists, is left at the top of+-- the stack.+nextPair :: Peeker a -> Peeker b -> Peeker (Maybe (a, b))+nextPair keyPeeker valuePeeker idx = retrieving "key-value pair" <$> do+  hasNext <- next idx+  if not hasNext+    then return $ Right Nothing+    else do+      key   <- retrieving "key"   <$> keyPeeker   (nthFromTop 2)+      value <- retrieving "value" <$> valuePeeker (nthFromTop 1)+      pop 1    -- remove value, leave the key+      return $ curry Just <$> key <*> value++-- | 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 a -> Peeker (Set a)+peekSet elementPeeker =+    fmap (retrieving "Set" .+          second (Set.fromList . map fst . filter snd))+  . peekKeyValuePairs elementPeeker peekBool

@@ -0,0 +1,108 @@+{-|+Module      : Foreign.Lua.Push+Copyright   : © 2020 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Stability   : beta+Portability : Portable++Functions which marshal and push Haskell values onto Lua's stack.+-}+module Foreign.Lua.Push+  ( Pusher+  -- * Primitives+  , pushBool+  , pushIntegral+  , pushRealFloat+  -- * Strings+  , pushByteString+  , pushLazyByteString+  , pushString+  , pushText+  -- * Collections+  , pushList+  , pushMap+  , pushSet+  ) where++import Control.Monad (zipWithM_)+import Data.ByteString (ByteString)+import Data.Map (Map, toList)+import Data.Set (Set)+import Foreign.Lua.Core as Lua+import Numeric (showGFloat)++import qualified Data.Text as T+import qualified Data.ByteString.Lazy as BL+import qualified Foreign.Lua.Utf8 as Utf8++-- | Function to push a value to Lua's stack.+type Pusher a = a -> Lua ()++-- | Pushes a 'Bool' as a Lua boolean.+pushBool :: Pusher Bool+pushBool = pushboolean++-- | Pushes a 'T.Text' value as an UTF-8 encoded string.+pushText :: Pusher T.Text+pushText = pushstring . Utf8.fromText++-- | Pushes a 'ByteString' as a raw string.+pushByteString :: Pusher ByteString+pushByteString = pushstring++-- | Pushes a lazy 'BL.ByteString' as a raw string.+pushLazyByteString :: Pusher BL.ByteString+pushLazyByteString = pushstring . BL.toStrict++-- | Pushes a 'String' as an UTF-8 encoded Lua string.+pushString :: String -> Lua ()+pushString = pushstring . Utf8.fromString++-- | Pushes an @Integer@ to the Lua stack. Values representable as Lua+-- integers are pushed as such; bigger integers are represented using+-- their string representation.+pushIntegral :: (Integral a, Show a) => a -> Lua ()+pushIntegral i =+  let maxInt = fromIntegral (maxBound :: Lua.Integer)+      minInt = fromIntegral (minBound :: Lua.Integer)+      i' = fromIntegral i :: Prelude.Integer+  in if i' >= minInt && i' <= maxInt+     then pushinteger $ fromIntegral i+     else pushString  $ show i++-- | Push a floating point number to the Lua stack. Uses a string+-- representation for all types which do not match the float properties+-- of the 'Lua.Number' type.+pushRealFloat :: RealFloat a => a -> Lua ()+pushRealFloat f =+  let+    number = 0 :: Lua.Number+    realFloatFitsInNumber = floatRadix number == floatRadix f+      && floatDigits number == floatDigits f+      && floatRange number == floatRange f+  in if realFloatFitsInNumber+     then pushnumber (realToFrac f :: Lua.Number)+     else pushString (showGFloat Nothing f "")++-- | Push list as numerically indexed table.+pushList :: Pusher a -> [a] -> Lua ()+pushList push xs = do+  let setField i x = push x *> rawseti (-2) i+  newtable+  zipWithM_ setField [1..] xs++-- | Push 'Map' as default key-value Lua table.+pushMap :: Pusher a -> Pusher b -> Pusher (Map a b)+pushMap pushKey pushValue m = do+  let addValue (k, v) = pushKey k *> pushValue v *> rawset (-3)+  newtable+  mapM_ addValue (toList m)++-- | Push a 'Set' as idiomatic Lua set, i.e., as a table with the set+-- elements as keys and @true@ as values.+pushSet :: Pusher a -> Pusher (Set a)+pushSet pushElement set = do+  let addItem item = pushElement item *> pushboolean True *> rawset (-3)+  newtable+  mapM_ addItem set

@@ -21,26 +21,27 @@   , reportValueOnFailure   ) where +import Control.Monad ((>=>)) import Data.ByteString (ByteString) import Data.Map (Map, fromList) import Data.Set (Set) import Foreign.Lua.Core as Lua import Foreign.Ptr (Ptr)-import Text.Read (readMaybe)  import qualified Control.Monad.Catch as Catch import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.ByteString.Lazy as BL+import qualified Foreign.Lua.Peek as Peek import qualified Foreign.Lua.Utf8 as Utf8  -- | Use @test@ to check whether the value at stack index @n@ has the correct--- type and use @peekfn@ to convert it to a haskell value if possible. A--- successfully received value is wrapped using the @'Success'@ constructor,--- while a type mismatch results in an @Error@ with the given error message.-typeChecked :: String-            -> (StackIndex -> Lua Bool)-            -> (StackIndex -> Lua a)+-- type and use @peekfn@ to convert it to a haskell value if possible. Throws+-- and exception if the test failes with the expected type name as part of the+-- message.+typeChecked :: String                   -- ^ expected type+            -> (StackIndex -> Lua Bool) -- ^ pre-condition Checker+            -> (StackIndex -> Lua a)    -- ^ retrieval function             -> StackIndex -> Lua a typeChecked expectedType test peekfn idx = do   v <- test idx@@ -84,10 +85,7 @@   peek = reportValueOnFailure "number" tonumber  instance Peekable ByteString where-  peek = reportValueOnFailure "string" $ \idx -> do-    -- copy value, as tostring converts numbers to strings *in-place*.-    pushvalue idx-    tostring stackTop <* pop 1+  peek = Peek.peekByteString >=> Peek.force  instance Peekable Bool where   peek = toboolean@@ -102,25 +100,25 @@   peek = reportValueOnFailure "Lua state (i.e., a thread)" tothread  instance Peekable T.Text where-  peek = fmap Utf8.toText . peek+  peek = Peek.peekText >=> Peek.force  instance Peekable BL.ByteString where-  peek = fmap BL.fromStrict . peek+  peek = Peek.peekLazyByteString >=> Peek.force  instance Peekable Prelude.Integer where-  peek = peekInteger+  peek = Peek.peekIntegral >=> Peek.force  instance Peekable Int where-  peek = fmap fromIntegral <$> peekInteger+  peek = Peek.peekIntegral >=> Peek.force  instance Peekable Float where-  peek = peekRealFloat+  peek = Peek.peekRealFloat >=> Peek.force  instance Peekable Double where-  peek = peekRealFloat+  peek = Peek.peekRealFloat >=> Peek.force  instance {-# OVERLAPS #-} Peekable [Char] where-  peek = fmap Utf8.toString . peek+  peek = Peek.peekString >=> Peek.force  instance Peekable a => Peekable [a] where   peek = peekList@@ -131,26 +129,6 @@ instance (Ord a, Peekable a) => Peekable (Set a) where   peek = -- All keys with non-nil values are in the set     fmap (Set.fromList . map fst . filter snd) . peekKeyValuePairs---- | Retrieve an @Int@ value from the stack.-peekInteger :: StackIndex -> Lua Prelude.Integer-peekInteger idx = ltype idx >>= \case-  TypeString -> do-    s <- peek idx-    case readMaybe s of-      Just x -> return x-      Nothing -> mismatchError "integer" idx-  _ -> fromIntegral <$> (peek idx :: Lua Lua.Integer)---- | Retrieve a @'RealFloat'@ (e.g., Float or Double) from the stack.-peekRealFloat :: (Read a, RealFloat a) => StackIndex -> Lua a-peekRealFloat idx = ltype idx >>= \case-  TypeString -> do-    s <- peek idx-    case readMaybe s of-      Just x -> return x-      Nothing -> mismatchError "number" idx-  _ -> realToFrac <$> (peek idx :: Lua Lua.Number)  -- | Read a table into a list peekList :: Peekable a => StackIndex -> Lua [a]

@@ -18,16 +18,15 @@   , pushList   ) where -import Control.Monad (zipWithM_) import Data.ByteString (ByteString)-import Data.Map (Map, toList)+import Data.Map (Map)+import Data.Text (Text) import Data.Set (Set) import Foreign.Lua.Core as Lua+import Foreign.Lua.Push as Push import Foreign.Ptr (Ptr) -import qualified Data.Text as T import qualified Data.ByteString.Lazy as BL-import qualified Foreign.Lua.Utf8 as Utf8  -- | A value that can be pushed to the Lua stack. class Pushable a where@@ -56,17 +55,17 @@ instance Pushable (Ptr a) where   push = pushlightuserdata -instance Pushable T.Text where-  push = push . Utf8.fromText+instance Pushable Text where+  push = pushText  instance Pushable BL.ByteString where-  push = push . BL.toStrict+  push = pushLazyByteString  instance Pushable Prelude.Integer where-  push = pushInteger+  push = pushIntegral  instance Pushable Int where-  push = pushInteger . fromIntegral+  push = pushIntegral  instance Pushable Float where   push = pushRealFloat@@ -75,53 +74,16 @@   push = pushRealFloat  instance {-# OVERLAPS #-} Pushable [Char] where-  push = push . Utf8.fromString+  push = pushString  instance Pushable a => Pushable [a] where-  push = pushList----- | Push an @Int@ to the Lua stack. Numbers representable as Lua integers are--- pushed as such; bigger integers are represented using their string--- representation.-pushInteger :: Prelude.Integer -> Lua ()-pushInteger i =-  let maxInt = fromIntegral (maxBound :: Lua.Integer)-      minInt = fromIntegral (minBound :: Lua.Integer)-  in if i >= minInt && i <= maxInt-     then push (fromIntegral i :: Lua.Integer)-     else push (show i)---- | Push a floating point number to the Lua stack.-pushRealFloat :: (RealFloat a, Show a) => a -> Lua ()-pushRealFloat f =-  let-    number = 0 :: Lua.Number-    doubleFitsInNumber = floatRadix number == floatRadix f-      && floatDigits number == floatDigits f-      && floatRange number == floatRange f-  in if doubleFitsInNumber-     then push (realToFrac f :: Lua.Number)-     else push (show f)---- | Push list as numerically indexed table.-pushList :: Pushable a => [a] -> Lua ()-pushList xs = do-  let setField i x = push x *> rawseti (-2) i-  newtable-  zipWithM_ setField [1..] xs+  push = pushList push  instance (Pushable a, Pushable b) => Pushable (Map a b) where-  push m = do-    let addValue (k, v) = push k *> push v *> rawset (-3)-    newtable-    mapM_ addValue (toList m)+  push = pushMap push push  instance Pushable a => Pushable (Set a) where-  push set = do-    let addItem item = push item *> push True *> rawset (-3)-    newtable-    mapM_ addItem set+  push = pushSet push  -- -- Tuples

@@ -11,8 +11,9 @@  Convenience functions to convert Haskell values into Lua userdata. -The main purpose of this module is to allow fast and simple creation of-instances for @'Peekable'@ and @'Pushable'@. E.g., given a data type Person+The main purpose of this module is to allow fast and simple+creation of instances for @Peekable@ and @Pushable@. E.g., given+a data type Person  > data Person = Person { name :: String, age :: Int } >    deriving (Eq, Show, Typeable, Data)

@@ -20,15 +20,18 @@  import qualified Data.Text as T import qualified Data.Text.Encoding as TextEncoding+import qualified Data.Text.Encoding.Error as TextEncoding --- | Decode @'ByteString'@ to @'String'@ using UTF-8.+-- | Decode @'ByteString'@ to @'String'@ using UTF-8. Invalid input+-- bytes are replaced with the Unicode replacement character U+FFFD. toString :: ByteString -> String-toString = T.unpack . TextEncoding.decodeUtf8+toString = T.unpack . toText {-# INLINABLE toString #-} --- | Decode @'ByteString'@ to @'Text'@ using UTF-8.+-- | Decode @'ByteString'@ to @'Text'@ using UTF-8. Invalid input+-- bytes are replaced with the Unicode replacement character U+FFFD. toText :: ByteString -> Text-toText = TextEncoding.decodeUtf8+toText = TextEncoding.decodeUtf8With TextEncoding.lenientDecode {-# INLINABLE toText #-}  -- | Encode @'String'@ to @'ByteString'@ using UTF-8.

@@ -57,8 +57,8 @@ runEither = try . run  -- | Run Lua computation with the given Lua state and the default--- error-to-exception converter (@'throwTopStringAsException'@). Exception--- handling is left to the caller.+-- error-to-exception converter. Exception handling is left to+-- the caller. runWith :: Lua.State -> Lua a -> IO a runWith = Lua.runWithConverter defaultErrorConversion 

@@ -0,0 +1,273 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-|+Module      : Foreign.Lua.PeekTests+Copyright   : © 2020 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Stability   : alpha+Portability : OverloadedStrings, TypeApplications++Tests for Haskell-value retriever functions.+-}+module Foreign.Lua.PeekTests (tests) where++import Control.Monad (forM_, zipWithM_)+import Data.Either (isLeft)+import Foreign.Lua.Peek++import Test.HsLua.Arbitrary ()+import Test.HsLua.Util ( (=:), pushLuaExpr, shouldBeResultOf+                       , shouldHoldForResultOf)+import Test.QuickCheck.Instances ()+import Test.QuickCheck.Monadic (monadicIO, run, assert)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import qualified Data.ByteString.Char8 as Char8+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Foreign.Lua as Lua+import qualified Foreign.Lua.Utf8 as Utf8++-- | Calling Haskell functions from Lua.+tests :: TestTree+tests = testGroup "Peek"+  [ testGroup "peekBool"+    [ "True" =:+      Right True `shouldBeResultOf` do+        Lua.pushboolean True+        peekBool Lua.stackTop++    , "False" =:+      Right False `shouldBeResultOf` do+        Lua.pushboolean False+        peekBool Lua.stackTop++    , "Numbers are truthy" =:+      Right True `shouldBeResultOf` do+        Lua.pushnumber 0+        peekBool Lua.stackTop++    , "Nil is falsy" =:+      Right False `shouldBeResultOf` do+        Lua.pushnil+        peekBool Lua.stackTop++    -- no tests for failing cases, this function always succeeds.+    ]++  , testGroup "peekIntegral"+    [ "negative Int" =:+      Right (-5) `shouldBeResultOf` do+        Lua.pushinteger (-5)+        peekIntegral @Int Lua.stackTop++    , "Int as string" =:+      Right 720 `shouldBeResultOf` do+        Lua.pushstring "720"+        peekIntegral @Int Lua.stackTop++    , "fail on boolean" =:+      let msg = "expected Integral, got 'true' (boolean)"+      in Left (errorMsg msg) `shouldBeResultOf` do+        Lua.pushboolean True+        peekIntegral @Int Lua.stackTop++    , "fail on non-numeric string" =:+      let msg = "expected Integral, got 'not a number' (string)"+      in Left (errorMsg msg) `shouldBeResultOf` do+        Lua.pushstring "not a number"+        peekIntegral @Integer Lua.stackTop+    ]++  , testGroup "peekRealFloat"+    [ "negative Float" =:+      Right (-13.37) `shouldBeResultOf` do+        Lua.pushnumber (-13.37)+        peekRealFloat @Float Lua.stackTop++    , "number as string" =:+      Right (-720.0) `shouldBeResultOf` do+        Lua.pushstring "-720"+        peekRealFloat @Float Lua.stackTop++    , "scientific notation string" =:+      Right 0.00071 `shouldBeResultOf` do+        Lua.pushstring "7.1e-4"+        peekRealFloat @Float Lua.stackTop++    , "fail on boolean" =:+      let msg = "expected RealFloat, got 'true' (boolean)"+      in Left (errorMsg msg) `shouldBeResultOf` do+        Lua.pushboolean True+        peekRealFloat @Float Lua.stackTop++    , "fail on non-numeric string" =:+      let msg = "expected RealFloat, got 'not a number' (string)"+      in Left (errorMsg msg) `shouldBeResultOf` do+        Lua.pushstring "not a number"+        peekRealFloat @Double Lua.stackTop+    ]++  , testGroup "Strings"+    [ testGroup "peekByteString"+      [ testProperty "retrieve any string" $ \bs -> monadicIO $ do+          retrieved <- run $ Lua.run $ do+            Lua.pushstring bs+            peekByteString Lua.stackTop+          assert (retrieved == Right bs)++      , testProperty "retrieve integer as string" $ \n -> monadicIO $ do+          retrieved <- run . Lua.run $ do+            Lua.pushinteger n+            peekByteString Lua.stackTop+          let numberAsByteString = Char8.pack . show @Integer . fromIntegral $ n+          assert (retrieved == Right numberAsByteString)++      , "fails on boolean" =:+      let msg = "expected string, got 'true' (boolean)"+      in Left (errorMsg msg) `shouldBeResultOf` do+        Lua.pushboolean True+        peekByteString Lua.stackTop+      ]++    , testGroup "peekText"+      [ testProperty "retrieve any string" $ \bs -> monadicIO $ do+          retrieved <- run $ Lua.run $ do+            Lua.pushstring bs+            peekText Lua.stackTop+          assert (retrieved == Right (Utf8.toText bs))++      , testProperty "retrieve UTF-8 encoded Text" $ \txt -> monadicIO $ do+          retrieved <- run $ Lua.run $ do+            Lua.pushstring (Utf8.fromText txt)+            peekText Lua.stackTop+          assert (retrieved == Right txt)++      , testProperty "retrieve integer as Text" $ \n -> monadicIO $ do+          retrieved <- run . Lua.run $ do+            Lua.pushinteger n+            peekText Lua.stackTop+          let numberAsByteString = T.pack . show @Integer . fromIntegral $ n+          assert (retrieved == Right numberAsByteString)++      , "fails on nil" =:+        let msg = "expected string, got 'nil' (nil)"+        in Left (errorMsg msg) `shouldBeResultOf` do+          Lua.pushnil+          peekByteString Lua.stackTop+      ]++    , testGroup "peekString"+      [ testProperty "retrieve UTF-8 encoded string" $ \txt -> monadicIO $ do+          retrieved <- run $ Lua.run $ do+            Lua.pushstring (Utf8.fromString txt)+            peekString Lua.stackTop+          assert (retrieved == Right txt)++      , "fails on table" =:+        isLeft `shouldHoldForResultOf` do+          _ <- Lua.pushglobaltable+          peekString Lua.stackTop++      , "fails on thread" =:+        isLeft `shouldHoldForResultOf` do+          _ <- Lua.pushthread+          peekString Lua.stackTop+      ]+    ]++  , testGroup "Containers"+    [ testGroup "peekList"+      [ "empty list" =:+        Right [] `shouldBeResultOf` do+          Lua.newtable+          peekList peekBool Lua.stackTop++      , testProperty "list of strings" $ \lst -> monadicIO $ do+          retrieved <- run $ Lua.run $ do+            Lua.newtable+            zipWithM_+              (\i s -> Lua.pushstring s *>+                       Lua.rawseti (Lua.nthFromTop 2) i)+              [1..]+              lst+            peekList peekByteString Lua.stackTop+          assert (retrieved == Right lst)++      , "string keys are not in list" =:+        Right [] `shouldBeResultOf` do+          pushLuaExpr "{['1'] = 'hello', ['2'] = 'world'}"+          peekList peekByteString Lua.stackTop++      , "missing pair causes an error" =:+        isLeft `shouldHoldForResultOf` do+          pushLuaExpr "{[1] = 'hello', [2] = 'world', [4] = 'nope'}"+          peekList peekByteString Lua.stackTop+      ]++    , testGroup "peekSet"+      [ "empty set" =:+        Right Set.empty `shouldBeResultOf` do+          Lua.newtable+          peekSet peekBool Lua.stackTop++      , testProperty "set of strings" $ \set -> monadicIO $ do+          retrieved <- run $ Lua.run $ do+            Lua.newtable+            forM_ (Set.toList set) $ \x -> do+              Lua.pushstring x+              Lua.pushboolean True+              Lua.rawset (Lua.nthFromTop 3)+            peekSet peekByteString Lua.stackTop+          assert (retrieved == Right set)++      , "keys with falsy values are not in set" =:+        Right (Set.fromList [1,3]) `shouldBeResultOf` do+          pushLuaExpr "{['1'] = 'hello', ['2'] = false, [3] = 5}"+          peekSet (peekIntegral @Int) Lua.stackTop++      , "fails if element peeker fails" =:+        let errorStack = [ "retrieving Set"+                         , "retrieving key-value pair"+                         , "retrieving key"+                         , "expected string, got 'true' (boolean)"]+        in Left (PeekError $ NonEmpty.fromList errorStack) `shouldBeResultOf` do+          pushLuaExpr "{ NaN = true, [true] = false }"+          peekSet peekText Lua.stackTop+      ]++    , testGroup "peekMap"+      [ "empty map" =:+        Right Map.empty `shouldBeResultOf` do+          Lua.newtable+          peekMap peekText peekText Lua.stackTop++      , "tables become maps" =:+        Right (Map.fromList [("one", 1), ("two", 2)]) `shouldBeResultOf` do+          pushLuaExpr "{ one = 1, two = 2}"+          peekMap peekText (peekIntegral @Int) Lua.stackTop++      , "fails if key peeker fails" =:+        let errorStack = [ "retrieving Map"+                         , "retrieving key-value pair"+                         , "retrieving key"+                         , "expected Integral, got 'NaN' (string)"]+        in Left (PeekError $ NonEmpty.fromList errorStack) `shouldBeResultOf` do+          pushLuaExpr "{ NaN = true }"+          peekMap (peekIntegral @Int) peekBool Lua.stackTop++      , "fails if value peeker fails" =:+        let errorStack = [ "retrieving Map"+                         , "retrieving key-value pair"+                         , "retrieving value"+                         , "expected string, got 'true' (boolean)"]+        in Left (PeekError $ NonEmpty.fromList errorStack) `shouldBeResultOf` do+          pushLuaExpr "{ [42] = true }"+          peekMap (peekIntegral @Int) peekText Lua.stackTop+      ]+    ]+  ]

@@ -0,0 +1,229 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-|+Module      : Foreign.Lua.PushTests+Copyright   : © 2020 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Stability   : alpha+Portability : OverloadedStrings, TypeApplications++Test pushing Haskell values to the stack.+-}+module Foreign.Lua.PushTests (tests) where++import Control.Monad (forM)+import Data.ByteString (ByteString)+import Data.Maybe (fromMaybe)+import Foreign.Lua.Core (Lua, Number)+import Foreign.Lua.Push++import Test.HsLua.Arbitrary ()+import Test.HsLua.Util ((=:), pushLuaExpr)+import Test.QuickCheck.Instances ()+import Test.QuickCheck.Monadic (monadicIO, run, assert)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertFailure)+import Test.Tasty.QuickCheck (Arbitrary, testProperty)++import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Foreign.Lua as Lua+import qualified Foreign.Lua.Utf8 as Utf8++-- | Calling Haskell functions from Lua.+tests :: TestTree+tests = testGroup "Push"+  [ testGroup "pushBool"+    [ "True" =:+      assertLuaEqual (pushBool True) "true"+    , "False" =:+      assertLuaEqual (pushBool False) "false"++    , testSingleElementProperty pushBool+    ]++  , testGroup "pushIntegral"+    [ testGroup "@Int"+      [ "0" =:+        assertLuaEqual (pushIntegral @Int 0) "0"+      , "23" =:+        assertLuaEqual (pushIntegral @Int 23) "23"+      , "-5" =:+        assertLuaEqual (pushIntegral @Int (-5)) "-5"+      , testSingleElementProperty (pushIntegral @Int)+      ]+    , testGroup "@Integer"+      [ "2^128 + 1" =:+        assertLuaEqual (pushIntegral @Integer+                         340282366920938463463374607431768211457)+                       "'340282366920938463463374607431768211457'"+      , "-2^129 + 1" =:+        assertLuaEqual (pushIntegral @Integer+                        (-680564733841876926926749214863536422911))+                       "'-680564733841876926926749214863536422911'"+      , testSingleElementProperty (pushIntegral @Integer)+      ]+    ]++  , testGroup "pushRealFloat"+    [ testGroup "@Number"+      [ "0.0" =:+        assertLuaEqual (pushRealFloat @Number 0.0) "0.0"+      , "42.0" =:+        assertLuaEqual (pushRealFloat @Number 42.0) "42.0"+      , "0.1" =:+        assertLuaEqual (pushRealFloat @Number 0.1) "0.1"+      , "-13.37" =:+        assertLuaEqual (pushRealFloat @Number (-13.37)) "-13.37"+      , testSingleElementProperty (pushRealFloat @Number)+      ]++    -- This test may fail if Lua is compiled with Float as the Number+    -- type. Usually though, numbers are doubles.+    , testGroup "@Float pushes strings"+      [ "0.0" =:+        assertLuaEqual (pushRealFloat @Float 0.0) "'0.0'"+      , "42.0" =:+        assertLuaEqual (pushRealFloat @Float 42.0) "'42.0'"+      , "-0.00071" =:+        assertLuaEqual (pushRealFloat @Float (-0.00071)) "'-7.1e-4'"+      , "-13.37" =:+        assertLuaEqual (pushRealFloat @Float (-13.37)) "'-13.37'"+      , testSingleElementProperty (pushRealFloat @Float)+      ]+    ]++  , testGroup "Strings"+    [ testGroup "pushByteString"+      [ "\"test\"" =:+        assertLuaEqual (pushByteString "test") "\"test\""+      , testSingleElementProperty pushByteString+      ]++    , testGroup "pushString"+      [ "\"test\"" =:+        assertLuaEqual (pushString "test") "\"test\""+      , "unicode" =:+        assertLuaEqual (pushString "ÄÉÏøûßð") (Utf8.fromString "'ÄÉÏøûßð'")+      , testSingleElementProperty pushString+      ]++    , testGroup "pushText"+      [ "\"test\"" =:+        assertLuaEqual (pushText "test") "\"test\""+      , "unicode" =:+        assertLuaEqual (pushText "ÄÉÏøûßð") (Utf8.fromString "'ÄÉÏøûßð'")+      , testSingleElementProperty pushText+      ]+    ]++  , testGroup "Collections"+    [ testGroup "pushList"+      [ testProperty "creates a table" $ \x -> monadicIO $ do+          producesTable <- run $ Lua.run $ do+            pushList pushBool x+            listType <- Lua.ltype Lua.stackTop+            return $ Lua.TypeTable == listType+          assert producesTable++      , testProperty "numeric indices start at 1" $ \list -> monadicIO $ do+          retrievedList <- run $ Lua.run $ do+            pushList (pushIntegral @Lua.Integer) list+            listIdx <- Lua.absindex Lua.stackTop+            forM [1..(fromIntegral $ length list)] $ \n ->+              Lua.rawgeti listIdx n+              *> (fromMaybe 0 <$> Lua.tointeger Lua.stackTop)+              <* Lua.pop 1+          assert $ retrievedList == list++      , testProperty "table size equals list length" $ \list -> monadicIO $ do+          tableSize <- run $ Lua.run $ do+            pushList pushString list+            Lua.rawlen Lua.stackTop+          assert $ fromIntegral tableSize == length list++      , testSingleElementProperty (pushList pushText)+      ]++    , testGroup "pushSet"+      [ testProperty "creates a table" $ \x -> monadicIO $ do+          producesTable <- run $ Lua.run $ do+            pushSet pushString x+            listType <- Lua.ltype Lua.stackTop+            return $ Lua.TypeTable == listType+          assert producesTable++      , testProperty "set values become table keys" $ \set -> monadicIO $+          case Set.lookupMin set of+            Nothing -> return ()+            Just el -> do+              hasKey <- run $ Lua.run $ do+                pushSet (pushIntegral @Lua.Integer) set+                pushIntegral el+                Lua.gettable (Lua.nthFromTop 2)+                Lua.toboolean Lua.stackTop+              assert hasKey++      , testSingleElementProperty (pushSet pushText)+      ]++    , testGroup "pushMap"+      [ testProperty "creates a table" $ \m -> monadicIO $ do+          producesTable <- run $ Lua.run $ do+            pushMap pushString pushString m+            listType <- Lua.ltype Lua.stackTop+            return $ Lua.TypeTable == listType+          assert producesTable++      , testProperty "pairs are in table" $ \m -> monadicIO $+          case Map.lookupMax m of+            Nothing -> return ()+            Just (k, v) -> do+              tabVal <- run $ Lua.run $ do+                pushMap pushText (pushRealFloat @Lua.Number) m+                pushText k+                Lua.gettable (Lua.nthFromTop 2)+                fromMaybe (error "key not found") <$>+                  Lua.tonumber Lua.stackTop+              assert (tabVal == v)++      , testSingleElementProperty (pushMap pushText (pushRealFloat @Double))+      ]+    ]+  ]++-- | Executes a Lua action and checks whether a the value at the top of the+-- stack equals the value represented by the string.+assertLuaEqual :: Lua () -> ByteString -> Assertion+assertLuaEqual action lit =+  let comparison = Lua.run $ do+        action+        pushLuaExpr lit+        isSame <- Lua.rawequal (Lua.nthFromTop 1) (Lua.nthFromTop 2)+        if isSame+          then return Nothing+          else do+            expectedType <- Lua.ltype (Lua.nthFromTop 1) >>= Lua.typename+            actualType <- Lua.ltype (Lua.nthFromTop 2) >>= Lua.typename+            actual <- Lua.tostring' (Lua.nthFromTop 2)+            return . Just $+              "Expected '" <> Utf8.toString lit <> "' (" <> expectedType <>+              ") but got '" <> Utf8.toString actual <> "'" <>+              " (" <> actualType <> ")"+  in comparison >>= \case+    Nothing -> return ()+    Just err -> assertFailure err+++-- | Verifies that the operation adds exactly one element to the Lua stack.+testSingleElementProperty :: (Arbitrary a, Show a) => Pusher a -> TestTree+testSingleElementProperty push = testProperty "pushes single element" $ \x ->+  monadicIO $ do+    (oldSize, newSize) <- run . Lua.run $ do+      old <- Lua.gettop+      push x+      new <- Lua.gettop+      return (old, new)+    assert (newSize == succ oldSize)

@@ -25,6 +25,8 @@ import qualified Foreign.Lua.CoreTests import qualified Foreign.Lua.FunctionCallingTests import qualified Foreign.Lua.ModuleTests+import qualified Foreign.Lua.PeekTests+import qualified Foreign.Lua.PushTests import qualified Foreign.Lua.TypesTests import qualified Foreign.Lua.Types.PeekableTests import qualified Foreign.Lua.Types.PushableTests@@ -38,6 +40,7 @@ tests :: [TestTree] tests =   [ Foreign.Lua.CoreTests.tests+  , Foreign.Lua.PushTests.tests   , Foreign.Lua.FunctionCallingTests.tests   , Foreign.Lua.UtilTests.tests   , testGroup "Sendings and receiving values from the stack"@@ -48,4 +51,5 @@   , Foreign.Lua.UserdataTests.tests   , Foreign.Lua.ModuleTests.tests   , Foreign.LuaTests.tests+  , Foreign.Lua.PeekTests.tests   ]