hslua-core (empty) → 1.0.0

raw patch · 21 files changed

+2936/−0 lines, 21 filesdep +QuickCheckdep +basedep +bytestring

Dependencies added: QuickCheck, base, bytestring, exceptions, hslua-core, lua, lua-arbitrary, mtl, quickcheck-instances, tasty, tasty-hunit, tasty-quickcheck, text

Files

• CHANGELOG.md +11/−0
• LICENSE +23/−0
• README.md +75/−0
• hslua-core.cabal +92/−0
• src/HsLua/Core.hs +200/−0
• src/HsLua/Core/Auxiliary.hs +257/−0
• src/HsLua/Core/Error.hs +144/−0
• src/HsLua/Core/Functions.hs +945/−0
• src/HsLua/Core/Run.hs +70/−0
• src/HsLua/Core/Types.hs +321/−0
• src/HsLua/Core/Utf8.hs +45/−0
• test/HsLua/Core/AuxiliaryTests.hs +85/−0
• test/HsLua/Core/ErrorTests.hs +25/−0
• test/HsLua/Core/RunTests.hs +36/−0
• test/HsLua/CoreTests.hs +458/−0
• test/Test/HsLua/Arbitrary.hs +28/−0
• test/Test/Tasty/HsLua.hs +92/−0
• test/lua/error.lua +1/−0
• test/lua/example.lua +8/−0
• test/lua/syntax-error.lua +1/−0
• test/test-hslua-core.hs +19/−0

@@ -0,0 +1,11 @@+# Changelog++`hslua-core` uses [PVP Versioning][1].++[1]: https://pvp.haskell.org++## hslua-core 1.0.0++Released 2021-02-27.++Extracted from hslua-1.3.0.

@@ -0,0 +1,23 @@+Copyright © 1994-2020 Lua.org, PUC-Rio.+Copyright © 2007-2012 Gracjan Polak+Copyright © 2012-2015 Ömer Sinan Ağacan+Copyright © 2016-2021 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.

@@ -0,0 +1,75 @@+# hslua-core++[![Build status][GitHub Actions badge]][GitHub Actions]+[![AppVeyor Status]](https://ci.appveyor.com/project/tarleb/hslua-r2y18)+[![Hackage]](https://hackage.haskell.org/package/hslua-core)++Basic building blocks to interface Haskell and Lua in a+Haskell-idiomatic style.++[GitHub Actions badge]: https://img.shields.io/github/workflow/status/hslua/hslua/CI.svg?logo=github+[GitHub Actions]: https://github.com/hslua/hslua/actions+[AppVeyor Status]: https://ci.appveyor.com/api/projects/status/ldutrilgxhpcau94/branch/main?svg=true+[Hackage]: https://img.shields.io/hackage/v/hslua-core.svg+++Overview+--------++[Lua](https://lua.org) is a small, well-designed, embeddable+scripting language. It has become the de-facto default to make+programs extensible and is widely used everywhere from servers+over games and desktop applications up to security software and+embedded devices. This package provides the basic building blocks+for coders to embed Lua into their programs.++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` package.

@@ -0,0 +1,92 @@+cabal-version:       2.2+name:                hslua-core+version:             1.0.0+synopsis:            Bindings to Lua, an embeddable scripting language+description:         Wrappers and helpers to bridge Haskell and+                     <https://www.lua.org/ Lua>.+                     .+                     It builds upon the /lua/ package, which allows to bundle+                     a Lua interpreter with a Haskell program.+homepage:            https://hslua.github.io/+bug-reports:         https://github.com/hslua/hslua/issues+license:             MIT+license-file:        LICENSE+author:              Albert Krewinkel, Gracjan Polak, Ömer Sinan Ağacan+maintainer:          albert+hslua@zeitkraut.de+copyright:           © 2007–2012 Gracjan Polak;+                     © 2012–2016 Ömer Sinan Ağacan;+                     © 2017-2021 Albert Krewinkel+category:            Foreign+build-type:          Simple+extra-source-files:  README.md+                   , CHANGELOG.md+                   , test/lua/*.lua+tested-with:         GHC == 8.0.2+                   , GHC == 8.2.2+                   , GHC == 8.4.4+                   , GHC == 8.6.5+                   , GHC == 8.8.4+                   , GHC == 8.10.3++source-repository head+  type:                git+  location:            https://github.com/hslua/hslua.git++common common-options+  default-language:    Haskell2010+  build-depends:       base          >= 4.8    && < 5+                     , bytestring    >= 0.10.2 && < 0.11+                     , exceptions    >= 0.8    && < 0.11+                     , lua           >= 2.0    && < 2.1+                     , mtl           >= 2.2    && < 2.3+                     , text          >= 1.0    && < 1.3+  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.Error+                     , HsLua.Core.Run+                     , HsLua.Core.Types+                     , HsLua.Core.Utf8+  other-modules:       HsLua.Core.Auxiliary+                     , HsLua.Core.Functions+  reexported-modules:  lua:Lua+  hs-source-dirs:      src+  default-extensions:  LambdaCase+  other-extensions:    DeriveDataTypeable+                     , DeriveFunctor+                     , FlexibleContexts+                     , FlexibleInstances+                     , ScopedTypeVariables++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.ErrorTests+                     , HsLua.Core.RunTests+                     , 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

