hslua-classes (empty) → 2.0.0

raw patch · 17 files changed

+1463/−0 lines, 17 filesdep +QuickCheckdep +basedep +bytestring

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

Files

• CHANGELOG.md +12/−0
• LICENSE +23/−0
• README.md +19/−0
• hslua-classes.cabal +94/−0
• src/HsLua/Class/Exposable.hs +80/−0
• src/HsLua/Class/Invokable.hs +49/−0
• src/HsLua/Class/Peekable.hs +256/−0
• src/HsLua/Class/Pushable.hs +186/−0
• src/HsLua/Class/Util.hs +68/−0
• src/HsLua/Classes.hs +39/−0
• test/HsLua/Class/ExposableTests.hs +61/−0
• test/HsLua/Class/InvokableTests.hs +48/−0
• test/HsLua/Class/PeekableTests.hs +120/−0
• test/HsLua/Class/PushableTests.hs +98/−0
• test/HsLua/Class/UtilTests.hs +108/−0
• test/HsLua/ClassesTests.hs +166/−0
• test/test-hslua-classes.hs +36/−0

@@ -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

@@ -0,0 +1,23 @@+Copyright © 1994-2020 Lua.org, PUC-Rio.+Copyright © 2007-2012 Gracjan Polak+Copyright © 2012-2015 Ömer Sinan Ağacan+Copyright © 2016-2021 Albert Krewinkel++Permission is hereby granted, free of charge, to any person obtaining a+copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

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

@@ -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

@@ -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 <tarleb+hslua@zeitkraut.de>+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

@@ -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 <tarleb+hslua@zeitkraut.de>+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

@@ -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 <tarleb+hslua@zeitkraut.de>+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

@@ -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 <tarleb+hslua@zeitkraut.de>+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

@@ -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 <tarleb+hslua@zeitkraut.de>+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 #-}

@@ -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 <tarleb+hslua@zeitkraut.de>+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

@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-|+Module      : HsLua.Class.ExposableTests+Copyright   : © 2017-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>++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)+  ]

@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-|+Module      : HsLua.Class.InvokableTests+Copyright   : © 2017-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>++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+  ]

@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-|+Module      :  HsLua.Class.PeekableTests+Copyright   :  © 2017-2021 Albert Krewinkel+License     :  MIT++Maintainer  :  Albert Krewinkel <tarleb+hslua@zeitkraut.de>+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)+    ]+  ]

@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications  #-}+{-|+Module      :  HsLua.Class.PushableTests+Copyright   :  © 2017-2021 Albert Krewinkel+License     :  MIT++Maintainer  :  Albert Krewinkel <tarleb+hslua@zeitkraut.de>+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)

@@ -0,0 +1,108 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-|+Module      :  HsLua.Class.UtilTests+Copyright   :  © 2017-2021 Albert Krewinkel+License     :  MIT++Maintainer  :  Albert Krewinkel <tarleb+hslua@zeitkraut.de>+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

@@ -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 <tarleb+hslua@zeitkraut.de>+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)

@@ -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 <tarleb+hslua@zeitkraut.de>+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+  ]