hslua-classes-2.3.0/0000755000000000000000000000000007346545000012454 5ustar0000000000000000hslua-classes-2.3.0/CHANGELOG.md0000644000000000000000000000315507346545000014271 0ustar0000000000000000# Changelog `hslua-classes` uses [PVP Versioning][]. ## hslua-classes-2.3.0 Released 2023-03-13. - Require version 2.3.* of HsLua packages hslua-core and hslua-marshalling. ## hslua-classes-2.2.0 Released 2022-02-19. - Relaxed upper bounds, allowing hslua-core-2.2.0 and hslua-marshalling-2.2.0. ## hslua-classes-2.1.0 Released 2022-01-29. - Updated to hslua-core 2.1 and hslua-marshalling 2.1. - The Peekable class has been remodeled: - Peekable now contains `safepeek`, which is a `Peeker` function for the type. - `peek` is no longer part of Peekable, but a normal function defined as `forcePeek . safepeek`. - HsLua.Class no longer exports `peekList` and `peekKeyValuePairs`. Use the functions from HsLua.Marshalling instead. - The Exposable class is changed to use the `Peek` monad instead of `LuaE`, thereby unifying the way errors are reported in HsLua. - PeekError has been removed; it is now sufficient for exception types used with Peekable, Exposable, and Invokable to be instances of LuaError. - The Invokable type class now has a single parameter. This removes the need for the AllowAmbiguousTypes extension and makes using `invoke` much more convenient, as the proper error type can now be inferred automatically. - Added function `pushAsHaskellFunction` to make it even easier to use Haskell functions in Lua. ## hslua-classes-2.0.0 Released 2021-10-21. - Initially created. Contains modules previously found in the `Foreign.Lua.Types` hierarchy from `hslua-1.3`. [PVP Versioning]: https://pvp.haskell.org hslua-classes-2.3.0/LICENSE0000644000000000000000000000224107346545000013460 0ustar0000000000000000Copyright © 1994-2022 Lua.org, PUC-Rio. Copyright © 2007-2012 Gracjan Polak Copyright © 2012-2015 Ömer Sinan Ağacan Copyright © 2016-2023 Albert Krewinkel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. hslua-classes-2.3.0/README.md0000644000000000000000000000141207346545000013731 0ustar0000000000000000# hslua-classes [![Build status][GitHub Actions badge]][GitHub Actions] [![AppVeyor Status]](https://ci.appveyor.com/project/tarleb/hslua-r2y18) [![Hackage]](https://hackage.haskell.org/package/hslua-classes) The HsLua package provides convenience classes for marshaling and function calling. This package is part of [HsLua], a Haskell framework built around the embeddable scripting language [Lua]. [HsLua]: https://hslua.org/ [Lua]: https://lua.org/ [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-classes.svg hslua-classes-2.3.0/hslua-classes.cabal0000644000000000000000000000731107346545000016211 0ustar0000000000000000cabal-version: 2.2 name: hslua-classes version: 2.3.0 synopsis: Type classes for HsLua description: Type classes for convenient marshalling and calling of Lua functions. homepage: https://hslua.org/ bug-reports: https://github.com/hslua/hslua/issues license: MIT license-file: LICENSE author: Albert Krewinkel, Gracjan Polak, Ömer Sinan Ağacan maintainer: tarleb@hslua.org copyright: © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2023 Albert Krewinkel category: Foreign build-type: Simple extra-source-files: README.md , CHANGELOG.md tested-with: GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.5 , GHC == 9.4.4 source-repository head type: git location: https://github.com/hslua/hslua.git subdir: hslua-classes common common-options default-language: Haskell2010 build-depends: base >= 4.11 && < 5 , bytestring >= 0.10.2 && < 0.12 , containers >= 0.5.9 && < 0.7 , exceptions >= 0.8 && < 0.11 , hslua-core >= 2.1 && < 2.4 , hslua-marshalling >= 2.1 && < 2.4 , text >= 1.2 && < 2.1 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.Classes , HsLua.Class.Exposable , HsLua.Class.Invokable , HsLua.Class.Peekable , HsLua.Class.Pushable , HsLua.Class.Util hs-source-dirs: src default-extensions: LambdaCase other-extensions: AllowAmbiguousTypes , CPP , FlexibleInstances , MultiParamTypeClasses , OverloadedStrings , ScopedTypeVariables , TypeApplications test-suite test-hslua-classes import: common-options type: exitcode-stdio-1.0 main-is: test-hslua-classes.hs hs-source-dirs: test ghc-options: -threaded -Wno-unused-do-bind other-modules: HsLua.ClassesTests , HsLua.Class.ExposableTests , HsLua.Class.InvokableTests , HsLua.Class.PeekableTests , HsLua.Class.PushableTests , HsLua.Class.UtilTests build-depends: hslua-classes , lua-arbitrary >= 1.0 , QuickCheck >= 2.7 , quickcheck-instances >= 0.3 , tasty >= 0.11 , tasty-hslua >= 1.0 , tasty-hunit >= 0.9 , tasty-quickcheck >= 0.8 other-extensions: OverloadedStrings , TypeApplications hslua-classes-2.3.0/src/HsLua/Class/0000755000000000000000000000000007346545000015324 5ustar0000000000000000hslua-classes-2.3.0/src/HsLua/Class/Exposable.hs0000644000000000000000000000646107346545000017611 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-| Module : HsLua.Class.Exposable Copyright : © 2007–2012 Gracjan Polak, 2012–2016 Ömer Sinan Ağacan, 2017-2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Call Haskell functions from Lua. -} module HsLua.Class.Exposable ( Exposable (..) , toHaskellFunction , pushAsHaskellFunction , registerHaskellFunction ) where import Data.String (fromString) import HsLua.Core as Lua import HsLua.Marshalling (Peek, forcePeek, liftLua, retrieving, withContext) import HsLua.Class.Peekable (Peekable (safepeek)) import HsLua.Class.Pushable (Pushable (push)) -- | Operations and functions that can be pushed to the Lua stack. This -- is a helper function not intended to be used directly. Use the -- @'toHaskellFunction'@ wrapper instead. class LuaError e => Exposable e a where -- | Helper function, called by @'toHaskellFunction'@. Should do a -- partial application of the argument at the given index to the -- underlying function. Recurses if necessary, causing further partial -- applications until the operation is a easily exposable to Lua. partialApply :: StackIndex -> a -> Peek e NumResults instance {-# OVERLAPPING #-} LuaError e => Exposable e (HaskellFunction e) where partialApply _ = liftLua instance (LuaError e, Pushable a) => Exposable e (LuaE e a) where partialApply _narg x = 1 <$ liftLua (x >>= push) instance (LuaError e, Pushable a) => Exposable e (Peek e a) where partialApply _narg x = 1 <$ (x >>= liftLua . push) instance (Peekable a, Exposable e b) => Exposable e (a -> b) where partialApply narg f = getArg >>= partialApply (narg + 1) . f where getArg = retrieving (fromString errorPrefix) (safepeek narg) errorPrefix = "argument " ++ show (fromStackIndex narg) -- | Convert a Haskell function to a function type directly exposable to -- Lua. Any Haskell function can be converted provided that: -- -- * all arguments are instances of @'Peekable'@ -- * return type is @LuaE e a@, where @a@ is an instance of -- @'Pushable'@ -- -- Any exception of type @e@ will be caught. -- -- /Important/: this does __not__ catch exceptions other than @e@; -- exception handling must be done by the Haskell function. Failure to -- do so will cause the program to crash. -- -- E.g., the following code could be used to handle an Exception -- of type FooException, if that type is an instance of -- 'Control.Monad.Catch.MonadCatch' and 'Pushable': -- -- > toHaskellFunction (myFun `catchM` (\e -> raiseError (e :: FooException))) toHaskellFunction :: forall e a. Exposable e a => a -> HaskellFunction e toHaskellFunction a = forcePeek $ do withContext "executing function call" $ partialApply 1 a -- | Pushes the given value as a function to the Lua stack. -- -- See 'toHaskellFunction' for details. pushAsHaskellFunction :: forall e a. Exposable e a => a -> LuaE e () pushAsHaskellFunction = pushHaskellFunction . toHaskellFunction -- | Imports a Haskell function and registers it at global name. registerHaskellFunction :: Exposable e a => Name -> a -> LuaE e () registerHaskellFunction n f = do pushAsHaskellFunction f setglobal n hslua-classes-2.3.0/src/HsLua/Class/Invokable.hs0000644000000000000000000000252207346545000017573 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-| Module : HsLua.Class.Invokable Copyright : © 2007–2012 Gracjan Polak, 2012–2016 Ömer Sinan Ağacan, 2017-2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : beta Portability : FlexibleInstances, ForeignFunctionInterface, ScopedTypeVariables Call Lua functions from Haskell. -} module HsLua.Class.Invokable ( Invokable (..) , invoke ) where import Data.ByteString (append) import HsLua.Core as Lua import HsLua.Class.Peekable import HsLua.Class.Pushable import HsLua.Class.Util (popValue) -- | Helper class used to make Lua functions useable from Haskell. class Invokable a where addArg :: Name -> (forall e. LuaError e => LuaE e ()) -> NumArgs -> a instance (LuaError e, Peekable a) => Invokable (LuaE e a) where addArg fnName pushArgs nargs = do _ <- dostring $ "return " `append` Lua.fromName fnName pushArgs call nargs 1 popValue instance (Pushable a, Invokable b) => Invokable (a -> b) where addArg fnName pushArgs nargs x = addArg fnName (pushArgs *> push x) (nargs + 1) -- | Invoke a Lua function. Use as: -- -- > v <- invoke "proc" "abc" (1::Int) (5.0::Double) invoke :: Invokable a => Name -> a invoke fname = addArg fname (return ()) 0 hslua-classes-2.3.0/src/HsLua/Class/Peekable.hs0000644000000000000000000001122107346545000017365 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-| Module : HsLua.Class.Peekable Copyright : © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : beta Portability : non-portable (depends on GHC) Sending haskell objects to the lua stack. -} module HsLua.Class.Peekable ( Peekable (..) , peek ) where import Data.Map (Map) import Data.Set (Set) import Data.Text (Text) import HsLua.Core as Lua import HsLua.Marshalling import Foreign.Ptr (Ptr) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified HsLua.Marshalling.Peekers as Peekers -- | A value that can be read from the Lua stack. class Peekable a where -- | Function that retrieves a value from the Lua stack. safepeek :: LuaError e => Peeker e a -- | Retrieves a 'Peekable' value from the stack. Throws an exception of -- type @e@ if the given stack index does not a suitable value. peek :: forall a e. (LuaError e, Peekable a) => StackIndex -> LuaE e a peek = forcePeek . safepeek instance Peekable () where safepeek = peekNil instance Peekable Lua.Integer where safepeek = reportValueOnFailure "integer" tointeger instance Peekable Lua.Number where safepeek = reportValueOnFailure "number" tonumber instance Peekable B.ByteString where safepeek = peekByteString instance Peekable Bool where safepeek = peekBool instance Peekable CFunction where safepeek = reportValueOnFailure "C function" tocfunction instance Peekable (Ptr a) where safepeek = reportValueOnFailure "userdata" touserdata instance Peekable Lua.State where safepeek = reportValueOnFailure "Lua state (i.e., a thread)" tothread instance Peekable Text where safepeek = peekText instance Peekable BL.ByteString where safepeek = peekLazyByteString instance Peekable Prelude.Integer where safepeek = peekIntegral instance Peekable Int where safepeek = peekIntegral instance Peekable Float where safepeek = peekRealFloat instance Peekable Double where safepeek = peekRealFloat instance {-# OVERLAPS #-} Peekable [Char] where safepeek = peekString instance Peekable a => Peekable [a] where safepeek = peekList safepeek instance (Ord a, Peekable a, Peekable b) => Peekable (Map a b) where safepeek = peekMap safepeek safepeek instance (Ord a, Peekable a) => Peekable (Set a) where safepeek = peekSet safepeek -- -- Tuples -- instance {-# OVERLAPPABLE #-} (Peekable a, Peekable b) => Peekable (a, b) where safepeek = peekPair safepeek safepeek instance {-# OVERLAPPABLE #-} (Peekable a, Peekable b, Peekable c) => Peekable (a, b, c) where safepeek = peekTriple safepeek safepeek safepeek instance {-# OVERLAPPABLE #-} (Peekable a, Peekable b, Peekable c, Peekable d) => Peekable (a, b, c, d) where safepeek = typeChecked "table" istable $ \idx -> (,,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3 <*> nthValue idx 4 instance {-# OVERLAPPABLE #-} (Peekable a, Peekable b, Peekable c, Peekable d, Peekable e) => Peekable (a, b, c, d, e) where safepeek = typeChecked "table" istable $ \idx -> (,,,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3 <*> nthValue idx 4 <*> nthValue idx 5 instance {-# OVERLAPPABLE #-} (Peekable a, Peekable b, Peekable c, Peekable d, Peekable e, Peekable f) => Peekable (a, b, c, d, e, f) where safepeek = typeChecked "table" istable $ \idx -> (,,,,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3 <*> nthValue idx 4 <*> nthValue idx 5 <*> nthValue idx 6 instance {-# OVERLAPPABLE #-} (Peekable a, Peekable b, Peekable c, Peekable d, Peekable e, Peekable f, Peekable g) => Peekable (a, b, c, d, e, f, g) where safepeek = typeChecked "table" istable $ \idx -> (,,,,,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3 <*> nthValue idx 4 <*> nthValue idx 5 <*> nthValue idx 6 <*> nthValue idx 7 instance {-# OVERLAPPABLE #-} (Peekable a, Peekable b, Peekable c, Peekable d, Peekable e, Peekable f, Peekable g, Peekable h) => Peekable (a, b, c, d, e, f, g, h) where safepeek = typeChecked "table" istable $ \idx -> (,,,,,,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3 <*> nthValue idx 4 <*> nthValue idx 5 <*> nthValue idx 6 <*> nthValue idx 7 <*> nthValue idx 8 -- | Helper function to get the nth table value nthValue :: (LuaError e, Peekable a) => StackIndex -> Lua.Integer -> Peek e a nthValue idx n = Peekers.peekIndexRaw n safepeek idx hslua-classes-2.3.0/src/HsLua/Class/Pushable.hs0000644000000000000000000001015207346545000017422 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-| Module : HsLua.Class.Pushable Copyright : © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : beta Portability : FlexibleInstances, ScopedTypeVariables Sending haskell objects to the lua stack. -} module HsLua.Class.Pushable ( Pushable (..) , pushList ) where import Data.ByteString (ByteString) import Data.Map (Map) import Data.Text (Text) import Data.Set (Set) import HsLua.Core as Lua import HsLua.Marshalling hiding (pushList) import Foreign.Ptr (Ptr) import qualified Data.ByteString.Lazy as BL import qualified HsLua.Marshalling as Push -- | A value that can be pushed to the Lua stack. class Pushable a where -- | Pushes a value onto Lua stack, casting it into meaningfully nearest Lua -- type. push :: LuaError e => a -> LuaE e () instance Pushable () where push = const pushnil instance Pushable Lua.Integer where push = pushinteger instance Pushable Lua.Number where push = pushnumber instance Pushable ByteString where push = pushstring instance Pushable Bool where push = pushboolean instance Pushable CFunction where push = pushcfunction instance Pushable (Ptr a) where push = pushlightuserdata instance Pushable Text where push = pushText instance Pushable BL.ByteString where push = pushLazyByteString instance Pushable Prelude.Integer where push = pushIntegral instance Pushable Int where push = pushIntegral instance Pushable Float where push = pushRealFloat instance Pushable Double where push = pushRealFloat instance {-# OVERLAPS #-} Pushable [Char] where push = pushString instance Pushable a => Pushable [a] where push = Push.pushList push instance (Pushable a, Pushable b) => Pushable (Map a b) where push = pushMap push push instance Pushable a => Pushable (Set a) where push = pushSet push -- | Push list as numerically indexed table. pushList :: (LuaError e, Pushable a) => [a] -> LuaE e () pushList = Push.pushList push -- -- Tuples -- instance {-# OVERLAPPABLE #-} (Pushable a, Pushable b) => Pushable (a, b) where push (a, b) = do newtable addRawInt 1 a addRawInt 2 b instance {-# OVERLAPPABLE #-} (Pushable a, Pushable b, Pushable c) => Pushable (a, b, c) where push (a, b, c) = do newtable addRawInt 1 a addRawInt 2 b addRawInt 3 c instance {-# OVERLAPPABLE #-} (Pushable a, Pushable b, Pushable c, Pushable d) => Pushable (a, b, c, d) where push (a, b, c, d) = do newtable addRawInt 1 a addRawInt 2 b addRawInt 3 c addRawInt 4 d instance {-# OVERLAPPABLE #-} (Pushable a, Pushable b, Pushable c, Pushable d, Pushable e) => Pushable (a, b, c, d, e) where push (a, b, c, d, e) = do newtable addRawInt 1 a addRawInt 2 b addRawInt 3 c addRawInt 4 d addRawInt 5 e instance {-# OVERLAPPABLE #-} (Pushable a, Pushable b, Pushable c, Pushable d, Pushable e, Pushable f) => Pushable (a, b, c, d, e, f) where push (a, b, c, d, e, f) = do newtable addRawInt 1 a addRawInt 2 b addRawInt 3 c addRawInt 4 d addRawInt 5 e addRawInt 6 f instance {-# OVERLAPPABLE #-} (Pushable a, Pushable b, Pushable c, Pushable d, Pushable e, Pushable f, Pushable g) => Pushable (a, b, c, d, e, f, g) where push (a, b, c, d, e, f, g) = do newtable addRawInt 1 a addRawInt 2 b addRawInt 3 c addRawInt 4 d addRawInt 5 e addRawInt 6 f addRawInt 7 g instance {-# OVERLAPPABLE #-} (Pushable a, Pushable b, Pushable c, Pushable d, Pushable e, Pushable f, Pushable g, Pushable h) => Pushable (a, b, c, d, e, f, g, h) where push (a, b, c, d, e, f, g, h) = do newtable addRawInt 1 a addRawInt 2 b addRawInt 3 c addRawInt 4 d addRawInt 5 e addRawInt 6 f addRawInt 7 g addRawInt 8 h -- | Set numeric key/value in table at the top of the stack. addRawInt :: (LuaError e, Pushable a) => Lua.Integer -> a -> LuaE e () addRawInt idx val = do push val rawseti (-2) idx hslua-classes-2.3.0/src/HsLua/Class/Util.hs0000644000000000000000000000411507346545000016576 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-| Module : HsLua.Class.Util Copyright : © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : beta Portability : non-portable (depends on GHC) HsLua utility functions. -} module HsLua.Class.Util ( raiseError , Optional (Optional, fromOptional) -- * getting values , peekEither , popValue ) where import Control.Applicative ((<|>)) import HsLua.Core (LuaE, LuaError, NumResults, StackIndex, top) import HsLua.Class.Peekable (Peekable (safepeek), peek) import HsLua.Class.Pushable (Pushable (push)) import qualified HsLua.Core as Lua import qualified HsLua.Marshalling as Lua -- | Raise a Lua error, using the given value as the error object. raiseError :: (LuaError e, Pushable a) => a -> LuaE e NumResults raiseError e = do push e Lua.error {-# INLINABLE raiseError #-} -- | Newtype wrapper intended to be used for optional Lua values. Nesting this -- type is strongly discouraged as missing values on inner levels are -- indistinguishable from missing values on an outer level; wrong values -- would be the likely result. newtype Optional a = Optional { fromOptional :: Maybe a } instance Peekable a => Peekable (Optional a) where safepeek idx = (Optional Nothing <$ Lua.peekNoneOrNil idx) <|> (Optional . Just <$> safepeek idx) instance Pushable a => Pushable (Optional a) where push (Optional Nothing) = Lua.pushnil push (Optional (Just x)) = push x -- -- Getting Values -- -- | Try to convert the value at the given stack index to a Haskell value. -- Returns 'Left' with the error on failure. peekEither :: (LuaError e, Peekable a) => StackIndex -> LuaE e (Either e a) peekEither = Lua.try . peek -- | Get, then pop the value at the top of the stack. The pop operation is -- executed even if the retrieval operation failed. popValue :: (LuaError e, Peekable a) => LuaE e a popValue = Lua.forcePeek $ safepeek top `Lua.lastly` Lua.pop 1 {-# INLINABLE popValue #-} hslua-classes-2.3.0/src/HsLua/0000755000000000000000000000000007346545000014257 5ustar0000000000000000hslua-classes-2.3.0/src/HsLua/Classes.hs0000644000000000000000000000175207346545000016215 0ustar0000000000000000{-| Module : HsLua.Classes Copyright : © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : beta Portability : non-portable (depends on GHC) Convenience module which re-exports all classes and utility functions provided by the /hslua-classes/ package. -} module HsLua.Classes ( -- * Receiving values from Lua stack (Lua → Haskell) Peekable (..) , peekEither -- * Pushing values to Lua stack (Haskell → Lua) , Pushable (..) , pushList -- * Calling Functions , Exposable (..) , toHaskellFunction , invoke , registerHaskellFunction -- * Utility functions and types , raiseError , Optional (Optional, fromOptional) -- ** Retrieving values , popValue ) where import HsLua.Class.Exposable import HsLua.Class.Invokable import HsLua.Class.Peekable import HsLua.Class.Pushable import HsLua.Class.Util hslua-classes-2.3.0/test/HsLua/Class/0000755000000000000000000000000007346545000015514 5ustar0000000000000000hslua-classes-2.3.0/test/HsLua/Class/ExposableTests.hs0000644000000000000000000000433407346545000021021 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-| Module : HsLua.Class.ExposableTests Copyright : © 2017-2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Tests that Haskell functions can be exposed to and called from Lua. -} module HsLua.Class.ExposableTests (tests) where import HsLua.Core (Lua) import HsLua.Class.Exposable as Lua import HsLua.Class.Peekable as Lua import Test.Tasty.HsLua ( (=:), pushLuaExpr, shouldBeErrorMessageOf , shouldBeResultOf ) import Test.Tasty (TestTree, testGroup) import qualified HsLua.Core as Lua -- | Specifications for Attributes parsing functions. tests :: TestTree tests = let integerOperation :: Lua.Integer -> Lua.Integer -> Lua Lua.Integer integerOperation i1 i2 = let (j1, j2) = (fromIntegral i1, fromIntegral i2) in return $ fromIntegral (product [1..j1] `mod` j2 :: Prelude.Integer) in testGroup "Exposable" [ "push Haskell function to Lua" =: (28 :: Lua.Integer) `shouldBeResultOf` do let add :: Lua Lua.Integer add = do i1 <- Lua.peek (-1) i2 <- Lua.peek (-2) return (i1 + i2) Lua.registerHaskellFunction "add" add Lua.loadstring "return add(23, 5)" *> Lua.call 0 1 Lua.peek Lua.top <* Lua.pop 1 , "push multi-argument Haskell function to Lua" =: (0 :: Lua.Integer) `shouldBeResultOf` do Lua.registerHaskellFunction "integerOp" integerOperation Lua.loadstring "return integerOp(23, 42)" *> Lua.call 0 1 Lua.peek (-1) <* Lua.pop 1 , "argument type errors are propagated" =: ("integer expected, got boolean" ++ "\n\twhile retrieving argument 2" ++ "\n\twhile executing function call") `shouldBeErrorMessageOf` do Lua.registerHaskellFunction "integerOp" integerOperation pushLuaExpr "integerOp(23, true)" , "Error in Haskell function is converted into Lua error" =: (False, "foo") `shouldBeResultOf` do Lua.openlibs Lua.pushAsHaskellFunction (Lua.failLua "foo" :: Lua ()) Lua.setglobal "throw_foo" Lua.loadstring "return pcall(throw_foo)" *> Lua.call 0 2 (,) <$> Lua.peek (Lua.nth 2) <*> Lua.peek @String (Lua.nth 1) ] hslua-classes-2.3.0/test/HsLua/Class/InvokableTests.hs0000644000000000000000000000272207346545000021010 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-| Module : HsLua.Class.InvokableTests Copyright : © 2017-2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Tests that Lua functions can be called from Haskell. -} module HsLua.Class.InvokableTests (tests) where import Data.ByteString.Char8 as Char8 import HsLua.Class.Invokable (invoke) import HsLua.Core (Lua, openlibs) import Test.Tasty.HsLua ((=:), shouldBeErrorMessageOf, shouldBeResultOf) import Test.Tasty (TestTree, testGroup) import qualified HsLua.Core as Lua -- | Specifications for Attributes parsing functions. tests :: TestTree tests = testGroup "Invokable" [ "test equality within lua" =: True `shouldBeResultOf` do openlibs invoke "rawequal" (5 :: Lua.Integer) (5.0 :: Lua.Number) , "failing lua function call" =: "foo" `shouldBeErrorMessageOf` do openlibs invoke "assert" False (Char8.pack "foo") :: Lua Bool , "pack table via lua procedure" =: (True, 23 :: Lua.Integer, "moin" :: ByteString) `shouldBeResultOf` do openlibs invoke "table.pack" True (23 :: Lua.Integer) (Char8.pack "moin") , "failing lua procedure call" =: "foo" `shouldBeErrorMessageOf` do openlibs invoke "error" (Char8.pack "foo") :: Lua () , "Error when Lua-to-Haskell result conversion fails" =: "string expected, got boolean" `shouldBeErrorMessageOf` do openlibs invoke "rawequal" (Char8.pack "a") () :: Lua String ] hslua-classes-2.3.0/test/HsLua/Class/PeekableTests.hs0000644000000000000000000000566707346545000020621 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-| Module : HsLua.Class.PeekableTests Copyright : © 2017-2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : stable Portability : portable Test for the conversion of lua values to haskell values. -} module HsLua.Class.PeekableTests (tests) where import Data.ByteString (ByteString) import HsLua.Class.Peekable import HsLua.Core as Lua import Test.Tasty.HsLua ( (=:), (?:), pushLuaExpr, shouldBeResultOf , shouldBeErrorMessageOf ) import Test.Tasty (TestTree, testGroup) -- | Specifications for Attributes parsing functions. tests :: TestTree tests = testGroup "Peekable" [ testGroup "Bool" ["literal true is truthy" ?: do pushLuaExpr @Lua.Exception "true" peek top , "0 as a non-nil value is truthy" ?: do pushnumber @Lua.Exception 0 peek top , "nil is falsy" ?: do pushnil @Lua.Exception not <$> peek top ] , testGroup "Lua.Integer" [ "integer can be peeked" =: (5 :: Lua.Integer) `shouldBeResultOf` do pushnumber 5.0 peek top ] , testGroup "Prelude.Integer" [ "small integer can be peeked" =: (23 :: Prelude.Integer) `shouldBeResultOf` do pushnumber 23 peek top , "very large integer can be peeked" =: (10000000000000000000001 :: Prelude.Integer) `shouldBeResultOf` do pushstring "10000000000000000000001" peek top ] , testGroup "error handling" [ "error is thrown if boolean is given instead of stringy value" =: "string expected, got boolean" `shouldBeErrorMessageOf` do pushboolean False peek top :: Lua ByteString , "floating point numbers cannot be peeked as integer" =: "integer expected, got number" `shouldBeErrorMessageOf` do pushnumber 23.1 peek top :: Lua Lua.Integer , "booleans cannot be retrieved as numbers" =: "number expected, got boolean" `shouldBeErrorMessageOf` do pushboolean False peek top :: Lua Lua.Number , "list cannot be read if a peeking at list element fails" =: ("number expected, got boolean" ++ "\n\twhile retrieving index 4" ++ "\n\twhile retrieving list") `shouldBeErrorMessageOf` do pushLuaExpr "{1, 5, 23, true, 42}" peek top :: Lua [Lua.Number] , "stack is unchanged if getting a list fails" =: 0 `shouldBeResultOf` do pushLuaExpr "{true, 1, 1, 2, 3, 5, 8}" topBefore <- gettop _ <- peek top :: Lua [Bool] topAfter <- gettop return (topAfter - topBefore) , "stack is unchanged if getting key-value pairs fails" =: 0 `shouldBeResultOf` do pushLuaExpr "{foo = 'bar', baz = false}" topBefore <- gettop _ <- try (peek top :: Lua [(String, String)]) topAfter <- gettop return (topAfter - topBefore) ] ] hslua-classes-2.3.0/test/HsLua/Class/PushableTests.hs0000644000000000000000000000641607346545000020645 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-| Module : HsLua.Class.PushableTests Copyright : © 2017-2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : stable Portability : portable Test for the interoperability between haskell and lua. -} module HsLua.Class.PushableTests (tests) where import Data.ByteString (ByteString) import HsLua.Class.Pushable (Pushable (push)) import HsLua.Core (gettop, equal, nth) import Foreign.StablePtr (castStablePtrToPtr, freeStablePtr, newStablePtr) import Lua.Arbitrary () import Test.Tasty.HsLua (pushLuaExpr) import Test.QuickCheck (Property) import Test.QuickCheck.Instances () import Test.QuickCheck.Monadic (monadicIO, run, assert) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, assertBool, testCase) import Test.Tasty.QuickCheck (testProperty) import qualified HsLua.Core as Lua -- | Specifications for Attributes parsing functions. tests :: TestTree tests = testGroup "Pushable" [ testGroup "pushing simple values to the stack" [ testCase "Boolean can be pushed correctly" $ assertLuaEqual "true was not pushed" True "true" , testCase "Lua.Numbers can be pushed correctly" $ assertLuaEqual "5::Lua.Number was not pushed" (5 :: Lua.Number) "5" , testCase "Lua.Integers can be pushed correctly" $ assertLuaEqual "42::Lua.Integer was not pushed" (42 :: Lua.Integer) "42" , testCase "ByteStrings can be pushed correctly" $ assertLuaEqual "string literal was not pushed" ("Hello!" :: ByteString) "\"Hello!\"" , testCase "Unit is pushed as nil" $ assertLuaEqual "() was not pushed as nil" () "nil" , testCase "Pointer is pushed as light userdata" $ let luaOp = do stblPtr <- Lua.liftIO $ newStablePtr (Just "5" :: Maybe String) push (castStablePtrToPtr stblPtr) res <- Lua.islightuserdata (-1) Lua.liftIO $ freeStablePtr stblPtr return res in assertBool "pointers must become light userdata" =<< Lua.run @Lua.Exception luaOp ] , testGroup "pushing a value increases stack size by one" [ testProperty "Lua.Integer" (prop_pushIncrStackSizeByOne :: Lua.Integer -> Property) , testProperty "Lua.Number" (prop_pushIncrStackSizeByOne :: Lua.Number -> Property) , testProperty "ByteString" (prop_pushIncrStackSizeByOne :: ByteString -> Property) , testProperty "String" (prop_pushIncrStackSizeByOne :: String -> Property) , testProperty "list of booleans" (prop_pushIncrStackSizeByOne :: [Bool] -> Property) ] ] -- | Takes a message, haskell value, and a representation of that value as lua -- string, assuming that the pushed values are equal within lua. assertLuaEqual :: Pushable a => String -> a -> ByteString -> Assertion assertLuaEqual msg x lit = assertBool msg =<< Lua.run @Lua.Exception (pushLuaExpr lit *> push x *> equal (nth 1) (nth 2)) prop_pushIncrStackSizeByOne :: Pushable a => a -> Property prop_pushIncrStackSizeByOne x = monadicIO $ do (oldSize, newSize) <- run . Lua.run @Lua.Exception $ ((,) <$> gettop <*> (push x *> gettop)) assert (newSize == succ oldSize) hslua-classes-2.3.0/test/HsLua/Class/UtilTests.hs0000644000000000000000000000622107346545000020011 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-| Module : HsLua.Class.UtilTests Copyright : © 2017-2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : stable Portability : portable Tests for utility types and functions -} module HsLua.Class.UtilTests (tests) where import Data.Either (isLeft, isRight) import HsLua.Class.Peekable import HsLua.Class.Pushable import HsLua.Class.Util import HsLua.Core as Lua import Test.Tasty.HsLua ( (?:), (=:), pushLuaExpr, shouldBeResultOf , shouldBeErrorMessageOf, shouldHoldForResultOf) import Test.Tasty (TestTree, testGroup) -- | Specifications for Attributes parsing functions. tests :: TestTree tests = testGroup "Utilities" [ "Optional return the value if it exists" =: (Just "Moin" :: Maybe String) `shouldBeResultOf` do push ("Moin" :: String) fromOptional <$> peek top , "Optional can deal with nil values" =: (Nothing :: Maybe String) `shouldBeResultOf` do pushnil fromOptional <$> peek top , "Optional can deal with nonexistent (none) values" =: Nothing `shouldBeResultOf` fmap fromOptional (peek (nthBottom 20) :: Lua (Optional String)) , "raiseError causes a Lua error" =: "test error message" `shouldBeErrorMessageOf` do pushHaskellFunction (raiseError ("test error message" :: String)) call 0 0 return () , testGroup "runEither" [ "Lua errors are caught" =: isLeft `shouldHoldForResultOf` liftIO (runEither' (push True *> peek (-1) :: Lua String)) , "error-less code gives 'Right'" =: isRight `shouldHoldForResultOf` liftIO (runEither' (push True *> peek (-1) :: Lua Bool)) ] , testGroup "peekEither" [ "return right result on success" =: Right (5 :: Lua.Integer) `shouldBeResultOf` do pushinteger 5 peekEither top , "return error message on failure" =: let msg = "integer expected, got boolean" <> "\n\twhile retrieving index 2" <> "\n\twhile retrieving list" in Left (Lua.Exception msg) `shouldBeResultOf` do pushLuaExpr "{1, false}" peekEither top :: Lua (Either Lua.Exception [Lua.Integer]) ] , testGroup "popValue" [ "value is retrieved and popped" =: (-1, "ocean" :: String) `shouldBeResultOf` do Lua.pushstring "ocean" oldTop <- Lua.gettop value <- popValue newTop <- Lua.gettop return (newTop - oldTop, value) , "value is popped even on error" =: (Left (-1) :: Either Lua.StackIndex Lua.Number) `shouldBeResultOf` do Lua.pushstring "not a number" oldTop <- Lua.gettop value <- Lua.try popValue newTop <- Lua.gettop let stackDiff = newTop - oldTop return $ case value of Left _ -> Left stackDiff Right x -> Right x , "error messages equals that of peek" ?: do Lua.pushstring "not a number" p1 <- Lua.try (peek Lua.top :: Lua Lua.Integer) p2 <- Lua.try (popValue :: Lua Lua.Integer) return (p1 == p2) ] ] runEither' :: Lua a -> IO (Either Lua.Exception a) runEither' = runEither hslua-classes-2.3.0/test/HsLua/0000755000000000000000000000000007346545000014447 5ustar0000000000000000hslua-classes-2.3.0/test/HsLua/ClassesTests.hs0000644000000000000000000001447307346545000017434 0ustar0000000000000000{-# LANGUAGE TypeApplications #-} {-| Module : HsLua.ClassesTests Copyright : © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : beta Portability : non-portable (depends on GHC) Test that conversions from and to the Lua stack are isomorphisms. -} module HsLua.ClassesTests (tests) where import Control.Monad (forM, forM_) import Data.ByteString (ByteString) import Data.Map (Map) import Data.Set (Set) import HsLua.Class.Peekable import HsLua.Class.Pushable import HsLua.Core as Lua import Lua.Arbitrary () import Test.QuickCheck import Test.QuickCheck.Instances () import Test.QuickCheck.Monadic as QCMonadic import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import qualified Data.Text as T -- | Specifications for Attributes parsing functions. tests :: TestTree tests = testGroup "peek and push are well behaved" [ testGroup "Peek can act as left inverse of push" [ testProperty "round-tripping unit" (prop_roundtripEqual :: () -> Property) , testProperty "booleans remain equal under push/peek" (prop_roundtripEqual :: Bool -> Property) , testProperty "lua numbers (i.e., doubles) remain equal under push/peek" (prop_roundtripEqual :: Lua.Number -> Property) , testProperty "Lua integers remain equal under push/peek" (prop_roundtripEqual :: Lua.Integer -> Property) , testProperty "bytestring remain equal under push/peek" (prop_roundtripEqual :: ByteString -> Property) , testProperty "Prelude.Integer" (prop_roundtripEqual :: Prelude.Integer -> Property) , testProperty "Float" (prop_roundtripEqual :: Float -> Property) , testProperty "Double" (prop_roundtripEqual :: Double -> Property) , testProperty "round-tripping strings" (prop_roundtripEqual :: String -> Property) , testProperty "lists of boolean remain equal under push/peeks" (prop_roundtripEqual :: [Bool] -> Property) , testProperty "lists of lua integers remain equal under push/peek" (prop_roundtripEqual :: [Lua.Integer] -> Property) , testProperty "lists of bytestrings remain equal under push/peek" (prop_roundtripEqual :: [ByteString] -> Property) , testProperty "text" (prop_roundtripEqual :: T.Text -> Property) , testProperty "map of strings to Lua.Number" (prop_roundtripEqual :: Map String Lua.Number -> Property) , testProperty "set of strings" (prop_roundtripEqual :: Set Lua.Number -> Property) , testGroup "tuples" [ testProperty "pair of Lua.Numbers" (prop_roundtripEqual :: (Lua.Number, Lua.Number) -> Property) , testProperty "triple of Lua.Numbers" (prop_roundtripEqual :: (Lua.Number, Lua.Number, Lua.Number) -> Property) , testProperty "quadruple of Lua.Numbers" (prop_roundtripEqual :: (Lua.Number, Lua.Number, Lua.Number, Lua.Number) -> Property) , testProperty "quintuple of Lua.Numbers" (prop_roundtripEqual :: (Lua.Number, Lua.Number, Lua.Number, Lua.Number, Lua.Number) -> Property) , testProperty "hextuple of Text, Lua.Numbers and Booleans" (prop_roundtripEqual :: (Bool, Lua.Number, T.Text, Bool, Lua.Number, Lua.Number) -> Property) , testProperty "septuple of Text, Lua.Number and Booleans" (prop_roundtripEqual :: (T.Text, Bool, Lua.Number, Bool, Bool, Lua.Number, Bool) -> Property) , testProperty "octuple of Strings and Booleans" (prop_roundtripEqual :: (Bool, String, Bool, Bool, String, Bool, Bool, String) -> Property) ] ] , testGroup "Random stack values" [ testProperty "can push/pop booleans" (prop_stackPushingPulling :: Bool -> Property) , testProperty "can push/pop lua integers" (prop_stackPushingPulling :: Lua.Integer -> Property) , testProperty "can push/pop lua numbers" (prop_stackPushingPulling :: Lua.Number -> Property) , testProperty "can push/pop bytestrings" (prop_stackPushingPulling :: ByteString -> Property) , testProperty "can push/pop lists of booleans" (prop_stackPushingPulling :: [Bool] -> Property) , testProperty "can push/pop lists of Lua.Integers" (prop_stackPushingPulling :: [Lua.Integer] -> Property) , testProperty "can push/pop lists of bytestrings" (prop_stackPushingPulling :: [ByteString] -> Property) , testProperty "can push/pop set of bytestrings" (prop_stackPushingPulling :: Set ByteString -> Property) ] ] prop_roundtripEqual :: (Eq a, Peekable a, Pushable a) => a -> Property prop_roundtripEqual x = monadicIO $ do y <- QCMonadic.run $ roundtrip x assert (x == y) roundtrip :: (Peekable a, Pushable a) => a -> IO a roundtrip x = Lua.run @Lua.Exception $ do push x peek (-1) -- | More involved check that the Peekable and Pushable instances of a -- datatype work prop_stackPushingPulling :: (Eq t, Pushable t, Peekable t) => t -> Property prop_stackPushingPulling t = monadicIO $ do -- Init Lua state l <- QCMonadic.run newstate -- Get an ascending list of small (1-100) positive integers -- These are the indices at which we will push the value to be tested -- Note that duplicate values don't matter so we don't need to guard against that Ordered indices' <- pick arbitrary let indices = map getPositive indices' let nItems = (if null indices then 0 else last indices) :: Lua.Integer -- Make sure there's enough room in the stack assert =<< QCMonadic.run (runWith l $ checkstack (2 * fromIntegral nItems)) -- Push elements QCMonadic.run $ forM_ [1..nItems] $ \n -> runWith @Lua.Exception l $ if n `elem` indices then push t else push n -- Check that the stack size is the same as the total number of pushed items stackSize <- QCMonadic.run $ runWith l gettop assert $ fromStackIndex stackSize == fromIntegral nItems -- Peek all items vals <- QCMonadic.run $ forM indices $ runWith @Lua.Exception l . peek . StackIndex . fromIntegral -- Check that the stack size did not change after peeking newStackSize <- QCMonadic.run $ runWith l gettop assert $ stackSize == newStackSize -- Check that we were able to peek at all pushed elements forM_ vals $ assert . (== t) -- Cleanup QCMonadic.run (close l) hslua-classes-2.3.0/test/0000755000000000000000000000000007346545000013433 5ustar0000000000000000hslua-classes-2.3.0/test/test-hslua-classes.hs0000644000000000000000000000175607346545000017524 0ustar0000000000000000{-| Module : Main Copyright : © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2023 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : beta Portability : non-portable (depends on GHC) Test marshaling/unmarshaling from and to the Lua stack. -} module Main (main) where import Test.Tasty (TestTree, defaultMain, testGroup) import qualified HsLua.ClassesTests import qualified HsLua.Class.ExposableTests import qualified HsLua.Class.InvokableTests import qualified HsLua.Class.PeekableTests import qualified HsLua.Class.PushableTests import qualified HsLua.Class.UtilTests main :: IO () main = defaultMain $ testGroup "hslua-classes" tests -- | HSpec tests tests :: [TestTree] tests = [ HsLua.Class.ExposableTests.tests , HsLua.Class.InvokableTests.tests , HsLua.Class.PeekableTests.tests , HsLua.Class.PushableTests.tests , HsLua.Class.UtilTests.tests , HsLua.ClassesTests.tests ]