hslua-core-2.3.2/0000755000000000000000000000000007346545000011751 5ustar0000000000000000hslua-core-2.3.2/CHANGELOG.md0000644000000000000000000001311607346545000013564 0ustar0000000000000000# Changelog `hslua-core` uses [PVP Versioning][]. ## hslua-core-2.3.2 Released 2024-01-18. - Relaxed upper bound for text, and bytestring, allowing text-2.1, and bytestring-0.12. ## hslua-core-2.3.1 Released 2023-03-17. - New module *HsLua.Core.Debug*: the module provides bindings to a subset of functions of the Lua debug interface. Currently the module only exports `getupvalue` and `setupvalue`, both of which are also re-exported from *HsLua.Core*. ## hslua-core-2.3.0 Released 2023-03-13. - The functions `loadfile`, `dofile`, and `dofileTrace` now expect the argument to be of type `Maybe FilePath`. The functions load from *stdin* when the argument is `Nothing`. - Added `setwarnf'` for simple warning messgae handling: The built-in method of setting a warn function is flexible but not straight-forward to use. The new `setwarnf'` function allows to set a Haskell action as a warning hook: the default warning behavior is kept in place, but, in addition to the default action, the hook is called on the concatenated warning messages. This can be used to plug Lua warnings into an application specific Haskell reporting system. - Export `GCManagedState`, `newGCManagedState`, `closeGCManagedState`, and `withGCManagedState` from `HsLua.Core`. ## hslua-core-2.2.1 Released 2022-06-19. - Ensure that loadfile works with umlauts in filepath: The OS does not necessarily expect filenames to be UTF-8 encoded, especially Windows. On non-Windows systems, the current file system encoding is now used to convert filenames to C strings. On Windows, the `CP_ACP` codepage is used, as required by the Windows API. - GC managed Lua state: Add new type `GCManagedState` and functions `newGCManagedState`, `closeGCManagedState`, and `withGCManagedState`. These allow to create and use a Lua state in flexible ways in that it does not require the state to be closed explicitly. The state will be closed when the respective variable is collected. - Require lua-2.2.1. - Relax upper bound for mtl, allow mtl-2.3. ## hslua-core-2.2.0 Released 2022-02-19. - Use lua-2.2.0, which requires Lua 5.4. - Rename `newuserdata` to `newuserdatauv` and let it take the number of associated uservalues as an additional argument. Similarly, `newhsuserdata` is now `newhsuserdatauv`. - Rename `getuservalue` and `setuservalue` to `getiuservalue` and `setiuservalue`, respectively. Like both functions now take an extra argument specifying the number of the uservalue that should be retrieved or set. It is now possible for `setiuservalue` to fail, so it returns a boolean to indicate whether the action was successful. - The `GCControl` type has been updated to match the new gc control: - The GCStep constructor takes an argument "stepsize"; - constructors GCGen and GCInc have been added; - constructors GCSetPause and GCSetStepMul have been removed. ## hslua-core-2.1.0 Released 29-01-2022. - The functions `rawget`, `rawgeti`, and `getref` now return the type of the value that was pushed to the stack. - A new function `checkstack'` is added to HsLua.Core.Auxiliary and exported from the main HsLua.Core module. The function throws an exception if the stack cannot be grown to accommodate a given number of elements; it is similar to `luaL_checkstack`. - Added function `requiref`, which safely wraps the unsafe `luaL_requiref` function. - New functions `pcallTrace`, `callTrace`, `dostringTrace`, and `dofileTrace`: behaves like the respective unsuffixed functions, but use a message handler that creates a stack traceback on error. - Added function `rotate`, wrapping `lua_rotate`. - Package helper `requirehs` signature changed to ``` haskell requirehs :: LuaError e => Name -- ^ modname -> (Name -> LuaE e ()) -- ^ openf -> LuaE e () ``` The function creating and pushing the module value now takes the module name as an argument. It also behaves more like `luaL_requiref` in that it reloads the module if the value in the LOADED table is falsy. ## hslua-core-2.0.0.2 Released 2021-11-03. - Fixed output of `pushTypeMismatchError` when there is no value at the given index. Previously the function would report the value as type `string` and now reports it as `no value`. ## hslua-core-2.0.0.1 Released 2021-10-29. - Fixed bug in pushTypeMismatchError. The function did not use an absolute stack index in one place, which sometimes lead to incorrect actual types being reported. ## hslua-core-2.0.0 Released 2021-10-21. - 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. Extracted from hslua-1.3.0. [PVP Versioning]: https://pvp.haskell.org hslua-core-2.3.2/LICENSE0000644000000000000000000000224107346545000012755 0ustar0000000000000000Copyright © 1994-2022 Lua.org, PUC-Rio. Copyright © 2007-2012 Gracjan Polak Copyright © 2012-2015 Ömer Sinan Ağacan Copyright © 2016-2024 Albert Krewinkel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. hslua-core-2.3.2/README.md0000644000000000000000000000656407346545000013243 0ustar0000000000000000hslua-core ========== [![Build status][]][1] [![AppVeyor Status][]][2] [![Hackage][]][3] Basic building blocks to interface Haskell and Lua in a Haskell-idiomatic style. [Build status]: https://img.shields.io/github/workflow/status/hslua/hslua/CI.svg?logo=github [1]: https://github.com/hslua/hslua/actions [AppVeyor Status]: https://ci.appveyor.com/api/projects/status/ldutrilgxhpcau94/branch/main?svg=true [2]: https://ci.appveyor.com/project/tarleb/hslua-r2y18 [Hackage]: https://img.shields.io/hackage/v/hslua-core.svg [3]: https://hackage.haskell.org/package/hslua-core Overview -------- [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][]. [Lua]: https://lua.org/ [HsLua]: https://hslua.org/ Interacting with Lua -------------------- HsLua core provides the `Lua` type to define Lua operations. The operations are executed by calling `run`. A simple “Hello, World” program, using the Lua `print` function, is given below: ``` haskell import HsLua.Core.Lua as Lua main :: IO () main = Lua.run prog where prog :: Lua () prog = do Lua.openlibs -- load Lua libraries so we can use 'print' Lua.getglobal "print" -- push print function Lua.pushstring "Hello, World!" -- push string argument Lua.call (NumArgs 1) -- number of arguments passed to the function (NumResults 0) -- number of results expected -- as return values ``` ### The Lua stack Lua’s API is stack-centered: most operations involve pushing values to the stack or receiving items from the stack. E.g., calling a function is performed by pushing the function onto the stack, followed by the function arguments in the order they should be passed to the function. The API function `call` then invokes the function with given numbers of arguments, pops the function and parameters off the stack, and pushes the results. ,----------. | arg 3 | +----------+ | arg 2 | +----------+ | arg 1 | +----------+ ,----------. | function | call 3 1 | result 1 | +----------+ ===========> +----------+ | | | | | stack | | stack | | | | | This package provides all basic building blocks to interact with the Lua stack. If you’d like more comfort, please consider using 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. hslua-core-2.3.2/hslua-core.cabal0000644000000000000000000001062307346545000015001 0ustar0000000000000000cabal-version: 2.2 name: hslua-core version: 2.3.2 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.org/ bug-reports: https://github.com/hslua/hslua/issues license: MIT license-file: LICENSE author: Albert Krewinkel, Gracjan Polak, Ömer Sinan Ağacan maintainer: tarleb@hslua.org copyright: © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2024 Albert Krewinkel category: Foreign build-type: Simple extra-source-files: README.md , CHANGELOG.md , test/lua/*.lua tested-with: GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.8 , GHC == 9.6.3 , GHC == 9.8.1 source-repository head type: git location: https://github.com/hslua/hslua.git common common-options default-language: Haskell2010 build-depends: base >= 4.11 && < 5 , bytestring >= 0.10.2 && < 0.13 , exceptions >= 0.8 && < 0.11 , lua >= 2.3.1 && < 2.4 , mtl >= 2.2 && < 2.4 , text >= 1.2 && < 2.2 ghc-options: -Wall -Wincomplete-record-updates -Wnoncanonical-monad-instances -Wredundant-constraints if impl(ghc >= 8.2) ghc-options: -Wcpp-undef -Werror=missing-home-modules if impl(ghc >= 8.4) ghc-options: -Widentities -Wincomplete-uni-patterns -Wpartial-fields -fhide-source-paths library import: common-options exposed-modules: HsLua.Core , HsLua.Core.Closures , HsLua.Core.Debug , HsLua.Core.Error , HsLua.Core.Package , HsLua.Core.Run , HsLua.Core.Trace , HsLua.Core.Types , HsLua.Core.Unsafe , HsLua.Core.Userdata , HsLua.Core.Utf8 other-modules: HsLua.Core.Auxiliary , HsLua.Core.Primary , HsLua.Core.Warn reexported-modules: lua:Lua hs-source-dirs: src default-extensions: LambdaCase , StrictData other-extensions: CPP , DeriveDataTypeable , GeneralizedNewtypeDeriving , OverloadedStrings , ScopedTypeVariables , TypeApplications test-suite test-hslua-core import: common-options type: exitcode-stdio-1.0 main-is: test-hslua-core.hs hs-source-dirs: test ghc-options: -threaded -Wno-unused-do-bind other-modules: HsLua.CoreTests , HsLua.Core.AuxiliaryTests , HsLua.Core.ClosuresTests , HsLua.Core.DebugTests , HsLua.Core.ErrorTests , HsLua.Core.PackageTests , HsLua.Core.PrimaryTests , HsLua.Core.RunTests , HsLua.Core.TraceTests , HsLua.Core.UnsafeTests , HsLua.Core.UserdataTests , HsLua.Core.WarnTests , Test.Tasty.HsLua , Test.HsLua.Arbitrary build-depends: hslua-core , lua-arbitrary >= 1.0 , QuickCheck >= 2.7 , quickcheck-instances >= 0.3 , tasty >= 0.11 , tasty-hunit >= 0.9 , tasty-quickcheck >= 0.8 hslua-core-2.3.2/src/HsLua/0000755000000000000000000000000007346545000013554 5ustar0000000000000000hslua-core-2.3.2/src/HsLua/Core.hs0000644000000000000000000001057407346545000015007 0ustar0000000000000000{-| Module : HsLua.Core Copyright : © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : beta Portability : non-portable (depends on GHC) Core Lua API. This module provides thin wrappers around the respective functions of the Lua C API. C functions which can throw an error are wrapped such that the error is converted into an @'Exception'@. However, memory allocation errors are not caught and will cause the host program to terminate. -} module HsLua.Core ( -- * Run Lua computations run , runWith , runEither , GCManagedState , newGCManagedState , closeGCManagedState , withGCManagedState -- * Lua Computations , LuaE (..) , Lua , unsafeRunWith , liftIO , state , LuaEnvironment (..) -- * Lua API types , CFunction , PreCFunction , Lua.Integer (..) , Lua.Number (..) -- ** Stack index , StackIndex (..) , nthTop , nthBottom , nth , top -- ** Number of arguments and return values , NumArgs (..) , NumResults (..) -- ** Table fields , Name (..) -- * Lua API -- ** Constants and pseudo-indices , multret , registryindex , upvalueindex -- ** State manipulation , Lua.State (..) , newstate , close -- ** Basic stack manipulation , absindex , gettop , settop , pushvalue , copy , insert , rotate , pop , remove , replace , checkstack -- ** types and type checks , Type (..) , ltype , typename , isboolean , iscfunction , isfunction , isinteger , islightuserdata , isnil , isnone , isnoneornil , isnumber , isstring , istable , isthread , isuserdata -- ** access functions (stack → Haskell) , toboolean , tocfunction , tointeger , tonumber , topointer , tostring , tothread , touserdata , rawlen -- ** Comparison and arithmetic functions , RelationalOperator (..) , compare , equal , lessthan , rawequal -- ** push functions (Haskell → stack) , pushboolean , pushcfunction , pushcclosure , pushinteger , pushlightuserdata , pushnil , pushnumber , pushstring , pushthread -- ** get functions (Lua → stack) , getglobal , gettable , getfield , rawget , rawgeti , createtable , newtable , newuserdatauv , getmetatable , getiuservalue -- ** set functions (stack → Lua) , setglobal , settable , setfield , rawset , rawseti , setmetatable , setiuservalue -- ** load and call functions (load and run Lua code) , call , pcall , load , loadbuffer , loadfile , loadstring -- ** Coroutine functions , Status (..) , status -- ** garbage-collection function and options , GCControl (..) , gc -- ** miscellaneous and helper functions , next , error , concat , pushglobaltable , register , setwarnf -- * loading libraries , openbase , opendebug , openio , openlibs , openmath , openpackage , openos , openstring , opentable -- * Auxiliary library , checkstack' , dostring , dofile , getmetafield , getmetatable' , getsubtable , newmetatable , requiref , tostring' , traceback , where' -- ** References , Reference (..) , ref , getref , unref , fromReference , toReference , noref , refnil -- ** Registry fields , loaded , preload -- ** Running with tracebacks , pcallTrace , callTrace , dofileTrace , dostringTrace -- ** Warnings , setwarnf' -- * Debug interface , getupvalue , setupvalue -- * Haskell userdata values -- -- | Push arbitrary Haskell values to the Lua stack. , newhsuserdatauv , newudmetatable , fromuserdata , putuserdata -- ** Haskell functions and closures , HaskellFunction , pushHaskellFunction , pushPreCFunction -- * Error handling , LuaError (..) , Exception (..) , try , failLua , throwErrorAsException , 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.Debug import HsLua.Core.Error import HsLua.Core.Package import HsLua.Core.Primary import HsLua.Core.Run import HsLua.Core.Trace import HsLua.Core.Types as Lua import HsLua.Core.Userdata import HsLua.Core.Warn hslua-core-2.3.2/src/HsLua/Core/0000755000000000000000000000000007346545000014444 5ustar0000000000000000hslua-core-2.3.2/src/HsLua/Core/Auxiliary.hs0000644000000000000000000003017707346545000016757 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-| Module : HsLua.Core.Auxiliary Copyright : © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : beta Portability : non-portable (depends on GHC) Wrappers for the auxiliary library. -} module HsLua.Core.Auxiliary ( -- * The Auxiliary Library checkstack' , dostring , dofile , getmetafield , getmetatable' , getsubtable , loadbuffer , loadfile , loadstring , newmetatable , newstate , requiref , tostring' , traceback , where' -- ** References , getref , ref , unref -- ** Registry fields , loaded , preload ) where import Control.Monad ((<$!>)) import Data.ByteString (ByteString) import Data.String (IsString (fromString)) import HsLua.Core.Error import HsLua.Core.Types (LuaE, Name (Name), Status, StackIndex, liftLua, multret, runWith) import Lua (top) import Lua.Auxiliary import Lua.Ersatz.Auxiliary import Foreign.Marshal.Alloc (alloca) import Foreign.Ptr import qualified Data.ByteString as B import qualified GHC.Foreign as GHC import qualified GHC.IO.Encoding as GHC import qualified HsLua.Core.Primary as Lua import qualified HsLua.Core.Types as Lua import qualified Foreign.Storable as Storable -- | Grows the stack size to @top + sz@ elements, raising an error if -- the stack cannot grow to that size. @msg@ is an additional text to go -- into the error message (or the empty string for no additional text). checkstack' :: LuaError e => Int -- ^ sz (requested additional size) -> String -- ^ msg -> LuaE e () checkstack' sz msg = Lua.checkstack sz >>= \case True -> pure () False -> failLua $ if msg == "" then "stack overflow" else "stack overflow (" ++ msg ++ ")" -- | 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 -> LuaE e Status dostring s = loadstring s >>= \case Lua.OK -> Lua.pcall 0 multret Nothing err -> return err {-# INLINABLE dostring #-} -- | Loads and runs the given file. Note that the filepath is -- interpreted by Lua, not Haskell. The resulting chunk is named using -- the UTF8 encoded filepath. dofile :: Maybe FilePath -> LuaE e Status dofile mfp = loadfile mfp >>= \case Lua.OK -> Lua.pcall 0 multret Nothing err -> return err {-# 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 'Lua.TypeNil'. -- -- Wraps 'luaL_getmetafield'. getmetafield :: StackIndex -- ^ 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. -- -- 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 :: LuaError e => StackIndex -> Reference -> LuaE e Lua.Type 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 :: 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 namestr Lua.gettable idx' >>= \case Lua.TypeTable -> return True _ -> do Lua.pop 1 Lua.newtable Lua.pushvalue top -- copy to be left at top Lua.setfield idx' fname return False {-# INLINABLE getsubtable #-} -- | Loads a ByteString as a Lua chunk. -- -- This function returns the same results as @'Lua.load'@. @name@ is the -- chunk name, used for debug information and error messages. Note that -- @name@ is used as a C string, so it may not contain null-bytes. -- -- Wraps 'luaL_loadbuffer'. loadbuffer :: ByteString -- ^ Program to load -> Name -- ^ chunk name -> LuaE e Status loadbuffer bs (Name name) = liftLua $ \l -> B.useAsCStringLen bs $ \(str, 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@. If -- filename is @Nothing@, then it loads from the standard input. The -- first line in the file is ignored if it starts with a @#@. -- -- The string mode works as in function @'Lua.load'@. -- -- This function returns the same results as @'Lua.load'@, but it has an -- extra error code @'Lua.ErrFile'@ for file-related errors (e.g., it -- cannot open or read the file). -- -- As @'Lua.load'@, this function only loads the chunk; it does not run -- it. -- -- See . loadfile :: Maybe FilePath -- ^ filename -> LuaE e Status loadfile mfp = liftLua $ \l -> do #if defined(mingw32_HOST_OS) fsEncoding <- GHC.mkTextEncoding "CP0" -- a.k.a CP_ACP #else fsEncoding <- GHC.getFileSystemEncoding #endif case mfp of Just fp -> GHC.withCString fsEncoding fp $! fmap Lua.toStatus . luaL_loadfile l Nothing -> Lua.toStatus <$!> luaL_loadfile l nullPtr {-# 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 -- contain any NUL characters. -- -- This function returns the same results as @lua_load@ (see -- @'Lua.load'@). -- -- Also as @'Lua.load'@, this function only loads the chunk; it does not -- run it. -- -- 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.) -- -- 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. -- -- 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 -- function (see -- of the Lua 5.4 Reference Manual) that prints an error message to the -- standard error output in case of fatal errors. -- -- 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). -- -- 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'@. -- -- Wraps 'luaL_ref'. ref :: StackIndex -> LuaE e Reference ref t = liftLua $ \l -> Lua.toReference <$> luaL_ref l t {-# INLINABLE ref #-} -- | If @modname@ is not already present in @package.loaded@. calls -- function @openf@ with string @modname@ as an argument and sets the -- call result in @package.loaded[modname]@, as if that function has -- been called through -- . -- -- If @glb@ is true, also stores the module into global @modname@. -- -- Leaves a copy of the module on the stack. -- -- See 'requirehs' for a version intended to be used with Haskell -- actions. requiref :: LuaError e => Name -- ^ modname -> Lua.CFunction -- ^ openf -> Bool -- ^ glb -> LuaE e () requiref (Name name) openf glb = liftLuaThrow $ \l status' -> B.useAsCString name $ \namePtr -> hsluaL_requiref l namePtr openf (Lua.toLuaBool glb) status' -- | 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. -- -- Wraps 'hsluaL_tolstring'. tostring' :: forall e. LuaError e => StackIndex -> LuaE e B.ByteString tostring' n = do l <- Lua.state Lua.liftIO $ alloca $ \lenPtr -> do cstr <- hsluaL_tolstring l n lenPtr if cstr == nullPtr 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 is 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' -> 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. -- -- Wraps 'luaL_unref'. See also: -- . unref :: StackIndex -- ^ idx -> Reference -- ^ ref -> 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 hslua-core-2.3.2/src/HsLua/Core/Closures.hs0000644000000000000000000000404307346545000016600 0ustar0000000000000000{-| Module : HsLua.Core.Closures Copyright : © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2024 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.Types.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 -- 'Lua.Types.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 #-} hslua-core-2.3.2/src/HsLua/Core/Debug.hs0000644000000000000000000000366007346545000016033 0ustar0000000000000000{-| Module : HsLua.Core.Debug Copyright : © 2023-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Bindings to Lua's debug interface. -} module HsLua.Core.Debug ( getupvalue , setupvalue ) where import Control.Monad ((<$!>)) import Foreign.C (CString) import Foreign.Ptr (nullPtr) import HsLua.Core.Types (LuaE, Name (Name), StackIndex, liftLua) import Lua.Debug (lua_getupvalue, lua_setupvalue) import qualified Data.ByteString as B -- | Gets information about the @n@-th upvalue of the closure at index -- @funcindex@. It pushes the upvalue's value onto the stack and returns -- its name. Returns 'Nothing' (and pushes nothing) when the index @n@ -- is greater than the number of upvalues. -- -- See -- -- for more information about upvalues. -- -- @[0, +(0|1), -]@ -- -- Wraps 'lua_getupvalue'. getupvalue :: StackIndex -- ^ funcindex -> Int -- ^ n -> LuaE e (Maybe Name) getupvalue idx n = liftLua $ \l -> lua_getupvalue l idx (fromIntegral n) >>= toMaybeName -- | Sets the value of a closure’s upvalue. It assigns the value on the -- top of the stack to the upvalue and returns its name. It also pops -- the value from the stack. -- -- Returns 'Nothing' (and pops nothing) when the index @n@ is greater -- than the number of upvalues. -- -- Parameters @funcindex@ and @n@ are as in the function 'getupvalue'. -- -- @[-(0|1), +0, -]@ -- -- Wraps 'lua_setupvalue'. setupvalue :: StackIndex -- ^ funcindex -> Int -- ^ n -> LuaE e (Maybe Name) setupvalue idx n = liftLua $ \l -> lua_setupvalue l idx (fromIntegral n) >>= toMaybeName -- | Convert a (possibly @NULL@) null-terminated C string to a name. toMaybeName :: CString -> IO (Maybe Name) toMaybeName cstr = if cstr == nullPtr then return Nothing else Just . Name <$!> B.packCString cstr hslua-core-2.3.2/src/HsLua/Core/Error.hs0000644000000000000000000001612707346545000016100 0ustar0000000000000000{-# 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-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Lua exceptions and exception handling. -} module HsLua.Core.Error ( Exception (..) , LuaError (..) , Lua , try , failLua , throwErrorAsException , throwTypeMismatchError , changeErrorType -- * Helpers for hslua C wrapper functions. , 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 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 import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Unsafe as B import qualified Foreign.Storable as Storable import qualified HsLua.Core.Types as Lua import qualified HsLua.Core.Utf8 as Utf8 #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) instance Show Exception where show (Exception msg) = "Lua exception: " ++ msg instance E.Exception Exception instance LuaError Exception where popException = do Exception . Utf8.toString <$!> liftLua popErrorMessage {-# INLINABLE popException #-} pushException (Exception msg) = Lua.liftLua $ \l -> B.unsafeUseAsCStringLen (Utf8.fromString msg) $ \(msgPtr, z) -> lua_pushlstring l msgPtr (fromIntegral z) {-# INLINABLE pushException #-} luaException = Exception {-# INLINABLE luaException #-} -- | Return either the result of a Lua computation or, if an exception was -- thrown, the error. try :: Catch.Exception e => LuaE e a -> LuaE e (Either e a) try = Catch.try {-# INLINABLE try #-} -- | 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 err <- popException Catch.throwM $! err {-# INLINABLE 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 #-} -- | 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 #-} -- -- 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 'LuaE' operation. Throws an exception if an error -- occured. liftLuaThrow :: forall e a. LuaError e => (Lua.State -> Ptr Lua.StatusCode -> IO a) -> LuaE e a liftLuaThrow f = Lua.liftLua (throwOnError (Proxy @e) f) -- | 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 -- 'popException'. popErrorMessage :: Lua.State -> IO ByteString popErrorMessage l = alloca $ \lenPtr -> do cstr <- hsluaL_tolstring l (-1) lenPtr if cstr == nullPtr 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 -- 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 let pushtype = lua_type l idx >>= lua_typename l >>= lua_pushstring l B.unsafeUseAsCString "__name" (luaL_getmetafield l idx) >>= \case LUA_TSTRING -> return () -- pushed the name LUA_TNIL -> void pushtype _ -> lua_pop l 1 <* pushtype let pushstring str = B.unsafeUseAsCStringLen str $ \(cstr, cstrLen) -> lua_pushlstring l cstr (fromIntegral cstrLen) pushstring expected pushstring " expected, got " lua_rotate l (-3) (-1) -- move actual type to the end lua_concat l 3 hslua-core-2.3.2/src/HsLua/Core/Package.hs0000644000000000000000000000356307346545000016342 0ustar0000000000000000{-| Module : HsLua.Core.Package Copyright : © 2019-2024 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_requiref@: If @modname@ is not already present in -- @package.loaded@, calls function @openf@ with string @modname@ as an -- argument and sets the call result in @package.loaded[modname]@, as if -- that function has been called through -- . -- -- Leaves a copy of the module on the stack. requirehs :: LuaError e => Name -- ^ modname -> (Name -> LuaE e ()) -- ^ openf -> LuaE e () requirehs modname openf = do void $ getsubtable registryindex loaded void $ getfield top modname toboolean top >>= \case True -> pure () -- package already loaded False -> do -- package not loaded, load it now pop 1 -- remove field oldtop <- gettop openf modname settop (oldtop + 1) pushvalue top -- make copy of module (call result) setfield (nth 3) modname remove (nth 2) -- remove LOADED table -- | 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 hslua-core-2.3.2/src/HsLua/Core/Primary.hs0000644000000000000000000011402207346545000016423 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-| Module : HsLua.Core.Primary Copyright : © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2024 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 a) -> LuaE e a 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 -> do let (data1, data2, data3) = toGCdata what fromIntegral <$!> lua_gc l (toGCcode what) data1 data2 data3 {-# 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 @n@-th user value associated with the -- full userdata at the given index and returns the type of the pushed -- value. -- -- If the userdata does not have that value, pushes __nil__ and returns -- 'LUA_TNONE'. -- -- Wraps 'lua_getiuservalue'. getiuservalue :: StackIndex -- ^ index -> Int -- ^ n -> LuaE e Type getiuservalue idx n = liftLua $ \l -> toType <$!> lua_getiuservalue l idx (fromIntegral n) -- | 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 creates and pushes on the stack a new full userdata, -- with @nuvalue@ associated Lua values, called @user values@, plus an -- associated block of raw memory with @size@ bytes. (The user values -- can be set and read with the functions 'lua_setiuservalue' and -- 'lua_getiuservalue'.) -- -- The function returns the address of the block of memory. Lua ensures -- that this address is valid as long as the corresponding userdata is -- alive (see ). -- Moreover, if the userdata is marked for finalization (see -- ), its -- address is valid at least until the call to its finalizer. -- -- This function wraps 'lua_newuserdatauv'. newuserdatauv :: Int {- ^ size -} -> Int {- ^ nuvalue -} -> LuaE e (Ptr ()) newuserdatauv size nuvalue = liftLua $ \l -> lua_newuserdatauv l (fromIntegral size) (fromIntegral nuvalue) {-# INLINABLE newuserdatauv #-} -- | 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 Type rawget n = ensureTable n (\l -> toType <$!> 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 Type rawgeti k n = ensureTable k (\l -> toType <$!> 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@. -- -- Behaves like "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 #-} -- | Rotates the stack elements between the valid index @idx@ and the -- top of the stack. The elements are rotated @n@ positions in the -- direction of the top, for a positive @n@, or @-n@ positions in the -- direction of the bottom, for a negative @n@. The absolute value of -- @n@ must not be greater than the size of the slice being rotated. -- This function cannot be called with a pseudo-index, because a -- pseudo-index is not an actual stack position. -- -- rotate :: StackIndex -- ^ @idx@ -> Int -- ^ @n@ -> LuaE e () rotate idx n = liftLua $ \l -> lua_rotate l idx (fromIntegral n) {-# INLINABLE rotate #-} -- | 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.4 -- 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.4 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 @n@-th user -- value associated to the full userdata at the given index. Returns 0 -- if the userdata does not have that value. -- -- Wraps 'lua_setiuservalue'. setiuservalue :: StackIndex {- ^ index -} -> Int {- ^ n -} -> LuaE e Bool setiuservalue idx n = liftLua $ \l -> fromLuaBool <$!> lua_setiuservalue l idx (fromIntegral n) -- | Sets the warning function to be used by Lua to emit warnings (see -- 'WarnFunction'). The @ud@ parameter sets the value @ud@ passed to the -- warning function. setwarnf :: WarnFunction -- ^ f -> Ptr () -- ^ ud -> LuaE e () setwarnf f ud = liftLua $ \l -> lua_setwarnf l f ud -- | 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.4 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.4 reference manual). -- -- See also: -- . upvalueindex :: StackIndex -> StackIndex upvalueindex i = registryindex - i {-# INLINABLE upvalueindex #-} hslua-core-2.3.2/src/HsLua/Core/Run.hs0000644000000000000000000000517107346545000015550 0ustar0000000000000000{-| Module : HsLua.Core.Run Copyright : © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : beta Portability : non-portable (depends on GHC) Helper functions to run 'LuaE' computations. -} module HsLua.Core.Run ( run , runEither , runWith -- * GCManaged state , GCManagedState , newGCManagedState , closeGCManagedState , withGCManagedState ) where import Control.Exception (bracket, try) import Control.Monad ((<$!>)) import Foreign.ForeignPtr (ForeignPtr, finalizeForeignPtr, newForeignPtr, withForeignPtr) import HsLua.Core.Types (LuaE, runWith) import Lua.Primary (lua_close_ptr) import Lua (State (..)) import qualified Control.Monad.Catch as Catch import qualified HsLua.Core.Auxiliary as Lua 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 :: LuaE e a -> IO a run = (Lua.newstate `bracket` Lua.close) . flip runWith . 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 -- type errors, etc.) are passed through. runEither :: Catch.Exception e => LuaE e a -> IO (Either e a) runEither = try . run {-# INLINABLE runEither #-} -- | Wrapper of a Lua state whose lifetime is managed by the Haskell -- garbage collector and has a finalizer attached. This means that the -- state does not have to be closed explicitly, but will be closed -- automatically when the value is garbage collected in Haskell. newtype GCManagedState = GCManagedState (ForeignPtr ()) -- | Creates a new Lua state that is under the control of the Haskell -- garbage collector. newGCManagedState :: IO GCManagedState newGCManagedState = do (State lptr) <- Lua.newstate GCManagedState <$!> newForeignPtr lua_close_ptr lptr -- | Closes the Lua state and runs all finalizers associated with it. -- The state _may not_ be used after it has been closed. closeGCManagedState :: GCManagedState -> IO () closeGCManagedState (GCManagedState fptr) = finalizeForeignPtr fptr -- | Runs a Lua action with a state that's managed by GC. withGCManagedState :: GCManagedState -> LuaE e a -> IO a withGCManagedState (GCManagedState fptr) action = withForeignPtr fptr $ \lptr -> runWith (State lptr) action hslua-core-2.3.2/src/HsLua/Core/Trace.hs0000644000000000000000000000442707346545000016045 0ustar0000000000000000{-# LANGUAGE TypeApplications #-} {-| Module : HsLua.Core.Trace Copyright : © 2017-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Helper functions to call Lua functions with tracebacks. -} module HsLua.Core.Trace ( pcallTrace , callTrace , dofileTrace , dostringTrace ) where import Data.ByteString (ByteString) import Foreign.C.Types import HsLua.Core.Auxiliary (loadfile, loadstring, tostring', traceback) import HsLua.Core.Error (Exception, LuaError, throwErrorAsException) import HsLua.Core.Primary (gettop, insert, pcall, pushcfunction, remove) import HsLua.Core.Run (runWith) import HsLua.Core.Types ( CFunction, LuaE, NumArgs (..), NumResults (..), PreCFunction , Status (OK), State (..), multret ) -- | Like @'pcall'@, but sets an appropriate message handler function, -- thereby adding a stack traceback if an error occurs. pcallTrace :: NumArgs -> NumResults -> LuaE e Status pcallTrace nargs@(NumArgs nargsint) nres = do curtop <- gettop let base = curtop - fromIntegral nargsint -- function index pushcfunction hsluaL_msghandler_ptr insert base -- insert msghandler below function status' <- pcall nargs nres (Just base) remove base return status' -- | Like @'call'@, but adds a traceback if an error occurs. callTrace :: LuaError e => NumArgs -> NumResults -> LuaE e () callTrace nargs nres = pcallTrace nargs nres >>= \case OK -> pure () _ -> throwErrorAsException -- | Run the given file as a Lua program, while also adding a -- traceback to the error message if an error occurs. dofileTrace :: Maybe FilePath -> LuaE e Status dofileTrace fp = loadfile fp >>= \case OK -> pcallTrace 0 multret s -> pure s dostringTrace :: ByteString -> LuaE e Status dostringTrace s = loadstring s >>= \case OK -> pcallTrace 0 multret err -> pure err -- | Helper function used as message handler if the function given to -- pcall fails. hsluaL_msghandler :: State -> IO NumResults hsluaL_msghandler l = runWith l $ do msg <- tostring' @Exception 1 traceback l (Just msg) 2 pure (NumResults 1) -- Turn message handler into a CFunction by exporting it, then importing -- at pointer to it. foreign export ccall hsluaL_msghandler :: PreCFunction foreign import ccall "&hsluaL_msghandler" hsluaL_msghandler_ptr:: CFunction hslua-core-2.3.2/src/HsLua/Core/Types.hs0000644000000000000000000002427307346545000016114 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-| Module : HsLua.Core.Types Copyright : © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : beta Portability : non-portable (depends on GHC) The core Lua types, including mappings of Lua types to Haskell. This module has mostly been moved to @'Lua.Types'@ and currently re-exports that module. This module might be removed in the future. -} module HsLua.Core.Types ( LuaE (..) , LuaEnvironment (..) , State (..) , Reader , liftLua , liftLua1 , state , runWith , unsafeRunWith , GCControl (..) , toGCcode , toGCdata , Type (..) , fromType , toType , liftIO , CFunction , PreCFunction , HaskellFunction , LuaBool (..) , fromLuaBool , toLuaBool , Integer (..) , Number (..) , StackIndex (..) , registryindex , NumArgs (..) , NumResults (..) , multret , RelationalOperator (..) , fromRelationalOperator , Status (..) , toStatus -- * References , Reference (..) , fromReference , toReference , noref , refnil -- * Stack index helpers , nthTop , 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 import Lua.Auxiliary ( Reference (..) , fromReference , toReference ) import qualified HsLua.Core.Utf8 as Utf8 -- | Environment in which Lua computations are evaluated. 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 LuaE e a = Lua { unLua :: ReaderT LuaEnvironment IO a } deriving ( Applicative , Functor , Monad , MonadCatch , MonadIO , MonadMask , MonadReader LuaEnvironment , MonadThrow ) -- | 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 -> LuaE e b liftLua1 f x = liftLua $ \l -> f l x {-# INLINABLE liftLua1 #-} -- | Get the Lua state of this Lua computation. state :: LuaE e State state = asks luaEnvState {-# INLINABLE state #-} -- | 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. -- -- This function is identical to 'runWith'; it exists for backwards -- compatibility. 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 -- -- | Enumeration used as type tag. -- See . data Type = TypeNone -- ^ non-valid stack index | TypeNil -- ^ type of Lua's @nil@ value | TypeBoolean -- ^ type of Lua booleans | TypeLightUserdata -- ^ type of light userdata | TypeNumber -- ^ type of Lua numbers. See @'Lua.Number'@ | TypeString -- ^ type of Lua string values | TypeTable -- ^ type of Lua tables | TypeFunction -- ^ type of functions, either normal or @'CFunction'@ | TypeUserdata -- ^ type of full user data | TypeThread -- ^ type of Lua threads deriving (Bounded, Eq, Ord, Show, Read) instance Enum Type where fromEnum = fromIntegral . fromTypeCode . fromType toEnum = toType . TypeCode . fromIntegral -- | Convert a Lua 'Type' to a type code which can be passed to the C -- API. fromType :: Type -> TypeCode fromType = \case TypeNone -> LUA_TNONE TypeNil -> LUA_TNIL TypeBoolean -> LUA_TBOOLEAN TypeLightUserdata -> LUA_TLIGHTUSERDATA TypeNumber -> LUA_TNUMBER TypeString -> LUA_TSTRING TypeTable -> LUA_TTABLE TypeFunction -> LUA_TFUNCTION TypeUserdata -> LUA_TUSERDATA TypeThread -> LUA_TTHREAD {-# INLINABLE fromType #-} -- | Convert numerical code to Lua 'Type'. toType :: TypeCode -> Type toType = \case LUA_TNONE -> TypeNone LUA_TNIL -> TypeNil LUA_TBOOLEAN -> TypeBoolean LUA_TLIGHTUSERDATA -> TypeLightUserdata LUA_TNUMBER -> TypeNumber LUA_TSTRING -> TypeString LUA_TTABLE -> TypeTable LUA_TFUNCTION -> TypeFunction LUA_TUSERDATA -> TypeUserdata LUA_TTHREAD -> TypeThread TypeCode c -> error ("No Type corresponding to " ++ show c) {-# INLINABLE toType #-} -- -- Thread status -- -- | Lua status values. data Status = OK -- ^ success | Yield -- ^ yielding / suspended coroutine | ErrRun -- ^ a runtime rror | ErrSyntax -- ^ syntax error during precompilation | ErrMem -- ^ memory allocation (out-of-memory) error. | ErrErr -- ^ error while running the message handler. | ErrFile -- ^ opening or reading a file failed. deriving (Eq, Show) -- | Convert C integer constant to @'Status'@. toStatus :: StatusCode -> Status toStatus = \case LUA_OK -> OK LUA_YIELD -> Yield LUA_ERRRUN -> ErrRun LUA_ERRSYNTAX -> ErrSyntax LUA_ERRMEM -> ErrMem LUA_ERRERR -> ErrErr LUA_ERRFILE -> ErrFile StatusCode n -> error $ "Cannot convert (" ++ show n ++ ") to Status" {-# INLINABLE toStatus #-} -- -- Relational Operator -- -- | Lua comparison operations. data RelationalOperator = EQ -- ^ Correponds to Lua's equality (==) operator. | LT -- ^ Correponds to Lua's strictly-lesser-than (<) operator | LE -- ^ Correponds to Lua's lesser-or-equal (<=) operator deriving (Eq, Ord, Show) -- | Convert relation operator to its C representation. fromRelationalOperator :: RelationalOperator -> OPCode fromRelationalOperator = \case EQ -> LUA_OPEQ LT -> LUA_OPLT LE -> LUA_OPLE {-# INLINABLE fromRelationalOperator #-} -- -- Boolean -- -- | Convert a @'LuaBool'@ to a Haskell @'Bool'@. fromLuaBool :: LuaBool -> Bool fromLuaBool FALSE = False fromLuaBool _ = True {-# INLINABLE fromLuaBool #-} -- | Convert a Haskell @'Bool'@ to a @'LuaBool'@. toLuaBool :: Bool -> LuaBool toLuaBool True = TRUE toLuaBool False = FALSE {-# INLINABLE toLuaBool #-} -- -- Garbage collection -- -- | 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 CInt -- ^ performs an incremental step of garbage -- collection, corresponding to the allocation of -- @stepsize@ Kbytes. | GCInc CInt CInt CInt -- ^ Changes the collector to incremental mode -- with the given parameters (see -- ). Returns the previous mode -- (@LUA_GCGEN@ or @LUA_GCINC@). -- Parameters: pause, stepmul, and stepsize. | GCGen CInt CInt -- ^ Changes the collector to generational mode -- with the given parameters (see -- ). Returns the previous mode -- (@LUA_GCGEN@ or @LUA_GCINC@). | GCIsRunning -- ^ returns a boolean that tells whether the -- collector is running (i.e., not stopped). deriving (Eq, Ord, Show) -- | 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 GCIsRunning -> LUA_GCISRUNNING GCGen {} -> LUA_GCGEN GCInc {} -> LUA_GCINC {-# INLINABLE toGCcode #-} -- | Returns the data value associated with a GCControl command. toGCdata :: GCControl -> (CInt, CInt, CInt) toGCdata = \case GCStep stepsize -> (stepsize, 0, 0) GCGen minormul majormul -> (minormul, majormul, 0) GCInc pause mul size -> (pause, mul, size) _ -> (0, 0, 0) {-# INLINABLE toGCdata #-} -- -- Special values -- -- | Option for multiple returns in @'HsLua.Core.pcall'@. multret :: NumResults multret = LUA_MULTRET -- | Pseudo stack index of the Lua registry. registryindex :: StackIndex registryindex = LUA_REGISTRYINDEX -- | Value signaling that no reference was created. refnil :: Int refnil = fromIntegral LUA_REFNIL -- | 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 #-} hslua-core-2.3.2/src/HsLua/Core/Unsafe.hs0000644000000000000000000000161207346545000016221 0ustar0000000000000000{-# OPTIONS_GHC -Wno-warnings-deprecations #-} {-| Module : HsLua.Core.Unsafe Copyright : © 2019-2024 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.next'@ function in HsLua.Core instead. next :: StackIndex -> LuaE e Bool next idx = liftLua $ \l -> fromLuaBool <$!> lua_next l idx {-# INLINABLE next #-} hslua-core-2.3.2/src/HsLua/Core/Userdata.hs0000644000000000000000000000526607346545000016561 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-| Module : HsLua.Core.Userdata Copyright : © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2024 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 ( newhsuserdatauv , newudmetatable , fromuserdata , putuserdata ) where import HsLua.Core.Types (LuaE, Name (..), StackIndex, liftLua, fromLuaBool) import Lua.Userdata ( hslua_fromuserdata , hslua_newhsuserdatauv , 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. newhsuserdatauv :: forall a e. a -- ^ Haskell object -> Int -- ^ number of extra userdata values -> LuaE e () newhsuserdatauv x nuvalue = liftLua $ \l -> hslua_newhsuserdatauv l x (fromIntegral nuvalue) {-# INLINABLE newhsuserdatauv #-} -- | 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. -- -- Returns 'True' if a new metatable was created, and 'False' otherwise. -- -- 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 #-} hslua-core-2.3.2/src/HsLua/Core/Utf8.hs0000644000000000000000000000245307346545000015632 0ustar0000000000000000{-| Module : HsLua.Core.Utf8 Copyright : © 2018-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : beta Portability : portable Encoding and decoding of String to and from UTF8. -} module HsLua.Core.Utf8 ( toString , toText , fromString , fromText ) where import Data.ByteString (ByteString) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TextEncoding import qualified Data.Text.Encoding.Error as TextEncoding -- | Decode @'ByteString'@ to @'String'@ using UTF-8. Invalid input -- bytes are replaced with the Unicode replacement character U+FFFD. toString :: ByteString -> String toString = T.unpack . toText {-# INLINABLE toString #-} -- | Decode @'ByteString'@ to @'Text'@ using UTF-8. Invalid input -- bytes are replaced with the Unicode replacement character U+FFFD. toText :: ByteString -> Text toText = TextEncoding.decodeUtf8With TextEncoding.lenientDecode {-# INLINABLE toText #-} -- | Encode @'String'@ to @'ByteString'@ using UTF-8. fromString :: String -> ByteString fromString = TextEncoding.encodeUtf8 . T.pack {-# INLINABLE fromString #-} -- | Encode @'Text'@ to @'ByteString'@ using UTF-8. fromText :: Text -> ByteString fromText = TextEncoding.encodeUtf8 {-# INLINABLE fromText #-} hslua-core-2.3.2/src/HsLua/Core/Warn.hs0000644000000000000000000000264607346545000015717 0ustar0000000000000000{-| Module : HsLua.Core.Warn Copyright : © 2023-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Simpler interface to the Lua warnings system. This module simplifies the process of setting a custom warn function. -} module HsLua.Core.Warn ( setwarnf' ) where import Data.ByteString (ByteString) import HsLua.Core.Closures (pushHaskellFunction) import HsLua.Core.Error (LuaError) import HsLua.Core.Primary (tostring) import HsLua.Core.Types (LuaE, NumResults (..), liftLua, nthBottom) import Lua.Warn (hsluaL_setwarnf) -- | Sets a warning function. This is a simplified version of -- 'lua_setwarnf'. The given function is called with the concatenated -- warning components as the single argument. -- -- Control messages are handled internally and are /not/ passed on the -- warning hook. As with the default warning function, the control -- messages @\@on@ and @\@off@ can switch error reporting to stderr on -- and off. The given Haskell function will be called in either case, -- even when the error is not written to stderr. -- -- Wraps 'hsluaL_setwarnf'. setwarnf' :: LuaError e => (ByteString -> LuaE e ()) -> LuaE e () setwarnf' fn = do pushHaskellFunction $ do mbmsg <- tostring (nthBottom 1) case mbmsg of Nothing -> pure (NumResults 0) -- couldn't get warning msg; do nothing Just msg -> NumResults 0 <$ fn msg liftLua hsluaL_setwarnf hslua-core-2.3.2/test/HsLua/Core/0000755000000000000000000000000007346545000014634 5ustar0000000000000000hslua-core-2.3.2/test/HsLua/Core/AuxiliaryTests.hs0000644000000000000000000001100607346545000020160 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-| Tests for the auxiliary library. -} module HsLua.Core.AuxiliaryTests (tests) where import Data.ByteString (ByteString) import Data.Maybe (fromMaybe) import HsLua.Core (nth) import Test.Tasty.HsLua ( (?:), (=:), pushLuaExpr, shouldBeResultOf , shouldBeErrorMessageOf) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit ((@=?)) import qualified Lua import qualified HsLua.Core as Lua -- | Specifications for Attributes parsing functions. tests :: TestTree tests = testGroup "Auxiliary" [ testGroup "checkstack'" [ "returns unit if stack space can be provided" =: () `shouldBeResultOf` Lua.checkstack' 2 "test" -- testing the error case is not possible for some reason -- , "fails if too much stack space is requested" =: -- "stack overflow (test)"`shouldBeErrorMessageOf` -- Lua.checkstack' maxBound "test" ] , testGroup "getsubtable" [ "gets a subtable from field" =: [5, 8] `shouldBeResultOf` do pushLuaExpr @Lua.Exception "{foo = {5, 8}}" _ <- Lua.getsubtable Lua.top "foo" Lua.rawgeti (nth 1) 1 Lua.rawgeti (nth 2) 2 i1 <- fromMaybe 0 <$> Lua.tointeger (nth 2) i2 <- fromMaybe 0 <$> Lua.tointeger (nth 1) return [i1, i2] , "creates new table at field if necessary" =: Lua.TypeTable `shouldBeResultOf` do Lua.newtable _ <- Lua.getsubtable Lua.top "new" Lua.getfield (Lua.nth 2) "new" Lua.ltype Lua.top , "returns True if a table exists" ?: do pushLuaExpr @Lua.Exception "{yep = {}}" Lua.getsubtable Lua.top "yep" , "returns False if field does not contain a table" ?: do pushLuaExpr @Lua.Exception "{nope = 5}" not <$> Lua.getsubtable Lua.top "nope" ] , testGroup "getmetafield'" [ "gets field from the object's metatable" =: ("testing" :: ByteString) `shouldBeResultOf` do Lua.newtable pushLuaExpr "{foo = 'testing'}" Lua.setmetatable (Lua.nth 2) _ <- Lua.getmetafield Lua.top "foo" Lua.tostring' Lua.top , "returns TypeNil if the object doesn't have a metatable" =: Lua.TypeNil `shouldBeResultOf` do Lua.newtable Lua.getmetafield Lua.top "foo" ] , testGroup "getmetatable'" [ "gets table created with newmetatable" =: ("__name" :: ByteString, "testing" :: ByteString) `shouldBeResultOf` do Lua.newmetatable "testing" *> Lua.pop 1 _ <- Lua.getmetatable' "testing" Lua.pushnil Lua.next (nth 2) key <- Lua.tostring' (nth 2) <* Lua.pop 1 value <- Lua.tostring' (nth 1) <* Lua.pop 1 return (key, value) , "returns nil if there is no such metatable" =: Lua.TypeNil `shouldBeResultOf` do _ <- Lua.getmetatable' "nope" Lua.ltype Lua.top , "returns TypeTable if metatable exists" =: Lua.TypeTable `shouldBeResultOf` do _ <- Lua.newmetatable "yep" Lua.getmetatable' "yep" ] , testGroup "requiref" [ "can load a module" =: do Lua.TypeTable `shouldBeResultOf` do Lua.openlibs Lua.requiref "mathematics" Lua.luaopen_math False Lua.ltype Lua.top , "returns () on success" =: do () `shouldBeResultOf` do Lua.openlibs -- already loaded Lua.requiref "math" Lua.luaopen_math False , "sets global if flag is set" =: do Lua.TypeTable `shouldBeResultOf` do Lua.openlibs Lua.requiref "foo" Lua.luaopen_math True Lua.pop 1 Lua.getglobal "foo" , "catches errors" =: do "attempt to index a nil value" `shouldBeErrorMessageOf` do -- unset registry Lua.pushnil Lua.copy Lua.top Lua.registryindex Lua.requiref "math" Lua.luaopen_package False ] , 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) ] hslua-core-2.3.2/test/HsLua/Core/ClosuresTests.hs0000644000000000000000000000317607346545000020021 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} {-| Module : HsLua.Core.ClosuresTests Copyright : © 2017-2024 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 ] hslua-core-2.3.2/test/HsLua/Core/DebugTests.hs0000644000000000000000000000200607346545000017237 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} {-| Module : HsLua.Core.DebugTests Copyright : © 2023-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Test the debug interface. -} module HsLua.Core.DebugTests (tests) where import HsLua.Core as Lua import Test.Tasty.HsLua ((=:), shouldBeResultOf) import Test.Tasty (TestTree, testGroup) -- | Specifications for Attributes parsing functions. tests :: TestTree tests = testGroup "Debug" [ "getupvalue" =: Just "x" `shouldBeResultOf` do loadstring "local x = 0; return function () return x + 23 end" call 0 1 getupvalue top 1 , "setupvalue" =: (Just "i", Just 28) `shouldBeResultOf` do loadstring "local i = 0; return function () return i + 23 end" call 0 1 -- set 'x' to 5 pushinteger 5 name <- setupvalue (nth 2) 1 -- call function and check the returned value call 0 1 i <- tointeger top return (name, i) ] hslua-core-2.3.2/test/HsLua/Core/ErrorTests.hs0000644000000000000000000000533207346545000017307 0ustar0000000000000000{-# 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, failLua) import HsLua.Core.Error ( LuaError, changeErrorType, popErrorMessage , throwTypeMismatchError) import HsLua.Core.Types (liftLua) import Test.Tasty.HsLua ( (=:), (?:), shouldBeResultOf, shouldHoldForResultOf , shouldBeErrorMessageOf) 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 (failLua "test" :: Lua ()) , "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) ] , testGroup "type mismatch" [ "got string" =: "number expected, got string" `shouldBeErrorMessageOf` do Lua.pushstring "moin" throwTypeMismatchError "number" Lua.top :: Lua () , "got unnamed userdata" =: "number expected, got userdata" `shouldBeErrorMessageOf` do Lua.newhsuserdatauv () 0 throwTypeMismatchError "number" Lua.top :: Lua () , "named userdata" =: "Bar expected, got Foo" `shouldBeErrorMessageOf` do Lua.newhsuserdatauv () 0 Lua.newudmetatable "Foo" Lua.setmetatable (Lua.nth 2) throwTypeMismatchError "Bar" Lua.top :: Lua () , "missing value" =: "boolean expected, got no value" `shouldBeErrorMessageOf` do curtop <- Lua.gettop throwTypeMismatchError "boolean" (curtop + 1) :: Lua () ] ] 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 hslua-core-2.3.2/test/HsLua/Core/PackageTests.hs0000644000000000000000000000430107346545000017544 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-| Module : HsLua.Core.RunTests Copyright : © 2017-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : stable Portability : portable Tests for different convenience functions to run Lua operations. -} module HsLua.Core.PackageTests (tests) where import HsLua.Core as Lua import Test.Tasty.HsLua ((=:), pushLuaExpr, shouldBeResultOf) import Test.Tasty (TestTree, testGroup) -- | Specifications for Attributes parsing functions. tests :: TestTree tests = testGroup "Package" [ testGroup "requirehs" [ "call the given function" =: "test" `shouldBeResultOf` do Lua.openlibs let openf (Lua.Name name) = Lua.pushstring name Lua.requirehs "test" openf Lua.tostring' Lua.top , "doesn't call function if module has been loaded" =: "foo" `shouldBeResultOf` do Lua.openlibs Lua.requirehs "test" (const $ Lua.pushstring "foo") Lua.pop 1 Lua.requirehs "test" (const $ Lua.failLua "nope") Lua.tostring' Lua.top , "pushes module to stack" =: 1 `shouldBeResultOf` do Lua.openlibs old <- Lua.gettop Lua.requirehs "foo" (\_ -> Lua.pushnumber 5.0 *> pushboolean True) new <- Lua.gettop return (new - old) , "module can be loaded with `require`" =: let testModule = "string as a module" in Just testModule `shouldBeResultOf` do Lua.openlibs Lua.requirehs "test.module" (const (Lua.pushstring testModule)) pushLuaExpr "require 'test.module'" Lua.tostring Lua.top ] , testGroup "preloadhs" [ "does not modify the stack" =: 0 `shouldBeResultOf` do Lua.openlibs old <- Lua.gettop Lua.preloadhs "foo" (1 <$ Lua.pushnumber 5.0) new <- Lua.gettop return (new - old) , "module can be loaded with `require`" =: let testModule = "string as a module" in Just testModule `shouldBeResultOf` do Lua.openlibs Lua.preloadhs "test.module" (1 <$ Lua.pushstring testModule) oldtop <- gettop pushLuaExpr "require 'test.module'" Lua.tostring (oldtop + 1) ] ] hslua-core-2.3.2/test/HsLua/Core/PrimaryTests.hs0000644000000000000000000000126407346545000017641 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-| Tests for the primary library. -} module HsLua.Core.PrimaryTests (tests) where import HsLua.Core import Test.Tasty.HsLua ((=:), shouldBeResultOf) import Test.Tasty (TestTree, testGroup) -- | Specifications for Attributes parsing functions. tests :: TestTree tests = testGroup "Primary" [ testGroup "rotate'" [ "rotates stack" =: (Just 2, Just 1, Just 4, Just 3) `shouldBeResultOf` do pushnumber 4 pushnumber 3 pushnumber 2 pushnumber 1 rotate (nth 4) 2 (,,,) <$> tonumber (nth 4) <*> tonumber (nth 3) <*> tonumber (nth 2) <*> tonumber (nth 1) ] ] hslua-core-2.3.2/test/HsLua/Core/RunTests.hs0000644000000000000000000000174607346545000016767 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} {-| Module : HsLua.Core.RunTests Copyright : © 2017-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : stable Portability : portable Tests for different convenience functions to run Lua operations. -} module HsLua.Core.RunTests (tests) where import Data.Either (isLeft, isRight) import HsLua.Core as Lua import Test.Tasty.HsLua ((=:), shouldHoldForResultOf) import Test.Tasty (TestTree, testGroup) -- | Specifications for Attributes parsing functions. tests :: TestTree tests = testGroup "Run" [ testGroup "runEither" [ "Lua errors are caught" =: isLeft `shouldHoldForResultOf` liftIO (runEither (failLua "failing" :: Lua Bool)) , "error-less code gives 'Right'" =: isRight `shouldHoldForResultOf` liftIO (runEither @Lua.Exception (pushboolean True *> toboolean top)) ] ] hslua-core-2.3.2/test/HsLua/Core/TraceTests.hs0000644000000000000000000000326707346545000017261 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-| Module : HsLua.Core.TraceTests Copyright : © 2017-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : stable Portability : portable Test call functions that produce traces on error. -} module HsLua.Core.TraceTests (tests) where import Data.ByteString (isInfixOf) import HsLua.Core as Lua import Test.Tasty.HsLua ( (=:), shouldBeResultOf, shouldHoldForResultOf , pushLuaExpr) import Test.Tasty (TestTree, testGroup) import qualified Data.List as List -- | Specifications for Attributes parsing functions. tests :: TestTree tests = testGroup "Trace" [ testGroup "pcallTrace" [ "Calls the function" =: "motor" `shouldBeResultOf` do openlibs pushLuaExpr "function () return 'motor' end" OK <- pcallTrace 0 1 tostring' top , "Adds a traceback" =: ("\nstack traceback:\n" `isInfixOf`) `shouldHoldForResultOf` do openlibs pushLuaExpr "function (b) error(tostring(b)) end" pushinteger 23 ErrRun <- pcallTrace 1 1 tostring' top ] , testGroup "callTrace" [ "Calls the function" =: "motor" `shouldBeResultOf` do openlibs pushLuaExpr "function () return 'motor' end" callTrace 0 1 tostring' top , "Adds a traceback" =: ("\nstack traceback:\n" `List.isInfixOf`) `shouldHoldForResultOf` do either show (const $ Prelude.error "should not succeed") <$> try (do openlibs pushLuaExpr "function (b) error(tostring(b)) end" pushinteger 23 callTrace 1 1 tostring' top) ] ] hslua-core-2.3.2/test/HsLua/Core/UnsafeTests.hs0000644000000000000000000000165307346545000017441 0ustar0000000000000000{-# OPTIONS_GHC -Wno-warnings-deprecations #-} {-# LANGUAGE OverloadedStrings #-} {-| Module : HsLua.Core.UnsafeTests Copyright : © 2021-2024 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) ] ] hslua-core-2.3.2/test/HsLua/Core/UserdataTests.hs0000644000000000000000000000371107346545000017765 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-| Module : HsLua.Core.UserdataTests Copyright : © 2017-2024 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, newhsuserdatauv, 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 newhsuserdatauv (Sample 0 "zero") 0 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 newhsuserdatauv (5 :: Integer) 0 newudmetatable "Integer" setmetatable (nth 2) fromuserdata top "Sample" , "change wrapped value" =: Just (Sample 1 "a") `shouldBeResultOf` do newhsuserdatauv (Sample 5 "five") 0 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 newhsuserdatauv (Sample 2 "b") 0 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) hslua-core-2.3.2/test/HsLua/Core/WarnTests.hs0000644000000000000000000000157207346545000017127 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-| Module : HsLua.Core.WarnTests Copyright : © 2017-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Check that setting hook for warning messages works. -} module HsLua.Core.WarnTests (tests) where import HsLua.Core import Test.Tasty.HsLua ((=:), shouldBeResultOf) import Test.Tasty (TestTree, testGroup) -- | Specifications for Attributes parsing functions. tests :: TestTree tests = testGroup "Warn" [ "warnings get handled" =: Just "Hi Mom!" `shouldBeResultOf` do openlibs setwarnf' $ \msg -> do pushstring msg setfield registryindex "hslua testing" stat <- dostring "warn('Hi', ' ', 'Mom!')" case stat of OK -> do getfield registryindex "hslua testing" tostring top _ -> do throwErrorAsException ] hslua-core-2.3.2/test/HsLua/0000755000000000000000000000000007346545000013744 5ustar0000000000000000hslua-core-2.3.2/test/HsLua/CoreTests.hs0000644000000000000000000004016107346545000016215 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} {-| Module : HsLua.CoreTests Copyright : © 2017-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : stable Portability : portable Tests for Lua C API-like functions. -} module HsLua.CoreTests (tests) where import Prelude hiding (compare) 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 ) import Test.QuickCheck (Property, (.&&.)) import Test.QuickCheck.Monadic (assert, monadicIO) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertEqual, testCase) import Test.Tasty.QuickCheck (testProperty) import qualified Prelude import qualified Data.ByteString as B import qualified HsLua.Core.AuxiliaryTests import qualified HsLua.Core.ClosuresTests import qualified HsLua.Core.DebugTests import qualified HsLua.Core.ErrorTests import qualified HsLua.Core.PackageTests import qualified HsLua.Core.PrimaryTests import qualified HsLua.Core.RunTests import qualified HsLua.Core.TraceTests import qualified HsLua.Core.UnsafeTests import qualified HsLua.Core.UserdataTests import qualified HsLua.Core.WarnTests import qualified Foreign.Marshal as Foreign import qualified Foreign.Ptr as Foreign import qualified Test.QuickCheck.Monadic as QCMonadic -- | Specifications for Attributes parsing functions. tests :: TestTree tests = testGroup "Core module" [ HsLua.Core.ErrorTests.tests , HsLua.Core.AuxiliaryTests.tests , testGroup "copy" [ "copies stack elements using positive indices" ?: do pushLuaExpr @Lua.Exception "5, 4, 3, 2, 1" copy 4 3 rawequal (nthBottom 4) (nthBottom 3) , "copies stack elements using negative indices" ?: do pushLuaExpr @Lua.Exception "5, 4, 3, 2, 1" copy (-1) (-3) rawequal (-1) (-3) ] , testGroup "insert" [ "inserts stack elements using positive indices" ?: do 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 @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 @Lua.Exception $ do pushLuaExpr "1, 2, 3, 4" liftIO . assertEqual "index from bottom doesn't change" (nthBottom 3) =<< absindex (nthBottom 3) liftIO . assertEqual "index from top is made absolute" (nthBottom 2) =<< absindex (nth 3) liftIO . assertEqual "pseudo indices are left unchanged" registryindex =<< absindex registryindex , "gettable gets a table value" =: Just 13.37 `shouldBeResultOf` do pushLuaExpr @Lua.Exception "{sum = 13.37}" pushstring "sum" gettable (nth 2) tonumber top , "rawlen gives the length of a list" =: 7 `shouldBeResultOf` do pushLuaExpr @Lua.Exception "{1, 1, 2, 3, 5, 8, 13}" rawlen top , testGroup "Type checking" [ "isfunction" ?: do pushLuaExpr @Lua.Exception "function () print \"hi!\" end" isfunction (-1) , "isnil" ?: pushLuaExpr @Lua.Exception "nil" *> isnil (-1) , "isnone" ?: isnone 5 -- stack index 5 does not exist , "isnoneornil" ?: do pushLuaExpr @Lua.Exception "nil" (&&) <$> isnoneornil 5 <*> isnoneornil (-1) ] , testCase "CFunction handling" . run $ do pushcfunction luaopen_debug liftIO . assertBool "not recognized as CFunction" =<< iscfunction (-1) liftIO . assertEqual "CFunction changed after receiving it from the stack" (Just luaopen_debug) =<< tocfunction (-1) , testGroup "getting values" [ testGroup "tointeger" [ "tointeger returns numbers verbatim" =: Just 149 `shouldBeResultOf` do pushLuaExpr @Lua.Exception "149" tointeger (-1) , "tointeger accepts strings coercible to integers" =: Just 451 `shouldBeResultOf` do pushLuaExpr @Lua.Exception "'451'" tointeger (-1) , "tointeger returns Nothing when given a boolean" =: Nothing `shouldBeResultOf` do pushLuaExpr @Lua.Exception "true" tointeger (-1) ] , testGroup "tonumber" [ "tonumber returns numbers verbatim" =: Just 14.9 `shouldBeResultOf` do pushLuaExpr @Lua.Exception "14.9" tonumber (-1) , "tonumber accepts strings as numbers" =: Just 42.23 `shouldBeResultOf` do pushLuaExpr @Lua.Exception "'42.23'" tonumber (-1) , "tonumber returns Nothing when given a boolean" =: Nothing `shouldBeResultOf` do pushLuaExpr @Lua.Exception "true" tonumber (-1) ] , testGroup "tostring" [ "get a string" =: Just "a string" `shouldBeResultOf` do pushLuaExpr @Lua.Exception "'a string'" tostring top , "get a number as string" =: Just "17.0" `shouldBeResultOf` do pushnumber 17 tostring top , "fail when looking at a boolean" =: Nothing `shouldBeResultOf` do pushboolean True tostring top ] ] , "setting and getting a global works" =: Just "Moin" `shouldBeResultOf` do pushLuaExpr @Lua.Exception "{'Moin', Hello = 'World'}" setglobal "hamburg" -- get first field getglobal "hamburg" rawgeti top 1 -- first field tostring top , testGroup "get functions (Lua to stack)" [ "unicode characters in field name are ok" =: True `shouldBeResultOf` do pushLuaExpr @Lua.Exception "{['\xE2\x9A\x94'] = true}" getfield top "⚔" toboolean top ] , "setting and getting a global works" =: Just "Fisch" `shouldBeResultOf` do newhsuserdatauv () 1 pushstring "Fisch" setiuservalue (nth 2) 1 -- get uservalue again TypeString <- getiuservalue top 1 tostring top , "can push and receive a thread" ?: do luaSt <- state isMain <- pushthread liftIO (assertBool "pushing the main thread should return True" isMain) luaSt' <- tothread top return (Just luaSt == luaSt') , "different threads are not equal in Haskell" ?: liftIO (do luaSt1 <- newstate luaSt2 <- newstate let result = luaSt1 /= luaSt2 close luaSt1 close luaSt2 return result) , testGroup "thread status" [ "OK is base thread status" =: OK `shouldBeResultOf` status , "Yield is the thread status after yielding" =: Yield `shouldBeResultOf` do openlibs getglobal "coroutine" getfield top "resume" 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 liftIO $ runWith contThread status ] , testGroup "miscellaneous functions" [ testGroup "pushglobaltable" [ "globals are fields in global table" =: "yep" `shouldBeResultOf` do pushstring "yep" setglobal "TEST" pushglobaltable getfield top "TEST" tostring' top ] ] , testGroup "auxiliary functions" [ testGroup "tostring'" [ "integers are converted in base10" =: "5" `shouldBeResultOf` do pushinteger 5 tostring' top , "a nil value is converted into the literal string 'nil'" =: "nil" `shouldBeResultOf` do pushnil tostring' top , "strings are returned verbatim" =: "Hello\NULWorld" `shouldBeResultOf` do pushstring "Hello\NULWorld" tostring' top , "string for userdata shows the pointer value" =: ("userdata: " `B.isPrefixOf`) `shouldHoldForResultOf` do l <- state liftIO . Foreign.alloca $ \ptr -> runWith l (pushlightuserdata (ptr :: Foreign.Ptr Int)) tostring' top , "string is also pushed to the stack" =: Just "true" `shouldBeResultOf` do pushboolean True _ <- tostring' top tostring top -- note the use of tostring instead of tostring' , "errors during metamethod execution are caught" =: "'__tostring' must return a string" `shouldBeErrorMessageOf` do -- create a table with a faulty `__tostring` metamethod let mt = "{__tostring = function() return nil end }" let tbl = "return setmetatable({}, " `append` mt `append` ")" openlibs <* dostring tbl tostring' top ] , testGroup "ref and unref" [ "store nil value to registry" =: Lua.RefNil `shouldBeResultOf` do Lua.pushnil Lua.ref Lua.registryindex , "get referenced value from registry" =: Just "Berlin" `shouldBeResultOf` do Lua.pushstring "Berlin" cityref <- Lua.ref Lua.registryindex Lua.settop 0 -- remove all elements from stack Lua.getref Lua.registryindex cityref Lua.tostring Lua.top , "references become invalid after unref" =: (Just "Heidelberg" /=) `shouldHoldForResultOf` do Lua.pushstring "Heidelberg" cityref <- Lua.ref Lua.registryindex Lua.unref Lua.registryindex cityref Lua.getref Lua.registryindex cityref Lua.tostring Lua.top ] ] , testGroup "loading" [ testGroup "loadstring" [ "loading a valid string should succeed" =: OK `shouldBeResultOf` loadstring "return 1" , "loading an invalid string should give a syntax error" =: ErrSyntax `shouldBeResultOf` loadstring "marzipan" ] , testGroup "dostring" [ "loading a string which fails should give a run error" =: ErrRun `shouldBeResultOf` dostring "error 'this fails'" , "loading an invalid string should return a syntax error" =: ErrSyntax `shouldBeResultOf` dostring "marzipan" , "loading a valid program should succeed" =: OK `shouldBeResultOf` dostring "return 1" , "top of the stack should be result of last computation" =: Just 5 `shouldBeResultOf` (dostring "return (2+3)" *> tointeger top) ] , testGroup "loadbuffer" [ "loading a valid string should succeed" =: OK `shouldBeResultOf` loadbuffer "return '\NUL'" "test" , "loading a string containing NUL should be correct" =: Just "\NUL" `shouldBeResultOf` do _ <- loadbuffer "return '\NUL'" "test" call 0 1 tostring top ] , testGroup "loadfile" [ "file error should be returned when file does not exist" =: ErrFile `shouldBeResultOf` loadfile (Just "./file-does-not-exist.lua") , "loading an invalid file should give a syntax error" =: ErrSyntax `shouldBeResultOf` loadfile (Just "test/lua/syntax-error.lua") , "loading a valid program should succeed" =: OK `shouldBeResultOf` loadfile (Just "./test/lua/example.lua") , "example fib program should be loaded correctly" =: Just 8 `shouldBeResultOf` do loadfile (Just "./test/lua/example.lua") *> call 0 0 getglobal "fib" pushinteger 6 call 1 1 tointeger top ] , testGroup "dofile" [ "file error should be returned when file does not exist" =: ErrFile `shouldBeResultOf` dofile (Just "./file-does-not-exist.lua") , "loading an invalid file should give a syntax error" =: ErrSyntax `shouldBeResultOf` dofile (Just "test/lua/syntax-error.lua") , "loading a failing program should give an run error" =: ErrRun `shouldBeResultOf` dofile (Just "test/lua/error.lua") , "loading a valid program should succeed" =: OK `shouldBeResultOf` dofile (Just "./test/lua/example.lua") , "example fib program should be loaded correctly" =: Just 21 `shouldBeResultOf` do _ <- dofile (Just "./test/lua/example.lua") getglobal "fib" pushinteger 8 call 1 1 tointeger top ] ] , testGroup "pcall" [ "raising an error should lead to an error status" =: ErrRun `shouldBeResultOf` do _ <- loadstring "error \"this fails\"" pcall 0 0 Nothing , "raising an error in the error handler should give a 'double error'" =: ErrErr `shouldBeResultOf` do 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. mapM_ gc [ GCStop, GCRestart, GCCollect, GCCollect, GCCountb , GCStep 12, GCInc 23 0 0, GCGen 5 10, GCIsRunning ] , testGroup "compare" [ testProperty "identifies strictly smaller values" $ compareWith (<) Lua.LT , testProperty "identifies smaller or equal values" $ compareWith (<=) Lua.LE , testProperty "identifies equal values" $ compareWith (==) Lua.EQ ] , testProperty "lessthan works" $ \n1 n2 -> monadicIO $ do luaCmp <- QCMonadic.run . run @Lua.Exception $ do pushnumber n2 pushnumber n1 lessthan (-1) (-2) <* pop 2 assert $ luaCmp == (n1 < n2) , testProperty "order of Lua types is consistent" $ \ lt1 lt2 -> let n1 = toType lt1 n2 = toType lt2 in Prelude.compare n1 n2 == Prelude.compare lt1 lt2 , testCase "boolean values are correct" $ do trueIsCorrect <- run $ pushboolean True *> dostring "return true" *> rawequal (-1) (-2) falseIsCorrect <- run $ pushboolean False *> dostring "return false" *> rawequal (-1) (-2) assertBool "LuaBool true is not equal to Lua's true" trueIsCorrect assertBool "LuaBool false is not equal to Lua's false" falseIsCorrect , testCase "functions can throw a table as error message" $ do let mt = "{__tostring = function (e) return e.error_code end}" let err = "error(setmetatable({error_code = 23}," `append` mt `append` "))" res <- run . try $ openbase *> loadstring err *> call 0 0 assertEqual "wrong error message" (Left (Lua.Exception "23")) res , testCase "handling table errors won't leak" $ do let mt = "{__tostring = function (e) return e.code end}" let err = "error(setmetatable({code = 5}," `append` mt `append` "))" let luaOp = do openbase oldtop <- gettop _ <- try $ loadstring err *> call 0 0 newtop <- gettop return (newtop - oldtop) res <- run @Lua.Exception luaOp assertEqual "error handling leaks values to the stack" 0 res , HsLua.Core.PrimaryTests.tests , HsLua.Core.ClosuresTests.tests , HsLua.Core.PackageTests.tests , HsLua.Core.RunTests.tests , HsLua.Core.TraceTests.tests , HsLua.Core.UnsafeTests.tests , HsLua.Core.UserdataTests.tests , HsLua.Core.WarnTests.tests , HsLua.Core.DebugTests.tests ] compareWith :: (Lua.Integer -> Lua.Integer -> Bool) -> RelationalOperator -> Lua.Integer -> Property compareWith op luaOp n = compareLT .&&. compareEQ .&&. compareGT where compareLT :: Property compareLT = monadicIO $ do luaCmp <- QCMonadic.run . run $ do pushinteger $ n - 1 pushinteger n compare @Lua.Exception (-2) (-1) luaOp assert $ luaCmp == op (n - 1) n compareEQ :: Property compareEQ = monadicIO $ do luaCmp <- QCMonadic.run . run $ do pushinteger n pushinteger n compare @Lua.Exception (-2) (-1) luaOp assert $ luaCmp == op n n compareGT :: Property compareGT = monadicIO $ do luaRes <- QCMonadic.run . run $ do pushinteger $ n + 1 pushinteger n compare @Lua.Exception (-2) (-1) luaOp assert $ luaRes == op (n + 1) n hslua-core-2.3.2/test/Test/HsLua/0000755000000000000000000000000007346545000014663 5ustar0000000000000000hslua-core-2.3.2/test/Test/HsLua/Arbitrary.hs0000644000000000000000000000126007346545000017155 0ustar0000000000000000 {-# OPTIONS_GHC -fno-warn-orphans #-} {-| Module : HsLua.Core.RunTests Copyright : © 2017-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : stable Portability : portable Instances for QuickCheck's Arbitrary. -} module Test.HsLua.Arbitrary () where import HsLua.Core (Type) import Test.QuickCheck (Arbitrary(arbitrary)) import qualified HsLua.Core as Lua import qualified Test.QuickCheck as QC instance Arbitrary Lua.Integer where arbitrary = QC.arbitrarySizedIntegral instance Arbitrary Lua.Number where arbitrary = Lua.Number <$> arbitrary instance Arbitrary Type where arbitrary = QC.arbitraryBoundedEnum hslua-core-2.3.2/test/Test/Tasty/0000755000000000000000000000000007346545000014753 5ustar0000000000000000hslua-core-2.3.2/test/Test/Tasty/HsLua.hs0000644000000000000000000000621407346545000016326 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-| Module : Test.Tasty.HsLua Copyright : © 2017-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : beta Portability : non-portable (depends on GHC) Utilities for testing of HsLua operations. -} module Test.Tasty.HsLua ( assertLuaBool , pushLuaExpr , shouldBeErrorMessageOf , shouldBeResultOf , shouldHoldForResultOf , (=:) , (?:) ) where import Data.ByteString (ByteString, append) import HsLua.Core (Lua, LuaE, LuaError, run, runEither, loadstring, call, multret) import Test.Tasty (TestTree) import Test.Tasty.HUnit (Assertion, HasCallStack, assertBool, assertFailure, testCase, (@?=)) import qualified HsLua.Core as Lua -- | Takes a Lua expression as a 'ByteString', evaluates it and pushes -- the result to the stack. -- -- > -- will return "12" -- > run $ do -- > pushLuaExpr "7 + 5" -- > tointeger top 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 expected luaOp = do errOrRes <- runEither luaOp case errOrRes of Left (Lua.Exception msg) -> assertFailure $ "Lua operation failed with " ++ "message: '" ++ msg ++ "'" Right res -> res @?= expected -- | Checks whether a 'Lua' operation fails with the given string as -- error message. shouldBeErrorMessageOf :: (HasCallStack, Show a) => String -> Lua a -> Assertion shouldBeErrorMessageOf expectedErrMsg luaOp = do errOrRes <- runEither luaOp case errOrRes of Left (Lua.Exception msg) -> msg @?= expectedErrMsg Right res -> assertFailure ("Lua operation succeeded unexpectedly and returned " ++ show res) -- | Checks whether the return value of an operation holds for the given -- predicate. shouldHoldForResultOf :: (HasCallStack, Show a) => (a -> Bool) -> Lua a -> Assertion shouldHoldForResultOf predicate luaOp = do errOrRes <- runEither luaOp case errOrRes of Left (Lua.Exception msg) -> assertFailure $ "Lua operation failed with " ++ "message: '" ++ msg ++ "'" Right res -> assertBool ("predicate doesn't hold for " ++ show res) (predicate res) -- | Checks whether the operation returns 'True'. 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 -> LuaE e Bool -> TestTree luaTestBool msg luaOp = testCase msg $ assertBool "Lua operation returned false" =<< run luaOp -- | Infix alias for 'testCase'. (=:) :: String -> Assertion -> TestTree (=:) = testCase infix 3 =: -- | Infix alias for 'luaTestBool'. (?:) :: HasCallStack => String -> LuaE e Bool -> TestTree (?:) = luaTestBool infixr 3 ?: hslua-core-2.3.2/test/lua/0000755000000000000000000000000007346545000013511 5ustar0000000000000000hslua-core-2.3.2/test/lua/error.lua0000644000000000000000000000006107346545000015342 0ustar0000000000000000error 'running this program will cause an error' hslua-core-2.3.2/test/lua/example.lua0000644000000000000000000000021407346545000015644 0ustar0000000000000000--- Compute the n-th fibonacci number. function fib(n) local a, b = 0, 1 for i = 0, (n - 1) do a, b = b, b + a end return a end hslua-core-2.3.2/test/lua/syntax-error.lua0000644000000000000000000000001307346545000016663 0ustar0000000000000000just wrong hslua-core-2.3.2/test/0000755000000000000000000000000007346545000012730 5ustar0000000000000000hslua-core-2.3.2/test/test-hslua-core.hs0000644000000000000000000000062207346545000016303 0ustar0000000000000000{-| Module : Main Copyright : © 2017-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Tests for HsLua.Core. -} import Test.Tasty (TestTree, defaultMain, testGroup) import qualified HsLua.CoreTests -- | Runs tests. main :: IO () main = defaultMain tests -- | HsLua core tests. tests :: TestTree tests = testGroup "hslua-core" [HsLua.CoreTests.tests]