diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,24 @@ ## Changelog +### 0.9.4 (unpublished) + +- Make Lua an instance of MonadMask: MonadMask from Control.Monad.Catch + allows to mask asynchronous exceptions. This allows to define a + finalizer for Lua operations. +- Add functions and constants to refer to stack indices: The functions + `nthFromBottom`, `nthFromTop` as well as the constants `stackTop` and + `stackBottom` have been introduced. Numeric constants are less clear, + and named constants can aid readability. +- Add type OrNil: This type can be used when dealing with optional + arguments to Lua functions. +- Add function absindex: it converts the acceptable index `idx` into an + equivalent absolute index (that is, one that does not depend on the + stack top). The function calls `lua_absindex` when compiled with Lua + 5.2 or later; for Lua 5.1, it is reimplemented in Haskell. +- Functions in `tasty` which have been deprecated have been replaced + with non-deprecated alternatives. + + ### 0.9.3 - Re-export more FunctionCalling helpers in `Foreign.Lua`: The typeclass diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,6 @@ [![Build Status]](https://travis-ci.org/hslua/hslua) [![AppVeyor Status]](https://ci.appveyor.com/project/tarleb/hslua-r2y18) -[![Coverage Status]](https://coveralls.io/github/osa1/hslua?branch=master) [![Hackage]](https://hackage.haskell.org/package/hslua) Hslua provides bindings, wrappers, types, and helper functions to bridge haskell @@ -10,7 +9,6 @@ [Build Status]: https://travis-ci.org/hslua/hslua.svg?branch=master [AppVeyor Status]: https://ci.appveyor.com/api/projects/status/ldutrilgxhpcau94/branch/master?svg=true -[Coverage Status]: https://coveralls.io/repos/osa1/hslua/badge.svg?branch=master&service=github [Hackage]: http://img.shields.io/hackage/v/hslua.svg diff --git a/hslua.cabal b/hslua.cabal --- a/hslua.cabal +++ b/hslua.cabal @@ -1,5 +1,5 @@ name: hslua -version: 0.9.3 +version: 0.9.4 stability: beta cabal-version: >= 1.8 license: MIT diff --git a/src/Foreign/Lua/Api.hs b/src/Foreign/Lua/Api.hs --- a/src/Foreign/Lua/Api.hs +++ b/src/Foreign/Lua/Api.hs @@ -45,6 +45,10 @@ , LuaInteger , LuaNumber , StackIndex (..) + , nthFromBottom + , nthFromTop + , stackTop + , stackBottom , NumArgs (..) , NumResults (..) -- * Lua API @@ -59,6 +63,7 @@ , newstate , close -- ** Basic stack manipulation + , absindex , gettop , settop , pushvalue @@ -253,6 +258,20 @@ -- -- API functions -- + +-- | Converts the acceptable index @idx@ into an equivalent absolute index (that +-- is, one that does not depend on the stack top). +absindex :: StackIndex -> Lua StackIndex +#if LUA_VERSION_NUMBER >= 502 +absindex = liftLua1 lua_absindex +#else +absindex idx = + if idx > 0 || ispseudo idx + then return idx + else fmap (\top -> top + 1 + idx) gettop + where + ispseudo = (<= registryindex) +#endif -- | Calls a function. -- diff --git a/src/Foreign/Lua/Api/RawBindings.hsc b/src/Foreign/Lua/Api/RawBindings.hsc --- a/src/Foreign/Lua/Api/RawBindings.hsc +++ b/src/Foreign/Lua/Api/RawBindings.hsc @@ -66,6 +66,12 @@ -------------------------------------------------------------------------------- -- * Basic stack manipulation +#if LUA_VERSION_NUMBER >= 502 +-- | See +foreign import ccall unsafe "lua.h lua_absindex" + lua_absindex :: LuaState -> StackIndex -> IO StackIndex +#endif + -- | See foreign import ccall unsafe "lua.h lua_gettop" lua_gettop :: LuaState -> IO StackIndex diff --git a/src/Foreign/Lua/Api/Types.hsc b/src/Foreign/Lua/Api/Types.hsc --- a/src/Foreign/Lua/Api/Types.hsc +++ b/src/Foreign/Lua/Api/Types.hsc @@ -258,6 +258,22 @@ newtype StackIndex = StackIndex { fromStackIndex :: CInt } deriving (Enum, Eq, Num, Ord, Show) +-- | Stack index of the nth element from the top of the stack. +nthFromTop :: CInt -> StackIndex +nthFromTop n = StackIndex (-n) + +-- | Stack index of the nth element from the bottom of the stack. +nthFromBottom :: CInt -> StackIndex +nthFromBottom = StackIndex + +-- | Top of the stack +stackTop :: StackIndex +stackTop = -1 + +-- | Bottom of the stack +stackBottom :: StackIndex +stackBottom = 1 + -- -- Number of arguments and return values -- diff --git a/src/Foreign/Lua/Types/Lua.hs b/src/Foreign/Lua/Types/Lua.hs --- a/src/Foreign/Lua/Types/Lua.hs +++ b/src/Foreign/Lua/Types/Lua.hs @@ -39,7 +39,7 @@ , liftLua1 ) where -import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Reader (ReaderT (..), MonadReader, MonadIO, ask, liftIO) import Foreign.Lua.Api.Types (LuaState) @@ -51,6 +51,7 @@ , Monad , MonadCatch , MonadIO + , MonadMask , MonadReader LuaState , MonadThrow ) diff --git a/src/Foreign/Lua/Util.hs b/src/Foreign/Lua/Util.hs --- a/src/Foreign/Lua/Util.hs +++ b/src/Foreign/Lua/Util.hs @@ -36,6 +36,7 @@ , setglobal' , runLua , runLuaEither + , OrNil (toMaybe) ) where import Control.Exception (bracket, try) @@ -47,7 +48,7 @@ -- exceptions are passed through; error handling is the responsibility of the -- caller. runLua :: Lua a -> IO a -runLua = bracket newstate close . flip runLuaWith +runLua = (newstate `bracket` close) . flip runLuaWith -- | Run the given Lua computation; exceptions raised in haskell code are -- caught, but other exceptions (user exceptions raised in haskell, unchecked @@ -94,3 +95,20 @@ getnested (x:xs) = do getglobal x mapM_ (\a -> getfield (-1) a *> remove (-2)) xs + +-- | Newtype wrapper intended to be used for optional Lua values. Nesting this +-- type is strongly discouraged as missing values on inner levels are +-- indistinguishable from missing values on an outer level; wrong values +-- would be the likely result. +newtype OrNil a = OrNil { toMaybe :: Maybe a } + +instance FromLuaStack a => FromLuaStack (OrNil a) where + peek idx = do + noValue <- isnoneornil idx + if noValue + then return (OrNil Nothing) + else OrNil . Just <$> peek idx + +instance ToLuaStack a => ToLuaStack (OrNil a) where + push (OrNil Nothing) = pushnil + push (OrNil (Just x)) = push x diff --git a/test/Foreign/Lua/ApiTest.hs b/test/Foreign/Lua/ApiTest.hs --- a/test/Foreign/Lua/ApiTest.hs +++ b/test/Foreign/Lua/ApiTest.hs @@ -58,7 +58,7 @@ [ luaTestCase "copies stack elements using positive indices" $ do pushLuaExpr "5, 4, 3, 2, 1" copy 4 3 - rawequal 4 3 + rawequal (nthFromBottom 4) (nthFromBottom 3) , luaTestCase "copies stack elements using negative indices" $ do pushLuaExpr "5, 4, 3, 2, 1" copy (-1) (-3) @@ -80,12 +80,21 @@ return (movedEl == 9 && newTop == 8) ] + , testCase "absindex" . runLua $ do + pushLuaExpr "1, 2, 3, 4" + liftIO . assertEqual "index from bottom doesn't change" (nthFromBottom 3) + =<< absindex (nthFromBottom 3) + liftIO . assertEqual "index from top is made absolute" (nthFromBottom 2) + =<< absindex (nthFromTop 3) + liftIO . assertEqual "pseudo indices are left unchanged" registryindex + =<< absindex registryindex + , luaTestCase "gettable gets a table value" $ do pushLuaExpr "{sum = 13.37}" pushnumber 13.37 pushstring "sum" - gettable (-3) - equal (-1) (-2) + gettable (nthFromTop 3) + equal (nthFromTop 1) (nthFromTop 2) , luaTestCase "strlen, objlen, and rawlen all behave the same" $ do pushLuaExpr "{1, 1, 2, 3, 5, 8}" @@ -150,15 +159,15 @@ -- get first field getglobal "hamburg" - rawgeti (-1) 1 -- first field + rawgeti stackTop 1 -- first field pushLuaExpr "'Moin'" - equal (-1) (-2) + equal (nthFromTop 1) (nthFromTop 2) , luaTestCase "can push and receive a thread" $ do luaSt <- luaState isMain <- pushthread liftIO (assertBool "pushing the main thread should return True" isMain) - luaSt' <- peek (-1) + luaSt' <- peek stackTop return (luaSt == luaSt') , testCase "different threads are not equal" $ do @@ -171,7 +180,7 @@ openlibs getglobal' "coroutine.resume" pushLuaExpr "coroutine.create(function() coroutine.yield(9) end)" - co <- tothread (-1) + co <- tothread stackTop call 1 0 liftIO . runLuaWith co $ do liftIO . assertEqual "yielding will put thread status to Yield" Yield diff --git a/test/Foreign/LuaTest.hs b/test/Foreign/LuaTest.hs --- a/test/Foreign/LuaTest.hs +++ b/test/Foreign/LuaTest.hs @@ -34,7 +34,7 @@ import System.Mem (performMajorGC) import Test.HsLua.Util (luaTestCase, pushLuaExpr) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assert, assertBool, assertEqual, testCase) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) import qualified Data.ByteString.Char8 as B import qualified Data.Text as T @@ -57,19 +57,19 @@ pushLuaExpr "function() return 2 end, function() return 1 end" idx1 <- ref registryindex idx2 <- ref registryindex - -- functions are removed from stack - liftIO . assert =<< fmap (TypeFunction /=) (ltype (-1)) + liftIO . assertBool "functions are removed from stack" + =<< fmap (TypeFunction /=) (ltype (-1)) -- get functions from registry rawgeti registryindex idx1 call 0 1 r1 <- peek (-1) :: Lua LuaInteger - liftIO (assert (r1 == 1)) + liftIO (assertEqual "received function returned wrong value" 1 r1) rawgeti registryindex idx2 call 0 1 r2 <- peek (-1) :: Lua LuaInteger - liftIO (assert (r2 == 2)) + liftIO (assertEqual "received function returned wrong value" 2 r2) -- delete references unref registryindex idx1 @@ -100,18 +100,18 @@ pushLuaExpr $ "setmetatable(" <> tableStr <> ", {'yup'})" getfield (-1) "firstname" firstname <- peek (-1) <* pop 1 :: Lua ByteString - liftIO (assert (firstname == "Jane")) + liftIO (assertEqual "Wrong value for firstname" "Jane" firstname) push ("surname" :: ByteString) rawget (-2) surname <- peek (-1) <* pop 1 :: Lua ByteString - liftIO (assert (surname == "Doe")) + liftIO (assertEqual "Wrong value for surname" surname "Doe") hasMetaTable <- getmetatable (-1) - liftIO (assert hasMetaTable) + liftIO (assertBool "getmetatable returned wrong result" hasMetaTable) rawgeti (-1) 1 mt1 <- peek (-1) <* pop 1 :: Lua ByteString - liftIO (assert (mt1 == "yup")) + liftIO (assertEqual "Metatable content not as expected " mt1 "yup") , testGroup "Getting strings to and from the stack" [ testCase "unicode ByteString" $ do @@ -194,7 +194,8 @@ runLuaEither (push True *> peek (-1) :: Lua Bool) , testCase "catching lua errors within the lua type" $ - assert . isLeft =<< (runLua $ tryLua (throwLuaError "test")) + assertBool "No error was thrown" . isLeft + =<< (runLua $ tryLua (throwLuaError "test")) , testCase "second alternative is used when first fails" $ assertEqual "alternative failed" (Right True) =<< diff --git a/test/Test/HsLua/Util.hs b/test/Test/HsLua/Util.hs --- a/test/Test/HsLua/Util.hs +++ b/test/Test/HsLua/Util.hs @@ -28,11 +28,11 @@ import Foreign.Lua (Lua, runLua, loadstring, call, multret) import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase, (@?)) +import Test.Tasty.HUnit (assertBool, testCase) luaTestCase :: String -> Lua Bool -> TestTree luaTestCase msg luaOp = - testCase msg $ runLua luaOp @? "lua operation returned false" + testCase msg $ assertBool "lua operation returned false" =<< runLua luaOp pushLuaExpr :: String -> Lua () pushLuaExpr expr = loadstring ("return " ++ expr) *> call 0 multret