diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,27 @@ [1]: https://pvp.haskell.org +## hslua-core 2.0.0 + +Release pending. + +- Error handling has been reworked completely. The type of + exceptions used and handled by HsLua is now exposed to the type + system. The type `Lua` makes use of a default error type. Custom + error handling can be implemented by using the `LuaE` type with + an exception type that is an instance of class `LuaError`. + +- Added new module HsLua.Core.Userdata. It contains thin wrappers + around the functions available for creating + Haskell-value-wrapping userdata objects. + +- Added new module HsLua.Core.Closures, containing functions to + expose Haskell functions to Lua. + +- Reverted to using the auxlib `luaL_loadfile` function to load a + Lua file. Previously files were opened and read in Haskell, but + some functionality of the auxlib function was missing. + ## hslua-core 1.0.0 Released 2021-02-27. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -16,13 +16,19 @@ Overview -------- -[Lua](https://lua.org) is a small, well-designed, embeddable -scripting language. It has become the de-facto default to make -programs extensible and is widely used everywhere from servers -over games and desktop applications up to security software and -embedded devices. This package provides the basic building blocks -for coders to embed Lua into their programs. +[Lua] is a small, well-designed, embeddable scripting language. It +has become the de-facto default to make programs extensible and is +widely used everywhere from servers over games and desktop +applications up to security software and embedded devices. This +package provides the basic building blocks for coders to embed Lua +into their programs. +This package is part of [HsLua], a Haskell framework built around +the embeddable scripting language [Lua]. + +[HsLua]: https://hslua.org/ +[Lua]: https://lua.org/ + Interacting with Lua -------------------- @@ -72,4 +78,20 @@ This package provides all basic building blocks to interact with the Lua stack. If you'd like more comfort, please consider using -the `hslua` package. +the `hslua-packaging` and `hslua-classes` packages. + + +Error handling +-------------- + +Errors and exceptions must always be caught and converted when +passing language boundaries. The exception type which can be +handled is encoded as the type `e` in the monad `LuaE e`. Only +exceptions of this type may be thrown; throwing different +exceptions across language boundaries will lead to a program +crash. + +Exceptions must support certain operations as defined by the +`LuaError` typeclass. The class ensures that errors can be +converted from and to Lua values, and that a new exception can be +created from a String message. diff --git a/hslua-core.cabal b/hslua-core.cabal --- a/hslua-core.cabal +++ b/hslua-core.cabal @@ -1,13 +1,13 @@ cabal-version: 2.2 name: hslua-core -version: 1.0.0 +version: 2.0.0 synopsis: Bindings to Lua, an embeddable scripting language description: Wrappers and helpers to bridge Haskell and . . It builds upon the /lua/ package, which allows to bundle a Lua interpreter with a Haskell program. -homepage: https://hslua.github.io/ +homepage: https://hslua.org/ bug-reports: https://github.com/hslua/hslua/issues license: MIT license-file: LICENSE @@ -26,7 +26,8 @@ , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 - , GHC == 8.10.3 + , GHC == 8.10.4 + , GHC == 9.0.1 source-repository head type: git @@ -35,7 +36,7 @@ common common-options default-language: Haskell2010 build-depends: base >= 4.8 && < 5 - , bytestring >= 0.10.2 && < 0.11 + , bytestring >= 0.10.2 && < 0.12 , exceptions >= 0.8 && < 0.11 , lua >= 2.0 && < 2.1 , mtl >= 2.2 && < 2.3 @@ -56,20 +57,25 @@ library import: common-options exposed-modules: HsLua.Core + , HsLua.Core.Closures , HsLua.Core.Error + , HsLua.Core.Package , HsLua.Core.Run , HsLua.Core.Types + , HsLua.Core.Unsafe + , HsLua.Core.Userdata , HsLua.Core.Utf8 other-modules: HsLua.Core.Auxiliary - , HsLua.Core.Functions + , HsLua.Core.Primary reexported-modules: lua:Lua hs-source-dirs: src default-extensions: LambdaCase - other-extensions: DeriveDataTypeable - , DeriveFunctor - , FlexibleContexts - , FlexibleInstances + other-extensions: CPP + , DeriveDataTypeable + , GeneralizedNewtypeDeriving + , OverloadedStrings , ScopedTypeVariables + , TypeApplications test-suite test-hslua-core import: common-options @@ -79,8 +85,11 @@ ghc-options: -threaded -Wno-unused-do-bind other-modules: HsLua.CoreTests , HsLua.Core.AuxiliaryTests + , HsLua.Core.ClosuresTests , HsLua.Core.ErrorTests , HsLua.Core.RunTests + , HsLua.Core.UnsafeTests + , HsLua.Core.UserdataTests , Test.Tasty.HsLua , Test.HsLua.Arbitrary build-depends: hslua-core diff --git a/src/HsLua/Core.hs b/src/HsLua/Core.hs --- a/src/HsLua/Core.hs +++ b/src/HsLua/Core.hs @@ -17,21 +17,18 @@ module HsLua.Core ( -- * Run Lua computations run - , run' , runWith , runEither -- * Lua Computations - , Lua (..) - , runWithConverter + , LuaE (..) + , Lua , unsafeRunWith , liftIO , state , LuaEnvironment (..) - , ErrorConversion (..) - , errorConversion - , unsafeErrorConversion -- * Lua API types , CFunction + , PreCFunction , Lua.Integer (..) , Lua.Number (..) -- ** Stack index @@ -43,6 +40,8 @@ -- ** Number of arguments and return values , NumArgs (..) , NumResults (..) + -- ** Table fields + , Name (..) -- * Lua API -- ** Constants and pseudo-indices , multret @@ -65,9 +64,6 @@ , checkstack -- ** types and type checks , Type (..) - , TypeCode (..) - , fromType - , toType , ltype , typename , isboolean @@ -95,7 +91,6 @@ , rawlen -- ** Comparison and arithmetic functions , RelationalOperator (..) - , fromRelationalOperator , compare , equal , lessthan @@ -120,6 +115,7 @@ , newtable , newuserdata , getmetatable + , getuservalue -- ** set functions (stack → Lua) , setglobal , settable @@ -127,6 +123,7 @@ , rawset , rawseti , setmetatable + , setuservalue -- ** load and call functions (load and run Lua code) , call , pcall @@ -136,10 +133,9 @@ , loadstring -- ** Coroutine functions , Status (..) - , toStatus , status -- ** garbage-collection function and options - , GCCONTROL (..) + , GCControl (..) , gc -- ** miscellaneous and helper functions , next @@ -166,6 +162,7 @@ , newmetatable , tostring' , traceback + , where' -- ** References , Reference (..) , ref @@ -176,25 +173,42 @@ , noref , refnil -- ** Registry fields - , loadedTableRegistryField - , preloadTableRegistryField + , loaded + , preload + -- * Haskell userdata values + -- + -- | Push arbitrary Haskell values to the Lua stack. + , newhsuserdata + , newudmetatable + , fromuserdata + , putuserdata + -- ** Haskell functions and closures + , HaskellFunction + , pushHaskellFunction + , pushPreCFunction -- * Error handling + , LuaError (..) , Exception (..) - , throwException - , catchException - , withExceptionMessage , try - , throwMessage - , errorMessage + , failLua , throwErrorAsException - , throwTopMessage - , throwTopMessageWithState + , throwTypeMismatchError + , changeErrorType + -- ** Helpers + , popErrorMessage + , pushTypeMismatchError + -- * Package + , requirehs + , preloadhs ) where import Prelude hiding (EQ, LT, compare, concat, error) import HsLua.Core.Auxiliary +import HsLua.Core.Closures import HsLua.Core.Error -import HsLua.Core.Functions +import HsLua.Core.Package +import HsLua.Core.Primary import HsLua.Core.Run import HsLua.Core.Types as Lua +import HsLua.Core.Userdata diff --git a/src/HsLua/Core/Auxiliary.hs b/src/HsLua/Core/Auxiliary.hs --- a/src/HsLua/Core/Auxiliary.hs +++ b/src/HsLua/Core/Auxiliary.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-| Module : HsLua.Core.Auxiliary Copyright : © 2007–2012 Gracjan Polak; @@ -12,7 +14,8 @@ Wrappers for the auxiliary library. -} module HsLua.Core.Auxiliary - ( dostring + ( -- * The Auxiliary Library + dostring , dofile , getmetafield , getmetatable' @@ -24,84 +27,98 @@ , newstate , tostring' , traceback - -- * References + , where' + -- ** References , getref , ref , unref - -- * Registry fields - , loadedTableRegistryField - , preloadTableRegistryField + -- ** Registry fields + , loaded + , preload ) where -import Control.Exception (IOException, try) +import Control.Monad ((<$!>)) import Data.ByteString (ByteString) -import Foreign.C (withCString) -import HsLua.Core.Types (Lua, Status, StackIndex, liftLua, multret) +import Data.String (IsString (fromString)) +import HsLua.Core.Error (LuaError, throwErrorAsException) +import HsLua.Core.Types + (LuaE, Name (Name), Status, StackIndex, liftLua, multret, runWith) import Lua (top) import Lua.Auxiliary import Lua.Ersatz.Auxiliary +import Foreign.C (withCString) import Foreign.Marshal.Alloc (alloca) import Foreign.Ptr import qualified Data.ByteString as B -import qualified HsLua.Core.Functions as Lua +import qualified HsLua.Core.Primary as Lua import qualified HsLua.Core.Types as Lua -import qualified HsLua.Core.Utf8 as Utf8 import qualified Foreign.Storable as Storable --- * The Auxiliary Library - -- | Loads and runs the given string. -- -- 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 :: ByteString -> LuaE e Status dostring s = do loadRes <- loadstring s if loadRes == Lua.OK then Lua.pcall 0 multret Nothing else return loadRes +{-# INLINABLE dostring #-} --- | Loads and runs the given file. Note that the filepath is interpreted by --- Haskell, not Lua. The resulting chunk is named using the UTF8 encoded --- filepath. -dofile :: FilePath -> Lua Status +-- | Loads and runs the given file. Note that the filepath is +-- interpreted by Haskell, not Lua. The resulting chunk is named using +-- the UTF8 encoded filepath. +dofile :: FilePath -> LuaE e Status dofile fp = do loadRes <- loadfile fp if loadRes == Lua.OK then Lua.pcall 0 multret Nothing else return loadRes +{-# INLINABLE dofile #-} --- | Pushes onto the stack the field @e@ from the metatable of the object at --- index @obj@ and returns the type of the pushed value. If the object does not --- have a metatable, or if the metatable does not have this field, pushes --- nothing and returns TypeNil. +-- | Pushes onto the stack the field @e@ from the metatable of the +-- object at index @obj@ and returns the type of the pushed value. If +-- the object does not have a metatable, or if the metatable does not +-- have this field, pushes nothing and returns 'TypeNil'. +-- +-- Wraps 'luaL_getmetafield'. getmetafield :: StackIndex -- ^ obj - -> String -- ^ e - -> Lua Lua.Type -getmetafield obj e = liftLua $ \l -> - withCString e $ fmap Lua.toType . luaL_getmetafield l obj + -> Name -- ^ e + -> LuaE e Lua.Type +getmetafield obj (Name name) = liftLua $ \l -> + B.useAsCString name $! fmap Lua.toType . luaL_getmetafield l obj +{-# INLINABLE getmetafield #-} --- | Pushes onto the stack the metatable associated with name @tname@ in the --- registry (see @newmetatable@) (@nil@ if there is no metatable associated --- with that name). Returns the type of the pushed value. -getmetatable' :: String -- ^ tname - -> Lua Lua.Type -getmetatable' tname = liftLua $ \l -> - withCString tname $ fmap Lua.toType . luaL_getmetatable l +-- | Pushes onto the stack the metatable associated with name @tname@ in +-- the registry (see 'newmetatable') (@nil@ if there is no metatable +-- associated with that name). Returns the type of the pushed value. +-- +-- Wraps 'luaL_getmetatable'. +getmetatable' :: Name -- ^ tname + -> LuaE e Lua.Type +getmetatable' (Name tname) = liftLua $ \l -> + B.useAsCString tname $ fmap Lua.toType . luaL_getmetatable l +{-# INLINABLE getmetatable' #-} -- | Push referenced value from the table at the given index. -getref :: StackIndex -> Reference -> Lua () +getref :: LuaError e => StackIndex -> Reference -> LuaE e () getref idx ref' = Lua.rawgeti idx (fromIntegral (Lua.fromReference ref')) +{-# INLINABLE getref #-} --- | Ensures that the value @t[fname]@, where @t@ is the value at index @idx@, --- is a table, and pushes that table onto the stack. Returns True if it finds a --- previous table there and False if it creates a new table. -getsubtable :: StackIndex -> String -> Lua Bool -getsubtable idx fname = do +-- | Ensures that the value @t[fname]@, where @t@ is the value at index +-- @idx@, is a table, and pushes that table onto the stack. Returns True +-- if it finds a previous table there and False if it creates a new +-- table. +getsubtable :: LuaError e + => StackIndex -- ^ idx + -> Name -- ^ fname + -> LuaE e Bool +getsubtable idx fname@(Name namestr) = do -- This is a reimplementation of luaL_getsubtable from lauxlib.c. idx' <- Lua.absindex idx - Lua.pushstring (Utf8.fromString fname) + Lua.pushstring namestr Lua.gettable idx' >>= \case Lua.TypeTable -> return True _ -> do @@ -110,6 +127,7 @@ Lua.pushvalue top -- copy to be left at top Lua.setfield idx' fname return False +{-# INLINABLE getsubtable #-} -- | Loads a ByteString as a Lua chunk. -- @@ -117,14 +135,15 @@ -- 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 . +-- Wraps 'luaL_loadbuffer'. loadbuffer :: ByteString -- ^ Program to load - -> String -- ^ chunk name - -> Lua Status -loadbuffer bs name = liftLua $ \l -> + -> Name -- ^ chunk name + -> LuaE e Status +loadbuffer bs (Name name) = liftLua $ \l -> B.useAsCStringLen bs $ \(str, len) -> - withCString name - (fmap Lua.toStatus . luaL_loadbuffer l str (fromIntegral len)) + B.useAsCString name $! + fmap Lua.toStatus . luaL_loadbuffer l str (fromIntegral len) +{-# INLINABLE loadbuffer #-} -- | 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 @@ -143,16 +162,10 @@ -- -- See . loadfile :: FilePath -- ^ filename - -> Lua Status -loadfile fp = Lua.liftIO contentOrError >>= \case - Right script -> loadbuffer script ("@" ++ fp) - Left e -> do - Lua.pushstring (Utf8.fromString (show e)) - return Lua.ErrFile - where - contentOrError :: IO (Either IOException ByteString) - contentOrError = try (B.readFile fp) - + -> LuaE e Status +loadfile fp = liftLua $ \l -> + withCString fp $! fmap Lua.toStatus . luaL_loadfile l +{-# INLINABLE loadfile #-} -- | 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 @@ -164,28 +177,29 @@ -- Also as @'Lua.load'@, this function only loads the chunk; it does not -- run it. -- --- See . -loadstring :: ByteString -> Lua Status -loadstring s = loadbuffer s (Utf8.toString s) - +-- See +-- . +loadstring :: ByteString -> LuaE e Status +loadstring s = loadbuffer s (Name s) +{-# INLINE loadstring #-} --- | If the registry already has the key tname, returns @False@. Otherwise, --- creates a new table to be used as a metatable for userdata, adds to this new --- table the pair @__name = tname@, adds to the registry the pair @[tname] = new --- table@, and returns @True@. (The entry @__name@ is used by some --- error-reporting functions.) +-- | If the registry already has the key tname, returns @False@. +-- Otherwise, creates a new table to be used as a metatable for +-- userdata, adds to this new table the pair @__name = tname@, adds to +-- the registry the pair @[tname] = new table@, and returns @True@. (The +-- entry @__name@ is used by some error-reporting functions.) -- --- In both cases pushes onto the stack the final value associated with @tname@ in --- the registry. +-- In both cases pushes onto the stack the final value associated with +-- @tname@ in the registry. -- --- The value of @tname@ is used as a C string and hence must not contain null --- bytes. +-- The value of @tname@ is used as a C string and hence must not contain +-- null bytes. -- --- See also: --- . -newmetatable :: String -> Lua Bool -newmetatable tname = liftLua $ \l -> - Lua.fromLuaBool <$> withCString tname (luaL_newmetatable l) +-- Wraps 'luaL_newmetatable'. +newmetatable :: Name -> LuaE e Bool +newmetatable (Name tname) = liftLua $ \l -> + Lua.fromLuaBool <$!> B.useAsCString tname (luaL_newmetatable l) +{-# INLINABLE newmetatable #-} -- | Creates a new Lua state. It calls @lua_newstate@ with an allocator -- based on the standard C @realloc@ function and then sets a panic @@ -193,65 +207,101 @@ -- of the Lua 5.3 Reference Manual) that prints an error message to the -- standard error output in case of fatal errors. -- --- See also: +-- Wraps 'hsluaL_newstate'. See also: -- . newstate :: IO Lua.State newstate = hsluaL_newstate +{-# INLINE newstate #-} --- | Creates and returns a reference, in the table at index @t@, for the object --- at the top of the stack (and pops the object). +-- | Creates and returns a reference, in the table at index @t@, for the +-- object at the top of the stack (and pops the object). -- --- A reference is a unique integer key. As long as you do not manually add --- integer keys into table @t@, @ref@ ensures the uniqueness of the key it --- returns. You can retrieve an object referred by reference @r@ by calling --- @rawgeti t r@. Function @'unref'@ frees a reference and its associated --- object. +-- A reference is a unique integer key. As long as you do not manually +-- add integer keys into table @t@, @ref@ ensures the uniqueness of the +-- key it returns. You can retrieve an object referred by reference @r@ +-- by calling @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 @'Lua.refnil'@. The constant @'Lua.noref'@ is guaranteed to -- be different from any reference returned by @'ref'@. -- --- See also: . -ref :: StackIndex -> Lua Reference +-- Wraps 'luaL_ref'. +ref :: StackIndex -> LuaE e Reference ref t = liftLua $ \l -> Lua.toReference <$> luaL_ref l t +{-# INLINABLE ref #-} --- | Converts any Lua value at the given index to a @'ByteString'@ in a --- reasonable format. The resulting string is pushed onto the stack and also --- returned by the function. +-- | Converts any Lua value at the given index to a 'ByteString' in a +-- reasonable format. The resulting string is pushed onto the stack and +-- also returned by the function. -- --- If the value has a metatable with a @__tostring@ field, then @tolstring'@ --- calls the corresponding metamethod with the value as argument, and uses the --- result of the call as its result. -tostring' :: StackIndex -> Lua B.ByteString +-- If the value has a metatable with a @__tostring@ field, then +-- @tolstring'@ calls the corresponding metamethod with the value as +-- argument, and uses the result of the call as its result. +-- +-- Wraps 'hsluaL_tolstring'. +tostring' :: forall e. LuaError e => StackIndex -> LuaE e B.ByteString tostring' n = do l <- Lua.state - e <- Lua.errorConversion Lua.liftIO $ alloca $ \lenPtr -> do cstr <- hsluaL_tolstring l n lenPtr if cstr == nullPtr - then Lua.errorToException e l + then runWith @e l throwErrorAsException else do cstrLen <- Storable.peek lenPtr B.packCStringLen (cstr, fromIntegral cstrLen) +{-# INLINABLE tostring' #-} --- | Creates and pushes a traceback of the stack L1. If a message is given it --- appended at the beginning of the traceback. The level parameter tells at --- which level to start the traceback. -traceback :: Lua.State -> Maybe String -> Int -> Lua () +-- | Creates and pushes a traceback of the stack L1. If a message is +-- given it appended at the beginning of the traceback. The level +-- parameter tells at which level to start the traceback. +-- +-- Wraps 'luaL_traceback'. +traceback :: Lua.State -> Maybe ByteString -> Int -> LuaE e () traceback l1 msg level = liftLua $ \l -> case msg of Nothing -> luaL_traceback l l1 nullPtr (fromIntegral level) - Just msg' -> withCString msg' $ \cstr -> + Just msg' -> B.useAsCString msg' $ \cstr -> luaL_traceback l l1 cstr (fromIntegral level) +{-# INLINABLE traceback #-} --- | Releases reference @'ref'@ from the table at index @idx@ (see @'ref'@). The --- entry is removed from the table, so that the referred object can be --- collected. The reference @'ref'@ is also freed to be used again. +-- | Releases reference @'ref'@ from the table at index @idx@ (see +-- @'ref'@). The entry is removed from the table, so that the referred +-- object can be collected. The reference @'ref'@ is also freed to be +-- used again. -- --- See also: +-- Wraps 'luaL_unref'. See also: -- . unref :: StackIndex -- ^ idx -> Reference -- ^ ref - -> Lua () + -> LuaE e () unref idx r = liftLua $ \l -> luaL_unref l idx (Lua.fromReference r) +{-# INLINABLE unref #-} + +-- | Pushes onto the stack a string identifying the current position of +-- the control at level @lvl@ in the call stack. Typically this string +-- has the following format: +-- +-- > chunkname:currentline: +-- +-- Level 0 is the running function, level 1 is the function that called +-- the running function, etc. +-- +-- This function is used to build a prefix for error messages. +where' :: Int -- ^ lvl + -> LuaE e () +where' lvl = liftLua $ \l -> luaL_where l (fromIntegral lvl) +{-# INLINABLE where' #-} + +-- +-- Registry fields +-- + +-- | Key to the registry field that holds the table of loaded modules. +loaded :: Name +loaded = fromString loadedTableRegistryField + +-- | Key to the registry field that holds the table of loader functions. +preload :: Name +preload = fromString preloadTableRegistryField diff --git a/src/HsLua/Core/Closures.hs b/src/HsLua/Core/Closures.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Core/Closures.hs @@ -0,0 +1,61 @@ +{-| +Module : HsLua.Core.Closures +Copyright : © 2007–2012 Gracjan Polak; + © 2012–2016 Ömer Sinan Ağacan; + © 2017-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : non-portable (depends on GHC) + +Expose Haskell functions as Lua closures. +-} +module HsLua.Core.Closures + ( pushPreCFunction + , pushHaskellFunction + ) where + +import Prelude hiding (error) +import HsLua.Core.Error (LuaError (..)) +import HsLua.Core.Primary (error) +import HsLua.Core.Types (LuaE, PreCFunction, HaskellFunction, liftLua, runWith) +import Lua.Call (hslua_pushhsfunction) +import qualified Control.Monad.Catch as Catch + +-- | Converts a pre C function to a Lua function and pushes it to the +-- stack. +-- +-- Pre C functions collect parameters from the stack and return a @CInt@ +-- that represents number of return values left on the stack. +-- See 'Lua.CFunction' for more info. +pushPreCFunction :: PreCFunction -> LuaE e () +pushPreCFunction preCFn = liftLua $ \l -> + hslua_pushhsfunction l preCFn +{-# INLINABLE pushPreCFunction #-} + +-- | Pushes Haskell function as a callable userdata. All values created +-- will be garbage collected. The function should behave similar to a +-- 'CFunction'. +-- +-- Error conditions should be indicated by raising a catchable exception +-- or by returning the result of @'Lua.error'@. +-- +-- Example: +-- +-- > mod23 :: Lua NumResults +-- > mod23 = do +-- > mn <- tointeger (nthBottom 1) +-- > case mn of +-- > Nothing -> pushstring "expected an integer" *> error +-- > Just n -> pushinteger (n `mod` 23) +-- > pushHaskellFunction mod23 +-- > setglobal "mod23" +pushHaskellFunction :: LuaError e => HaskellFunction e -> LuaE e () +pushHaskellFunction fn = do + let preCFn l = runWith l (exceptionToError fn) + pushPreCFunction preCFn +{-# INLINABLE pushHaskellFunction #-} + +exceptionToError :: LuaError e => HaskellFunction e -> HaskellFunction e +exceptionToError op = op `Catch.catch` \e -> pushException e *> error +{-# INLINABLE exceptionToError #-} diff --git a/src/HsLua/Core/Error.hs b/src/HsLua/Core/Error.hs --- a/src/HsLua/Core/Error.hs +++ b/src/HsLua/Core/Error.hs @@ -1,39 +1,43 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- Don't warn about lua_concat; the way it's use here is safe. +{-# OPTIONS_GHC -Wno-warnings-deprecations #-} {-| Module : HsLua.Core.Error Copyright : © 2017-2021 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel -Stability : beta -Portability : DeriveDataTypeable Lua exceptions and exception handling. -} module HsLua.Core.Error ( Exception (..) - , catchException - , throwException - , withExceptionMessage - , throwErrorAsException - , throwTopMessage - , throwTopMessageWithState - , errorMessage + , LuaError (..) + , Lua , try + , failLua + , throwErrorAsException + , throwTypeMismatchError + , changeErrorType -- * Helpers for hslua C wrapper functions. - , throwMessage , liftLuaThrow + , popErrorMessage + , pushTypeMismatchError ) where import Control.Applicative (Alternative (..)) +import Control.Monad ((<$!>), void) import Data.ByteString (ByteString) +import Data.Proxy (Proxy (Proxy)) import Data.Typeable (Typeable) -import HsLua.Core.Types (Lua) -import Lua (lua_pop, lua_pushlstring, hsluaL_tolstring) import Foreign.Marshal.Alloc (alloca) import Foreign.Ptr +import HsLua.Core.Types (LuaE, liftLua) +import Lua import qualified Control.Exception as E import qualified Control.Monad.Catch as Catch @@ -41,11 +45,38 @@ import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Unsafe as B import qualified Foreign.Storable as Storable -import qualified Lua.Types as Lua import qualified HsLua.Core.Types as Lua import qualified HsLua.Core.Utf8 as Utf8 --- | Exceptions raised by Lua-related operations. +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail (MonadFail (..)) +#endif + +-- | A Lua operation. +-- +-- This type is suitable for most users. It uses a default exception for +-- error handling. Users who need more control over error handling can +-- use 'LuaE' with a custom error type instead. +type Lua a = LuaE Exception a + +-- | Any type that you wish to use for error handling in HsLua must be +-- an instance of the @LuaError@ class. +class E.Exception e => LuaError e where + -- | Converts the error at the top of the stack into an exception and + -- pops the error off the stack. + -- + -- This function is expected to produce a valid result for any Lua + -- value; neither a Haskell exception nor a Lua error may result when + -- this is called. + popException :: LuaE e e + -- | Pushes an exception to the top of the Lua stack. The pushed Lua + -- object is used as an error object, and it is recommended that + -- calling @tostring()@ on the object produces an informative message. + pushException :: e -> LuaE e () + -- | Creates a new exception with the given message. + luaException :: String -> e + +-- | Default Lua error type. Exceptions raised by Lua-related operations. newtype Exception = Exception { exceptionMessage :: String} deriving (Eq, Typeable) @@ -54,91 +85,129 @@ instance E.Exception Exception --- | Raise a Lua @'Exception'@ containing the given error message. -throwException :: String -> Lua a -throwException = Catch.throwM . Exception -{-# INLINABLE throwException #-} +instance LuaError Exception where + popException = do + Exception . Utf8.toString <$!> liftLua popErrorMessage + {-# INLINABLE popException #-} --- | Catch a Lua @'Exception'@. -catchException :: Lua a -> (Exception -> Lua a) -> Lua a -catchException = Catch.catch -{-# INLINABLE catchException #-} + pushException (Exception msg) = Lua.liftLua $ \l -> + B.unsafeUseAsCStringLen (Utf8.fromString msg) $ \(msgPtr, z) -> + lua_pushlstring l msgPtr (fromIntegral z) + {-# INLINABLE pushException #-} --- | Catch Lua @'Exception'@, alter the message and rethrow. -withExceptionMessage :: (String -> String) -> Lua a -> Lua a -withExceptionMessage modifier luaOp = - luaOp `catchException` \(Exception msg) -> throwException (modifier msg) -{-# INLINABLE withExceptionMessage #-} + luaException = Exception + {-# INLINABLE luaException #-} -- | Return either the result of a Lua computation or, if an exception was -- thrown, the error. -try :: Lua a -> Lua (Either Exception a) +try :: Catch.Exception e => LuaE e a -> LuaE e (Either e a) try = Catch.try {-# INLINABLE try #-} --- | Convert a Lua error into a Haskell exception. The error message is --- expected to be at the top of the stack. -throwErrorAsException :: Lua a +-- | Raises an exception in the Lua monad. +failLua :: forall e a. LuaError e => String -> LuaE e a +failLua msg = Catch.throwM (luaException @e msg) +{-# INLINABLE failLua #-} + +-- | Converts a Lua error at the top of the stack into a Haskell +-- exception and throws it. +throwErrorAsException :: LuaError e => LuaE e a throwErrorAsException = do - e <- Lua.errorConversion - l <- Lua.state - Lua.liftIO (Lua.errorToException e l) + err <- popException + Catch.throwM $! err +{-# INLINABLE throwErrorAsException #-} --- | Alias for `throwErrorAsException`; will be deprecated in the next --- mayor release. -throwTopMessage :: Lua a -throwTopMessage = throwErrorAsException +-- | Raises an exception that's appropriate when the type of a Lua +-- object at the given index did not match the expected type. The name +-- or description of the expected type is taken as an argument. +throwTypeMismatchError :: forall e a. LuaError e + => ByteString -> StackIndex -> LuaE e a +throwTypeMismatchError expected idx = do + pushTypeMismatchError expected idx + throwErrorAsException +{-# INLINABLE throwTypeMismatchError #-} --- | Helper function which uses proper error-handling to throw an --- exception with the given message. -throwMessage :: String -> Lua a -throwMessage msg = do - Lua.liftLua $ \l -> - B.unsafeUseAsCStringLen (Utf8.fromString msg) $ \(msgPtr, z) -> - lua_pushlstring l msgPtr (fromIntegral z) - e <- Lua.errorConversion - Lua.liftLua (Lua.errorToException e) +-- | Change the error type of a computation. +changeErrorType :: forall old new a. LuaE old a -> LuaE new a +changeErrorType op = Lua.liftLua $ \l -> do + x <- Lua.runWith l op + return $! x +{-# INLINABLE changeErrorType #-} -instance Alternative Lua where - empty = throwMessage "empty" - x <|> y = do - e <- Lua.errorConversion - Lua.alternative e x y --- | Convert the object at the top of the stack into a string and throw --- it as a HsLua @'Exception'@. -- --- This function serves as the default to convert Lua errors to Haskell --- exceptions. -throwTopMessageWithState :: Lua.State -> IO a -throwTopMessageWithState l = do - msg <- Lua.liftIO (errorMessage l) - Catch.throwM $ Exception (Utf8.toString msg) +-- Orphan instances +-- +instance LuaError e => Alternative (LuaE e) where + empty = failLua "empty" + x <|> y = x `Catch.catch` (\(_ :: e) -> y) + +instance LuaError e => MonadFail (LuaE e) where + fail = failLua + +-- +-- Helpers +-- + -- | Takes a failable HsLua function and transforms it into a -- monadic 'Lua' operation. Throws an exception if an error -- occured. -liftLuaThrow :: (Lua.State -> Ptr Lua.StatusCode -> IO a) -> Lua a -liftLuaThrow f = do - (result, status) <- Lua.liftLua $ \l -> alloca $ \statusPtr -> do - result <- f l statusPtr - status <- Lua.toStatus <$> Storable.peek statusPtr - return (result, status) - if status == Lua.OK - then return result - else throwTopMessage +liftLuaThrow :: forall e a. LuaError e + => (Lua.State -> Ptr Lua.StatusCode -> IO a) + -> LuaE e a +liftLuaThrow f = Lua.liftLua (throwOnError (Proxy @e) f) --- | Retrieve and pop the top object as an error message. This is very similar --- to tostring', but ensures that we don't recurse if getting the message --- failed. -errorMessage :: Lua.State -> IO ByteString -errorMessage l = alloca $ \lenPtr -> do +-- | Helper function which takes an ersatz function and checks for +-- errors during its execution. If an error occured, it is converted +-- into a 'LuaError' and thrown as an exception. +throwOnError :: forall e a. LuaError e + => Proxy e + -> (Lua.State -> Ptr Lua.StatusCode -> IO a) + -> Lua.State + -> IO a +throwOnError _errProxy f l = alloca $ \statusPtr -> do + result <- f l statusPtr + status <- Storable.peek statusPtr + if status == LUA_OK + then return $! result + else Lua.runWith l (throwErrorAsException @e) + + +-- | Retrieve and pop the top object as an error message. This is very +-- similar to tostring', but ensures that we don't recurse if getting +-- the message failed. +-- +-- This helpful as a \"last resort\" method when implementing +-- 'peekException'. +popErrorMessage :: Lua.State -> IO ByteString +popErrorMessage l = alloca $ \lenPtr -> do cstr <- hsluaL_tolstring l (-1) lenPtr if cstr == nullPtr - then return $ Char8.pack ("An error occurred, but the error object " ++ - "cannot be converted into a string.") + then do + lua_pop l 1 + return $ Char8.pack + "An error occurred, but the error object could not be retrieved." else do cstrLen <- Storable.peek lenPtr msg <- B.packCStringLen (cstr, fromIntegral cstrLen) - lua_pop l 2 + lua_pop l 2 -- pop original msg and product of hsluaL_tolstring return msg + +-- | Creates an error to notify about a Lua type mismatch and pushes it +-- to the stack. +pushTypeMismatchError :: ByteString -- ^ name or description of expected type + -> StackIndex -- ^ stack index of mismatching object + -> LuaE e () +pushTypeMismatchError expected idx = liftLua $ \l -> do + idx' <- lua_absindex l idx + let pushstring str = B.unsafeUseAsCStringLen str $ \(cstr, cstrLen) -> + lua_pushlstring l cstr (fromIntegral cstrLen) + let pushtype = lua_type l idx' >>= lua_typename l >>= lua_pushstring l + pushstring expected + pushstring " expected, got " + B.unsafeUseAsCString "__name" (luaL_getmetafield l idx) >>= \case + LUA_TSTRING -> return () -- pushed the name + LUA_TNIL -> void pushtype + _ -> lua_pop l 1 <* pushtype + lua_concat l 3 diff --git a/src/HsLua/Core/Functions.hs b/src/HsLua/Core/Functions.hs deleted file mode 100644 --- a/src/HsLua/Core/Functions.hs +++ /dev/null @@ -1,945 +0,0 @@ -{-| -Module : HsLua.Core.Functions -Copyright : © 2007–2012 Gracjan Polak; - © 2012–2016 Ömer Sinan Ağacan; - © 2017-2021 Albert Krewinkel -License : MIT -Maintainer : Albert Krewinkel -Stability : beta -Portability : non-portable (depends on GHC) - -Monadic functions which operate within the Lua type. - -The functions in this module are mostly just thin wrappers around the respective -C functions. However, C function which can throw an error are wrapped such that -the error is converted into an @'Exception'@. Memory allocation errors, -however, are not caught and will cause the host program to terminate. --} -module HsLua.Core.Functions where - -import Prelude hiding (EQ, LT, compare, concat, error) - -import Control.Monad -import Data.ByteString (ByteString) -import Data.Maybe (fromMaybe) -import HsLua.Core.Error -import HsLua.Core.Types as Lua -import Lua -import Foreign.Marshal.Alloc (alloca) -import Foreign.Ptr - -import qualified Data.ByteString as B -import qualified Data.ByteString.Unsafe as B -import qualified Foreign.C as C -import qualified HsLua.Core.Utf8 as Utf8 -import qualified Foreign.Storable as F - --- --- Helper functions --- - --- | Execute an action only if the given index is a table. Throw an --- error otherwise. -ensureTable :: StackIndex -> (Lua.State -> IO ()) -> Lua () -ensureTable idx ioOp = do - isTbl <- istable idx - if isTbl - then liftLua ioOp - else do - tyName <- ltype idx >>= typename - throwMessage ("table expected, got " ++ tyName) - --- --- 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 -absindex = liftLua1 lua_absindex - --- | Calls a function. --- --- To call a function you must use the following protocol: first, the function --- to be called is pushed onto the stack; then, the arguments to the function --- are pushed in direct order; that is, the first argument is pushed first. --- Finally you call @call@; @nargs@ is the number of arguments that you pushed --- onto the stack. All arguments and the function value are popped from the --- stack when the function is called. The function results are pushed onto the --- stack when the function returns. The number of results is adjusted to --- @nresults@, unless @nresults@ is @multret@. In this case, all results from --- the function are pushed. Lua takes care that the returned values fit into the --- stack space. The function results are pushed onto the stack in direct order --- (the first result is pushed first), so that after the call the last result is --- on the top of the stack. --- --- Any error inside the called function cause a @'Exception'@ to be thrown. --- --- The following example shows how the host program can do the equivalent to --- this Lua code: --- --- > a = f("how", t.x, 14) --- --- Here it is in Haskell (assuming the OverloadedStrings language extension): --- --- > getglobal "f" -- function to be called --- > pushstring "how" -- 1st argument --- > getglobal "t" -- table to be indexed --- > getfield (-1) "x" -- push result of t.x (2nd arg) --- > remove (-2) -- remove 't' from the stack --- > pushinteger 14 -- 3rd argument --- > call 3 1 -- call 'f' with 3 arguments and 1 result --- > setglobal "a" -- set global 'a' --- --- Note that the code above is "balanced": at its end, the stack is back to its --- original configuration. This is considered good programming practice. --- --- See . -call :: NumArgs -> NumResults -> Lua () -call nargs nresults = do - res <- pcall nargs nresults Nothing - when (res /= OK) throwTopMessage - --- | Ensures that the stack has space for at least @n@ extra slots (that is, --- that you can safely push up to @n@ values into it). It returns false if it --- cannot fulfill the request, either because it would cause the stack to be --- larger than a fixed maximum size (typically at least several thousand --- elements) or because it cannot allocate memory for the extra space. This --- function never shrinks the stack; if the stack already has space for the --- extra slots, it is left unchanged. --- --- This is a wrapper function of --- . -checkstack :: Int -> Lua Bool -checkstack n = liftLua $ \l -> fromLuaBool <$> lua_checkstack l (fromIntegral n) - --- | Destroys all objects in the given Lua state (calling the corresponding --- garbage-collection metamethods, if any) and frees all dynamic memory used by --- this state. On several platforms, you may not need to call this function, --- because all resources are naturally released when the host program ends. On --- the other hand, long-running programs that create multiple states, such as --- daemons or web servers, will probably need to close states as soon as they --- are not needed. --- --- This is a wrapper function of --- . -close :: Lua.State -> IO () -close = lua_close - --- | Compares two Lua values. Returns @True@ if the value at index @idx1@ --- satisfies @op@ when compared with the value at index @idx2@, following the --- semantics of the corresponding Lua operator (that is, it may call --- metamethods). Otherwise returns @False@. Also returns @False@ if any of the --- indices is not valid. --- --- The value of op must be of type @RelationalOperator@: --- --- EQ: compares for equality (==) --- LT: compares for less than (<) --- LE: compares for less or equal (<=) --- --- This is a wrapper function of --- . -compare :: StackIndex -> StackIndex -> RelationalOperator -> Lua Bool -compare idx1 idx2 relOp = fromLuaBool <$> do - liftLuaThrow $ \l -> hslua_compare l idx1 idx2 (fromRelationalOperator relOp) - --- | Concatenates the @n@ values at the top of the stack, pops them, and leaves --- the result at the top. If @n@ is 1, the result is the single value on the --- stack (that is, the function does nothing); if @n@ is 0, the result is the --- empty string. Concatenation is performed following the usual semantics of Lua --- (see of the lua --- manual). --- --- This is a wrapper function of --- . -concat :: NumArgs -> Lua () -concat n = liftLuaThrow (`hslua_concat` n) - --- | Copies the element at index @fromidx@ into the valid index @toidx@, --- replacing the value at that position. Values at other positions are not --- affected. --- --- See also in --- the lua manual. -copy :: StackIndex -> StackIndex -> Lua () -copy fromidx toidx = liftLua $ \l -> lua_copy l fromidx toidx - --- | Creates a new empty table and pushes it onto the stack. Parameter narr is a --- hint for how many elements the table will have as a sequence; parameter nrec --- is a hint for how many other elements the table will have. Lua may use these --- hints to preallocate memory for the new table. This preallocation is useful --- for performance when you know in advance how many elements the table will --- have. Otherwise you can use the function lua_newtable. --- --- This is a wrapper for function --- . -createtable :: Int -> Int -> Lua () -createtable narr nrec = liftLua $ \l -> - lua_createtable l (fromIntegral narr) (fromIntegral nrec) - --- 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 -- ^ 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 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 - --- | Controls the garbage collector. --- --- This function performs several tasks, according to the value of the parameter --- what: --- --- * @'GCSTOP'@: stops the garbage collector. --- --- * @'GCRESTART'@: restarts the garbage collector. --- --- * @'GCCOLLECT'@: performs a full garbage-collection cycle. --- --- * @'GCCOUNT'@: returns the current amount of memory (in Kbytes) in use by --- Lua. --- --- * @'GCCOUNTB'@: returns the remainder of dividing the current amount of --- bytes of memory in use by Lua by 1024. --- --- * @'GCSTEP'@: performs an incremental step of garbage collection. The step --- "size" is controlled by data (larger values mean more steps) in a --- non-specified way. If you want to control the step size you must --- experimentally tune the value of data. The function returns 1 if the step --- finished a garbage-collection cycle. --- --- * @'GCSETPAUSE@': sets data as the new value for the pause of the collector --- (see §2.10). The function returns the previous value of the pause. --- --- * @'GCSETSTEPMUL'@: sets data as the new value for the step multiplier of --- the collector (see §2.10). The function returns the previous value of the --- step multiplier. --- --- See . -gc :: GCCONTROL -> Int -> Lua Int -gc what data' = liftLua $ \l -> - fromIntegral <$> lua_gc l (toGCCode what) (fromIntegral data') - --- | Pushes onto the stack the value @t[k]@, where @t@ is the value at the given --- stack index. As in Lua, this function may trigger a metamethod for the --- "index" event (see of --- lua's manual). --- --- Errors on the Lua side are caught and rethrown as @'Exception'@. --- --- See also: --- . -getfield :: StackIndex -> String -> Lua Type -getfield i s = do - absidx <- absindex i - pushstring (Utf8.fromString s) - gettable absidx - --- | Pushes onto the stack the value of the global @name@. --- --- Errors on the Lua side are caught and rethrown as @'Exception'@. --- --- Wrapper of --- . -getglobal :: String -> Lua Type -getglobal name = liftLuaThrow $ \l status' -> - C.withCStringLen name $ \(namePtr, len) -> - toType <$> hslua_getglobal l namePtr (fromIntegral len) status' - --- | If the value at the given index has a metatable, the function pushes that --- metatable onto the stack and returns @True@. Otherwise, the function returns --- @False@ and pushes nothing on the stack. --- --- See also: --- . -getmetatable :: StackIndex -> Lua Bool -getmetatable n = liftLua $ \l -> - fromLuaBool <$> lua_getmetatable l n - --- | Pushes onto the stack the value @t[k]@, where @t@ is the value at the given --- index and @k@ is the value at the top of the stack. --- --- This function pops the key from the stack, pushing the resulting value in its --- place. As in Lua, this function may trigger a metamethod for the "index" --- event (see of lua's --- manual). --- --- Errors on the Lua side are caught and rethrown as @'Exception'@. --- --- See also: --- . -gettable :: StackIndex -> Lua Type -gettable n = liftLuaThrow (\l -> fmap toType . hslua_gettable l n) - --- | Returns the index of the top element in the stack. Because indices start at --- 1, this result is equal to the number of elements in the stack (and so 0 --- means an empty stack). --- --- See also: . -gettop :: Lua StackIndex -gettop = liftLua lua_gettop - --- | Moves the top element into the given valid index, shifting up the elements --- above this index to open space. This function cannot be called with a --- pseudo-index, because a pseudo-index is not an actual stack position. --- --- See also: --- . -insert :: StackIndex -> Lua () -insert index = liftLua $ \l -> lua_insert l index - --- | Returns @True@ if the value at the given index is a boolean, and @False@ --- otherwise. --- --- See also: --- . -isboolean :: StackIndex -> Lua Bool -isboolean n = liftLua $ \l -> fromLuaBool <$> lua_isboolean l n - --- | Returns @True@ if the value at the given index is a C function, and @False@ --- otherwise. --- --- See also: --- . -iscfunction :: StackIndex -> Lua Bool -iscfunction n = liftLua $ \l -> fromLuaBool <$> lua_iscfunction l n - --- | Returns @True@ if the value at the given index is a function (either C or --- Lua), and @False@ otherwise. --- --- See also: --- . -isfunction :: StackIndex -> Lua Bool -isfunction n = (== TypeFunction) <$> ltype n - --- | Returns @True@ if the value at the given index is an integer (that is, the --- value is a number and is represented as an integer), and @False@ otherwise. -isinteger :: StackIndex -> Lua Bool -isinteger n = liftLua $ \l -> fromLuaBool <$> lua_isinteger l n - --- | Returns @True@ if the value at the given index is a light userdata, and --- @False@ otherwise. --- --- See also: --- . -islightuserdata :: StackIndex -> Lua Bool -islightuserdata n = (== TypeLightUserdata) <$> ltype n - --- | Returns @True@ if the value at the given index is @nil@, and @False@ --- otherwise. --- --- See also: --- . -isnil :: StackIndex -> Lua Bool -isnil n = (== TypeNil) <$> ltype n - --- | Returns @True@ if the given index is not valid, and @False@ otherwise. --- --- See also: --- . -isnone :: StackIndex -> Lua Bool -isnone n = (== TypeNone) <$> ltype n - --- | Returns @True@ if the given index is not valid or if the value at the given --- index is @nil@, and @False@ otherwise. --- --- See also: --- . -isnoneornil :: StackIndex -> Lua Bool -isnoneornil idx = (<= TypeNil) <$> ltype idx - --- | Returns @True@ if the value at the given index is a number or a string --- convertible to a number, and @False@ otherwise. --- --- See also: --- . -isnumber :: StackIndex -> Lua Bool -isnumber n = liftLua $ \l -> fromLuaBool <$> lua_isnumber l n - --- | Returns @True@ if the value at the given index is a string or a number --- (which is always convertible to a string), and @False@ otherwise. --- --- See also: --- . -isstring :: StackIndex -> Lua Bool -isstring n = liftLua $ \l -> fromLuaBool <$> lua_isstring l n - --- | Returns @True@ if the value at the given index is a table, and @False@ --- otherwise. --- --- See also: --- . -istable :: StackIndex -> Lua Bool -istable n = (== TypeTable) <$> ltype n - --- | Returns @True@ if the value at the given index is a thread, and @False@ --- otherwise. --- --- See also: --- . -isthread :: StackIndex -> Lua Bool -isthread n = (== TypeThread) <$> ltype n - --- | Returns @True@ if the value at the given index is a userdata (either full --- or light), and @False@ otherwise. --- --- See also: --- . -isuserdata :: StackIndex -> Lua Bool -isuserdata n = liftLua $ \l -> fromLuaBool <$> lua_isuserdata l n - --- | Tests whether the object under the first index is smaller than that under --- the second. Uses @'compare'@ internally. -lessthan :: StackIndex -> StackIndex -> Lua Bool -lessthan index1 index2 = compare index1 index2 LT - --- | Loads a Lua chunk (without running it). If there are no errors, @'load'@ --- pushes the compiled chunk as a Lua function on top of the stack. Otherwise, --- it pushes an error message. --- --- The return values of @'load'@ are: --- --- - @'OK'@: no errors; --- - @'ErrSyntax'@: syntax error during pre-compilation; --- - @'ErrMem'@: memory allocation error; --- - @'ErrGcmm'@: error while running a @__gc@ metamethod. (This error has no --- relation with the chunk being loaded. It is generated by the garbage --- collector.) --- --- This function only loads a chunk; it does not run it. --- --- @load@ automatically detects whether the chunk is text or binary, and loads --- it accordingly (see program luac). --- --- The @'load'@ function uses a user-supplied reader function to read the chunk --- (see @'Lua.Reader'@). The data argument is an opaque value passed to the --- reader function. --- --- The @chunkname@ argument gives a name to the chunk, which is used for error --- messages and in debug information (see --- ). Note that the --- @chunkname@ is used as a C string, so it may not contain null-bytes. -load :: Lua.Reader -> Ptr () -> ByteString -> Lua Status -load reader data' chunkname = liftLua $ \l -> - B.useAsCString chunkname $ \namePtr -> - toStatus <$> lua_load l reader data' namePtr nullPtr - --- | Returns the type of the value in the given valid index, or @'TypeNone'@ for --- a non-valid (but acceptable) index. --- --- See . -ltype :: StackIndex -> Lua Type -ltype idx = toType <$> liftLua (`lua_type` idx) - --- | Creates a new empty table and pushes it onto the stack. It is equivalent to --- @createtable 0 0@. --- --- See also: --- . -newtable :: Lua () -newtable = createtable 0 0 - --- | This function allocates a new block of memory with the given size, pushes --- onto the stack a new full userdata with the block address, and returns this --- address. The host program can freely use this memory. --- --- See also: --- . -newuserdata :: Int -> Lua (Ptr ()) -newuserdata = liftLua1 lua_newuserdata . fromIntegral - --- | Pops a key from the stack, and pushes a key–value pair from the table at --- the given index (the "next" pair after the given key). If there are no more --- elements in the table, then @next@ returns @False@ (and pushes nothing). --- --- Errors on the Lua side are caught and rethrown as a @'Exception'@. --- --- See also: --- . -next :: StackIndex -> Lua Bool -next idx = fromLuaBool <$> liftLuaThrow (\l -> hslua_next l idx) - --- | Opens all standard Lua libraries into the current state and sets each --- library name as a global value. --- --- See also: --- . -openlibs :: Lua () -openlibs = liftLua luaL_openlibs - --- | Pushes Lua's /base/ library onto the stack. --- --- See . -openbase :: Lua () -openbase = pushcfunction luaopen_base *> call 0 multret - --- | Pushes Lua's /debug/ library onto the stack. --- --- See also: --- . -opendebug :: Lua () -opendebug = pushcfunction luaopen_debug *> call 0 multret - --- | Pushes Lua's /io/ library onto the stack. --- --- See also: --- . -openio :: Lua () -openio = pushcfunction luaopen_io *> call 0 multret - --- | Pushes Lua's /math/ library onto the stack. --- --- See also: --- . -openmath :: Lua () -openmath = pushcfunction luaopen_math *> call 0 multret - --- | Pushes Lua's /os/ library onto the stack. --- --- See also: --- . -openos :: Lua () -openos = pushcfunction luaopen_os *> call 0 multret - --- | Pushes Lua's /package/ library onto the stack. --- --- See also: --- . -openpackage :: Lua () -openpackage = pushcfunction luaopen_package *> call 0 multret - --- | Pushes Lua's /string/ library onto the stack. --- --- See also: --- . -openstring :: Lua () -openstring = pushcfunction luaopen_string *> call 0 multret - --- | Pushes Lua's /table/ library onto the stack. --- --- See also: --- . -opentable :: Lua () -opentable = pushcfunction luaopen_table *> call 0 multret - --- | Calls a function in protected mode. --- --- Both @nargs@ and @nresults@ have the same meaning as in @'call'@. If there --- are no errors during the call, @pcall@ behaves exactly like @'call'@. --- However, if there is any error, @pcall@ catches it, pushes a single value on --- the stack (the error message), and returns the error code. Like @'call'@, --- @pcall@ always removes the function and its arguments from the stack. --- --- If @msgh@ is @Nothing@, then the error object returned on the stack is --- exactly the original error object. Otherwise, when @msgh@ is @Just idx@, the --- stack index @idx@ is the location of a message handler. (This index cannot be --- a pseudo-index.) In case of runtime errors, this function will be called with --- the error object and its return value will be the object returned on the --- stack by @'pcall'@. --- --- Typically, the message handler is used to add more debug information to the --- error object, such as a stack traceback. Such information cannot be gathered --- after the return of @'pcall'@, since by then the stack has unwound. --- --- See . -pcall :: NumArgs -> NumResults -> Maybe StackIndex -> Lua Status -pcall nargs nresults msgh = liftLua $ \l -> - toStatus <$> lua_pcall l nargs nresults (fromMaybe 0 msgh) - --- | Pops @n@ elements from the stack. --- --- See also: . -pop :: Int -> Lua () -pop n = liftLua $ \l -> lua_pop l (fromIntegral n) - --- | Pushes a boolean value with the given value onto the stack. --- --- See also: --- . -pushboolean :: Bool -> Lua () -pushboolean b = liftLua $ \l -> lua_pushboolean l (toLuaBool b) - --- | Pushes a new C closure onto the stack. --- --- When a C function is created, it is possible to associate some values with --- it, thus creating a C closure (see --- ); these values are then --- accessible to the function whenever it is called. To associate values with a --- C function, first these values should be pushed onto the stack (when there --- are multiple values, the first value is pushed first). Then lua_pushcclosure --- is called to create and push the C function onto the stack, with the argument --- @n@ telling how many values should be associated with the function. --- lua_pushcclosure also pops these values from the stack. --- --- The maximum value for @n@ is 255. --- --- See also: --- . -pushcclosure :: CFunction -> NumArgs -> Lua () -pushcclosure f n = liftLua $ \l -> lua_pushcclosure l f n - --- | Pushes a C function onto the stack. This function receives a pointer to a C --- function and pushes onto the stack a Lua value of type function that, when --- called, invokes the corresponding C function. --- --- Any function to be callable by Lua must follow the correct protocol to --- receive its parameters and return its results (see @'CFunction'@) --- --- See also: --- . -pushcfunction :: CFunction -> Lua () -pushcfunction f = pushcclosure f 0 - --- | Pushes the global environment onto the stack. --- --- Wraps . -pushglobaltable :: Lua () -pushglobaltable = liftLua lua_pushglobaltable - --- | Pushes an integer with with the given value onto the stack. --- --- See also: --- . -pushinteger :: Lua.Integer -> Lua () -pushinteger = liftLua1 lua_pushinteger - --- | Pushes a light userdata onto the stack. --- --- Userdata represent C values in Lua. A light userdata represents a pointer, a --- @Ptr ()@ (i.e., @void*@ in C lingo). It is a value (like a number): you do --- not create it, it has no individual metatable, and it is not collected (as it --- was never created). A light userdata is equal to "any" light userdata with --- the same C address. --- --- See also: --- . -pushlightuserdata :: Ptr a -> Lua () -pushlightuserdata = liftLua1 lua_pushlightuserdata - --- | Pushes a nil value onto the stack. --- --- See . -pushnil :: Lua () -pushnil = liftLua lua_pushnil - --- | Pushes a float with the given value onto the stack. --- --- See . -pushnumber :: Lua.Number -> Lua () -pushnumber = liftLua1 lua_pushnumber - --- | Pushes the zero-terminated string pointed to by s onto the stack. Lua makes --- (or reuses) an internal copy of the given string, so the memory at s can be --- freed or reused immediately after the function returns. --- --- See also: . -pushstring :: ByteString -> Lua () -pushstring s = liftLua $ \l -> - B.unsafeUseAsCStringLen s $ \(sPtr, z) -> lua_pushlstring l sPtr (fromIntegral z) - --- | Pushes the current thread onto the stack. Returns @True@ if this thread is --- the main thread of its state, @False@ otherwise. --- --- See also: --- . -pushthread :: Lua Bool -pushthread = (1 ==) <$> liftLua lua_pushthread - --- | Pushes a copy of the element at the given index onto the stack. --- --- See . -pushvalue :: StackIndex -> Lua () -pushvalue n = liftLua $ \l -> lua_pushvalue l n - --- | Returns @True@ if the two values in indices @idx1@ and @idx2@ are --- primitively equal (that is, without calling the @__eq@ metamethod). Otherwise --- returns @False@. Also returns @False@ if any of the indices are not valid. --- --- See also: --- . -rawequal :: StackIndex -> StackIndex -> Lua Bool -rawequal idx1 idx2 = liftLua $ \l -> - fromLuaBool <$> lua_rawequal l idx1 idx2 - --- | Similar to @'gettable'@, but does a raw access (i.e., without metamethods). --- --- See also: --- . -rawget :: StackIndex -> Lua () -rawget n = ensureTable n (\l -> lua_rawget l n) - --- | Pushes onto the stack the value @t[n]@, where @t@ is the table at the given --- index. The access is raw, that is, it does not invoke the @__index@ --- metamethod. --- --- See also: --- . -rawgeti :: StackIndex -> Lua.Integer -> Lua () -rawgeti k n = ensureTable k (\l -> lua_rawgeti l k n) - --- | 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 --- memory allocated for the userdata; for other values, it is 0. --- --- See also: --- . -rawlen :: StackIndex -> Lua Int -rawlen idx = liftLua $ \l -> fromIntegral <$> lua_rawlen l idx - --- | Similar to @'settable'@, but does a raw assignment (i.e., without --- metamethods). --- --- See also: --- . -rawset :: StackIndex -> Lua () -rawset n = ensureTable n (\l -> lua_rawset l n) - --- | Does the equivalent of @t[i] = v@, where @t@ is the table at the given --- index and @v@ is the value at the top of the stack. --- --- This function pops the value from the stack. The assignment is raw, that is, --- it does not invoke the @__newindex@ metamethod. --- --- See also: --- . -rawseti :: StackIndex -> Lua.Integer -> Lua () -rawseti k m = ensureTable k (\l -> lua_rawseti l k m) - --- | Sets the C function @f@ as the new value of global @name@. --- --- See . -register :: String -> CFunction -> Lua () -register name f = do - pushcfunction f - setglobal name - --- | Removes the element at the given valid index, shifting down the elements --- above this index to fill the gap. This function cannot be called with a --- pseudo-index, because a pseudo-index is not an actual stack position. --- --- See . -remove :: StackIndex -> Lua () -remove n = liftLua $ \l -> lua_remove l n - --- | Moves the top element into the given valid index without shifting any --- element (therefore replacing the value at that given index), and then pops --- the top element. --- --- See . -replace :: StackIndex -> Lua () -replace n = liftLua $ \l -> lua_replace l n - --- | Does the equivalent to @t[k] = v@, where @t@ is the value at the given --- index and @v@ is the value at the top of the stack. --- --- This function pops the value from the stack. As in Lua, this function may --- trigger a metamethod for the "newindex" event (see --- of the Lua 5.3 --- Reference Manual). --- --- Errors on the Lua side are caught and rethrown as a @'Exception'@. --- --- See also: --- . -setfield :: StackIndex -> String -> Lua () -setfield i s = do - absidx <- absindex i - pushstring (Utf8.fromString s) - insert (nthTop 2) - settable absidx - --- | Pops a value from the stack and sets it as the new value of global @name@. --- --- Errors on the Lua side are caught and rethrown as a @'Exception'@. --- --- See also: --- . -setglobal :: String -> Lua () -setglobal name = liftLuaThrow $ \l status' -> - C.withCStringLen name $ \(namePtr, nameLen) -> - hslua_setglobal l namePtr (fromIntegral nameLen) status' - --- | Pops a table from the stack and sets it as the new metatable for the value --- at the given index. --- --- See also: --- . -setmetatable :: StackIndex -> Lua () -setmetatable idx = liftLua $ \l -> lua_setmetatable l idx - --- | Does the equivalent to @t[k] = v@, where @t@ is the value at the given --- index, @v@ is the value at the top of the stack, and @k@ is the value just --- below the top. --- --- This function pops both the key and the value from the stack. As in Lua, this --- function may trigger a metamethod for the "newindex" event (see --- of the Lua 5.3 --- Reference Manual). --- --- Errors on the Lua side are caught and rethrown as a @'Exception'@. --- --- See also: --- . -settable :: StackIndex -> Lua () -settable index = liftLuaThrow $ \l -> hslua_settable l index - --- | Accepts any index, or 0, and sets the stack top to this index. If the new --- top is larger than the old one, then the new elements are filled with nil. If --- index is 0, then all stack elements are removed. --- --- See also: --- . -settop :: StackIndex -> Lua () -settop = liftLua1 lua_settop - --- | 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. --- --- 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: . -status :: Lua Status -status = liftLua $ fmap toStatus . lua_status - --- | Converts the Lua value at the given index to a haskell boolean value. Like --- all tests in Lua, @toboolean@ returns @True@ for any Lua value different from --- @false@ and @nil@; otherwise it returns @False@. (If you want to accept only --- actual boolean values, use @'isboolean'@ to test the value's type.) --- --- See also: --- . -toboolean :: StackIndex -> Lua Bool -toboolean n = liftLua $ \l -> fromLuaBool <$> lua_toboolean l n - --- | Converts a value at the given index to a C function. That value must be a C --- function; otherwise, returns @Nothing@. --- --- See also: --- . -tocfunction :: StackIndex -> Lua (Maybe CFunction) -tocfunction n = liftLua $ \l -> do - fnPtr <- lua_tocfunction l n - 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 --- convertible to an integer (see --- of the Lua 5.3 --- Reference Manual); otherwise, @tointeger@ returns @Nothing@. --- --- If the number is not an integer, it is truncated in some non-specified way. --- --- See also: --- . -tointeger :: StackIndex -> Lua (Maybe Lua.Integer) -tointeger n = liftLua $ \l -> alloca $ \boolPtr -> do - res <- lua_tointegerx l n boolPtr - isNum <- fromLuaBool <$> F.peek boolPtr - return (if isNum then Just res else Nothing) - --- | Converts the Lua value at the given index to the C type lua_Number. The Lua --- value must be a number or a string convertible to a number; otherwise, --- @tonumber@ returns @'Nothing'@. --- --- See . -tonumber :: StackIndex -> Lua (Maybe Lua.Number) -tonumber n = liftLua $ \l -> alloca $ \bptr -> do - res <- lua_tonumberx l n bptr - isNum <- fromLuaBool <$> F.peek bptr - return (if isNum then Just res else Nothing) - --- | Converts the value at the given index to a generic C pointer (void*). The --- value can be a userdata, a table, a thread, or a function; otherwise, --- lua_topointer returns @nullPtr@. Different objects will give different --- pointers. There is no way to convert the pointer back to its original value. --- --- Typically this function is used only for hashing and debug information. --- --- See also: --- . -topointer :: StackIndex -> Lua (Ptr ()) -topointer n = liftLua $ \l -> lua_topointer l n - --- | Converts the Lua value at the given index to a @'ByteString'@. The Lua --- value must be a string or a number; otherwise, the function returns --- @'Nothing'@. If the value is a number, then @'tostring'@ also changes the --- actual value in the stack to a string. (This change confuses @'next'@ when --- @'tostring'@ is applied to keys during a table traversal.) --- --- See . -tostring :: StackIndex -> Lua (Maybe ByteString) -tostring n = liftLua $ \l -> - alloca $ \lenPtr -> do - cstr <- lua_tolstring l n lenPtr - if cstr == nullPtr - then return Nothing - else do - cstrLen <- F.peek lenPtr - Just <$> B.packCStringLen (cstr, fromIntegral cstrLen) - --- | Converts the value at the given index to a Lua thread (represented as --- lua_State*). This value must be a thread; otherwise, the function returns --- @Nothing@. --- --- See also: --- . -tothread :: StackIndex -> Lua (Maybe Lua.State) -tothread n = liftLua $ \l -> do - thread@(Lua.State ptr) <- lua_tothread l n - if ptr == nullPtr - then return Nothing - else return (Just thread) - --- | If the value at the given index is a full userdata, returns its block --- address. If the value is a light userdata, returns its pointer. Otherwise, --- returns @Nothing@.. --- --- See also: --- . -touserdata :: StackIndex -> Lua (Maybe (Ptr a)) -touserdata n = liftLua $ \l -> do - ptr <- lua_touserdata l n - if ptr == nullPtr - then return Nothing - else return (Just ptr) - --- | Returns the name of the type encoded by the value @tp@, which must be one --- the values returned by @'ltype'@. --- --- See also: --- . -typename :: Type -> Lua String -typename tp = liftLua $ \l -> - lua_typename l (fromType tp) >>= C.peekCString - --- | Returns the pseudo-index that represents the @i@-th upvalue of the running --- function (see of the --- Lua 5.3 reference manual). --- --- See also: --- . -upvalueindex :: StackIndex -> StackIndex -upvalueindex i = registryindex - i diff --git a/src/HsLua/Core/Package.hs b/src/HsLua/Core/Package.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Core/Package.hs @@ -0,0 +1,62 @@ +{-| +Module : HsLua.Core.Package +Copyright : © 2019-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : alpha +Portability : Requires GHC 8 or later. + +Utility functions for HsLua modules. +-} +module HsLua.Core.Package + ( requirehs + , preloadhs + ) +where + +import Control.Monad (void) +import HsLua.Core.Auxiliary +import HsLua.Core.Closures (pushHaskellFunction) +import HsLua.Core.Error (LuaError) +import HsLua.Core.Primary +import HsLua.Core.Types +-- import HsLua.Core.Utf8 (fromString) + +-- | Load a module, defined by a Haskell action, under the given +-- name. +-- +-- Similar to @luaL_required@: After checking "loaded" table, +-- calls @pushMod@ to push a module to the stack, and registers +-- the result in @package.loaded@ table. +-- +-- The @pushMod@ function must push exactly one element to the top +-- of the stack. This is not checked, but failure to do so will +-- lead to problems. Lua's @package@ module must have been loaded +-- by the time this function is invoked. +-- +-- Leaves a copy of the module on the stack. +requirehs :: LuaError e => Name -> LuaE e () -> LuaE e () +requirehs modname pushMod = do + -- get table of loaded modules + void $ getfield registryindex loaded + + -- Check whether module has already been loaded. + getfield top modname >>= \case -- LOADED[modname] + TypeNil -> do -- not loaded yet, load now + pop 1 -- remove LOADED[modname], i.e., nil + pushMod -- push module + pushvalue top -- make copy of module + -- add module under the given name (LOADED[modname] = module) + setfield (nth 3) modname + _ -> return () + + remove (nth 2) -- remove table of loaded modules + +-- | Registers a preloading function. Takes an module name and the +-- Lua operation which produces the package. +preloadhs :: LuaError e => Name -> LuaE e NumResults -> LuaE e () +preloadhs name pushMod = do + void $ getfield registryindex preload + pushHaskellFunction pushMod + setfield (nth 2) name + pop 1 diff --git a/src/HsLua/Core/Primary.hs b/src/HsLua/Core/Primary.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Core/Primary.hs @@ -0,0 +1,1001 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : HsLua.Core.Primary +Copyright : © 2007–2012 Gracjan Polak; + © 2012–2016 Ömer Sinan Ağacan; + © 2017-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : non-portable (depends on GHC) + +Monadic functions which operate within the Lua type. + +The functions in this module are mostly thin wrappers around the +respective C functions. However, C function which can throw an error are +wrapped such that the error is converted into an exception. +-} +module HsLua.Core.Primary where + +import Prelude hiding (EQ, LT, compare, concat, error) + +import Control.Monad +import Data.ByteString (ByteString) +import Data.Maybe (fromMaybe) +import HsLua.Core.Error +import HsLua.Core.Types as Lua +import Lua +import Foreign.Marshal.Alloc (alloca) +import Foreign.Ptr + +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import qualified Foreign.Storable as F + +-- +-- Helper functions +-- + +-- | Execute an action only if the given index is a table. Throw an +-- error otherwise. +ensureTable :: LuaError e => StackIndex -> (Lua.State -> IO ()) -> LuaE e () +ensureTable idx ioOp = do + isTbl <- istable idx + if isTbl + then liftLua ioOp + else throwTypeMismatchError "table" idx +{-# INLINE ensureTable #-} + +-- +-- API functions +-- + +-- | Converts the acceptable index @idx@ into an equivalent absolute +-- index (that is, one that does not depend on the stack top). +-- +-- Wraps 'lua_absindex'. +absindex :: StackIndex -> LuaE e StackIndex +absindex = liftLua1 lua_absindex +{-# INLINABLE absindex #-} + +-- | Calls a function. +-- +-- To call a function you must use the following protocol: first, the +-- function to be called is pushed onto the stack; then, the arguments +-- to the function are pushed in direct order; that is, the first +-- argument is pushed first. Finally you call @call@; @nargs@ is the +-- number of arguments that you pushed onto the stack. All arguments and +-- the function value are popped from the stack when the function is +-- called. The function results are pushed onto the stack when the +-- function returns. The number of results is adjusted to @nresults@, +-- unless @nresults@ is @multret@. In this case, all results from the +-- function are pushed. Lua takes care that the returned values fit into +-- the stack space. The function results are pushed onto the stack in +-- direct order (the first result is pushed first), so that after the +-- call the last result is on the top of the stack. +-- +-- Any error inside the called function is propagated as exception of +-- type @e@. +-- +-- The following example shows how the host program can do the +-- equivalent to this Lua code: +-- +-- > a = f("how", t.x, 14) +-- +-- Here it is in Haskell (assuming the OverloadedStrings language +-- extension): +-- +-- > getglobal "f" -- function to be called +-- > pushstring "how" -- 1st argument +-- > getglobal "t" -- table to be indexed +-- > getfield (-1) "x" -- push result of t.x (2nd arg) +-- > remove (-2) -- remove 't' from the stack +-- > pushinteger 14 -- 3rd argument +-- > call 3 1 -- call 'f' with 3 arguments and 1 result +-- > setglobal "a" -- set global 'a' +-- +-- Note that the code above is "balanced": at its end, the stack is back +-- to its original configuration. This is considered good programming +-- practice. +-- +-- See . +call :: LuaError e => NumArgs -> NumResults -> LuaE e () +call nargs nresults = do + res <- pcall nargs nresults Nothing + when (res /= OK) throwErrorAsException +{-# INLINABLE call #-} + +-- | Ensures that the stack has space for at least @n@ extra slots (that +-- is, that you can safely push up to @n@ values into it). It returns +-- false if it cannot fulfill the request, either because it would cause +-- the stack to be larger than a fixed maximum size (typically at least +-- several thousand elements) or because it cannot allocate memory for +-- the extra space. This function never shrinks the stack; if the stack +-- already has space for the extra slots, it is left unchanged. +-- +-- Wraps 'lua_checkstack'. +checkstack :: Int -> LuaE e Bool +checkstack n = liftLua $ \l -> + fromLuaBool <$!> lua_checkstack l (fromIntegral n) +{-# INLINABLE checkstack #-} + +-- | Destroys all objects in the given Lua state (calling the +-- corresponding garbage-collection metamethods, if any) and frees all +-- dynamic memory used by this state. On several platforms, you may not +-- need to call this function, because all resources are naturally +-- released when the host program ends. On the other hand, long-running +-- programs that create multiple states, such as daemons or web servers, +-- will probably need to close states as soon as they are not needed. +-- +-- Same as 'lua_close'. +close :: Lua.State -> IO () +close = lua_close +{-# INLINABLE close #-} + +-- | Compares two Lua values. Returns 'True' if the value at index +-- @idx1@ satisfies @op@ when compared with the value at index @idx2@, +-- following the semantics of the corresponding Lua operator (that is, +-- it may call metamethods). Otherwise returns @False@. Also returns +-- @False@ if any of the indices is not valid. +-- +-- The value of op must be of type 'RelationalOperator': +-- +-- EQ: compares for equality (==) +-- LT: compares for less than (<) +-- LE: compares for less or equal (<=) +-- +-- Wraps 'hslua_compare'. See also +-- . +compare :: LuaError e + => StackIndex -- ^ idx1 + -> StackIndex -- ^ idx2 + -> RelationalOperator + -> LuaE e Bool +compare idx1 idx2 relOp = fromLuaBool <$!> liftLuaThrow + (\l -> hslua_compare l idx1 idx2 (fromRelationalOperator relOp)) +{-# INLINABLE compare #-} + +-- | Concatenates the @n@ values at the top of the stack, pops them, and +-- leaves the result at the top. If @n@ is 1, the result is the single +-- value on the stack (that is, the function does nothing); if @n@ is 0, +-- the result is the empty string. Concatenation is performed following +-- the usual semantics of Lua (see +-- of the Lua +-- manual). +-- +-- Wraps 'hslua_concat'. See also +-- . +concat :: LuaError e => NumArgs -> LuaE e () +concat n = liftLuaThrow (`hslua_concat` n) +{-# INLINABLE concat #-} + +-- | Copies the element at index @fromidx@ into the valid index @toidx@, +-- replacing the value at that position. Values at other positions are +-- not affected. +-- +-- Wraps 'lua_copy'. +copy :: StackIndex -> StackIndex -> LuaE e () +copy fromidx toidx = liftLua $ \l -> lua_copy l fromidx toidx +{-# INLINABLE copy #-} + +-- | Creates a new empty table and pushes it onto the stack. Parameter +-- narr is a hint for how many elements the table will have as a +-- sequence; parameter nrec is a hint for how many other elements the +-- table will have. Lua may use these hints to preallocate memory for +-- the new table. This preallocation is useful for performance when you +-- know in advance how many elements the table will have. Otherwise you +-- can use the function lua_newtable. +-- +-- Wraps 'lua_createtable'. +createtable :: Int -> Int -> LuaE e () +createtable narr nrec = liftLua $ \l -> + lua_createtable l (fromIntegral narr) (fromIntegral nrec) +{-# INLINABLE createtable #-} + +-- 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 :: LuaError e + => StackIndex -- ^ index1 + -> StackIndex -- ^ index2 + -> LuaE e Bool +equal index1 index2 = compare index1 index2 EQ +{-# INLINABLE equal #-} + +-- | Signals to Lua that an error has occurred and that the error object +-- is at the top of the stack. +error :: LuaE e NumResults +error = liftLua hslua_error +{-# INLINABLE error #-} + +-- | Controls the garbage collector. +-- +-- This function performs several tasks, according to the given control +-- command. See the documentation for 'GCControl'. +-- +-- Wraps 'lua_gc'. +gc :: GCControl -> LuaE e Int +gc what = liftLua $ \l -> + fromIntegral <$!> lua_gc l (toGCcode what) (toGCdata what) +{-# INLINABLE gc #-} + +-- | Pushes onto the stack the value @t[k]@, where @t@ is the value at +-- the given stack index. As in Lua, this function may trigger a +-- metamethod for the "index" event (see +-- of Lua's +-- manual). +-- +-- Errors on the Lua side are propagated. +-- +-- See also +-- . +getfield :: LuaError e => StackIndex -> Name -> LuaE e Type +getfield i (Name s) = do + absidx <- absindex i + pushstring s + gettable absidx +{-# INLINABLE getfield #-} + +-- | Pushes onto the stack the value of the global @name@. +-- +-- Errors on the Lua side are propagated. +-- +-- Wraps 'hslua_getglobal'. +getglobal :: LuaError e => Name -> LuaE e Type +getglobal (Name name) = liftLuaThrow $ \l status' -> + B.unsafeUseAsCStringLen name $ \(namePtr, len) -> + toType <$!> hslua_getglobal l namePtr (fromIntegral len) status' +{-# INLINABLE getglobal #-} + +-- | If the value at the given index has a metatable, the function +-- pushes that metatable onto the stack and returns @True@. Otherwise, +-- the function returns @False@ and pushes nothing on the stack. +-- +-- Wraps 'lua_getmetatable'. +getmetatable :: StackIndex -> LuaE e Bool +getmetatable n = liftLua $ \l -> + fromLuaBool <$!> lua_getmetatable l n +{-# INLINABLE getmetatable #-} + +-- | Pushes onto the stack the value @t[k]@, where @t@ is the value at +-- the given index and @k@ is the value at the top of the stack. +-- +-- This function pops the key from the stack, pushing the resulting +-- value in its place. As in Lua, this function may trigger a metamethod +-- for the "index" event (see +-- of Lua's +-- manual). +-- +-- Errors on the Lua side are caught and rethrown. +-- +-- Wraps 'hslua_gettable'. See also: +-- . +gettable :: LuaError e => StackIndex -> LuaE e Type +gettable n = liftLuaThrow (\l -> fmap toType . hslua_gettable l n) +{-# INLINABLE gettable #-} + +-- | Returns the index of the top element in the stack. Because indices +-- start at 1, this result is equal to the number of elements in the +-- stack (and so 0 means an empty stack). +-- +-- Wraps 'lua_gettop'. +gettop :: LuaE e StackIndex +gettop = liftLua lua_gettop +{-# INLINABLE gettop #-} + +-- | Pushes onto the stack the Lua value associated with the full +-- userdata at the given index. +-- +-- Returns the type of the pushed value. +-- +-- Wraps 'lua_getuservalue'. +getuservalue :: StackIndex -> LuaE e Type +getuservalue idx = toType <$> liftLua (`lua_getuservalue` idx) + +-- | Moves the top element into the given valid index, shifting up the +-- elements above this index to open space. This function cannot be +-- called with a pseudo-index, because a pseudo-index is not an actual +-- stack position. +-- +-- Wraps 'lua_insert'. +insert :: StackIndex -> LuaE e () +insert index = liftLua $ \l -> lua_insert l index +{-# INLINABLE insert #-} + +-- | Returns 'True' if the value at the given index is a boolean, and +-- 'False' otherwise. +-- +-- Wraps 'lua_isboolean'. +isboolean :: StackIndex -> LuaE e Bool +isboolean n = liftLua $ \l -> fromLuaBool <$!> lua_isboolean l n +{-# INLINABLE isboolean #-} + +-- | Returns 'True' if the value at the given index is a C function, and +-- 'False' otherwise. +-- +-- Wraps 'lua_iscfunction'. +iscfunction :: StackIndex -> LuaE e Bool +iscfunction n = liftLua $ \l -> fromLuaBool <$!> lua_iscfunction l n +{-# INLINABLE iscfunction #-} + +-- | Returns 'True' if the value at the given index is a function +-- (either C or Lua), and 'False' otherwise. +-- +-- Wraps 'lua_isfunction'. +isfunction :: StackIndex -> LuaE e Bool +isfunction n = liftLua $ \l -> fromLuaBool <$!> lua_isfunction l n +{-# INLINABLE isfunction #-} + +-- | Returns @True@ if the value at the given index is an integer (that +-- is, the value is a number and is represented as an integer), and +-- 'False' otherwise. +-- +-- Wraps 'lua_isinteger'. +isinteger :: StackIndex -> LuaE e Bool +isinteger n = liftLua $ \l -> fromLuaBool <$!> lua_isinteger l n +{-# INLINABLE isinteger #-} + +-- | Returns @True@ if the value at the given index is a light userdata, +-- and @False@ otherwise. +-- +-- Wraps 'lua_islightuserdata'. +islightuserdata :: StackIndex -> LuaE e Bool +islightuserdata n = liftLua $ \l -> fromLuaBool <$!> lua_islightuserdata l n +{-# INLINABLE islightuserdata #-} + +-- | Returns 'True' if the value at the given index is *nil*, and +-- 'False' otherwise. +-- +-- Wraps 'lua_isnil'. +isnil :: StackIndex -> LuaE e Bool +isnil n = liftLua $ \l -> fromLuaBool <$!> lua_isnil l n +{-# INLINABLE isnil #-} + +-- | Returns 'True' if the given index is not valid, and 'False' +-- otherwise. +-- +-- Wraps 'lua_isnone'. +isnone :: StackIndex -> LuaE e Bool +isnone n = liftLua $ \l -> fromLuaBool <$!> lua_isnone l n +{-# INLINABLE isnone #-} + +-- | Returns 'True' if the given index is not valid or if the value at +-- the given index is *nil*, and 'False' otherwise. +-- +-- Wraps 'lua_isnoneornil'. +isnoneornil :: StackIndex -> LuaE e Bool +isnoneornil n = liftLua $ \l -> fromLuaBool <$!> lua_isnoneornil l n +{-# INLINABLE isnoneornil #-} + +-- | Returns 'True' if the value at the given index is a number or a +-- string convertible to a number, and 'False' otherwise. +-- +-- Wraps 'lua_isnumber'. +isnumber :: StackIndex -> LuaE e Bool +isnumber n = liftLua $ \l -> fromLuaBool <$!> lua_isnumber l n +{-# INLINABLE isnumber #-} + +-- | Returns 'True' if the value at the given index is a string or a +-- number (which is always convertible to a string), and 'False' +-- otherwise. +-- +-- Wraps 'lua_isstring'. +isstring :: StackIndex -> LuaE e Bool +isstring n = liftLua $ \l -> fromLuaBool <$!> lua_isstring l n +{-# INLINABLE isstring #-} + +-- | Returns 'True' if the value at the given index is a table, and +-- 'False' otherwise. +-- +-- Wraps 'lua_istable'. +istable :: StackIndex -> LuaE e Bool +istable n = liftLua $ \l -> fromLuaBool <$!> lua_istable l n +{-# INLINABLE istable #-} + +-- | Returns 'True' if the value at the given index is a thread, and +-- 'False' otherwise. +-- +-- Wraps 'lua_isthread'. +isthread :: StackIndex -> LuaE e Bool +isthread n = liftLua $ \l -> fromLuaBool <$!> lua_isthread l n +{-# INLINABLE isthread #-} + +-- | Returns 'True' if the value at the given index is a userdata +-- (either full or light), and 'False' otherwise. +-- +-- Wraps 'lua_isuserdata'. +isuserdata :: StackIndex -> LuaE e Bool +isuserdata n = liftLua $ \l -> fromLuaBool <$!> lua_isuserdata l n +{-# INLINABLE isuserdata #-} + +-- | Tests whether the object under the first index is smaller than that +-- under the second. Uses @'compare'@ internally. +lessthan :: LuaError e => StackIndex -> StackIndex -> LuaE e Bool +lessthan index1 index2 = compare index1 index2 LT +{-# INLINABLE lessthan #-} + +-- | Loads a Lua chunk (without running it). If there are no errors, +-- @'load'@ pushes the compiled chunk as a Lua function on top of the +-- stack. Otherwise, it pushes an error message. +-- +-- The return values of @'load'@ are: +-- +-- - @'OK'@: no errors; +-- - @'ErrSyntax'@: syntax error during pre-compilation; +-- - @'ErrMem'@: memory allocation error; +-- - @'ErrGcmm'@: error while running a @__gc@ metamethod. (This error +-- has no relation with the chunk being loaded. It is generated by the +-- garbage collector.) +-- +-- This function only loads a chunk; it does not run it. +-- +-- @load@ automatically detects whether the chunk is text or binary, and +-- loads it accordingly (see program luac). +-- +-- The @'load'@ function uses a user-supplied reader function to read +-- the chunk (see @'Lua.Reader'@). The data argument is an opaque value +-- passed to the reader function. +-- +-- The @chunkname@ argument gives a name to the chunk, which is used for +-- error messages and in debug information (see +-- ). Note that the +-- @chunkname@ is used as a C string, so it may not contain null-bytes. +-- +-- This is a wrapper of 'lua_load'. +load :: Lua.Reader -> Ptr () -> Name -> LuaE e Status +load reader data' (Name chunkname) = liftLua $ \l -> + B.useAsCString chunkname $ \namePtr -> + toStatus <$!> lua_load l reader data' namePtr nullPtr +{-# INLINABLE load #-} + +-- | Returns the type of the value in the given valid index, or +-- @'TypeNone'@ for a non-valid (but acceptable) index. +-- +-- This function wraps 'lua_type'. +ltype :: StackIndex -> LuaE e Type +ltype idx = toType <$!> liftLua (`lua_type` idx) +{-# INLINABLE ltype #-} + +-- | Creates a new empty table and pushes it onto the stack. It is +-- equivalent to @createtable 0 0@. +-- +-- See also: +-- . +newtable :: LuaE e () +newtable = createtable 0 0 +{-# INLINABLE newtable #-} + +-- | This function allocates a new block of memory with the given size, +-- pushes onto the stack a new full userdata with the block address, and +-- returns this address. The host program can freely use this memory. +-- +-- This function wraps 'lua_newuserdata'. +newuserdata :: Int -> LuaE e (Ptr ()) +newuserdata = liftLua1 lua_newuserdata . fromIntegral +{-# INLINABLE newuserdata #-} + +-- | Pops a key from the stack, and pushes a key–value pair from the +-- table at the given index (the "next" pair after the given key). If +-- there are no more elements in the table, then @next@ returns @False@ +-- (and pushes nothing). +-- +-- Errors on the Lua side are caught and rethrown as a @'Exception'@. +-- +-- This function wraps 'hslua_next'. +-- See also: +-- . +next :: LuaError e => StackIndex -> LuaE e Bool +next idx = fromLuaBool <$!> liftLuaThrow (\l -> hslua_next l idx) +{-# INLINABLE next #-} + +-- | Opens all standard Lua libraries into the current state and sets +-- each library name as a global value. +-- +-- This function wraps 'luaL_openlibs'. +openlibs :: LuaE e () +openlibs = liftLua luaL_openlibs +{-# INLINABLE openlibs #-} + +-- | Pushes Lua's /base/ library onto the stack. +-- +-- This function pushes and and calls 'luaopen_base'. +openbase :: LuaError e => LuaE e () +openbase = pushcfunction luaopen_base *> call 0 multret +{-# INLINABLE openbase #-} + +-- | Pushes Lua's /debug/ library onto the stack. +-- +-- This function pushes and and calls 'luaopen_io'. +opendebug :: LuaError e => LuaE e () +opendebug = pushcfunction luaopen_debug *> call 0 multret +{-# INLINABLE opendebug #-} + +-- | Pushes Lua's /io/ library onto the stack. +-- +-- This function pushes and and calls 'luaopen_io'. +openio :: LuaError e => LuaE e () +openio = pushcfunction luaopen_io *> call 0 multret +{-# INLINABLE openio #-} + +-- | Pushes Lua's /math/ library onto the stack. +-- +-- This function pushes and and calls 'luaopen_math'. +openmath :: LuaError e => LuaE e () +openmath = pushcfunction luaopen_math *> call 0 multret +{-# INLINABLE openmath #-} + +-- | Pushes Lua's /os/ library onto the stack. +-- +-- This function pushes and and calls 'luaopen_os'. +openos :: LuaError e => LuaE e () +openos = pushcfunction luaopen_os *> call 0 multret +{-# INLINABLE openos #-} + +-- | Pushes Lua's /package/ library onto the stack. +-- +-- This function pushes and and calls 'luaopen_package'. +openpackage :: LuaError e => LuaE e () +openpackage = pushcfunction luaopen_package *> call 0 multret +{-# INLINABLE openpackage #-} + +-- | Pushes Lua's /string/ library onto the stack. +-- +-- This function pushes and and calls 'luaopen_string'. +openstring :: LuaError e => LuaE e () +openstring = pushcfunction luaopen_string *> call 0 multret +{-# INLINABLE openstring #-} + +-- | Pushes Lua's /table/ library onto the stack. +-- +-- This function pushes and and calls 'luaopen_table'. +opentable :: LuaError e => LuaE e () +opentable = pushcfunction luaopen_table *> call 0 multret +{-# INLINABLE opentable #-} + +-- | Calls a function in protected mode. +-- +-- Both @nargs@ and @nresults@ have the same meaning as in @'call'@. If +-- there are no errors during the call, @pcall@ behaves exactly like +-- @'call'@. However, if there is any error, @pcall@ catches it, pushes +-- a single value on the stack (the error message), and returns the +-- error code. Like @'call'@, @pcall@ always removes the function and +-- its arguments from the stack. +-- +-- If @msgh@ is @Nothing@, then the error object returned on the stack +-- is exactly the original error object. Otherwise, when @msgh@ is @Just +-- idx@, the stack index @idx@ is the location of a message handler. +-- (This index cannot be a pseudo-index.) In case of runtime errors, +-- this function will be called with the error object and its return +-- value will be the object returned on the stack by @'pcall'@. +-- +-- Typically, the message handler is used to add more debug information +-- to the error object, such as a stack traceback. Such information +-- cannot be gathered after the return of @'pcall'@, since by then the +-- stack has unwound. +-- +-- This function wraps 'lua_pcall'. +pcall :: NumArgs -> NumResults -> Maybe StackIndex -> LuaE e Status +pcall nargs nresults msgh = liftLua $ \l -> + toStatus <$!> lua_pcall l nargs nresults (fromMaybe 0 msgh) +{-# INLINABLE pcall #-} + +-- | Pops @n@ elements from the stack. +-- +-- See also: . +pop :: Int -> LuaE e () +pop n = liftLua $ \l -> lua_pop l (fromIntegral n) +{-# INLINABLE pop #-} + +-- | Pushes a boolean value with the given value onto the stack. +-- +-- This functions wraps 'lua_pushboolean'. +pushboolean :: Bool -> LuaE e () +pushboolean b = liftLua $ \l -> lua_pushboolean l (toLuaBool b) +{-# INLINABLE pushboolean #-} + +-- | Pushes a new C closure onto the stack. +-- +-- When a C function is created, it is possible to associate some values +-- with it, thus creating a C closure (see +-- ); these values +-- are then accessible to the function whenever it is called. To +-- associate values with a C function, first these values should be +-- pushed onto the stack (when there are multiple values, the first +-- value is pushed first). Then pushcclosure is called to create and +-- push the C function onto the stack, with the argument @n@ telling how +-- many values should be associated with the function. pushcclosure also +-- pops these values from the stack. +-- +-- The maximum value for @n@ is 255. +-- +-- Wraps 'lua_pushcclosure'. +pushcclosure :: CFunction -> NumArgs {- ^ n -} -> LuaE e () +pushcclosure f n = liftLua $ \l -> lua_pushcclosure l f n +{-# INLINABLE pushcclosure #-} + +-- | Pushes a C function onto the stack. This function receives a +-- pointer to a C function and pushes onto the stack a Lua value of type +-- function that, when called, invokes the corresponding C function. +-- +-- Any function to be callable by Lua must follow the correct protocol +-- to receive its parameters and return its results (see @'CFunction'@) +-- +-- Same as @flip 'pushcclosure' 0@. +-- . +pushcfunction :: CFunction -> LuaE e () +pushcfunction f = pushcclosure f 0 +{-# INLINABLE pushcfunction #-} + +-- | Pushes the global environment onto the stack. +-- +-- Wraps 'lua_pushglobaltable'. +pushglobaltable :: LuaE e () +pushglobaltable = liftLua lua_pushglobaltable +{-# INLINABLE pushglobaltable #-} + +-- | Pushes an integer with with the given value onto the stack. +-- +-- Wraps 'lua_pushinteger'. +pushinteger :: Lua.Integer -> LuaE e () +pushinteger = liftLua1 lua_pushinteger +{-# INLINABLE pushinteger #-} + +-- | Pushes a light userdata onto the stack. +-- +-- Userdata represent C values in Lua. A light userdata represents a +-- pointer, a @Ptr a@ (i.e., @void*@ in C). It is a value (like a +-- number): you do not create it, it has no individual metatable, and it +-- is not collected (as it was never created). A light userdata is equal +-- to "any" light userdata with the same C address. +-- +-- Wraps 'lua_pushlightuserdata'. +pushlightuserdata :: Ptr a -> LuaE e () +pushlightuserdata = liftLua1 lua_pushlightuserdata +{-# INLINABLE pushlightuserdata #-} + +-- | Pushes a nil value onto the stack. +-- +-- Wraps 'lua_pushnil'. +pushnil :: LuaE e () +pushnil = liftLua lua_pushnil +{-# INLINABLE pushnil #-} + +-- | Pushes a float with the given value onto the stack. +-- +-- Wraps 'lua_pushnumber'. +pushnumber :: Lua.Number -> LuaE e () +pushnumber = liftLua1 lua_pushnumber +{-# INLINABLE pushnumber #-} + +-- | Pushes the string pointed to by s onto the stack. Lua makes (or +-- reuses) an internal copy of the given string, so the memory at s can +-- be freed or reused immediately after the function returns. +-- +-- Wraps 'lua_pushlstring'. +pushstring :: ByteString -> LuaE e () +pushstring s = liftLua $ \l -> + B.unsafeUseAsCStringLen s $ \(sPtr, z) -> lua_pushlstring l sPtr (fromIntegral z) +{-# INLINABLE pushstring #-} + +-- | Pushes the current thread onto the stack. Returns @True@ if this thread is +-- the main thread of its state, @False@ otherwise. +-- +-- Wraps 'lua_pushthread'. +pushthread :: LuaE e Bool +pushthread = (1 ==) <$!> liftLua lua_pushthread +{-# INLINABLE pushthread #-} + +-- | Pushes a copy of the element at the given index onto the stack. +-- +-- Wraps 'lua_pushvalue'. +pushvalue :: StackIndex -> LuaE e () +pushvalue n = liftLua $ \l -> lua_pushvalue l n +{-# INLINABLE pushvalue #-} + +-- | Returns @True@ if the two values in indices @idx1@ and @idx2@ are +-- primitively equal (that is, without calling the @__eq@ metamethod). +-- Otherwise returns @False@. Also returns @False@ if any of the indices +-- are not valid. +-- +-- Wraps 'lua_rawequal'. +rawequal :: StackIndex -> StackIndex -> LuaE e Bool +rawequal idx1 idx2 = liftLua $ \l -> + fromLuaBool <$!> lua_rawequal l idx1 idx2 +{-# INLINABLE rawequal #-} + +-- | Similar to @'gettable'@, but does a raw access (i.e., without +-- metamethods). +-- +-- Wraps 'lua_rawget'. +rawget :: LuaError e => StackIndex -> LuaE e () +rawget n = ensureTable n (\l -> lua_rawget l n) +{-# INLINABLE rawget #-} + +-- | Pushes onto the stack the value @t[n]@, where @t@ is the table at +-- the given index. The access is raw, that is, it does not invoke the +-- @__index@ metamethod. +-- +-- Wraps 'lua_rawgeti'. +rawgeti :: LuaError e => StackIndex -> Lua.Integer -> LuaE e () +rawgeti k n = ensureTable k (\l -> lua_rawgeti l k n) +{-# INLINABLE rawgeti #-} + +-- | 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 memory allocated for the userdata; for other +-- values, it is 0. +-- +-- Wraps 'lua_rawlen'. +rawlen :: StackIndex -> LuaE e Int +rawlen idx = liftLua $ \l -> fromIntegral <$!> lua_rawlen l idx +{-# INLINABLE rawlen #-} + +-- | Similar to @'settable'@, but does a raw assignment (i.e., without +-- metamethods). +-- +-- Wraps 'lua_rawset'. +rawset :: LuaError e => StackIndex -> LuaE e () +rawset n = ensureTable n (\l -> lua_rawset l n) +{-# INLINABLE rawset #-} + +-- | Does the equivalent of @t[i] = v@, where @t@ is the table at the given +-- index and @v@ is the value at the top of the stack. +-- +-- This function pops the value from the stack. The assignment is raw, that is, +-- it does not invoke the @__newindex@ metamethod. +-- +-- Wraps 'lua_rawseti'. +rawseti :: LuaError e => StackIndex -> Lua.Integer -> LuaE e () +rawseti k m = ensureTable k (\l -> lua_rawseti l k m) +{-# INLINABLE rawseti #-} + +-- | Sets the C function @f@ as the new value of global @name@. +-- +-- Wraps 'lua_register'. +register :: LuaError e => Name -> CFunction -> LuaE e () +register name f = do + pushcfunction f + setglobal name +{-# INLINABLE register #-} + +-- | Removes the element at the given valid index, shifting down the +-- elements above this index to fill the gap. This function cannot be +-- called with a pseudo-index, because a pseudo-index is not an actual +-- stack position. +-- +-- Wraps 'lua_remove'. +remove :: StackIndex -> LuaE e () +remove n = liftLua $ \l -> lua_remove l n +{-# INLINABLE remove #-} + +-- | Moves the top element into the given valid index without shifting +-- any element (therefore replacing the value at that given index), and +-- then pops the top element. +-- +-- Wraps 'lua_replace'. +replace :: StackIndex -> LuaE e () +replace n = liftLua $ \l -> lua_replace l n +{-# INLINABLE replace #-} + +-- | Does the equivalent to @t[k] = v@, where @t@ is the value at the +-- given index and @v@ is the value at the top of the stack. +-- +-- This function pops the value from the stack. As in Lua, this function +-- may trigger a metamethod for the "newindex" event (see +-- of the Lua 5.3 +-- Reference Manual). +-- +-- Errors on the Lua side are caught and rethrown as a @'Exception'@. +-- +-- See also: +-- . +setfield :: LuaError e => StackIndex -> Name -> LuaE e () +setfield i (Name s) = do + absidx <- absindex i + pushstring s + insert (nthTop 2) + settable absidx +{-# INLINABLE setfield #-} + +-- | Pops a value from the stack and sets it as the new value of global +-- @name@. +-- +-- Errors on the Lua side are caught and rethrown as 'Exception'. +-- +-- Wraps 'hslua_setglobal'. See also: +-- . +setglobal :: LuaError e => Name {- ^ name -} -> LuaE e () +setglobal (Name name) = liftLuaThrow $ \l status' -> + B.unsafeUseAsCStringLen name $ \(namePtr, nameLen) -> + hslua_setglobal l namePtr (fromIntegral nameLen) status' +{-# INLINABLE setglobal #-} + +-- | Pops a table from the stack and sets it as the new metatable for +-- the value at the given index. +-- +-- Wraps 'lua_setmetatable'. +setmetatable :: StackIndex -> LuaE e () +setmetatable idx = liftLua $ \l -> lua_setmetatable l idx +{-# INLINABLE setmetatable #-} + +-- | Does the equivalent to @t[k] = v@, where @t@ is the value at the +-- given index, @v@ is the value at the top of the stack, and @k@ is the +-- value just below the top. +-- +-- This function pops both the key and the value from the stack. As in +-- Lua, this function may trigger a metamethod for the "newindex" event +-- (see of the Lua +-- 5.3 Reference Manual). +-- +-- Errors on the Lua side are caught and rethrown. +-- +-- Wraps 'hslua_settable'. +settable :: LuaError e => StackIndex -> LuaE e () +settable index = liftLuaThrow $ \l -> hslua_settable l index +{-# INLINABLE settable #-} + +-- | Accepts any index, or 0, and sets the stack top to this index. If +-- the new top is larger than the old one, then the new elements are +-- filled with nil. If index is 0, then all stack elements are removed. +-- +-- Wraps 'lua_settop'. +settop :: StackIndex -> LuaE e () +settop = liftLua1 lua_settop +{-# INLINABLE settop #-} + +-- | Pops a value from the stack and sets it as the new value associated +-- to the full userdata at the given index. +-- +-- +setuservalue :: StackIndex -> LuaE e () +setuservalue idx = liftLua (`lua_setuservalue` idx) + +-- | 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. +-- +-- 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). +-- +-- Wraps 'lua_status'. +status :: LuaE e Status +status = liftLua $ fmap toStatus . lua_status +{-# INLINABLE status #-} + +-- | Converts the Lua value at the given index to a haskell boolean +-- value. Like all tests in Lua, @toboolean@ returns @True@ for any Lua +-- value different from @false@ and @nil@; otherwise it returns @False@. +-- (If you want to accept only actual boolean values, use @'isboolean'@ +-- to test the value's type.) +-- +-- Wraps 'lua_toboolean'. +toboolean :: StackIndex -> LuaE e Bool +toboolean n = liftLua $ \l -> fromLuaBool <$!> lua_toboolean l n +{-# INLINABLE toboolean #-} + +-- | Converts a value at the given index to a C function. That value +-- must be a C function; otherwise, returns @Nothing@. +-- +-- Wraps 'lua_tocfunction'. +tocfunction :: StackIndex -> LuaE e (Maybe CFunction) +tocfunction n = liftLua $ \l -> do + fnPtr <- lua_tocfunction l n + return (if fnPtr == nullFunPtr then Nothing else Just fnPtr) +{-# INLINABLE tocfunction #-} + +-- | 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 convertible to an integer (see +-- of the Lua +-- 5.3 Reference Manual); otherwise, @tointeger@ returns @Nothing@. +-- +-- If the number is not an integer, it is truncated in some +-- non-specified way. +-- +-- Wraps 'lua_tointegerx'. See also: +-- . +tointeger :: StackIndex -> LuaE e (Maybe Lua.Integer) +tointeger n = liftLua $ \l -> alloca $ \boolPtr -> do + res <- lua_tointegerx l n boolPtr + isNum <- fromLuaBool <$!> F.peek boolPtr + return (if isNum then Just res else Nothing) +{-# INLINABLE tointeger #-} + +-- | Converts the Lua value at the given index to a 'Lua.Number'. The +-- Lua value must be a number or a string convertible to a number; +-- otherwise, @tonumber@ returns @'Nothing'@. +-- +-- Wraps 'lua_tonumberx'. See also +-- . +tonumber :: StackIndex -> LuaE e (Maybe Lua.Number) +tonumber n = liftLua $ \l -> alloca $ \bptr -> do + res <- lua_tonumberx l n bptr + isNum <- fromLuaBool <$!> F.peek bptr + return (if isNum then Just res else Nothing) +{-# INLINABLE tonumber #-} + +-- | Converts the value at the given index to a generic C pointer +-- (void*). The value can be a userdata, a table, a thread, or a +-- function; otherwise, lua_topointer returns @nullPtr@. Different +-- objects will give different pointers. There is no way to convert the +-- pointer back to its original value. +-- +-- Typically this function is used only for hashing and debug +-- information. +-- +-- Wraps 'lua_topointer'. +topointer :: StackIndex -> LuaE e (Ptr ()) +topointer n = liftLua $ \l -> lua_topointer l n +{-# INLINABLE topointer #-} + +-- | Converts the Lua value at the given index to a 'ByteString'. The +-- Lua value must be a string or a number; otherwise, the function +-- returns 'Nothing'. If the value is a number, then 'tostring' also +-- changes the actual value in the stack to a string. (This change +-- confuses 'next' when 'tostring' is applied to keys during a table +-- traversal.) +-- +-- Wraps 'lua_tolstring'. +tostring :: StackIndex -> LuaE e (Maybe ByteString) +tostring n = liftLua $ \l -> + alloca $ \lenPtr -> do + cstr <- lua_tolstring l n lenPtr + if cstr == nullPtr + then return Nothing + else do + cstrLen <- F.peek lenPtr + Just <$!> B.packCStringLen (cstr, fromIntegral cstrLen) +{-# INLINABLE tostring #-} + +-- | Converts the value at the given index to a Lua thread (represented +-- as 'Lua.State'). This value must be a thread; otherwise, the function +-- returns @Nothing@. +-- +-- Wraps 'lua_tothread'. +tothread :: StackIndex -> LuaE e (Maybe Lua.State) +tothread n = liftLua $ \l -> do + thread@(Lua.State ptr) <- lua_tothread l n + if ptr == nullPtr + then return Nothing + else return (Just thread) +{-# INLINABLE tothread #-} + +-- | If the value at the given index is a full userdata, returns its +-- block address. If the value is a light userdata, returns its pointer. +-- Otherwise, returns @Nothing@.. +-- +-- Wraps 'lua_touserdata'. +touserdata :: StackIndex -> LuaE e (Maybe (Ptr a)) +touserdata n = liftLua $ \l -> do + ptr <- lua_touserdata l n + if ptr == nullPtr + then return Nothing + else return (Just ptr) +{-# INLINABLE touserdata #-} + +-- | Returns the name of the type encoded by the value @tp@, which must +-- be one the values returned by @'ltype'@. +-- +-- Wraps 'lua_typename'. +typename :: Type -> LuaE e ByteString +typename tp = liftLua $ \l -> + lua_typename l (fromType tp) >>= B.packCString +{-# INLINABLE typename #-} + +-- | Returns the pseudo-index that represents the @i@-th upvalue of the +-- running function (see of the Lua 5.3 reference manual). +-- +-- See also: +-- . +upvalueindex :: StackIndex -> StackIndex +upvalueindex i = registryindex - i +{-# INLINABLE upvalueindex #-} diff --git a/src/HsLua/Core/Run.hs b/src/HsLua/Core/Run.hs --- a/src/HsLua/Core/Run.hs +++ b/src/HsLua/Core/Run.hs @@ -12,59 +12,28 @@ -} module HsLua.Core.Run ( run - , run' , runEither , runWith - , defaultErrorConversion ) where import Control.Exception (bracket, try) -import HsLua.Core.Types (Lua) +import HsLua.Core.Types (LuaE, runWith) import qualified Control.Monad.Catch as Catch import qualified HsLua.Core.Auxiliary as Lua -import qualified HsLua.Core.Error as Lua -import qualified HsLua.Core.Functions as Lua -import qualified HsLua.Core.Types as Lua -import qualified HsLua.Core.Utf8 as Utf8 +import qualified HsLua.Core.Primary as Lua -- | Run Lua computation using the default HsLua state as starting -- point. Exceptions are masked, thus avoiding some issues when using -- multiple threads. All exceptions are passed through; error handling -- is the responsibility of the caller. -run :: Lua a -> IO a +run :: LuaE e a -> IO a run = (Lua.newstate `bracket` Lua.close) . flip runWith . Catch.mask_ - --- | Run Lua computation using the default HsLua state as starting point. --- Conversion from Lua errors to Haskell exceptions can be controlled through --- @'Lua.ErrorConversion'@. -run' :: Lua.ErrorConversion -> Lua a -> IO a -run' ec = (Lua.newstate `bracket` Lua.close) . - flip (Lua.runWithConverter ec) . Catch.mask_ +{-# INLINABLE run #-} --- | Run the given Lua computation; exceptions raised in haskell code are --- caught, but other exceptions (user exceptions raised in haskell, unchecked +-- | Run the given Lua computation; exceptions raised in Haskell code are +-- caught, but other exceptions (user exceptions raised in Haskell, unchecked -- type errors, etc.) are passed through. -runEither :: Catch.Exception e => Lua a -> IO (Either e a) +runEither :: Catch.Exception e => LuaE e a -> IO (Either e a) runEither = try . run - --- | Run Lua computation with the given Lua state and the default --- error-to-exception converter. Exception handling is left to --- the caller. -runWith :: Lua.State -> Lua a -> IO a -runWith = Lua.runWithConverter defaultErrorConversion - --- | Conversions between Lua errors and Haskell exceptions; only deals with --- @'Lua.Exception'@s. -defaultErrorConversion :: Lua.ErrorConversion -defaultErrorConversion = Lua.ErrorConversion - { Lua.errorToException = Lua.throwTopMessageWithState - , Lua.addContextToException = Lua.withExceptionMessage . (++) - , Lua.alternative = \x y -> Lua.try x >>= \case - Left _ -> y - Right x' -> return x' - , Lua.exceptionToError = (`Lua.catchException` - \(Lua.Exception msg) -> do - Lua.pushstring $ Utf8.fromString msg - Lua.error) - } +{-# INLINABLE runEither #-} diff --git a/src/HsLua/Core/Types.hs b/src/HsLua/Core/Types.hs --- a/src/HsLua/Core/Types.hs +++ b/src/HsLua/Core/Types.hs @@ -1,6 +1,5 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} {-| Module : HsLua.Core.Types Copyright : © 2007–2012 Gracjan Polak; @@ -18,26 +17,25 @@ the future. -} module HsLua.Core.Types - ( Lua (..) + ( LuaE (..) , LuaEnvironment (..) - , ErrorConversion (..) - , errorConversion , State (..) , Reader , liftLua , liftLua1 , state - , runWithConverter + , runWith , unsafeRunWith - , unsafeErrorConversion - , GCCONTROL (..) - , toGCCode + , GCControl (..) + , toGCcode + , toGCdata , Type (..) - , TypeCode (..) , fromType , toType , liftIO , CFunction + , PreCFunction + , HaskellFunction , LuaBool (..) , fromLuaBool , toLuaBool @@ -51,7 +49,6 @@ , RelationalOperator (..) , fromRelationalOperator , Status (..) - , StatusCode (..) , toStatus -- * References , Reference (..) @@ -64,12 +61,17 @@ , nthBottom , nth , top + -- * Table field names + , Name (..) ) where import Prelude hiding (Integer, EQ, LT) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Reader (ReaderT (..), MonadReader, MonadIO, asks, liftIO) +import Data.ByteString (ByteString) +import Data.String (IsString (..)) +import Foreign.C (CInt) import Lua (nth, nthBottom, nthTop, top) import Lua.Constants import Lua.Types @@ -78,32 +80,20 @@ , fromReference , toReference ) - --- | Define the ways in which exceptions and errors are handled. -data ErrorConversion = ErrorConversion - { errorToException :: forall a . State -> IO a - -- ^ Translate Lua errors to Haskell exceptions - , addContextToException :: forall a . String -> Lua a -> Lua a - -- ^ Add information on the current context to an exception. - , alternative :: forall a . Lua a -> Lua a -> Lua a - -- ^ Runs the second computation only if the first fails; returns - -- the result of the first successful computation, if any. - , exceptionToError :: Lua NumResults -> Lua NumResults - -- ^ Translate Haskell exceptions to Lua errors - } +import qualified HsLua.Core.Utf8 as Utf8 +#if !MIN_VERSION_base(4,12,0) +import Data.Semigroup (Semigroup) +#endif -- | Environment in which Lua computations are evaluated. -data LuaEnvironment = LuaEnvironment - { luaEnvErrorConversion :: ErrorConversion - -- ^ Functions for error and exception handling and conversion - , luaEnvState :: State - -- ^ Lua interpreter state +newtype LuaEnvironment = LuaEnvironment + { luaEnvState :: State -- ^ Lua interpreter state } --- | A Lua computation. This is the base type used to run Lua programs of any --- kind. The Lua state is handled automatically, but can be retrieved via --- @'state'@. -newtype Lua a = Lua { unLua :: ReaderT LuaEnvironment IO a } +-- | A Lua computation. This is the base type used to run Lua programs +-- of any kind. The Lua state is handled automatically, but can be +-- retrieved via @'state'@. +newtype LuaE e a = Lua { unLua :: ReaderT LuaEnvironment IO a } deriving ( Applicative , Functor @@ -115,42 +105,36 @@ , MonadThrow ) --- | Turn a function of typ @Lua.State -> IO a@ into a monadic Lua operation. -liftLua :: (State -> IO a) -> Lua a +-- | Turn a function of typ @Lua.State -> IO a@ into a monadic Lua +-- operation. +liftLua :: (State -> IO a) -> LuaE e a liftLua f = state >>= liftIO . f +{-# INLINABLE liftLua #-} --- | Turn a function of typ @Lua.State -> a -> IO b@ into a monadic Lua operation. -liftLua1 :: (State -> a -> IO b) -> a -> Lua b +-- | Turn a function of typ @Lua.State -> a -> IO b@ into a monadic Lua +-- operation. +liftLua1 :: (State -> a -> IO b) -> a -> LuaE e b liftLua1 f x = liftLua $ \l -> f l x +{-# INLINABLE liftLua1 #-} -- | Get the Lua state of this Lua computation. -state :: Lua State +state :: LuaE e State state = asks luaEnvState - --- | Get the error-to-exception function. -errorConversion :: Lua ErrorConversion -errorConversion = asks luaEnvErrorConversion +{-# INLINABLE state #-} --- | Run Lua computation with the given Lua state and error-to-exception --- converter. Any resulting exceptions are left unhandled. -runWithConverter :: ErrorConversion -> State -> Lua a -> IO a -runWithConverter e2e l s = - runReaderT (unLua s) (LuaEnvironment e2e l) +-- | Run Lua computation with the given Lua state. Exception handling is +-- left to the caller; resulting exceptions are left unhandled. +runWith :: State -> LuaE e a -> IO a +runWith l s = runReaderT (unLua s) (LuaEnvironment l) +{-# INLINABLE runWith #-} -- | Run the given operation, but crash if any Haskell exceptions occur. -unsafeRunWith :: State -> Lua a -> IO a -unsafeRunWith = runWithConverter unsafeErrorConversion - --- | Unsafe @'ErrorConversion'@; no proper error handling is attempted, --- any error leads to a crash. -unsafeErrorConversion :: ErrorConversion -unsafeErrorConversion = ErrorConversion - { errorToException = const (error "An unrecoverable Lua error occured.") - , addContextToException = const id - , alternative = const - , exceptionToError = id - } +unsafeRunWith :: State -> LuaE e a -> IO a +unsafeRunWith = runWith +-- | Haskell function that can be called from Lua. +-- The HsLua equivallent of a 'PreCFunction'. +type HaskellFunction e = LuaE e NumResults -- -- Type of Lua values @@ -189,6 +173,7 @@ TypeFunction -> LUA_TFUNCTION TypeUserdata -> LUA_TUSERDATA TypeThread -> LUA_TTHREAD +{-# INLINABLE fromType #-} -- | Convert numerical code to Lua 'Type'. toType :: TypeCode -> Type @@ -204,6 +189,7 @@ LUA_TUSERDATA -> TypeUserdata LUA_TTHREAD -> TypeThread TypeCode c -> error ("No Type corresponding to " ++ show c) +{-# INLINABLE toType #-} -- @@ -275,31 +261,53 @@ -- Garbage collection -- --- | Enumeration used by @gc@ function. -data GCCONTROL - = GCSTOP - | GCRESTART - | GCCOLLECT - | GCCOUNT - | GCCOUNTB - | GCSTEP - | GCSETPAUSE - | GCSETSTEPMUL - | GCISRUNNING - deriving (Enum, Eq, Ord, Show) +-- | Commands to control the garbage collector. +data GCControl + = GCStop -- ^ stops the garbage collector. + | GCRestart -- ^ restarts the garbage collector + | GCCollect -- ^ performs a full garbage-collection cycle. + | GCCount -- ^ returns the current amount of memory (in + -- Kbytes) in use by Lua. + | GCCountb -- ^ returns the remainder of dividing the current + -- amount of bytes of memory in use by Lua by 1024. + | GCStep -- ^ performs an incremental step of garbage + -- collection. + | GCSetPause CInt -- ^ sets data as the new value for the pause of + -- the collector (see + -- of the Lua reference manual) and returns + -- the previous value of the pause. + | GCSetStepMul CInt -- ^ sets data as the new value for the step + -- multiplier of the collector (see + -- of the Lua reference manual) and returns + -- the previous value of the step multiplier. + | GCIsRunning -- ^ returns a boolean that tells whether the + -- collector is running (i.e., not stopped). + deriving (Eq, Ord, Show) -toGCCode :: GCCONTROL -> GCCode -toGCCode = \case - GCSTOP -> LUA_GCSTOP - GCRESTART -> LUA_GCRESTART - GCCOLLECT -> LUA_GCCOLLECT - GCCOUNT -> LUA_GCCOUNT - GCCOUNTB -> LUA_GCCOUNTB - GCSTEP -> LUA_GCSTEP - GCSETPAUSE -> LUA_GCSETPAUSE - GCSETSTEPMUL -> LUA_GCSETSTEPMUL - GCISRUNNING -> LUA_GCISRUNNING +-- | Converts a GCControl command to its corresponding code. +toGCcode :: GCControl -> GCCode +toGCcode = \case + GCStop -> LUA_GCSTOP + GCRestart -> LUA_GCRESTART + GCCollect -> LUA_GCCOLLECT + GCCount -> LUA_GCCOUNT + GCCountb -> LUA_GCCOUNTB + GCStep -> LUA_GCSTEP + GCSetPause {} -> LUA_GCSETPAUSE + GCSetStepMul {} -> LUA_GCSETSTEPMUL + GCIsRunning -> LUA_GCISRUNNING +{-# INLINABLE toGCcode #-} +-- | Returns the data value associated with a GCControl command. +toGCdata :: GCControl -> CInt +toGCdata = \case + GCSetPause p -> p + GCSetStepMul m -> m + _ -> 0 +{-# INLINABLE toGCdata #-} + -- -- Special values -- @@ -319,3 +327,20 @@ -- | Value signaling that no reference was found. noref :: Int noref = fromIntegral LUA_NOREF + +-- +-- Field names +-- + +-- | Name of a function, table field, or chunk; the name must be valid +-- UTF-8 and may not contain any nul characters. +-- +-- Implementation note: this is a @newtype@ instead of a simple @type +-- Name = ByteString@ alias so we can define a UTF-8 based 'IsString' +-- instance. Non-ASCII users would have a bad time otherwise. +newtype Name = Name { fromName :: ByteString } + deriving (Eq, Ord, Semigroup, Show) + +instance IsString Name where + fromString = Name . Utf8.fromString + {-# INLINABLE fromString #-} diff --git a/src/HsLua/Core/Unsafe.hs b/src/HsLua/Core/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Core/Unsafe.hs @@ -0,0 +1,30 @@ +{-# OPTIONS_GHC -Wno-warnings-deprecations #-} +{-| +Module : HsLua.Core.Unsafe +Copyright : © 2019-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel + +Unsafe Lua functions. + +This module exports functions which conflict with those in 'HsLua.Core'. +It is intended to be imported qualified. +-} +module HsLua.Core.Unsafe + ( next + ) +where + +import Control.Monad ((<$!>)) +import HsLua.Core.Types (LuaE, StackIndex, liftLua, fromLuaBool) +import Lua.Primary (lua_next) + +-- | Wrapper for 'lua_next'. +-- +-- __WARNING__: @lua_next@ is unsafe in Haskell: This function will +-- cause an unrecoverable crash an error if the given key is neither +-- @nil@ nor present in the table. Consider using the safe +-- @'HsLua.Core.Primary.next'@ function in HsLua.Core instead. +next :: StackIndex -> LuaE e Bool +next idx = liftLua $ \l -> fromLuaBool <$!> lua_next l idx +{-# INLINABLE next #-} diff --git a/src/HsLua/Core/Userdata.hs b/src/HsLua/Core/Userdata.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Core/Userdata.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE RankNTypes #-} +{-| +Module : HsLua.Core.Userdata +Copyright : © 2007–2012 Gracjan Polak; + © 2012–2016 Ömer Sinan Ağacan; + © 2017-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : non-portable (depends on GHC) + +Convenience functions to convert Haskell values into Lua userdata. +-} +module HsLua.Core.Userdata + ( newhsuserdata + , newudmetatable + , fromuserdata + , putuserdata + ) where + +import HsLua.Core.Types (LuaE, Name (..), StackIndex, liftLua, fromLuaBool) +import Lua.Userdata + ( hslua_fromuserdata + , hslua_newhsuserdata + , hslua_newudmetatable + , hslua_putuserdata + ) +import qualified Data.ByteString as B + +-- | Creates a new userdata wrapping the given Haskell object. The +-- userdata is pushed to the top of the stack. +newhsuserdata :: forall a e. a -> LuaE e () +newhsuserdata = liftLua . flip hslua_newhsuserdata +{-# INLINABLE newhsuserdata #-} + +-- | Creates and registers a new metatable for a userdata-wrapped +-- Haskell value; checks whether a metatable of that name has been +-- registered yet and uses the registered table if possible. +-- +-- Using a metatable created by this functions ensures that the pointer +-- to the Haskell value will be freed when the userdata object is +-- garbage collected in Lua. +-- +-- The name may not contain a nul character. +newudmetatable :: Name -> LuaE e Bool +newudmetatable (Name name) = liftLua $ \l -> + B.useAsCString name (fmap fromLuaBool . hslua_newudmetatable l) +{-# INLINABLE newudmetatable #-} + +-- | Retrieves a Haskell object from userdata at the given index. The +-- userdata /must/ have the given name. +fromuserdata :: forall a e. + StackIndex -- ^ stack index of userdata + -> Name -- ^ expected name of userdata object + -> LuaE e (Maybe a) +fromuserdata idx (Name name) = liftLua $ \l -> + B.useAsCString name (hslua_fromuserdata l idx) +{-# INLINABLE fromuserdata #-} + +-- | Replaces the Haskell value contained in the userdata value at +-- @index@. Checks that the userdata is of type @name@ and returns +-- 'True' on success, or 'False' otherwise. +putuserdata :: forall a e. + StackIndex -- ^ index + -> Name -- ^ name + -> a -- ^ new value + -> LuaE e Bool +putuserdata idx (Name name) x = liftLua $ \l -> + B.useAsCString name $ \namePtr -> + hslua_putuserdata l idx namePtr x +{-# INLINABLE putuserdata #-} diff --git a/test/HsLua/Core/AuxiliaryTests.hs b/test/HsLua/Core/AuxiliaryTests.hs --- a/test/HsLua/Core/AuxiliaryTests.hs +++ b/test/HsLua/Core/AuxiliaryTests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {-| Tests for the auxiliary library. -} module HsLua.Core.AuxiliaryTests (tests) where @@ -18,7 +19,7 @@ [ testGroup "getsubtable" [ "gets a subtable from field" =: [5, 8] `shouldBeResultOf` do - pushLuaExpr "{foo = {5, 8}}" + pushLuaExpr @Lua.Exception "{foo = {5, 8}}" _ <- Lua.getsubtable Lua.top "foo" Lua.rawgeti (nth 1) 1 Lua.rawgeti (nth 2) 2 @@ -34,11 +35,11 @@ Lua.ltype Lua.top , "returns True if a table exists" ?: do - pushLuaExpr "{yep = {}}" + pushLuaExpr @Lua.Exception "{yep = {}}" Lua.getsubtable Lua.top "yep" , "returns False if field does not contain a table" ?: do - pushLuaExpr "{nope = 5}" + pushLuaExpr @Lua.Exception "{nope = 5}" not <$> Lua.getsubtable Lua.top "nope" ] @@ -80,6 +81,26 @@ Lua.getmetatable' "yep" ] - , "loadedTable" =: ("_LOADED" @=? Lua.loadedTableRegistryField) - , "preloadTable" =: ("_PRELOAD" @=? Lua.preloadTableRegistryField) + , testGroup "where'" + [ "return location in chunk" =: + "test:1: nope, not yet" `shouldBeResultOf` do + Lua.openlibs + Lua.pushHaskellFunction $ 1 <$ do + Lua.settop 1 + Lua.where' 2 + Lua.pushstring "nope, " + Lua.pushvalue 1 + Lua.concat 3 + Lua.setglobal "frob" + Lua.OK <- Lua.loadbuffer + "return frob('not yet')" + "@test" + result <- Lua.pcall 0 1 Nothing + if result /= Lua.OK + then Lua.throwErrorAsException + else Lua.tostring' Lua.top + ] + + , "loaded" =: ("_LOADED" @=? Lua.loaded) + , "preload" =: ("_PRELOAD" @=? Lua.preload) ] diff --git a/test/HsLua/Core/ClosuresTests.hs b/test/HsLua/Core/ClosuresTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/Core/ClosuresTests.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-| +Module : HsLua.Core.ClosuresTests +Copyright : © 2017-2021 Albert Krewinkel +License : MIT + +Maintainer : Albert Krewinkel +Stability : stable +Portability : portable + +Test exposing Haskell functions to Lua. +-} +module HsLua.Core.ClosuresTests (tests) where + +import Control.Monad (forM_, void) +import Data.Maybe (fromMaybe) +import HsLua.Core as Lua +import Test.Tasty.HsLua ((=:), (?:), shouldBeResultOf) +import Test.Tasty (TestTree, testGroup) + +-- | Specifications for Attributes parsing functions. +tests :: TestTree +tests = testGroup "Closures" + [ "Haskell functions are callable from Lua" =: + Just (113 :: Lua.Integer) `shouldBeResultOf` do + -- add 23 + pushHaskellFunction $ do + i <- tointeger (nthBottom 1) + pushinteger (fromMaybe 0 i + 42) + return (NumResults 1) + pushinteger 71 + call 1 1 + tointeger top + + , "Haskell functions have the Lua type C function" ?: do + pushHaskellFunction (return 0 :: Lua NumResults) + iscfunction top + + -- The following test case will hang if there are issues with the way + -- functions are garbage collection. + , "function garbage collection" =: + () `shouldBeResultOf` do + let pushAndPopAdder n = do + let fn :: Lua NumResults + fn = do + x <- fromMaybe 0 <$> tointeger (nthBottom 1) + pushinteger (x + n) + return (NumResults 1) + pushHaskellFunction fn + pop 1 + forM_ [1..5000::Lua.Integer] pushAndPopAdder + void $ gc Lua.GCCollect + ] diff --git a/test/HsLua/Core/ErrorTests.hs b/test/HsLua/Core/ErrorTests.hs --- a/test/HsLua/Core/ErrorTests.hs +++ b/test/HsLua/Core/ErrorTests.hs @@ -1,25 +1,55 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {-| Tests for error handling. -} module HsLua.Core.ErrorTests (tests) where import Control.Applicative ((<|>), empty) +import Control.Exception +import Data.ByteString (ByteString) +import Data.Typeable (Typeable) import Data.Either (isLeft) -import HsLua.Core (Lua) -import Test.Tasty.HsLua ( (=:), shouldBeResultOf, shouldHoldForResultOf) +import HsLua.Core (Lua, failLua) +import HsLua.Core.Error (LuaError, changeErrorType, popErrorMessage) +import HsLua.Core.Types (liftLua) +import Test.Tasty.HsLua ( (=:), (?:), shouldBeResultOf, shouldHoldForResultOf) import Test.Tasty (TestTree, testGroup) import qualified HsLua.Core as Lua +import qualified HsLua.Core.Utf8 as Utf8 -- | Specifications for Attributes parsing functions. tests :: TestTree tests = testGroup "Error" [ "try catches errors" =: - isLeft `shouldHoldForResultOf` Lua.try (Lua.throwException "test" :: Lua ()) + isLeft `shouldHoldForResultOf` Lua.try + (failLua "test" :: Lua ()) - , "second alternative is used when first fails" =: - True `shouldBeResultOf` (Lua.throwException "test" <|> return True) + , "second alternative is used when first fails" ?: + ((failLua "test" :: Lua Bool) <|> return True) , "Applicative.empty implementation throws an exception" =: isLeft `shouldHoldForResultOf` Lua.try (empty :: Lua ()) + + , testGroup "changeErrorType" + [ "catches error as different type in argument operation" =: + Left (SampleException "message") `shouldBeResultOf` + changeErrorType (Lua.try @SampleException @() $ failLua "message") + + , "passes value through on success" =: + Just "plant" `shouldBeResultOf` do + Lua.pushstring "plant" + changeErrorType (Lua.tostring Lua.top) + ] ] + +newtype SampleException = SampleException ByteString + deriving (Eq, Typeable, Show) + +instance Exception SampleException + +instance LuaError SampleException where + popException = SampleException <$> liftLua popErrorMessage + pushException (SampleException msg) = Lua.pushstring msg + luaException = SampleException . Utf8.fromString diff --git a/test/HsLua/Core/RunTests.hs b/test/HsLua/Core/RunTests.hs --- a/test/HsLua/Core/RunTests.hs +++ b/test/HsLua/Core/RunTests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} {-| Module : HsLua.Core.RunTests @@ -24,13 +25,10 @@ [ testGroup "runEither" [ "Lua errors are caught" =: isLeft `shouldHoldForResultOf` - liftIO (runEither' (throwMessage "failing" :: Lua Bool)) + liftIO (runEither (failLua "failing" :: Lua Bool)) , "error-less code gives 'Right'" =: isRight `shouldHoldForResultOf` - liftIO (runEither' (pushboolean True *> toboolean top)) + liftIO (runEither @Lua.Exception (pushboolean True *> toboolean top)) ] ] - -runEither' :: Lua a -> IO (Either Lua.Exception a) -runEither' = runEither diff --git a/test/HsLua/Core/UnsafeTests.hs b/test/HsLua/Core/UnsafeTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/Core/UnsafeTests.hs @@ -0,0 +1,36 @@ +{-# OPTIONS_GHC -Wno-warnings-deprecations #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : HsLua.Core.UnsafeTests +Copyright : © 2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta + +Tests for bindings to unsafe functions. +-} +module HsLua.Core.UnsafeTests (tests) where + +import HsLua.Core +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HsLua ((=:), pushLuaExpr, shouldBeResultOf) +import qualified HsLua.Core.Unsafe as Unsafe + +-- | Tests for unsafe methods. +tests :: TestTree +tests = testGroup "Unsafe" + [ testGroup "next" + [ "get next key from table" =: + Just 43 `shouldBeResultOf` do + pushLuaExpr "{43}" + pushnil -- first key + True <- Unsafe.next (nth 2) + tonumber top + + , "returns FALSE if table is empty" =: + False `shouldBeResultOf` do + newtable + pushnil + Unsafe.next (nth 2) + ] + ] diff --git a/test/HsLua/Core/UserdataTests.hs b/test/HsLua/Core/UserdataTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/Core/UserdataTests.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : HsLua.Core.UserdataTests +Copyright : © 2017-2021 Albert Krewinkel +License : MIT + +Maintainer : Albert Krewinkel + +Tests that any data type can be pushed to Lua. +-} +module HsLua.Core.UserdataTests (tests) where + +import HsLua.Core (getfield, pushboolean, setmetatable, tostring) +import HsLua.Core.Userdata + (fromuserdata, newhsuserdata, newudmetatable, putuserdata) +import HsLua.Core.Types (nth, top) +import Test.Tasty.HsLua ((=:), shouldBeResultOf) +import Test.Tasty (TestTree, testGroup) + +-- | Specifications for Attributes parsing functions. +tests :: TestTree +tests = testGroup "Userdata" + [ "Name is kept in __name" =: + Just "Sample" `shouldBeResultOf` do + newudmetatable "Sample" + getfield top "__name" + tostring top + + , "get back pushed value" =: + Just (Sample 0 "zero") `shouldBeResultOf` do + newhsuserdata (Sample 0 "zero") + newudmetatable "Sample" + setmetatable (nth 2) + fromuserdata top "Sample" + + , "fail on boolean" =: + (Nothing :: Maybe Sample) `shouldBeResultOf` do + pushboolean False + fromuserdata top "Sample" + + , "fail on wrong userdata" =: + (Nothing :: Maybe Sample) `shouldBeResultOf` do + newhsuserdata (5 :: Integer) + newudmetatable "Integer" + setmetatable (nth 2) + fromuserdata top "Sample" + + , "change wrapped value" =: + Just (Sample 1 "a") `shouldBeResultOf` do + newhsuserdata (Sample 5 "five") + newudmetatable "Sample" + setmetatable (nth 2) + True <- putuserdata top "Sample" (Sample 1 "a") + fromuserdata top "Sample" + + , "change fails on wrong name" =: + Just (Sample 2 "b") `shouldBeResultOf` do + newhsuserdata (Sample 2 "b") + newudmetatable "Sample" + setmetatable (nth 2) + False <- putuserdata top "WRONG" (Sample 3 "c") + fromuserdata top "Sample" + ] + +-- | Sample data type. +data Sample = Sample Int String + deriving (Eq, Show) diff --git a/test/HsLua/CoreTests.hs b/test/HsLua/CoreTests.hs --- a/test/HsLua/CoreTests.hs +++ b/test/HsLua/CoreTests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} {-| Module : HsLua.CoreTests @@ -15,14 +16,14 @@ import Prelude hiding (compare) -import Control.Monad (forM_) import Data.ByteString (append) import Data.Maybe (fromMaybe) import Lua.Lib (luaopen_debug) import HsLua.Core as Lua +import HsLua.Core.Types (toType) import Lua.Arbitrary () import Test.Tasty.HsLua ( (?:), (=:), shouldBeErrorMessageOf, shouldBeResultOf - , shouldHoldForResultOf, pushLuaExpr ) + , shouldHoldForResultOf, pushLuaExpr ) import Test.QuickCheck (Property, (.&&.)) import Test.QuickCheck.Monadic (assert, monadicIO) import Test.Tasty (TestTree, testGroup) @@ -33,6 +34,9 @@ import qualified Data.ByteString as B import qualified HsLua.Core.AuxiliaryTests import qualified HsLua.Core.ErrorTests +import qualified HsLua.Core.RunTests +import qualified HsLua.Core.UnsafeTests +import qualified HsLua.Core.UserdataTests import qualified Foreign.Marshal as Foreign import qualified Foreign.Ptr as Foreign import qualified Test.QuickCheck.Monadic as QCMonadic @@ -45,33 +49,33 @@ , HsLua.Core.AuxiliaryTests.tests , testGroup "copy" [ "copies stack elements using positive indices" ?: do - pushLuaExpr "5, 4, 3, 2, 1" + pushLuaExpr @Lua.Exception "5, 4, 3, 2, 1" copy 4 3 rawequal (nthBottom 4) (nthBottom 3) , "copies stack elements using negative indices" ?: do - pushLuaExpr "5, 4, 3, 2, 1" + pushLuaExpr @Lua.Exception "5, 4, 3, 2, 1" copy (-1) (-3) rawequal (-1) (-3) ] , testGroup "insert" [ "inserts stack elements using positive indices" ?: do - pushLuaExpr "1, 2, 3, 4, 5, 6, 7, 8, 9" + pushLuaExpr @Lua.Exception "1, 2, 3, 4, 5, 6, 7, 8, 9" insert 4 movedEl <- tointeger (nthBottom 4) newTop <- tointeger (nth 1) return (movedEl == Just 9 && newTop == Just 8) , "inserts stack elements using negative indices" ?: do - pushLuaExpr "1, 2, 3, 4, 5, 6, 7, 8, 9" + pushLuaExpr @Lua.Exception "1, 2, 3, 4, 5, 6, 7, 8, 9" insert (-6) movedEl <- tointeger (nth 6) newTop <- tointeger (nth 1) return (movedEl == Just 9 && newTop == Just 8) ] - , testCase "absindex" . run $ do + , testCase "absindex" . run @Lua.Exception $ do pushLuaExpr "1, 2, 3, 4" liftIO . assertEqual "index from bottom doesn't change" (nthBottom 3) =<< absindex (nthBottom 3) @@ -82,27 +86,27 @@ , "gettable gets a table value" =: Just 13.37 `shouldBeResultOf` do - pushLuaExpr "{sum = 13.37}" + pushLuaExpr @Lua.Exception "{sum = 13.37}" pushstring "sum" gettable (nth 2) tonumber top , "rawlen gives the length of a list" =: 7 `shouldBeResultOf` do - pushLuaExpr "{1, 1, 2, 3, 5, 8, 13}" + pushLuaExpr @Lua.Exception "{1, 1, 2, 3, 5, 8, 13}" rawlen top , testGroup "Type checking" [ "isfunction" ?: do - pushLuaExpr "function () print \"hi!\" end" + pushLuaExpr @Lua.Exception "function () print \"hi!\" end" isfunction (-1) - , "isnil" ?: pushLuaExpr "nil" *> isnil (-1) + , "isnil" ?: pushLuaExpr @Lua.Exception "nil" *> isnil (-1) , "isnone" ?: isnone 5 -- stack index 5 does not exist , "isnoneornil" ?: do - pushLuaExpr "nil" + pushLuaExpr @Lua.Exception "nil" (&&) <$> isnoneornil 5 <*> isnoneornil (-1) ] @@ -116,41 +120,41 @@ [ testGroup "tointeger" [ "tointeger returns numbers verbatim" =: Just 149 `shouldBeResultOf` do - pushLuaExpr "149" + pushLuaExpr @Lua.Exception "149" tointeger (-1) , "tointeger accepts strings coercible to integers" =: Just 451 `shouldBeResultOf` do - pushLuaExpr "'451'" + pushLuaExpr @Lua.Exception "'451'" tointeger (-1) , "tointeger returns Nothing when given a boolean" =: Nothing `shouldBeResultOf` do - pushLuaExpr "true" + pushLuaExpr @Lua.Exception "true" tointeger (-1) ] , testGroup "tonumber" [ "tonumber returns numbers verbatim" =: Just 14.9 `shouldBeResultOf` do - pushLuaExpr "14.9" + pushLuaExpr @Lua.Exception "14.9" tonumber (-1) , "tonumber accepts strings as numbers" =: Just 42.23 `shouldBeResultOf` do - pushLuaExpr "'42.23'" + pushLuaExpr @Lua.Exception "'42.23'" tonumber (-1) , "tonumber returns Nothing when given a boolean" =: Nothing `shouldBeResultOf` do - pushLuaExpr "true" + pushLuaExpr @Lua.Exception "true" tonumber (-1) ] , testGroup "tostring" [ "get a string" =: Just "a string" `shouldBeResultOf` do - pushLuaExpr "'a string'" + pushLuaExpr @Lua.Exception "'a string'" tostring top , "get a number as string" =: @@ -167,7 +171,7 @@ , "setting and getting a global works" =: Just "Moin" `shouldBeResultOf` do - pushLuaExpr "{'Moin', Hello = 'World'}" + pushLuaExpr @Lua.Exception "{'Moin', Hello = 'World'}" setglobal "hamburg" -- get first field @@ -178,11 +182,21 @@ , testGroup "get functions (Lua to stack)" [ "unicode characters in field name are ok" =: True `shouldBeResultOf` do - pushLuaExpr "{['\xE2\x9A\x94'] = true}" + pushLuaExpr @Lua.Exception "{['\xE2\x9A\x94'] = true}" getfield top "⚔" toboolean top ] + , "setting and getting a global works" =: + Just "Fisch" `shouldBeResultOf` do + newhsuserdata () + pushstring "Fisch" + setuservalue (nth 2) + + -- get uservalue again + TypeString <- getuservalue top + tostring top + , "can push and receive a thread" ?: do luaSt <- state isMain <- pushthread @@ -208,7 +222,7 @@ openlibs getglobal "coroutine" getfield top "resume" - pushLuaExpr "coroutine.create(function() coroutine.yield(9) end)" + pushLuaExpr @Lua.Exception "coroutine.create(function() coroutine.yield(9) end)" contThread <- fromMaybe (Prelude.error "not a thread at top of stack") <$> tothread top call 1 0 @@ -375,14 +389,15 @@ , "raising an error in the error handler should give a 'double error'" =: ErrErr `shouldBeResultOf` do - pushLuaExpr "function () error 'error in error handler' end" + pushLuaExpr @Lua.Exception "function () error 'error in error handler' end" _ <- loadstring "error \"this fails\"" pcall 0 0 (Just (nth 2)) ] , testCase "garbage collection" . run $ - -- test that gc can be called with all constructors of type GCCONTROL. - forM_ [GCSTOP .. GCSETSTEPMUL] $ \what -> gc what 23 + -- test that gc can be called with all constructors of type GCControl. + mapM_ gc [ GCStop, GCRestart, GCCollect, GCCollect, GCCountb + , GCStep, GCSetPause 23, GCSetStepMul 5, GCIsRunning ] , testGroup "compare" [ testProperty "identifies strictly smaller values" $ compareWith (<) Lua.LT @@ -391,7 +406,7 @@ ] , testProperty "lessthan works" $ \n1 n2 -> monadicIO $ do - luaCmp <- QCMonadic.run . run $ do + luaCmp <- QCMonadic.run . run @Lua.Exception $ do pushnumber n2 pushnumber n1 lessthan (-1) (-2) <* pop 2 @@ -425,8 +440,12 @@ _ <- try $ loadstring err *> call 0 0 newtop <- gettop return (newtop - oldtop) - res <- run luaOp + res <- run @Lua.Exception luaOp assertEqual "error handling leaks values to the stack" 0 res + + , HsLua.Core.RunTests.tests + , HsLua.Core.UnsafeTests.tests + , HsLua.Core.UserdataTests.tests ] compareWith :: (Lua.Integer -> Lua.Integer -> Bool) @@ -438,7 +457,7 @@ luaCmp <- QCMonadic.run . run $ do pushinteger $ n - 1 pushinteger n - compare (-2) (-1) luaOp + compare @Lua.Exception (-2) (-1) luaOp assert $ luaCmp == op (n - 1) n compareEQ :: Property @@ -446,7 +465,7 @@ luaCmp <- QCMonadic.run . run $ do pushinteger n pushinteger n - compare (-2) (-1) luaOp + compare @Lua.Exception (-2) (-1) luaOp assert $ luaCmp == op n n compareGT :: Property @@ -454,5 +473,5 @@ luaRes <- QCMonadic.run . run $ do pushinteger $ n + 1 pushinteger n - compare (-2) (-1) luaOp + compare @Lua.Exception (-2) (-1) luaOp assert $ luaRes == op (n + 1) n diff --git a/test/Test/Tasty/HsLua.hs b/test/Test/Tasty/HsLua.hs --- a/test/Test/Tasty/HsLua.hs +++ b/test/Test/Tasty/HsLua.hs @@ -20,7 +20,8 @@ ) where import Data.ByteString (ByteString, append) -import HsLua.Core (Lua, run, runEither, loadstring, call, multret) +import HsLua.Core + (Lua, LuaE, LuaError, run, runEither, loadstring, call, multret) import Test.Tasty (TestTree) import Test.Tasty.HUnit (Assertion, HasCallStack, assertBool, assertFailure, testCase, (@?=)) @@ -34,12 +35,13 @@ -- > run $ do -- > pushLuaExpr "7 + 5" -- > tointeger top -pushLuaExpr :: ByteString -> Lua () +pushLuaExpr :: LuaError e => ByteString -> LuaE e () pushLuaExpr expr = loadstring ("return " `append` expr) *> call 0 multret -- | Takes a value and a 'Lua' operation and turns them into an -- 'Assertion' which checks that the operation produces the given value. -shouldBeResultOf :: (HasCallStack, Eq a, Show a) => a -> Lua a -> Assertion +shouldBeResultOf :: (HasCallStack, Eq a, Show a) + => a -> Lua a -> Assertion shouldBeResultOf expected luaOp = do errOrRes <- runEither luaOp case errOrRes of @@ -72,12 +74,12 @@ (predicate res) -- | Checks whether the operation returns 'True'. -assertLuaBool :: HasCallStack => Lua Bool -> Assertion +assertLuaBool :: HasCallStack => LuaE e Bool -> Assertion assertLuaBool luaOp = assertBool "" =<< run luaOp -- | Creates a new test case with the given name, checking whether the -- operation returns 'True'. -luaTestBool :: HasCallStack => String -> Lua Bool -> TestTree +luaTestBool :: HasCallStack => String -> LuaE e Bool -> TestTree luaTestBool msg luaOp = testCase msg $ assertBool "Lua operation returned false" =<< run luaOp @@ -87,6 +89,6 @@ infix 3 =: -- | Infix alias for 'luaTestBool'. -(?:) :: HasCallStack => String -> Lua Bool -> TestTree +(?:) :: HasCallStack => String -> LuaE e Bool -> TestTree (?:) = luaTestBool infixr 3 ?: