diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +# Changelog + +`hslua-classes` uses [PVP Versioning][1]. + +## hslua-classes 2.0.0 + +Release pending. + +- Initially created. Contains modules previously found in the + `Foreign.Lua.Types` hierarchy from `hslua-1.3`. + +[1]: https://pvp.haskell.org 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,19 @@ +# 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 diff --git a/hslua-classes.cabal b/hslua-classes.cabal new file mode 100644 --- /dev/null +++ b/hslua-classes.cabal @@ -0,0 +1,94 @@ +cabal-version: 2.2 +name: hslua-classes +version: 2.0.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: 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 +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.4 + , GHC == 9.0.1 + +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.8 && < 5 + , bytestring >= 0.10.2 && < 0.12 + , containers >= 0.5.9 && < 0.7 + , exceptions >= 0.8 && < 0.11 + , hslua-core >= 2.0 && < 2.1 + , hslua-marshalling >= 2.0 && < 2.1 + , 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.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 diff --git a/src/HsLua/Class/Exposable.hs b/src/HsLua/Class/Exposable.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Class/Exposable.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-| +Module : HsLua.Class.Exposable +Copyright : © 2007–2012 Gracjan Polak, + 2012–2016 Ömer Sinan Ağacan, + 2017-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : FlexibleInstances, ForeignFunctionInterface, ScopedTypeVariables + +Call Haskell functions from Lua. +-} +module HsLua.Class.Exposable + ( Exposable (..) + , toHaskellFunction + , registerHaskellFunction + ) where + +import HsLua.Core as Lua +import HsLua.Class.Peekable (Peekable (peek), PeekError (..), inContext) +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 PeekError 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 -> LuaE e NumResults + +instance {-# OVERLAPPING #-} PeekError e => + Exposable e (HaskellFunction e) where + partialApply _ = id + +instance (PeekError e, Pushable a) => Exposable e (LuaE e a) where + partialApply _narg x = 1 <$ (x >>= push) + +instance (Peekable a, Exposable e b) => Exposable e (a -> b) where + partialApply narg f = getArg >>= partialApply (narg + 1) . f + where + getArg = inContext errorPrefix (peek narg) + errorPrefix = "could not read 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 @Lua a@, where @a@ is an instance of +-- @'Pushable'@ +-- +-- Any @'Lua.Exception'@ will be converted to a string and returned +-- as Lua error. +-- +-- /Important/: this does __not__ catch exceptions other than +-- @'Lua.Exception'@; exception handling must be done by the converted +-- 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 = do + inContext "Error during function call:" $ partialApply 1 a + +-- | Imports a Haskell function and registers it at global name. +registerHaskellFunction :: Exposable e a + => Name -> a -> LuaE e () +registerHaskellFunction n f = do + pushHaskellFunction $ toHaskellFunction f + setglobal n diff --git a/src/HsLua/Class/Invokable.hs b/src/HsLua/Class/Invokable.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Class/Invokable.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : HsLua.Class.Invokable +Copyright : © 2007–2012 Gracjan Polak, + 2012–2016 Ömer Sinan Ağacan, + 2017-2021 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 PeekError e => Invokable e a where + addArg :: Name -> LuaE e () -> NumArgs -> a + +instance (PeekError e, Peekable a) => Invokable e (LuaE e a) where + addArg fnName pushArgs nargs = do + _ <- dostring $ "return " `append` Lua.fromName fnName + pushArgs + call nargs 1 + popValue + +instance (Pushable a, PeekError e, Invokable e b) => Invokable e (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 :: forall e a. Invokable e a => Name -> a +invoke fname = addArg @e fname (return ()) 0 diff --git a/src/HsLua/Class/Peekable.hs b/src/HsLua/Class/Peekable.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Class/Peekable.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : HsLua.Class.Peekable +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) + +Sending haskell objects to the lua stack. +-} +module HsLua.Class.Peekable + ( Peekable (..) + , PeekError (..) + , peekKeyValuePairs + , peekList + , reportValueOnFailure + , inContext + ) where + +import Control.Monad ((>=>)) +import Data.ByteString (ByteString) +import Data.Map (Map, fromList) +import Data.Set (Set) +import HsLua.Core as Lua +import HsLua.Marshalling.Peek (runPeeker) +import Foreign.Ptr (Ptr) + +import qualified Control.Monad.Catch as Catch +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.ByteString.Lazy as BL +import qualified HsLua.Core.Unsafe as Unsafe +import qualified HsLua.Marshalling as Peek + +-- | Use @test@ to check whether the value at stack index @n@ has the +-- correct type and use @peekfn@ to convert it to a haskell value if +-- possible. Throws and exception if the test failes with the expected +-- type name as part of the message. +typeChecked :: forall e a. LuaError e + => ByteString -- ^ expected type + -> (StackIndex -> LuaE e Bool) -- ^ pre-condition Checker + -> (StackIndex -> LuaE e a) -- ^ retrieval function + -> StackIndex -> LuaE e a +typeChecked expectedType test peekfn idx = do + v <- test idx + if v + then peekfn idx + else throwTypeMismatchError expectedType idx + +-- | Report the expected and actual type of the value under the given +-- index if conversion failed. +reportValueOnFailure :: forall e a. PeekError e + => ByteString + -> (StackIndex -> LuaE e (Maybe a)) + -> StackIndex -> LuaE e a +reportValueOnFailure expected peekMb idx = do + res <- peekMb idx + case res of + (Just x) -> return x + Nothing -> throwTypeMismatchError expected idx + +-- | A value that can be read from the Lua stack. +class Peekable a where + -- | Check if at index @n@ there is a convertible Lua value and if so return + -- it. Throws a @'Lua.Exception'@ otherwise. + peek :: PeekError e => StackIndex -> LuaE e a + +instance Peekable () where + peek = reportValueOnFailure "nil" $ \idx -> do + isNil <- isnil idx + return (if isNil then Just () else Nothing) + +instance Peekable Lua.Integer where + peek = reportValueOnFailure "integer" tointeger + +instance Peekable Lua.Number where + peek = reportValueOnFailure "number" tonumber + +instance Peekable ByteString where + peek = runPeeker Peek.peekByteString >=> Peek.force + +instance Peekable Bool where + peek = toboolean + +instance Peekable CFunction where + peek = reportValueOnFailure "C function" tocfunction + +instance Peekable (Ptr a) where + peek = reportValueOnFailure "userdata" touserdata + +instance Peekable Lua.State where + peek = reportValueOnFailure "Lua state (i.e., a thread)" tothread + +instance Peekable T.Text where + peek = runPeeker Peek.peekText >=> Peek.force + +instance Peekable BL.ByteString where + peek = runPeeker Peek.peekLazyByteString >=> Peek.force + +instance Peekable Prelude.Integer where + peek = runPeeker Peek.peekIntegral >=> Peek.force + +instance Peekable Int where + peek = runPeeker Peek.peekIntegral >=> Peek.force + +instance Peekable Float where + peek = runPeeker Peek.peekRealFloat >=> Peek.force + +instance Peekable Double where + peek = runPeeker Peek.peekRealFloat >=> Peek.force + +instance {-# OVERLAPS #-} Peekable [Char] where + peek = runPeeker Peek.peekString >=> Peek.force + +instance Peekable a => Peekable [a] where + peek = peekList + +instance (Ord a, Peekable a, Peekable b) => Peekable (Map a b) where + peek = fmap fromList . peekKeyValuePairs + +instance (Ord a, Peekable a) => Peekable (Set a) where + peek = -- All keys with non-nil values are in the set + fmap (Set.fromList . map fst . filter snd) . peekKeyValuePairs + +-- | Read a table into a list +peekList :: (PeekError e, Peekable a) => StackIndex -> LuaE e [a] +peekList = typeChecked "table" istable $ \idx -> do + let elementsAt [] = return [] + elementsAt (i : is) = do + x <- (rawgeti idx i *> peek top) `Catch.finally` pop 1 + (x:) <$> elementsAt is + listLength <- fromIntegral <$> rawlen idx + inContext "Could not read list:" (elementsAt [1..listLength]) + +-- | Read a table into a list of pairs. +peekKeyValuePairs :: (Peekable a, Peekable b, PeekError e) + => StackIndex -> LuaE e [(a, b)] +peekKeyValuePairs = typeChecked "table" istable $ \idx -> do + let remainingPairs = do + res <- nextPair (if idx < 0 then idx - 1 else idx) + case res of + Nothing -> [] <$ return () + Just a -> (a:) <$> remainingPairs + pushnil + remainingPairs + -- ensure the remaining key is removed from the stack on exception + `Catch.onException` pop 1 + +-- | Get the next key-value pair from a table. Assumes the last key to +-- be on the top of the stack and the table at the given index @idx@. +nextPair :: (PeekError e, Peekable a, Peekable b) + => StackIndex -> LuaE e (Maybe (a, b)) +nextPair idx = do + hasNext <- Unsafe.next idx + if hasNext + then let pair = (,) <$> inContext "Could not read key of key-value pair:" + (peek (nth 2)) + <*> inContext "Could not read value of key-value pair:" + (peek (nth 1)) + in Just <$> pair `Catch.finally` pop 1 + -- removes the value, keeps the key + else return Nothing + +-- | Specify a name for the context in which a computation is run. The +-- name is added to the error message in case of an exception. +inContext :: forall e a. PeekError e + => String -> LuaE e a -> LuaE e a +inContext ctx op = try op >>= \case + Right x -> return x + Left (err :: e) -> Catch.throwM $ + luaException @e (ctx ++ "\n\t" ++ messageFromException err) + +-- | Exceptions that are to be used with 'peek' and similar functions +-- must be instances of this class. It ensures that error can be amended +-- with the context in which they happened. +class LuaError e => PeekError e where + messageFromException :: e -> String + +instance PeekError Lua.Exception where + messageFromException = Lua.exceptionMessage + +-- +-- Tuples +-- + +instance {-# OVERLAPPABLE #-} + (Peekable a, Peekable b) => + Peekable (a, b) + where + peek = typeChecked "table" istable $ \idx -> + (,) <$> nthValue idx 1 <*> nthValue idx 2 + +instance {-# OVERLAPPABLE #-} + (Peekable a, Peekable b, Peekable c) => + Peekable (a, b, c) + where + peek = typeChecked "table" istable $ \idx -> + (,,) <$> nthValue idx 1 <*> nthValue idx 2 <*> nthValue idx 3 + +instance {-# OVERLAPPABLE #-} + (Peekable a, Peekable b, Peekable c, Peekable d) => + Peekable (a, b, c, d) + where + peek = 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 + peek = 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 + peek = 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 + peek = 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 + peek = 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 :: (PeekError e, Peekable a) + => StackIndex -> Lua.Integer -> LuaE e a +nthValue idx n = do + rawgeti idx n + peek top `Catch.finally` pop 1 diff --git a/src/HsLua/Class/Pushable.hs b/src/HsLua/Class/Pushable.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Class/Pushable.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-| +Module : HsLua.Class.Pushable +Copyright : © 2007–2012 Gracjan Polak; + © 2012–2016 Ömer Sinan Ağacan; + © 2017-2021 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 diff --git a/src/HsLua/Class/Util.hs b/src/HsLua/Class/Util.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Class/Util.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-| +Module : HsLua.Class.Util +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) + +HsLua utility functions. +-} +module HsLua.Class.Util + ( raiseError + , Optional (Optional, fromOptional) + -- * getting values + , peekEither + , popValue + ) where + +import HsLua.Core (LuaE, NumResults, StackIndex, top) +import HsLua.Class.Peekable (Peekable (peek), PeekError) +import HsLua.Class.Pushable (Pushable (push)) + +import qualified Control.Monad.Catch as Catch +import qualified HsLua.Core as Lua + +-- | Raise a Lua error, using the given value as the error object. +raiseError :: (PeekError 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 + peek idx = do + noValue <- Lua.isnoneornil idx + if noValue + then return $ Optional Nothing + else Optional . Just <$> peek 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 :: (PeekError 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 :: (PeekError e, Peekable a) => LuaE e a +popValue = peek top `Catch.finally` Lua.pop 1 +{-# INLINABLE popValue #-} diff --git a/src/HsLua/Classes.hs b/src/HsLua/Classes.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Classes.hs @@ -0,0 +1,39 @@ +{-| +Module : HsLua.Classes +Copyright : © 2007–2012 Gracjan Polak; + © 2012–2016 Ömer Sinan Ağacan; + © 2017-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +Stability : beta +Portability : non-portable (depends on GHC) + +Convenience 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 + , peekList + , peekKeyValuePairs + -- * 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 diff --git a/test/HsLua/Class/ExposableTests.hs b/test/HsLua/Class/ExposableTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/Class/ExposableTests.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : HsLua.Class.ExposableTests +Copyright : © 2017-2021 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" $ toHaskellFunction @Lua.Exception 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" =: + ("Error during function call:\n\tcould not read argument 2:\n\t" + ++ "integer expected, got boolean") `shouldBeErrorMessageOf` do + Lua.registerHaskellFunction "integerOp" integerOperation + pushLuaExpr "integerOp(23, true)" + + , "Error in Haskell function is converted into Lua error" =: + (False, "Error during function call:\n\tfoo") `shouldBeResultOf` do + Lua.openlibs + Lua.pushHaskellFunction $ + toHaskellFunction (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) + ] diff --git a/test/HsLua/Class/InvokableTests.hs b/test/HsLua/Class/InvokableTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/Class/InvokableTests.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : HsLua.Class.InvokableTests +Copyright : © 2017-2021 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 @Lua.Exception "rawequal" (5 :: Lua.Integer) (5.0 :: Lua.Number) + + , "failing lua function call" =: + "foo" `shouldBeErrorMessageOf` do + openlibs + invoke @Lua.Exception "assert" False (Char8.pack "foo") :: Lua Bool + + , "pack table via lua procedure" =: + (True, 23 :: Lua.Integer, "moin" :: ByteString) `shouldBeResultOf` do + openlibs + invoke @Lua.Exception "table.pack" True (23 :: Lua.Integer) (Char8.pack "moin") + + , "failing lua procedure call" =: + "foo" `shouldBeErrorMessageOf` do + openlibs + invoke @Lua.Exception "error" (Char8.pack "foo") :: Lua () + + , "Error when Lua-to-Haskell result conversion fails" =: + "string expected, got boolean" `shouldBeErrorMessageOf` do + openlibs + invoke @Lua.Exception "rawequal" (Char8.pack "a") () :: Lua String + ] diff --git a/test/HsLua/Class/PeekableTests.hs b/test/HsLua/Class/PeekableTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/Class/PeekableTests.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : HsLua.Class.PeekableTests +Copyright : © 2017-2021 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) + +import qualified Data.Set as Set + +-- | 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 "peekKeyValuePairs" + [ "`next` is not confused when peeking at number keys as strings" =: + -- list of numbers can be retrieved as pair of strings + [("1", "2"), ("2", "4"), ("3", "8"), ("4", "16")] `shouldBeResultOf` do + pushLuaExpr "{2, 4, 8, 16}" + peekKeyValuePairs top :: Lua [(String, String)] + + , "peek string pairs" =: + Set.fromList [("foo", "bar"), ("qux", "quux")] `shouldBeResultOf` do + pushLuaExpr "{foo = 'bar', qux = 'quux'}" + Set.fromList <$> (peekKeyValuePairs top :: Lua [(String, String)]) + + , "stack is left unchanged" =: + 0 `shouldBeResultOf` do + pushLuaExpr "{foo = 'bar', qux = 'quux'}" + topBefore <- gettop + _ <- peekKeyValuePairs top :: Lua [(String, String)] + topAfter <- gettop + return (topAfter - topBefore) + ] + + , 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" =: + "Could not read list:\n\tnumber expected, got boolean" + `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 + _ <- peekList 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 (peekKeyValuePairs top :: Lua [(String, String)]) + topAfter <- gettop + return (topAfter - topBefore) + ] + ] diff --git a/test/HsLua/Class/PushableTests.hs b/test/HsLua/Class/PushableTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/Class/PushableTests.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : HsLua.Class.PushableTests +Copyright : © 2017-2021 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) diff --git a/test/HsLua/Class/UtilTests.hs b/test/HsLua/Class/UtilTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/Class/UtilTests.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : HsLua.Class.UtilTests +Copyright : © 2017-2021 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) + +#if !MIN_VERSION_base(4,12,0) +import Data.Semigroup (Semigroup ((<>))) +#endif + +-- | 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 = "Could not read list:\n" + <> "\tinteger expected, got boolean" + 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 diff --git a/test/HsLua/ClassesTests.hs b/test/HsLua/ClassesTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/ClassesTests.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE TypeApplications #-} +{-| +Module : HsLua.ClassesTests +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) + +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) diff --git a/test/test-hslua-classes.hs b/test/test-hslua-classes.hs new file mode 100644 --- /dev/null +++ b/test/test-hslua-classes.hs @@ -0,0 +1,36 @@ +{-| +Module : Main +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) + +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 + ]