@@ -0,0 +1,200 @@+{-|+Module      : HsLua.Core+Copyright   : © 2007–2012 Gracjan Polak;+              © 2012–2016 Ömer Sinan Ağacan;+              © 2017-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+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+  , run'+  , runWith+  , runEither+  -- * Lua Computations+  , Lua (..)+  , runWithConverter+  , unsafeRunWith+  , liftIO+  , state+  , LuaEnvironment (..)+  , ErrorConversion (..)+  , errorConversion+  , unsafeErrorConversion+  -- * Lua API types+  , CFunction+  , Lua.Integer (..)+  , Lua.Number (..)+  -- ** Stack index+  , StackIndex (..)+  , nthTop+  , nthBottom+  , nth+  , top+  -- ** Number of arguments and return values+  , NumArgs (..)+  , NumResults (..)+  -- * Lua API+  -- ** Constants and pseudo-indices+  , multret+  , registryindex+  , upvalueindex+  -- ** State manipulation+  , Lua.State (..)+  , newstate+  , close+  -- ** Basic stack manipulation+  , absindex+  , gettop+  , settop+  , pushvalue+  , copy+  , insert+  , pop+  , remove+  , replace+  , checkstack+  -- ** types and type checks+  , Type (..)+  , TypeCode (..)+  , fromType+  , toType+  , 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 (..)+  , fromRelationalOperator+  , 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+  , newuserdata+  , getmetatable+  -- ** set functions (stack → Lua)+  , setglobal+  , settable+  , setfield+  , rawset+  , rawseti+  , setmetatable+  -- ** load and call functions (load and run Lua code)+  , call+  , pcall+  , load+  , loadbuffer+  , loadfile+  , loadstring+  -- ** Coroutine functions+  , Status (..)+  , toStatus+  , status+  -- ** garbage-collection function and options+  , GCCONTROL (..)+  , gc+  -- ** miscellaneous and helper functions+  , next+  , error+  , concat+  , pushglobaltable+  , register+  -- * loading libraries+  , openbase+  , opendebug+  , openio+  , openlibs+  , openmath+  , openpackage+  , openos+  , openstring+  , opentable+  -- * Auxiliary library+  , dostring+  , dofile+  , getmetafield+  , getmetatable'+  , getsubtable+  , newmetatable+  , tostring'+  , traceback+  -- ** References+  , Reference (..)+  , ref+  , getref+  , unref+  , fromReference+  , toReference+  , noref+  , refnil+  -- ** Registry fields+  , loadedTableRegistryField+  , preloadTableRegistryField+  -- * Error handling+  , Exception (..)+  , throwException+  , catchException+  , withExceptionMessage+  , try+  , throwMessage+  , errorMessage+  , throwErrorAsException+  , throwTopMessage+  , throwTopMessageWithState+  ) where++import Prelude hiding (EQ, LT, compare, concat, error)++import HsLua.Core.Auxiliary+import HsLua.Core.Error+import HsLua.Core.Functions+import HsLua.Core.Run+import HsLua.Core.Types as Lua

@@ -0,0 +1,257 @@+{-# LANGUAGE OverloadedStrings #-}+{-|+Module      : HsLua.Core.Auxiliary+Copyright   : © 2007–2012 Gracjan Polak;+              © 2012–2016 Ömer Sinan Ağacan;+              © 2017-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Stability   : beta+Portability : non-portable (depends on GHC)++Wrappers for the auxiliary library.+-}+module HsLua.Core.Auxiliary+  ( dostring+  , dofile+  , getmetafield+  , getmetatable'+  , getsubtable+  , loadbuffer+  , loadfile+  , loadstring+  , newmetatable+  , newstate+  , tostring'+  , traceback+  -- * References+  , getref+  , ref+  , unref+  -- * Registry fields+  , loadedTableRegistryField+  , preloadTableRegistryField+  ) where++import Control.Exception (IOException, try)+import Data.ByteString (ByteString)+import Foreign.C (withCString)+import HsLua.Core.Types (Lua, Status, StackIndex, liftLua, multret)+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 HsLua.Core.Functions as Lua+import qualified HsLua.Core.Types as Lua+import qualified HsLua.Core.Utf8 as Utf8+import qualified Foreign.Storable as Storable++-- * The Auxiliary Library++-- | Loads and runs the given string.+--+-- Returns 'Lua.OK' on success, or an error if either loading of the+-- string or calling of the thunk failed.+dostring :: ByteString -> Lua Status+dostring s = do+  loadRes <- loadstring s+  if loadRes == Lua.OK+    then Lua.pcall 0 multret Nothing+    else return loadRes++-- | Loads and runs the given file. Note that the filepath is interpreted by+-- Haskell, not Lua. The resulting chunk is named using the UTF8 encoded+-- filepath.+dofile :: FilePath -> Lua Status+dofile fp = do+  loadRes <- loadfile fp+  if loadRes == Lua.OK+    then Lua.pcall 0 multret Nothing+    else return loadRes++-- | Pushes onto the stack the field @e@ from the metatable of the object at+-- index @obj@ and returns the type of the pushed value. If the object does not+-- have a metatable, or if the metatable does not have this field, pushes+-- nothing and returns TypeNil.+getmetafield :: StackIndex -- ^ obj+             -> String     -- ^ e+             -> Lua Lua.Type+getmetafield obj e = liftLua $ \l ->+  withCString e $ fmap Lua.toType . luaL_getmetafield l obj++-- | Pushes onto the stack the metatable associated with name @tname@ in the+-- registry (see @newmetatable@) (@nil@ if there is no metatable associated+-- with that name). Returns the type of the pushed value.+getmetatable' :: String -- ^ tname+              -> Lua Lua.Type+getmetatable' tname = liftLua $ \l ->+  withCString tname $ fmap Lua.toType . luaL_getmetatable l++-- | Push referenced value from the table at the given index.+getref :: StackIndex -> Reference -> Lua ()+getref idx ref' = Lua.rawgeti idx (fromIntegral (Lua.fromReference ref'))++-- | Ensures that the value @t[fname]@, where @t@ is the value at index @idx@,+-- is a table, and pushes that table onto the stack. Returns True if it finds a+-- previous table there and False if it creates a new table.+getsubtable :: StackIndex -> String -> Lua Bool+getsubtable idx fname = do+  -- This is a reimplementation of luaL_getsubtable from lauxlib.c.+  idx' <- Lua.absindex idx+  Lua.pushstring (Utf8.fromString fname)+  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++-- | 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.+--+-- See <https://www.lua.org/manual/5.3/manual.html#luaL_loadbuffer luaL_loadbuffer>.+loadbuffer :: ByteString -- ^ Program to load+           -> String     -- ^ chunk name+           -> Lua Status+loadbuffer bs name = liftLua $ \l ->+  B.useAsCStringLen bs $ \(str, len) ->+  withCString name+    (fmap Lua.toStatus . luaL_loadbuffer l str (fromIntegral len))++-- | Loads a file as a Lua chunk. This function uses @lua_load@ (see+-- @'Lua.load'@) to load the chunk in the file named filename. The first+-- line in the file is ignored if it starts with a @#@.+--+-- The string mode works as in function @'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.+--+-- Note that the file is opened by Haskell, not Lua.+--+-- See <https://www.lua.org/manual/5.3/manual.html#luaL_loadfile luaL_loadfile>.+loadfile :: FilePath -- ^ filename+         -> Lua Status+loadfile fp = Lua.liftIO contentOrError >>= \case+  Right script -> loadbuffer script ("@" ++ fp)+  Left e -> do+    Lua.pushstring (Utf8.fromString (show e))+    return Lua.ErrFile+ where+  contentOrError :: IO (Either IOException ByteString)+  contentOrError = try (B.readFile fp)+++-- | 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 <https://www.lua.org/manual/5.3/manual.html#luaL_loadstring luaL_loadstring>.+loadstring :: ByteString -> Lua Status+loadstring s = loadbuffer s (Utf8.toString s)+++-- | 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.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#luaL_newmetatable luaL_newmetatable>.+newmetatable :: String -> Lua Bool+newmetatable tname = liftLua $ \l ->+  Lua.fromLuaBool <$> withCString tname (luaL_newmetatable l)++-- | Creates a new Lua state. It calls @lua_newstate@ with an allocator+-- based on the standard C @realloc@ function and then sets a panic+-- function (see <https://www.lua.org/manual/5.3/manual.html#4.6 §4.6>+-- of the Lua 5.3 Reference Manual) that prints an error message to the+-- standard error output in case of fatal errors.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#luaL_newstate luaL_newstate>.+newstate :: IO Lua.State+newstate = hsluaL_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'@.+--+-- See also: <https://www.lua.org/manual/5.3/manual.html#luaL_ref luaL_ref>.+ref :: StackIndex -> Lua Reference+ref t = liftLua $ \l -> Lua.toReference <$> luaL_ref l t++-- | Converts any Lua value at the given index to a @'ByteString'@ in a+-- reasonable format. The resulting string is pushed onto the stack and also+-- returned by the function.+--+-- If the value has a metatable with a @__tostring@ field, then @tolstring'@+-- calls the corresponding metamethod with the value as argument, and uses the+-- result of the call as its result.+tostring' :: StackIndex -> Lua B.ByteString+tostring' n = do+  l <- Lua.state+  e <- Lua.errorConversion+  Lua.liftIO $ alloca $ \lenPtr -> do+    cstr <- hsluaL_tolstring l n lenPtr+    if cstr == nullPtr+      then Lua.errorToException e l+      else do+        cstrLen <- Storable.peek lenPtr+        B.packCStringLen (cstr, fromIntegral cstrLen)++-- | Creates and pushes a traceback of the stack L1. If a message is given it+-- appended at the beginning of the traceback. The level parameter tells at+-- which level to start the traceback.+traceback :: Lua.State -> Maybe String -> Int -> Lua ()+traceback l1 msg level = liftLua $ \l ->+  case msg of+    Nothing -> luaL_traceback l l1 nullPtr (fromIntegral level)+    Just msg' -> withCString msg' $ \cstr ->+      luaL_traceback l l1 cstr (fromIntegral level)++-- | Releases reference @'ref'@ from the table at index @idx@ (see @'ref'@). The+-- entry is removed from the table, so that the referred object can be+-- collected. The reference @'ref'@ is also freed to be used again.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#luaL_unref luaL_unref>.+unref :: StackIndex -- ^ idx+      -> Reference  -- ^ ref+      -> Lua ()+unref idx r = liftLua $ \l ->+  luaL_unref l idx (Lua.fromReference r)

@@ -0,0 +1,144 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# OPTIONS_GHC -fno-warn-orphans       #-}+{-|+Module      : HsLua.Core.Error+Copyright   : © 2017-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Stability   : beta+Portability : DeriveDataTypeable++Lua exceptions and exception handling.+-}+module HsLua.Core.Error+  ( Exception (..)+  , catchException+  , throwException+  , withExceptionMessage+  , throwErrorAsException+  , throwTopMessage+  , throwTopMessageWithState+  , errorMessage+  , try+    -- * Helpers for hslua C wrapper functions.+  , throwMessage+  , liftLuaThrow+  ) where++import Control.Applicative (Alternative (..))+import Data.ByteString (ByteString)+import Data.Typeable (Typeable)+import HsLua.Core.Types (Lua)+import Lua (lua_pop, lua_pushlstring, hsluaL_tolstring)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Ptr++import 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 Lua.Types as Lua+import qualified HsLua.Core.Types as Lua+import qualified HsLua.Core.Utf8 as Utf8++-- | 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++-- | Raise a Lua @'Exception'@ containing the given error message.+throwException :: String -> Lua a+throwException = Catch.throwM . Exception+{-# INLINABLE throwException #-}++-- | Catch a Lua @'Exception'@.+catchException :: Lua a -> (Exception -> Lua a) -> Lua a+catchException = Catch.catch+{-# INLINABLE catchException #-}++-- | Catch Lua @'Exception'@, alter the message and rethrow.+withExceptionMessage :: (String -> String) -> Lua a -> Lua a+withExceptionMessage modifier luaOp =+  luaOp `catchException` \(Exception msg) -> throwException (modifier msg)+{-# INLINABLE withExceptionMessage #-}++-- | Return either the result of a Lua computation or, if an exception was+-- thrown, the error.+try :: Lua a -> Lua (Either Exception a)+try = Catch.try+{-# INLINABLE try #-}++-- | Convert a Lua error into a Haskell exception. The error message is+-- expected to be at the top of the stack.+throwErrorAsException :: Lua a+throwErrorAsException = do+  e <- Lua.errorConversion+  l <- Lua.state+  Lua.liftIO (Lua.errorToException e l)++-- | Alias for `throwErrorAsException`; will be deprecated in the next+-- mayor release.+throwTopMessage :: Lua a+throwTopMessage = throwErrorAsException++-- | Helper function which uses proper error-handling to throw an+-- exception with the given message.+throwMessage :: String -> Lua a+throwMessage msg = do+  Lua.liftLua $ \l ->+    B.unsafeUseAsCStringLen (Utf8.fromString msg) $ \(msgPtr, z) ->+      lua_pushlstring l msgPtr (fromIntegral z)+  e <- Lua.errorConversion+  Lua.liftLua (Lua.errorToException e)++instance Alternative Lua where+  empty = throwMessage "empty"+  x <|> y = do+    e <- Lua.errorConversion+    Lua.alternative e x y++-- | Convert the object at the top of the stack into a string and throw+-- it as a HsLua @'Exception'@.+--+-- This function serves as the default to convert Lua errors to Haskell+-- exceptions.+throwTopMessageWithState :: Lua.State -> IO a+throwTopMessageWithState l = do+  msg <- Lua.liftIO (errorMessage l)+  Catch.throwM $ Exception (Utf8.toString msg)++-- | Takes a failable HsLua function and transforms it into a+-- monadic 'Lua' operation. Throws an exception if an error+-- occured.+liftLuaThrow :: (Lua.State -> Ptr Lua.StatusCode -> IO a) -> Lua a+liftLuaThrow f = do+  (result, status) <- Lua.liftLua $ \l -> alloca $ \statusPtr -> do+    result <- f l statusPtr+    status <- Lua.toStatus <$> Storable.peek statusPtr+    return (result, status)+  if status == Lua.OK+    then return result+    else throwTopMessage++-- | Retrieve and pop the top object as an error message. This is very similar+-- to tostring', but ensures that we don't recurse if getting the message+-- failed.+errorMessage :: Lua.State -> IO ByteString+errorMessage l = alloca $ \lenPtr -> do+  cstr <- hsluaL_tolstring l (-1) lenPtr+  if cstr == nullPtr+    then return $ Char8.pack ("An error occurred, but the error object " +++                              "cannot be converted into a string.")+    else do+      cstrLen <- Storable.peek lenPtr+      msg <- B.packCStringLen (cstr, fromIntegral cstrLen)+      lua_pop l 2+      return msg

@@ -0,0 +1,945 @@+{-|+Module      : HsLua.Core.Functions+Copyright   : © 2007–2012 Gracjan Polak;+              © 2012–2016 Ömer Sinan Ağacan;+              © 2017-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Stability   : beta+Portability : non-portable (depends on GHC)++Monadic functions which operate within the Lua type.++The functions in this module are mostly just thin wrappers around the respective+C functions. However, C function which can throw an error are wrapped such that+the error is converted into an @'Exception'@. Memory allocation errors,+however, are not caught and will cause the host program to terminate.+-}+module HsLua.Core.Functions where++import Prelude hiding (EQ, LT, compare, concat, error)++import Control.Monad+import Data.ByteString (ByteString)+import Data.Maybe (fromMaybe)+import HsLua.Core.Error+import HsLua.Core.Types as Lua+import Lua+import Foreign.Marshal.Alloc (alloca)+import Foreign.Ptr++import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import qualified Foreign.C as C+import qualified HsLua.Core.Utf8 as Utf8+import qualified Foreign.Storable as F++--+-- Helper functions+--++-- | Execute an action only if the given index is a table. Throw an+-- error otherwise.+ensureTable :: StackIndex -> (Lua.State -> IO ()) -> Lua ()+ensureTable idx ioOp = do+  isTbl <- istable idx+  if isTbl+    then liftLua ioOp+    else do+      tyName <- ltype idx >>= typename+      throwMessage ("table expected, got " ++ tyName)++--+-- API functions+--++-- | Converts the acceptable index @idx@ into an equivalent absolute index (that+-- is, one that does not depend on the stack top).+absindex :: StackIndex -> Lua StackIndex+absindex = liftLua1 lua_absindex++-- |  Calls a function.+--+-- To call a function you must use the following protocol: first, the function+-- to be called is pushed onto the stack; then, the arguments to the function+-- are pushed in direct order; that is, the first argument is pushed first.+-- Finally you call @call@; @nargs@ is the number of arguments that you pushed+-- onto the stack. All arguments and the function value are popped from the+-- stack when the function is called. The function results are pushed onto the+-- stack when the function returns. The number of results is adjusted to+-- @nresults@, unless @nresults@ is @multret@. In this case, all results from+-- the function are pushed. Lua takes care that the returned values fit into the+-- stack space. The function results are pushed onto the stack in direct order+-- (the first result is pushed first), so that after the call the last result is+-- on the top of the stack.+--+-- Any error inside the called function cause a @'Exception'@ to be thrown.+--+-- The following example shows how the host program can do the equivalent to+-- this Lua code:+--+-- > a = f("how", t.x, 14)+--+-- Here it is in Haskell (assuming the OverloadedStrings language extension):+--+-- > getglobal "f"         -- function to be called+-- > pushstring  "how"     -- 1st argument+-- > getglobal "t"         -- table to be indexed+-- > getfield (-1) "x"     -- push result of t.x (2nd arg)+-- > remove (-2)           -- remove 't' from the stack+-- > pushinteger 14        -- 3rd argument+-- > call 3 1              -- call 'f' with 3 arguments and 1 result+-- > setglobal "a"         -- set global 'a'+--+-- Note that the code above is "balanced": at its end, the stack is back to its+-- original configuration. This is considered good programming practice.+--+-- See <https://www.lua.org/manual/5.3/manual.html#lua_call lua_call>.+call :: NumArgs -> NumResults -> Lua ()+call nargs nresults = do+  res <- pcall nargs nresults Nothing+  when (res /= OK) throwTopMessage++-- | Ensures that the stack has space for at least @n@ extra slots (that is,+-- that you can safely push up to @n@ values into it). It returns false if it+-- cannot fulfill the request, either because it would cause the stack to be+-- larger than a fixed maximum size (typically at least several thousand+-- elements) or because it cannot allocate memory for the extra space. This+-- function never shrinks the stack; if the stack already has space for the+-- extra slots, it is left unchanged.+--+-- This is a wrapper function of+-- <https://www.lua.org/manual/5.3/manual.html#lua_checkstack lua_checkstack>.+checkstack :: Int -> Lua Bool+checkstack n = liftLua $ \l -> fromLuaBool <$> lua_checkstack l (fromIntegral n)++-- | Destroys all objects in the given Lua state (calling the corresponding+-- garbage-collection metamethods, if any) and frees all dynamic memory used by+-- this state. On several platforms, you may not need to call this function,+-- because all resources are naturally released when the host program ends. On+-- the other hand, long-running programs that create multiple states, such as+-- daemons or web servers, will probably need to close states as soon as they+-- are not needed.+--+-- This is a wrapper function of+-- <https://www.lua.org/manual/5.3/manual.html#lua_close lua_close>.+close :: Lua.State -> IO ()+close = lua_close++-- | Compares two Lua values. Returns @True@ if the value at index @idx1@+-- satisfies @op@ when compared with the value at index @idx2@, following the+-- semantics of the corresponding Lua operator (that is, it may call+-- metamethods). Otherwise returns @False@. Also returns @False@ if any of the+-- indices is not valid.+--+-- The value of op must be of type @RelationalOperator@:+--+--    EQ: compares for equality (==)+--    LT: compares for less than (<)+--    LE: compares for less or equal (<=)+--+-- This is a wrapper function of+-- <https://www.lua.org/manual/5.3/manual.html#lua_compare lua_compare>.+compare :: StackIndex -> StackIndex -> RelationalOperator -> Lua Bool+compare idx1 idx2 relOp = fromLuaBool <$> do+  liftLuaThrow $ \l -> hslua_compare l idx1 idx2 (fromRelationalOperator relOp)++-- | Concatenates the @n@ values at the top of the stack, pops them, and leaves+-- the result at the top. If @n@ is 1, the result is the single value on the+-- stack (that is, the function does nothing); if @n@ is 0, the result is the+-- empty string. Concatenation is performed following the usual semantics of Lua+-- (see <https://www.lua.org/manual/5.3/manual.html#3.4.6 §3.4.6> of the lua+-- manual).+--+-- This is a wrapper function of+-- <https://www.lua.org/manual/5.3/manual.html#lua_concat lua_concat>.+concat :: NumArgs -> Lua ()+concat n = liftLuaThrow (`hslua_concat` n)++-- | Copies the element at index @fromidx@ into the valid index @toidx@,+-- replacing the value at that position. Values at other positions are not+-- affected.+--+-- See also <https://www.lua.org/manual/5.3/manual.html#lua_copy lua_copy> in+-- the lua manual.+copy :: StackIndex -> StackIndex -> Lua ()+copy fromidx toidx = liftLua $ \l -> lua_copy l fromidx toidx++-- | Creates a new empty table and pushes it onto the stack. Parameter narr is a+-- hint for how many elements the table will have as a sequence; parameter nrec+-- is a hint for how many other elements the table will have. Lua may use these+-- hints to preallocate memory for the new table. This preallocation is useful+-- for performance when you know in advance how many elements the table will+-- have. Otherwise you can use the function lua_newtable.+--+-- This is a wrapper for function+-- <https://www.lua.org/manual/5.3/manual.html#lua_createtable lua_createtable>.+createtable :: Int -> Int -> Lua ()+createtable narr nrec = liftLua $ \l ->+  lua_createtable l (fromIntegral narr) (fromIntegral nrec)++-- TODO: implement dump++-- | Returns @True@ if the two values in acceptable indices index1 and+-- index2 are equal, following the semantics of the Lua @==@ operator+-- (that is, may call metamethods). Otherwise returns @False@. Also+-- returns @False@ if any of the indices is non valid. Uses @'compare'@+-- internally.+equal :: StackIndex  -- ^ index1+      -> StackIndex  -- ^ index2+      -> Lua Bool+equal index1 index2 = compare index1 index2 EQ++-- | This is a convenience function to implement error propagation+-- convention described in [Error handling in hslua](#g:1). hslua+-- doesn't implement the @lua_error@ function from Lua C API because+-- it's never safe to use. (see [Error handling in hslua](#g:1) for+-- details)+error :: Lua NumResults+error = liftLua hslua_error++-- |  Controls the garbage collector.+--+-- This function performs several tasks, according to the value of the parameter+-- what:+--+--   * @'GCSTOP'@: stops the garbage collector.+--+--   * @'GCRESTART'@: restarts the garbage collector.+--+--   * @'GCCOLLECT'@: performs a full garbage-collection cycle.+--+--   * @'GCCOUNT'@: returns the current amount of memory (in Kbytes) in use by+--     Lua.+--+--   * @'GCCOUNTB'@: returns the remainder of dividing the current amount of+--     bytes of memory in use by Lua by 1024.+--+--   * @'GCSTEP'@: performs an incremental step of garbage collection. The step+--     "size" is controlled by data (larger values mean more steps) in a+--     non-specified way. If you want to control the step size you must+--     experimentally tune the value of data. The function returns 1 if the step+--     finished a garbage-collection cycle.+--+--   * @'GCSETPAUSE@': sets data as the new value for the pause of the collector+--     (see §2.10). The function returns the previous value of the pause.+--+--   * @'GCSETSTEPMUL'@: sets data as the new value for the step multiplier of+--     the collector (see §2.10). The function returns the previous value of the+--     step multiplier.+--+-- See <https://www.lua.org/manual/5.3/manual.html#lua_gc lua_gc>.+gc :: GCCONTROL -> Int -> Lua Int+gc what data' = liftLua $ \l ->+  fromIntegral <$> lua_gc l (toGCCode what) (fromIntegral data')++-- | Pushes onto the stack the value @t[k]@, where @t@ is the value at the given+-- stack index. As in Lua, this function may trigger a metamethod for the+-- "index" event (see <https://www.lua.org/manual/5.3/manual.html#2.4 §2.4> of+-- lua's manual).+--+-- Errors on the Lua side are caught and rethrown as @'Exception'@.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_getfield lua_getfield>.+getfield :: StackIndex -> String -> Lua Type+getfield i s = do+  absidx <- absindex i+  pushstring (Utf8.fromString s)+  gettable absidx++-- | Pushes onto the stack the value of the global @name@.+--+-- Errors on the Lua side are caught and rethrown as @'Exception'@.+--+-- Wrapper of+-- <https://www.lua.org/manual/5.3/manual.html#lua_getglobal lua_getglobal>.+getglobal :: String -> Lua Type+getglobal name = liftLuaThrow $ \l status' ->+  C.withCStringLen name $ \(namePtr, len) ->+  toType <$> hslua_getglobal l namePtr (fromIntegral len) status'++-- | If the value at the given index has a metatable, the function pushes that+-- metatable onto the stack and returns @True@. Otherwise, the function returns+-- @False@ and pushes nothing on the stack.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_getmetatable lua_getmetatable>.+getmetatable :: StackIndex -> Lua Bool+getmetatable n = liftLua $ \l ->+  fromLuaBool <$> lua_getmetatable l n++-- | Pushes onto the stack the value @t[k]@, where @t@ is the value at the given+-- index and @k@ is the value at the top of the stack.+--+-- This function pops the key from the stack, pushing the resulting value in its+-- place. As in Lua, this function may trigger a metamethod for the "index"+-- event (see <https://www.lua.org/manual/5.3/manual.html#2.4 §2.4> of lua's+-- manual).+--+-- Errors on the Lua side are caught and rethrown as @'Exception'@.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_gettable lua_gettable>.+gettable :: StackIndex -> Lua Type+gettable n = liftLuaThrow (\l -> fmap toType . hslua_gettable l n)++-- | Returns the index of the top element in the stack. Because indices start at+-- 1, this result is equal to the number of elements in the stack (and so 0+-- means an empty stack).+--+-- See also: <https://www.lua.org/manual/5.3/manual.html#lua_gettop lua_gettop>.+gettop :: Lua StackIndex+gettop = liftLua lua_gettop++-- | Moves the top element into the given valid index, shifting up the elements+-- above this index to open space. This function cannot be called with a+-- pseudo-index, because a pseudo-index is not an actual stack position.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_insert lua_insert>.+insert :: StackIndex -> Lua ()+insert index = liftLua $ \l -> lua_insert l index++-- | Returns @True@ if the value at the given index is a boolean, and @False@+-- otherwise.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_isboolean lua_isboolean>.+isboolean :: StackIndex -> Lua Bool+isboolean n = liftLua $ \l -> fromLuaBool <$> lua_isboolean l n++-- | Returns @True@ if the value at the given index is a C function, and @False@+-- otherwise.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_iscfunction lua_iscfunction>.+iscfunction :: StackIndex -> Lua Bool+iscfunction n = liftLua $ \l -> fromLuaBool <$> lua_iscfunction l n++-- | Returns @True@ if the value at the given index is a function (either C or+-- Lua), and @False@ otherwise.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_isfunction lua_isfunction>.+isfunction :: StackIndex -> Lua Bool+isfunction n = (== TypeFunction) <$> ltype n++-- | Returns @True@ if the value at the given index is an integer (that is, the+-- value is a number and is represented as an integer), and @False@ otherwise.+isinteger :: StackIndex -> Lua Bool+isinteger n = liftLua $ \l -> fromLuaBool <$> lua_isinteger l n++-- | Returns @True@ if the value at the given index is a light userdata, and+-- @False@ otherwise.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_islightuserdata \+-- lua_islightuserdata>.+islightuserdata :: StackIndex -> Lua Bool+islightuserdata n = (== TypeLightUserdata) <$> ltype n++-- | Returns @True@ if the value at the given index is @nil@, and @False@+-- otherwise.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_isnil lua_isnil>.+isnil :: StackIndex -> Lua Bool+isnil n = (== TypeNil) <$> ltype n++-- | Returns @True@ if the given index is not valid, and @False@ otherwise.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_isnone lua_isnone>.+isnone :: StackIndex -> Lua Bool+isnone n = (== TypeNone) <$> ltype n++-- | Returns @True@ if the given index is not valid or if the value at the given+-- index is @nil@, and @False@ otherwise.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_isnoneornil lua_isnoneornil>.+isnoneornil :: StackIndex -> Lua Bool+isnoneornil idx = (<= TypeNil) <$> ltype idx++-- | Returns @True@ if the value at the given index is a number or a string+-- convertible to a number, and @False@ otherwise.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_isnumber lua_isnumber>.+isnumber :: StackIndex -> Lua Bool+isnumber n = liftLua $ \l -> fromLuaBool <$> lua_isnumber l n++-- | Returns @True@ if the value at the given index is a string or a number+-- (which is always convertible to a string), and @False@ otherwise.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_isstring lua_isstring>.+isstring :: StackIndex -> Lua Bool+isstring n = liftLua $ \l -> fromLuaBool <$> lua_isstring l n++-- | Returns @True@ if the value at the given index is a table, and @False@+-- otherwise.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_istable lua_istable>.+istable :: StackIndex -> Lua Bool+istable n = (== TypeTable) <$> ltype n++-- | Returns @True@ if the value at the given index is a thread, and @False@+-- otherwise.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_isthread lua_isthread>.+isthread :: StackIndex -> Lua Bool+isthread n = (== TypeThread) <$> ltype n++-- | Returns @True@ if the value at the given index is a userdata (either full+-- or light), and @False@ otherwise.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_isuserdata lua_isuserdata>.+isuserdata :: StackIndex -> Lua Bool+isuserdata n = liftLua $ \l -> fromLuaBool <$> lua_isuserdata l n++-- | Tests whether the object under the first index is smaller than that under+-- the second. Uses @'compare'@ internally.+lessthan :: StackIndex -> StackIndex -> Lua Bool+lessthan index1 index2 = compare index1 index2 LT++-- | Loads a Lua chunk (without running it). If there are no errors, @'load'@+-- pushes the compiled chunk as a Lua function on top of the stack. Otherwise,+-- it pushes an error message.+--+-- The return values of @'load'@ are:+--+-- - @'OK'@: no errors;+-- - @'ErrSyntax'@: syntax error during pre-compilation;+-- - @'ErrMem'@: memory allocation error;+-- - @'ErrGcmm'@: error while running a @__gc@ metamethod. (This error has no+--   relation with the chunk being loaded. It is generated by the garbage+--   collector.)+--+-- This function only loads a chunk; it does not run it.+--+-- @load@ automatically detects whether the chunk is text or binary, and loads+-- it accordingly (see program luac).+--+-- The @'load'@ function uses a user-supplied reader function to read the chunk+-- (see @'Lua.Reader'@). The data argument is an opaque value passed to the+-- reader function.+--+-- The @chunkname@ argument gives a name to the chunk, which is used for error+-- messages and in debug information (see+-- <https://www.lua.org/manual/5.3/manual.html#4.9 §4.9>). Note that the+-- @chunkname@ is used as a C string, so it may not contain null-bytes.+load :: Lua.Reader -> Ptr () -> ByteString -> Lua Status+load reader data' chunkname = liftLua $ \l ->+  B.useAsCString chunkname $ \namePtr ->+  toStatus <$> lua_load l reader data' namePtr nullPtr++-- | Returns the type of the value in the given valid index, or @'TypeNone'@ for+-- a non-valid (but acceptable) index.+--+-- See <https://www.lua.org/manual/5.3/manual.html#lua_type lua_type>.+ltype :: StackIndex -> Lua Type+ltype idx = toType <$> liftLua (`lua_type` idx)++-- | Creates a new empty table and pushes it onto the stack. It is equivalent to+-- @createtable 0 0@.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_newtable lua_newtable>.+newtable :: Lua ()+newtable = createtable 0 0++-- | This function allocates a new block of memory with the given size, pushes+-- onto the stack a new full userdata with the block address, and returns this+-- address. The host program can freely use this memory.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_newuserdata lua_newuserdata>.+newuserdata :: Int -> Lua (Ptr ())+newuserdata = liftLua1 lua_newuserdata . fromIntegral++-- | Pops a key from the stack, and pushes a key–value pair from the table at+-- the given index (the "next" pair after the given key). If there are no more+-- elements in the table, then @next@ returns @False@ (and pushes nothing).+--+-- Errors on the Lua side are caught and rethrown as a @'Exception'@.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_next lua_next>.+next :: StackIndex -> Lua Bool+next idx = fromLuaBool <$> liftLuaThrow (\l -> hslua_next l idx)++-- | Opens all standard Lua libraries into the current state and sets each+-- library name as a global value.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#luaL_openlibs luaL_openlibs>.+openlibs :: Lua ()+openlibs = liftLua luaL_openlibs++-- | Pushes Lua's /base/ library onto the stack.+--+-- See <https://www.lua.org/manual/5.3/manual.html#pdf-luaopen_base luaopen_base>.+openbase :: Lua ()+openbase = pushcfunction luaopen_base *> call 0 multret++-- | Pushes Lua's /debug/ library onto the stack.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#pdf-luaopen_debug luaopen_debug>.+opendebug :: Lua ()+opendebug = pushcfunction luaopen_debug *> call 0 multret++-- | Pushes Lua's /io/ library onto the stack.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#pdf-luaopen_io luaopen_io>.+openio :: Lua ()+openio = pushcfunction luaopen_io *> call 0 multret++-- | Pushes Lua's /math/ library onto the stack.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#pdf-luaopen_math luaopen_math>.+openmath :: Lua ()+openmath = pushcfunction luaopen_math *> call 0 multret++-- | Pushes Lua's /os/ library onto the stack.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#pdf-luaopen_os luaopen_os>.+openos :: Lua ()+openos = pushcfunction luaopen_os *> call 0 multret++-- | Pushes Lua's /package/ library onto the stack.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#pdf-luaopen_package luaopen_package>.+openpackage :: Lua ()+openpackage = pushcfunction luaopen_package *> call 0 multret++-- | Pushes Lua's /string/ library onto the stack.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#pdf-luaopen_string luaopen_string>.+openstring :: Lua ()+openstring = pushcfunction luaopen_string *> call 0 multret++-- | Pushes Lua's /table/ library onto the stack.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#pdf-luaopen_table luaopen_table>.+opentable :: Lua ()+opentable = pushcfunction luaopen_table *> call 0 multret++-- | Calls a function in protected mode.+--+-- Both @nargs@ and @nresults@ have the same meaning as in @'call'@. If there+-- are no errors during the call, @pcall@ behaves exactly like @'call'@.+-- However, if there is any error, @pcall@ catches it, pushes a single value on+-- the stack (the error message), and returns the error code. Like @'call'@,+-- @pcall@ always removes the function and its arguments from the stack.+--+-- If @msgh@ is @Nothing@, then the error object returned on the stack is+-- exactly the original error object. Otherwise, when @msgh@ is @Just idx@, the+-- stack index @idx@ is the location of a message handler. (This index cannot be+-- a pseudo-index.) In case of runtime errors, this function will be called with+-- the error object and its return value will be the object returned on the+-- stack by @'pcall'@.+--+-- Typically, the message handler is used to add more debug information to the+-- error object, such as a stack traceback. Such information cannot be gathered+-- after the return of @'pcall'@, since by then the stack has unwound.+--+-- See <https://www.lua.org/manual/5.3/manual.html#lua_pcall lua_pcall>.+pcall :: NumArgs -> NumResults -> Maybe StackIndex -> Lua Status+pcall nargs nresults msgh = liftLua $ \l ->+  toStatus <$> lua_pcall l nargs nresults (fromMaybe 0 msgh)++-- | Pops @n@ elements from the stack.+--+-- See also: <https://www.lua.org/manual/5.3/manual.html#lua_pop lua_pop>.+pop :: Int -> Lua ()+pop n = liftLua $ \l -> lua_pop l (fromIntegral n)++-- | Pushes a boolean value with the given value onto the stack.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_pushboolean lua_pushboolean>.+pushboolean :: Bool -> Lua ()+pushboolean b = liftLua $ \l -> lua_pushboolean l (toLuaBool b)++-- | Pushes a new C closure onto the stack.+--+-- When a C function is created, it is possible to associate some values with+-- it, thus creating a C closure (see+-- <https://www.lua.org/manual/5.1/manual.html#3.4 §3.4>); these values are then+-- accessible to the function whenever it is called. To associate values with a+-- C function, first these values should be pushed onto the stack (when there+-- are multiple values, the first value is pushed first). Then lua_pushcclosure+-- is called to create and push the C function onto the stack, with the argument+-- @n@ telling how many values should be associated with the function.+-- lua_pushcclosure also pops these values from the stack.+--+-- The maximum value for @n@ is 255.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_pushcclosure lua_pushcclosure>.+pushcclosure :: CFunction -> NumArgs -> Lua ()+pushcclosure f n = liftLua $ \l -> lua_pushcclosure l f n++-- | Pushes a C function onto the stack. This function receives a pointer to a C+-- function and pushes onto the stack a Lua value of type function that, when+-- called, invokes the corresponding C function.+--+-- Any function to be callable by Lua must follow the correct protocol to+-- receive its parameters and return its results (see @'CFunction'@)+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_pushcfunction lua_pushcfunction>.+pushcfunction :: CFunction -> Lua ()+pushcfunction f = pushcclosure f 0++-- | Pushes the global environment onto the stack.+--+-- Wraps <https://www.lua.org/manual/5.3/manual.html#lua_pushglobaltable \+-- lua_pushglobaltable>.+pushglobaltable :: Lua ()+pushglobaltable = liftLua lua_pushglobaltable++-- | Pushes an integer with with the given value onto the stack.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_pushinteger lua_pushinteger>.+pushinteger :: Lua.Integer -> Lua ()+pushinteger = liftLua1 lua_pushinteger++-- |  Pushes a light userdata onto the stack.+--+-- Userdata represent C values in Lua. A light userdata represents a pointer, a+-- @Ptr ()@ (i.e., @void*@ in C lingo). It is a value (like a number): you do+-- not create it, it has no individual metatable, and it is not collected (as it+-- was never created). A light userdata is equal to "any" light userdata with+-- the same C address.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_pushlightuserdata lua_pushlightuserdata>.+pushlightuserdata :: Ptr a -> Lua ()+pushlightuserdata = liftLua1 lua_pushlightuserdata++-- | Pushes a nil value onto the stack.+--+-- See <https://www.lua.org/manual/5.3/manual.html#lua_pushnil lua_pushnil>.+pushnil :: Lua ()+pushnil = liftLua lua_pushnil++-- | Pushes a float with the given value onto the stack.+--+-- See <https://www.lua.org/manual/5.3/manual.html#lua_pushnumber lua_pushnumber>.+pushnumber :: Lua.Number -> Lua ()+pushnumber = liftLua1 lua_pushnumber++-- | Pushes the zero-terminated string pointed to by s onto the stack. Lua makes+-- (or reuses) an internal copy of the given string, so the memory at s can be+-- freed or reused immediately after the function returns.+--+-- See also: <https://www.lua.org/manual/5.3/manual.html#lua_pushstring \+-- lua_pushstring>.+pushstring :: ByteString -> Lua ()+pushstring s = liftLua $ \l ->+  B.unsafeUseAsCStringLen s $ \(sPtr, z) -> lua_pushlstring l sPtr (fromIntegral z)++-- | Pushes the current thread onto the stack. Returns @True@ if this thread is+-- the main thread of its state, @False@ otherwise.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_pushthread lua_pushthread>.+pushthread :: Lua Bool+pushthread = (1 ==)  <$> liftLua lua_pushthread++-- | Pushes a copy of the element at the given index onto the stack.+--+-- See <https://www.lua.org/manual/5.3/manual.html#lua_pushvalue lua_pushvalue>.+pushvalue :: StackIndex -> Lua ()+pushvalue n = liftLua $ \l -> lua_pushvalue l n++-- | Returns @True@ if the two values in indices @idx1@ and @idx2@ are+-- primitively equal (that is, without calling the @__eq@ metamethod). Otherwise+-- returns @False@. Also returns @False@ if any of the indices are not valid.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_rawequal lua_rawequal>.+rawequal :: StackIndex -> StackIndex -> Lua Bool+rawequal idx1 idx2 = liftLua $ \l ->+  fromLuaBool <$> lua_rawequal l idx1 idx2++-- | Similar to @'gettable'@, but does a raw access (i.e., without metamethods).+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_rawget lua_rawget>.+rawget :: StackIndex -> Lua ()+rawget n = ensureTable n (\l -> lua_rawget l n)++-- | Pushes onto the stack the value @t[n]@, where @t@ is the table at the given+-- index. The access is raw, that is, it does not invoke the @__index@+-- metamethod.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_rawgeti lua_rawgeti>.+rawgeti :: StackIndex -> Lua.Integer -> Lua ()+rawgeti k n = ensureTable k (\l -> lua_rawgeti l k n)++-- | Returns the raw "length" of the value at the given index: for strings, this+-- is the string length; for tables, this is the result of the length operator+-- (@#@) with no metamethods; for userdata, this is the size of the block of+-- memory allocated for the userdata; for other values, it is 0.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_rawlen lua_rawlen>.+rawlen :: StackIndex -> Lua Int+rawlen idx = liftLua $ \l -> fromIntegral <$> lua_rawlen l idx++-- | Similar to @'settable'@, but does a raw assignment (i.e., without+-- metamethods).+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_rawset lua_rawset>.+rawset :: StackIndex -> Lua ()+rawset n = ensureTable n (\l -> lua_rawset l n)++-- | Does the equivalent of @t[i] = v@, where @t@ is the table at the given+-- index and @v@ is the value at the top of the stack.+--+-- This function pops the value from the stack. The assignment is raw, that is,+-- it does not invoke the @__newindex@ metamethod.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_rawseti lua_rawseti>.+rawseti :: StackIndex -> Lua.Integer -> Lua ()+rawseti k m = ensureTable k (\l -> lua_rawseti l k m)++-- | Sets the C function @f@ as the new value of global @name@.+--+-- See <https://www.lua.org/manual/5.3/manual.html#lua_register lua_register>.+register :: String -> CFunction -> Lua ()+register name f = do+  pushcfunction f+  setglobal name++-- | Removes the element at the given valid index, shifting down the elements+-- above this index to fill the gap. This function cannot be called with a+-- pseudo-index, because a pseudo-index is not an actual stack position.+--+-- See <https://www.lua.org/manual/5.3/manual.html#lua_remove lua_remove>.+remove :: StackIndex -> Lua ()+remove n = liftLua $ \l -> lua_remove l n++-- | Moves the top element into the given valid index without shifting any+-- element (therefore replacing the value at that given index), and then pops+-- the top element.+--+-- See <https://www.lua.org/manual/5.3/manual.html#lua_replace lua_replace>.+replace :: StackIndex -> Lua ()+replace n = liftLua $ \l ->  lua_replace l n++-- | Does the equivalent to @t[k] = v@, where @t@ is the value at the given+-- index and @v@ is the value at the top of the stack.+--+-- This function pops the value from the stack. As in Lua, this function may+-- trigger a metamethod for the "newindex" event (see+-- <https://www.lua.org/manual/5.3/manual.html#2.4 §2.4> of the Lua 5.3+-- Reference Manual).+--+-- Errors on the Lua side are caught and rethrown as a @'Exception'@.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_setfield lua_setfield>.+setfield :: StackIndex -> String -> Lua ()+setfield i s = do+  absidx <- absindex i+  pushstring (Utf8.fromString s)+  insert (nthTop 2)+  settable absidx++-- | Pops a value from the stack and sets it as the new value of global @name@.+--+-- Errors on the Lua side are caught and rethrown as a @'Exception'@.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_setglobal lua_setglobal>.+setglobal :: String -> Lua ()+setglobal name = liftLuaThrow $ \l status' ->+  C.withCStringLen name $ \(namePtr, nameLen) ->+  hslua_setglobal l namePtr (fromIntegral nameLen) status'++-- | Pops a table from the stack and sets it as the new metatable for the value+-- at the given index.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_setmetatable \+-- lua_setmetatable>.+setmetatable :: StackIndex -> Lua ()+setmetatable idx = liftLua $ \l -> lua_setmetatable l idx++-- | Does the equivalent to @t[k] = v@, where @t@ is the value at the given+-- index, @v@ is the value at the top of the stack, and @k@ is the value just+-- below the top.+--+-- This function pops both the key and the value from the stack. As in Lua, this+-- function may trigger a metamethod for the "newindex" event (see+-- <https://www.lua.org/manual/5.3/manual.html#2.4 §2.4> of the Lua 5.3+-- Reference Manual).+--+-- Errors on the Lua side are caught and rethrown as a @'Exception'@.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_settable lua_settable>.+settable :: StackIndex -> Lua ()+settable index = liftLuaThrow $ \l -> hslua_settable l index++-- | Accepts any index, or 0, and sets the stack top to this index. If the new+-- top is larger than the old one, then the new elements are filled with nil. If+-- index is 0, then all stack elements are removed.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_settop lua_settop>.+settop :: StackIndex -> Lua ()+settop = liftLua1 lua_settop++-- |  Returns the status of this Lua thread.+--+-- The status can be 'OK' for a normal thread, an error value if the+-- thread finished the execution of a @lua_resume@ with an error, or+-- 'Yield' if the thread is suspended.+--+-- You can only call functions in threads with status 'OK'. You can+-- resume threads with status 'OK' (to start a new coroutine) or 'Yield'+-- (to resume a coroutine).+--+-- See also: <https://www.lua.org/manual/5.3/manual.html#lua_status lua_status>.+status :: Lua Status+status = liftLua $ fmap toStatus . lua_status++-- | Converts the Lua value at the given index to a haskell boolean value. Like+-- all tests in Lua, @toboolean@ returns @True@ for any Lua value different from+-- @false@ and @nil@; otherwise it returns @False@. (If you want to accept only+-- actual boolean values, use @'isboolean'@ to test the value's type.)+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_toboolean lua_toboolean>.+toboolean :: StackIndex -> Lua Bool+toboolean n = liftLua $ \l -> fromLuaBool <$> lua_toboolean l n++-- | Converts a value at the given index to a C function. That value must be a C+-- function; otherwise, returns @Nothing@.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_tocfunction lua_tocfunction>.+tocfunction :: StackIndex -> Lua (Maybe CFunction)+tocfunction n = liftLua $ \l -> do+  fnPtr <- lua_tocfunction l n+  return (if fnPtr == nullFunPtr then Nothing else Just fnPtr)++-- | Converts the Lua value at the given acceptable index to the signed integral+-- type 'Lua.Integer'. The Lua value must be an integer, a number or a string+-- convertible to an integer (see+-- <https://www.lua.org/manual/5.3/manual.html#3.4.3 §3.4.3> of the Lua 5.3+-- Reference Manual); otherwise, @tointeger@ returns @Nothing@.+--+-- If the number is not an integer, it is truncated in some non-specified way.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_tointeger lua_tointeger>.+tointeger :: StackIndex -> Lua (Maybe Lua.Integer)+tointeger n = liftLua $ \l -> alloca $ \boolPtr -> do+  res <- lua_tointegerx l n boolPtr+  isNum <- fromLuaBool <$> F.peek boolPtr+  return (if isNum then Just res else Nothing)++-- | Converts the Lua value at the given index to the C type lua_Number. The Lua+-- value must be a number or a string convertible to a number; otherwise,+-- @tonumber@ returns @'Nothing'@.+--+-- See <https://www.lua.org/manual/5.3/manual.html#lua_tonumber lua_tonumber>.+tonumber :: StackIndex -> Lua (Maybe Lua.Number)+tonumber n = liftLua $ \l -> alloca $ \bptr -> do+  res <- lua_tonumberx l n bptr+  isNum <- fromLuaBool <$> F.peek bptr+  return (if isNum then Just res else Nothing)++-- | Converts the value at the given index to a generic C pointer (void*). The+-- value can be a userdata, a table, a thread, or a function; otherwise,+-- lua_topointer returns @nullPtr@. Different objects will give different+-- pointers. There is no way to convert the pointer back to its original value.+--+-- Typically this function is used only for hashing and debug information.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_topointer lua_topointer>.+topointer :: StackIndex -> Lua (Ptr ())+topointer n = liftLua $ \l -> lua_topointer l n++-- | Converts the Lua value at the given index to a @'ByteString'@. The Lua+-- value must be a string or a number; otherwise, the function returns+-- @'Nothing'@. If the value is a number, then @'tostring'@ also changes the+-- actual value in the stack to a string. (This change confuses @'next'@ when+-- @'tostring'@ is applied to keys during a table traversal.)+--+-- See <https://www.lua.org/manual/5.3/manual.html#lua_tolstring lua_tolstring>.+tostring :: StackIndex -> Lua (Maybe ByteString)+tostring n = liftLua $ \l ->+  alloca $ \lenPtr -> do+    cstr <- lua_tolstring l n lenPtr+    if cstr == nullPtr+      then return Nothing+      else do+      cstrLen <- F.peek lenPtr+      Just <$> B.packCStringLen (cstr, fromIntegral cstrLen)++-- | Converts the value at the given index to a Lua thread (represented as+-- lua_State*). This value must be a thread; otherwise, the function returns+-- @Nothing@.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_tothread lua_tothread>.+tothread :: StackIndex -> Lua (Maybe Lua.State)+tothread n = liftLua $ \l -> do+  thread@(Lua.State ptr) <- lua_tothread l n+  if ptr == nullPtr+    then return Nothing+    else return (Just thread)++-- | If the value at the given index is a full userdata, returns its block+-- address. If the value is a light userdata, returns its pointer. Otherwise,+-- returns @Nothing@..+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_touserdata lua_touserdata>.+touserdata :: StackIndex -> Lua (Maybe (Ptr a))+touserdata n = liftLua $ \l -> do+  ptr <- lua_touserdata l n+  if ptr == nullPtr+    then return Nothing+    else return (Just ptr)++-- | Returns the name of the type encoded by the value @tp@, which must be one+-- the values returned by @'ltype'@.+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_typename lua_typename>.+typename :: Type -> Lua String+typename tp = liftLua $ \l ->+  lua_typename l (fromType tp) >>= C.peekCString++-- | Returns the pseudo-index that represents the @i@-th upvalue of the running+-- function (see <https://www.lua.org/manual/5.3/manual.html#4.4 §4.4> of the+-- Lua 5.3 reference manual).+--+-- See also:+-- <https://www.lua.org/manual/5.3/manual.html#lua_upvalueindex lua_upvalueindex>.+upvalueindex :: StackIndex -> StackIndex+upvalueindex i = registryindex - i

@@ -0,0 +1,70 @@+{-|+Module      : HsLua.Core.Run+Copyright   : © 2007–2012 Gracjan Polak;+              © 2012–2016 Ömer Sinan Ağacan;+              © 2017-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Stability   : beta+Portability : non-portable (depends on GHC)++Helper functions to run 'Lua' computations.+-}+module HsLua.Core.Run+  ( run+  , run'+  , runEither+  , runWith+  , defaultErrorConversion+  ) where++import Control.Exception (bracket, try)+import HsLua.Core.Types (Lua)++import qualified Control.Monad.Catch as Catch+import qualified HsLua.Core.Auxiliary as Lua+import qualified HsLua.Core.Error as Lua+import qualified HsLua.Core.Functions as Lua+import qualified HsLua.Core.Types as Lua+import qualified HsLua.Core.Utf8 as Utf8++-- | Run Lua computation using the default HsLua state as starting+-- point. Exceptions are masked, thus avoiding some issues when using+-- multiple threads. All exceptions are passed through; error handling+-- is the responsibility of the caller.+run :: Lua a -> IO a+run = (Lua.newstate `bracket` Lua.close) . flip runWith . Catch.mask_++-- | Run Lua computation using the default HsLua state as starting point.+-- Conversion from Lua errors to Haskell exceptions can be controlled through+-- @'Lua.ErrorConversion'@.+run' :: Lua.ErrorConversion -> Lua a -> IO a+run' ec = (Lua.newstate `bracket` Lua.close) .+  flip (Lua.runWithConverter ec) . Catch.mask_++-- | Run the given Lua computation; exceptions raised in haskell code are+-- caught, but other exceptions (user exceptions raised in haskell, unchecked+-- type errors, etc.) are passed through.+runEither :: Catch.Exception e => Lua a -> IO (Either e a)+runEither = try . run++-- | Run Lua computation with the given Lua state and the default+-- error-to-exception converter. Exception handling is left to+-- the caller.+runWith :: Lua.State -> Lua a -> IO a+runWith = Lua.runWithConverter defaultErrorConversion++-- | Conversions between Lua errors and Haskell exceptions; only deals with+-- @'Lua.Exception'@s.+defaultErrorConversion :: Lua.ErrorConversion+defaultErrorConversion = Lua.ErrorConversion+  { Lua.errorToException = Lua.throwTopMessageWithState+  , Lua.addContextToException = Lua.withExceptionMessage . (++)+  , Lua.alternative = \x y -> Lua.try x >>= \case+      Left _   -> y+      Right x' -> return x'+  , Lua.exceptionToError = (`Lua.catchException`+                             \(Lua.Exception msg) -> do+                               Lua.pushstring $ Utf8.fromString msg+                               Lua.error)+  }

@@ -0,0 +1,321 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE RankNTypes                 #-}+{-|+Module      : HsLua.Core.Types+Copyright   : © 2007–2012 Gracjan Polak;+              © 2012–2016 Ömer Sinan Ağacan;+              © 2017-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+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+  ( Lua (..)+  , LuaEnvironment (..)+  , ErrorConversion (..)+  , errorConversion+  , State (..)+  , Reader+  , liftLua+  , liftLua1+  , state+  , runWithConverter+  , unsafeRunWith+  , unsafeErrorConversion+  , GCCONTROL (..)+  , toGCCode+  , Type (..)+  , TypeCode (..)+  , fromType+  , toType+  , liftIO+  , CFunction+  , LuaBool (..)+  , fromLuaBool+  , toLuaBool+  , Integer (..)+  , Number (..)+  , StackIndex (..)+  , registryindex+  , NumArgs (..)+  , NumResults (..)+  , multret+  , RelationalOperator (..)+  , fromRelationalOperator+  , Status (..)+  , StatusCode (..)+  , toStatus+    -- * References+  , Reference (..)+  , fromReference+  , toReference+  , noref+  , refnil+    -- * Stack index helpers+  , nthTop+  , nthBottom+  , nth+  , top+  ) where++import Prelude hiding (Integer, EQ, LT)++import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)+import Control.Monad.Reader (ReaderT (..), MonadReader, MonadIO, asks, liftIO)+import Lua (nth, nthBottom, nthTop, top)+import Lua.Constants+import Lua.Types+import Lua.Auxiliary+  ( Reference (..)+  , fromReference+  , toReference+  )++-- | Define the ways in which exceptions and errors are handled.+data ErrorConversion = ErrorConversion+  { errorToException :: forall a . State -> IO a+    -- ^ Translate Lua errors to Haskell exceptions+  , addContextToException :: forall a . String -> Lua a -> Lua a+    -- ^ Add information on the current context to an exception.+  , alternative :: forall a . Lua a -> Lua a -> Lua a+    -- ^ Runs the second computation only if the first fails; returns+    -- the result of the first successful computation, if any.+  , exceptionToError :: Lua NumResults -> Lua NumResults+    -- ^ Translate Haskell exceptions to Lua errors+  }++-- | Environment in which Lua computations are evaluated.+data LuaEnvironment = LuaEnvironment+  { luaEnvErrorConversion :: ErrorConversion+    -- ^ Functions for error and exception handling and conversion+  , luaEnvState :: State+    -- ^ Lua interpreter state+  }++-- | A Lua computation. This is the base type used to run Lua programs of any+-- kind. The Lua state is handled automatically, but can be retrieved via+-- @'state'@.+newtype Lua a = Lua { unLua :: ReaderT LuaEnvironment IO a }+  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) -> Lua a+liftLua f = state >>= liftIO . f++-- | Turn a function of typ @Lua.State -> a -> IO b@ into a monadic Lua operation.+liftLua1 :: (State -> a -> IO b) -> a -> Lua b+liftLua1 f x = liftLua $ \l -> f l x++-- | Get the Lua state of this Lua computation.+state :: Lua State+state = asks luaEnvState++-- | Get the error-to-exception function.+errorConversion :: Lua ErrorConversion+errorConversion = asks luaEnvErrorConversion++-- | Run Lua computation with the given Lua state and error-to-exception+-- converter. Any resulting exceptions are left unhandled.+runWithConverter :: ErrorConversion -> State -> Lua a -> IO a+runWithConverter e2e l s =+  runReaderT (unLua s) (LuaEnvironment e2e l)++-- | Run the given operation, but crash if any Haskell exceptions occur.+unsafeRunWith :: State -> Lua a -> IO a+unsafeRunWith = runWithConverter unsafeErrorConversion++-- | Unsafe @'ErrorConversion'@; no proper error handling is attempted,+-- any error leads to a crash.+unsafeErrorConversion :: ErrorConversion+unsafeErrorConversion = ErrorConversion+  { errorToException = const (error "An unrecoverable Lua error occured.")+  , addContextToException = const id+  , alternative = const+  , exceptionToError = id+  }+++--+-- Type of Lua values+--++-- | Enumeration used as type tag.+-- See <https://www.lua.org/manual/5.3/manual.html#lua_type lua_type>.+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)++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++-- | 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)+++--+-- 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.+  | ErrGcmm   -- ^ error while running a @__gc@ metamethod.+  | 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_ERRGCMM   -> ErrGcmm+  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+--++-- | Enumeration used by @gc@ function.+data GCCONTROL+  = GCSTOP+  | GCRESTART+  | GCCOLLECT+  | GCCOUNT+  | GCCOUNTB+  | GCSTEP+  | GCSETPAUSE+  | GCSETSTEPMUL+  | GCISRUNNING+  deriving (Enum, Eq, Ord, Show)++toGCCode :: GCCONTROL -> GCCode+toGCCode = \case+  GCSTOP       -> LUA_GCSTOP+  GCRESTART    -> LUA_GCRESTART+  GCCOLLECT    -> LUA_GCCOLLECT+  GCCOUNT      -> LUA_GCCOUNT+  GCCOUNTB     -> LUA_GCCOUNTB+  GCSTEP       -> LUA_GCSTEP+  GCSETPAUSE   -> LUA_GCSETPAUSE+  GCSETSTEPMUL -> LUA_GCSETSTEPMUL+  GCISRUNNING  -> LUA_GCISRUNNING++--+-- Special values+--++-- | Option for multiple returns in @'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

@@ -0,0 +1,45 @@+{-|+Module      : HsLua.Core.Utf8+Copyright   : © 2018-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+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 #-}

@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}+{-| 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)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@=?))++import qualified HsLua.Core as Lua++-- | Specifications for Attributes parsing functions.+tests :: TestTree+tests = testGroup "Auxiliary"+  [ testGroup "getsubtable"+    [ "gets a subtable from field" =:+      [5, 8] `shouldBeResultOf` do+        pushLuaExpr "{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 "{yep = {}}"+        Lua.getsubtable Lua.top "yep"++    , "returns False if field does not contain a table" ?: do+        pushLuaExpr "{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"+    ]++  , "loadedTable" =: ("_LOADED" @=? Lua.loadedTableRegistryField)+  , "preloadTable" =: ("_PRELOAD" @=? Lua.preloadTableRegistryField)+  ]

@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}+{-| Tests for error handling.+-}+module HsLua.Core.ErrorTests (tests) where++import Control.Applicative ((<|>), empty)+import Data.Either (isLeft)+import HsLua.Core (Lua)+import Test.Tasty.HsLua ( (=:), shouldBeResultOf, shouldHoldForResultOf)+import Test.Tasty (TestTree, testGroup)++import qualified HsLua.Core as Lua++-- | Specifications for Attributes parsing functions.+tests :: TestTree+tests = testGroup "Error"+  [ "try catches errors" =:+    isLeft `shouldHoldForResultOf` Lua.try (Lua.throwException "test" :: Lua ())++  , "second alternative is used when first fails" =:+    True `shouldBeResultOf` (Lua.throwException "test" <|> return True)++  , "Applicative.empty implementation throws an exception" =:+    isLeft `shouldHoldForResultOf` Lua.try (empty :: Lua ())+  ]

@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}+{-|+Module      :  HsLua.Core.RunTests+Copyright   :  © 2017-2021 Albert Krewinkel+License     :  MIT++Maintainer  :  Albert Krewinkel <tarleb+hslua@zeitkraut.de>+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' (throwMessage "failing" :: Lua Bool))++    , "error-less code gives 'Right'" =:+      isRight `shouldHoldForResultOf`+        liftIO (runEither' (pushboolean True *> toboolean top))+    ]+  ]++runEither' :: Lua a -> IO (Either Lua.Exception a)+runEither' = runEither

