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