@@ -0,0 +1,458 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}+{-|+Module      :  HsLua.CoreTests+Copyright   :  © 2017-2021 Albert Krewinkel+License     :  MIT++Maintainer  :  Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Stability   :  stable+Portability :  portable++Tests for Lua C API-like functions.+-}+module HsLua.CoreTests (tests) where++import Prelude hiding (compare)++import Control.Monad (forM_)+import Data.ByteString (append)+import Data.Maybe (fromMaybe)+import Lua.Lib (luaopen_debug)+import HsLua.Core as Lua+import 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.ErrorTests+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 "5, 4, 3, 2, 1"+        copy 4 3+        rawequal (nthBottom 4) (nthBottom 3)++    , "copies stack elements using negative indices" ?: do+        pushLuaExpr "5, 4, 3, 2, 1"+        copy (-1) (-3)+        rawequal (-1) (-3)+    ]++  , testGroup "insert"+    [ "inserts stack elements using positive indices" ?: do+        pushLuaExpr "1, 2, 3, 4, 5, 6, 7, 8, 9"+        insert 4+        movedEl <- tointeger (nthBottom 4)+        newTop <- tointeger (nth 1)+        return (movedEl == Just 9 && newTop == Just 8)++    , "inserts stack elements using negative indices" ?: do+        pushLuaExpr "1, 2, 3, 4, 5, 6, 7, 8, 9"+        insert (-6)+        movedEl <- tointeger (nth 6)+        newTop <- tointeger (nth 1)+        return (movedEl == Just 9 && newTop == Just 8)+    ]++  , testCase "absindex" . run $ 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 "{sum = 13.37}"+      pushstring "sum"+      gettable (nth 2)+      tonumber top++  , "rawlen gives the length of a list" =:+    7 `shouldBeResultOf` do+      pushLuaExpr "{1, 1, 2, 3, 5, 8, 13}"+      rawlen top++  , testGroup "Type checking"+    [ "isfunction" ?: do+        pushLuaExpr "function () print \"hi!\" end"+        isfunction (-1)++    , "isnil" ?: pushLuaExpr "nil" *> isnil (-1)++    , "isnone" ?: isnone 5 -- stack index 5 does not exist++    , "isnoneornil" ?: do+        pushLuaExpr "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 "149"+          tointeger (-1)++      , "tointeger accepts strings coercible to integers" =:+        Just 451 `shouldBeResultOf` do+          pushLuaExpr "'451'"+          tointeger (-1)++      , "tointeger returns Nothing when given a boolean" =:+        Nothing `shouldBeResultOf` do+          pushLuaExpr "true"+          tointeger (-1)+      ]++    , testGroup "tonumber"+      [ "tonumber returns numbers verbatim" =:+        Just 14.9 `shouldBeResultOf` do+          pushLuaExpr "14.9"+          tonumber (-1)++      , "tonumber accepts strings as numbers" =:+        Just 42.23 `shouldBeResultOf` do+          pushLuaExpr "'42.23'"+          tonumber (-1)++      , "tonumber returns Nothing when given a boolean" =:+        Nothing `shouldBeResultOf` do+          pushLuaExpr "true"+          tonumber (-1)+      ]++    , testGroup "tostring"+      [ "get a string" =:+        Just "a string" `shouldBeResultOf` do+          pushLuaExpr "'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 "{'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 "{['\xE2\x9A\x94'] = true}"+        getfield top "⚔"+        toboolean 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 "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.pushnil -- dummy op+          Lua.getref Lua.registryindex cityref+          Lua.tostring Lua.top++      , "references become invalid after unref" =:+        Nothing `shouldBeResultOf` 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 "./file-does-not-exist.lua"++      , "loading an invalid file should give a syntax error" =:+        ErrSyntax `shouldBeResultOf` loadfile "test/lua/syntax-error.lua"++      , "loading a valid program should succeed" =:+        OK `shouldBeResultOf` loadfile "./test/lua/example.lua"++      , "example fib program should be loaded correctly" =:+        Just 8 `shouldBeResultOf` do+          loadfile "./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 "./file-does-not-exist.lua"++      , "loading an invalid file should give a syntax error" =:+        ErrSyntax `shouldBeResultOf` dofile "test/lua/syntax-error.lua"++      , "loading a failing program should give an run error" =:+        ErrRun `shouldBeResultOf` dofile "test/lua/error.lua"++      , "loading a valid program should succeed" =:+        OK `shouldBeResultOf` dofile "./test/lua/example.lua"++      , "example fib program should be loaded correctly" =:+        Just 21 `shouldBeResultOf` do+          _ <- dofile "./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 "function () error 'error in error handler' end"+        _ <- loadstring "error \"this fails\""+        pcall 0 0 (Just (nth 2))+    ]++  , testCase "garbage collection" . run $+      -- test that gc can be called with all constructors of type GCCONTROL.+      forM_ [GCSTOP .. GCSETSTEPMUL] $ \what -> gc what 23++  , 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 $ 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 luaOp+      assertEqual "error handling leaks values to the stack" 0 res+  ]++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 (-2) (-1) luaOp+    assert $ luaCmp == op (n - 1) n++  compareEQ :: Property+  compareEQ = monadicIO  $ do+    luaCmp <- QCMonadic.run . run $ do+      pushinteger n+      pushinteger n+      compare (-2) (-1) luaOp+    assert $ luaCmp == op n n++  compareGT :: Property+  compareGT = monadicIO $ do+    luaRes <- QCMonadic.run . run $ do+      pushinteger $ n + 1+      pushinteger n+      compare (-2) (-1) luaOp+    assert $ luaRes == op (n + 1) n

@@ -0,0 +1,28 @@++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Module      :  HsLua.Core.RunTests+Copyright   :  © 2017-2021 Albert Krewinkel+License     :  MIT++Maintainer  :  Albert Krewinkel <tarleb+hslua@zeitkraut.de>+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

@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}+{-|+Module      : Test.Tasty.HsLua+Copyright   : © 2017-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+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, 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 :: ByteString -> Lua ()+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 => Lua Bool -> Assertion+assertLuaBool luaOp = assertBool "" =<< run luaOp++-- | Creates a new test case with the given name, checking whether the+-- operation returns 'True'.+luaTestBool :: HasCallStack => String -> Lua Bool -> TestTree+luaTestBool 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 -> Lua Bool -> TestTree+(?:) = luaTestBool+infixr 3 ?:

@@ -0,0 +1,1 @@+error 'running this program will cause an error'

@@ -0,0 +1,8 @@+--- 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

@@ -0,0 +1,1 @@+just wrong

@@ -0,0 +1,19 @@+{-|+Module      : Main+Copyright   : © 2017-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>++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]