packages feed

hslua-marshalling (empty) → 2.0.0

raw patch · 15 files changed

+1821/−0 lines, 15 filesdep +QuickCheckdep +basedep +bytestring

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

Files

+ CHANGELOG.md view
@@ -0,0 +1,16 @@+## Changelog++`hslua-marshalling` uses [PVP Versioning](https://pvp.haskell.org).++### hslua-marshalling 2.0.0++Release pending.++- Initially created. Contains modules previously found in the+  modules `Foreign.Lua.Peek` and `Foreign.Lua.Push` from+  `hslua-1.3`.++- Removed most functions from the Userdata module, incl. peekAny,+  pushAny. The functions don't add much value over those in+  `HsLua.Core.Userdata`. Use UDTypes from hslua-packaging for a+  more comfortable method of exposing data via userdata values.
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,16 @@+# hslua-marshalling++[![Build status][GitHub Actions badge]][GitHub Actions]+[![AppVeyor Status]](https://ci.appveyor.com/project/tarleb/hslua-r2y18)+[![Hackage]](https://hackage.haskell.org/package/hslua-marshalling)++Functions to marshal values from Haskell to Lua, and *vice versa*.++This package is part of [HsLua], a Haskell framework built around+the embeddable scripting language [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-marshalling.svg+[HsLua]: https://hslua.org/
+ hslua-marshalling.cabal view
@@ -0,0 +1,93 @@+cabal-version:       2.2+name:                hslua-marshalling+version:             2.0.0+synopsis:            Marshalling of values between Haskell and Lua.+description:         Provides functions to marshal values from Haskell+                     to Lua, and /vice versa/.+                     .+                     This package is part of HsLua, a Haskell framework+                     built around the embeddable scripting language+                     <https://lua.org Lua>.+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+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-marshalling++common common-options+  default-language:    Haskell2010+  build-depends:       base              >= 4.8    && < 5+                     , bytestring        >= 0.10.2 && < 0.12+                     , containers        >= 0.5.9  && < 0.7+                     , hslua-core        >= 2.0    && < 2.1+                     , mtl               >= 2.2    && < 2.3+                     , text              >= 1.0    && < 1.3+  ghc-options:         -Wall+                       -Wincomplete-record-updates+                       -Wnoncanonical-monad-instances+                       -Wredundant-constraints+  if impl(ghc >= 8.2)+    ghc-options:         -Wcpp-undef+                         -Werror=missing-home-modules+  if impl(ghc >= 8.4)+    ghc-options:         -Widentities+                         -Wincomplete-uni-patterns+                         -Wpartial-fields+                         -fhide-source-paths++library+  import:              common-options+  exposed-modules:     HsLua.Marshalling+                     , HsLua.Marshalling.Peek+                     , HsLua.Marshalling.Peekers+                     , HsLua.Marshalling.Push+                     , HsLua.Marshalling.Userdata+  hs-source-dirs:      src+  default-extensions:  LambdaCase+  other-extensions:    DeriveDataTypeable+                     , DeriveFunctor+                     , OverloadedStrings+                     , TypeApplications++test-suite test-hslua+  import:              common-options+  type:                exitcode-stdio-1.0+  main-is:             test-hslua-marshalling.hs+  hs-source-dirs:      test+  ghc-options:         -threaded -Wno-unused-do-bind+  other-modules:       HsLua.MarshallingTests+                     , HsLua.Marshalling.PeekTests+                     , HsLua.Marshalling.PeekersTests+                     , HsLua.Marshalling.PushTests+                     , HsLua.Marshalling.UserdataTests+  build-depends:       hslua-marshalling+                     , lua-arbitrary        >= 1.0+                     , QuickCheck           >= 2.7+                     , quickcheck-instances >= 0.3+                     , tasty-hslua+                     , tasty                >= 0.11+                     , tasty-hunit          >= 0.9+                     , tasty-quickcheck     >= 0.8+  other-extensions:    DeriveDataTypeable+                     , LambdaCase+                     , OverloadedStrings+                     , TypeApplications
+ src/HsLua/Marshalling.hs view
@@ -0,0 +1,70 @@+{-|+Module      : HsLua.Marshalling+Copyright   : © 2007–2012 Gracjan Polak;+              © 2012–2016 Ömer Sinan Ağacan;+              © 2017-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>++Functions to push and retrieve data to and from Lua.+-}+module HsLua.Marshalling+  ( -- * Receiving values from Lua stack (Lua → Haskell)+    Peeker+  , runPeeker+  , Result (..)+  , force+  , retrieving+  , failure+  , resultToEither+    -- ** Primitive types+  , peekNil+  , peekNoneOrNil+  , peekBool+  , peekIntegral+  , peekRealFloat+    -- ** Strings+  , peekByteString+  , peekLazyByteString+  , peekString+  , peekText+  , peekStringy+  , peekName+    -- ** Readable types+  , peekRead+    -- ** Collections+  , peekKeyValuePairs+  , peekList+  , peekMap+  , peekSet+    -- ** Combinators+  , choice+  , peekFieldRaw+  , peekPair+  , peekTriple+    -- ** Lua peek monad+  , Peek (..)+  , forcePeek+  , liftLua+  , withContext+  , failPeek+  , lastly+  , cleanup+    -- ** Building Peek functions+  , typeChecked+  , typeMismatchMessage+  , reportValueOnFailure++    -- * Pushing values to Lua stack (Haskell → Lua)+  , module HsLua.Marshalling.Push++    -- * Utilities+  , pushIterator+  ) where++import Prelude hiding (compare, concat)++import HsLua.Marshalling.Peek+import HsLua.Marshalling.Peekers+import HsLua.Marshalling.Push+import HsLua.Marshalling.Userdata (pushIterator)
+ src/HsLua/Marshalling/Peek.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-|+Module      : HsLua.Marshalling.Peek+Copyright   : © 2020-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Stability   : beta+Portability : Portable++Types for unmarshalling of values from Lua.+-}+module HsLua.Marshalling.Peek+  ( Peeker+  , runPeeker+  , Result (..)+  , isFailure+  , failure+  , force+  , retrieving+  , resultToEither+  , toPeeker+  -- * Lua peek monad+  , Peek (..)+  , forcePeek+  , failPeek+  , liftLua+  , withContext+  , lastly+  , cleanup+  ) where++import Control.Applicative (Alternative (..))+import Control.Monad ((<$!>), (<=<))+import Data.ByteString (ByteString)+import Data.List (intercalate)+import HsLua.Core as Lua+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail (..))+#endif+import qualified HsLua.Core.Utf8 as Utf8++-- | Record to keep track of failure contexts while retrieving objects+-- from the Lua stack.+data Result a+  = Success a+  | Failure ByteString [Name]       -- ^ Error message and stack of contexts+  deriving (Show, Eq, Functor)++instance Applicative Result where+  pure = Success+  {-# INLINE pure #-}+  Success f         <*> s = fmap f s+  Failure msg stack <*> _         = Failure msg stack+  {-# INLINE (<*>) #-}++instance Monad Result where+  Failure msg stack >>= _ = Failure msg stack+  Success x         >>= f = f x++instance Alternative Result where+  empty = Failure "empty" []+  {-# INLINE empty #-}+  x <|> y = case x of+    Failure {} -> y+    _          -> x+  {-# INLINE (<|>) #-}++--+-- Peek+--++-- | Lua operation with an additional failure mode that can stack errors+-- from different contexts; errors are not based on exceptions).+newtype Peek e a = Peek { runPeek :: LuaE e (Result a) }+  deriving (Functor)++-- | Converts a Peek action into a LuaE action, throwing an exception in+-- case of a peek failure.+forcePeek :: LuaError e => Peek e a -> LuaE e a+forcePeek = force <=< runPeek+{-# INLINE forcePeek #-}++-- | Fails the peek operation.+failPeek :: forall a e. ByteString -> Peek e a+failPeek = Peek . return . failure+{-# INLINE failPeek #-}++-- | Lifts a Lua operation into the Peek monad.+liftLua :: LuaE e a -> Peek e a+liftLua = Peek . fmap pure+{-# INLINE liftLua #-}++instance Applicative (Peek e) where+  pure = Peek . return . pure+  {-# INLINE pure #-}++  Peek f <*> x = Peek $! f >>= \case+    Failure msg stack -> return $ Failure msg stack+    Success f'        -> fmap f' <$!> runPeek x+  {-# INLINEABLE (<*>) #-}++  m *> k = m >>= const k+  {-# INLINE (*>) #-}++instance Monad (Peek e) where+  Peek m >>= k = Peek $+    m >>= \case+      Failure msg stack -> return $ Failure msg stack+      Success x         -> runPeek (k x)+  {-# INLINE (>>=) #-}++instance Alternative (Peek e) where+  empty = Peek . return $ failure "empty"+  {-# INLINE empty #-}++  a <|> b = Peek $ runPeek a >>= \case+    Success ra -> return (pure ra)+    _          -> runPeek b+  {-# INLINE (<|>) #-}++instance MonadFail (Peek e) where+  fail = Peek . return . failure . Utf8.fromString+  {-# INLINABLE fail #-}++-- | Transform the result using the given function.+withContext :: Name -> Peek e a -> Peek e a+withContext ctx = Peek . fmap (addFailureContext ctx) . runPeek+{-# INLINABLE withContext #-}++-- | Runs the peek action and Lua action in sequence, even if the peek+-- action fails.+lastly :: Peek e a -> LuaE e b -> Peek e a+lastly p after = Peek $ runPeek p <* after+{-# INLINABLE lastly #-}++-- | Runs the peek action, resetting the stack top afterwards. This can+-- be used with peek actions that might otherwise leave elements on the+-- stack in case of a failure.+cleanup :: Peek e a -> Peek e a+cleanup p = Peek $ do+  oldtop <- gettop+  result <- runPeek p+  settop oldtop+  return result+{-# INLINABLE cleanup #-}++-- | Returns 'True' iff the peek result is a Failure.+isFailure :: Result a -> Bool+isFailure Failure {} = True+isFailure _          = False++-- | Combines the peek failure components into a reportable string.+formatPeekFailure :: ByteString -> [Name] -> String+formatPeekFailure msg stack =+  intercalate "\n\twhile retrieving " $+  map Utf8.toString (msg : map fromName (reverse stack))++-- | Function to retrieve a value from Lua's stack.+type Peeker e a = StackIndex -> Peek e a++-- | Runs the peeker function.+runPeeker :: Peeker e a -> StackIndex -> LuaE e (Result a)+runPeeker p = runPeek . p++-- | Create a peek failure record from an error message.+failure :: ByteString -> Result a+failure msg = Failure msg []++-- | Add a message to the peek traceback stack.+addFailureContext :: Name -> Result a -> Result a+addFailureContext name = \case+  Failure msg stack -> Failure msg (name : stack)+  x -> x+{-# INLINABLE addFailureContext #-}++-- | Add context information to the peek traceback stack.+retrieving :: Name+           -> Peek e a+           -> Peek e a+retrieving = withContext+{-# INLINE retrieving #-}++-- | Force creation of an unwrapped result, throwing an exception if+-- that's not possible.+force :: LuaError e => Result a -> LuaE e a+force = \case+  Success x -> return x+  Failure msg stack -> failLua $ formatPeekFailure msg stack+{-# INLINABLE force #-}++-- | Converts a Result into an Either, where @Left@ holds the reportable+-- string in case of an failure.+resultToEither :: Result a -> Either String a+resultToEither = \case+  Failure msg stack -> Left $ formatPeekFailure msg stack+  Success x         -> Right x++-- | Converts an old peek funtion to a 'Peeker'.+toPeeker :: LuaError e+         => (StackIndex -> LuaE e a)+         -> Peeker e a+toPeeker op idx = Peek $ try (op idx) >>= \case+  Left err  -> return $! failure $ Utf8.fromString (show err)+  Right res -> return $! Success res
+ src/HsLua/Marshalling/Peekers.hs view
@@ -0,0 +1,329 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-|+Module      : HsLua.Marshalling.Peekers+Copyright   : © 2020-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Stability   : beta+Portability : Portable++Functions which unmarshal and retrieve Haskell values from Lua's stack.+-}+module HsLua.Marshalling.Peekers+  ( -- * Peeking values from the stack+    -- ** Primitives+    peekNil+  , peekNoneOrNil+  , peekBool+  , peekIntegral+  , peekRealFloat+    -- ** Strings+  , peekByteString+  , peekLazyByteString+  , peekString+  , peekText+  , peekStringy+  , peekName+  -- ** Readable types+  , peekRead+  -- ** Collections+  , peekKeyValuePairs+  , peekList+  , peekMap+  , peekSet+  -- ** Combinators+  , choice+  , peekFieldRaw+  , peekIndexRaw+  , peekPair+  , peekTriple+  -- ** Building peek functions+  , typeChecked+  , reportValueOnFailure+  , typeMismatchMessage+  ) where++import Control.Applicative (Alternative (..))+import Control.Monad ((<$!>), (>=>))+import Data.ByteString (ByteString)+import Data.Map (Map)+import Data.Set (Set)+import Data.String (IsString (fromString))+import HsLua.Core as Lua+import HsLua.Marshalling.Peek+import Text.Read (readMaybe)++#if !MIN_VERSION_base(4,12,0)+import Data.Semigroup (Semigroup ((<>)))+#endif++import qualified Data.ByteString.Lazy as BL+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified HsLua.Core.Unsafe as Unsafe+import qualified HsLua.Core.Utf8 as Utf8++-- | 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. A successfully received value is wrapped+-- using the 'Right' constructor, while a type mismatch results+-- in @Left PeekError@ with the given error message.+typeChecked :: Name                         -- ^ expected type+            -> (StackIndex -> LuaE e Bool)  -- ^ pre-condition checker+            -> Peeker e a+            -> Peeker e a+typeChecked expectedType test peekfn idx = do+  v <- liftLua $ test idx+  if v+    then peekfn idx+    else typeMismatchMessage expectedType idx >>= failPeek++-- | Generate a type mismatch error.+typeMismatchMessage :: Name       -- ^ expected type+                    -> StackIndex -- ^ index of offending value+                    -> Peek e ByteString+typeMismatchMessage (Name expected) idx = liftLua $ do+  pushTypeMismatchError expected idx+  (tostring top <* pop 1) >>= \case+    Just !msg -> return msg+    Nothing  -> return $ mconcat+      [ "Unknown type mismatch for "+      , expected+      , " at stack index "+      , Utf8.fromString $ show (fromStackIndex idx)+      ]++-- | Report the expected and actual type of the value under the given+-- index if conversion failed.+reportValueOnFailure :: Name         -- ^ expected type+                     -> (StackIndex -> LuaE e (Maybe a))+                     -> Peeker e a+reportValueOnFailure expected peekMb idx = do+  res <- liftLua $ peekMb idx+  case res of+    Just x  -> return $! x+    Nothing -> typeMismatchMessage expected idx >>= failPeek++--+-- Primitives+--++-- | Succeeds if the value at the given index is @nil@.+peekNil :: Peeker e ()+peekNil = typeChecked "nil" Lua.isnil $ const (return ())+{-# INLINABLE peekNil #-}++-- | Succeeds if the given index is not valid or if the value at this+-- index is @nil@.+peekNoneOrNil :: Peeker e ()+peekNoneOrNil = typeChecked "none or nil" Lua.isnoneornil $ const (return ())+{-# INLINABLE peekNoneOrNil #-}++-- | Retrieves a 'Bool' as a Lua boolean.+peekBool :: Peeker e Bool+peekBool = liftLua . toboolean++--+-- Strings+--++-- | Like 'tostring', but ensures that the value at the given index is+-- not silently converted to a string, as would happen with numbers.+toByteString :: StackIndex -> LuaE e (Maybe ByteString)+toByteString idx = do+  -- copy value, as tostring converts numbers to strings *in-place*.+  pushvalue idx+  tostring top <* pop 1+{-# INLINABLE toByteString #-}++-- | Retrieves a 'ByteString' as a raw string.+peekByteString :: Peeker e ByteString+peekByteString = reportValueOnFailure "string" toByteString+{-# INLINABLE peekByteString #-}++-- | Retrieves a lazy 'BL.ByteString' as a raw string.+peekLazyByteString :: Peeker e BL.ByteString+peekLazyByteString = (BL.fromStrict <$!>) . peekByteString+{-# INLINABLE peekLazyByteString #-}++-- | Retrieves a 'String' from an UTF-8 encoded Lua string.+peekString :: Peeker e String+peekString = peekStringy+{-# INLINABLE peekString #-}++-- | Retrieves a String-like value from an UTF-8 encoded Lua string.+--+-- This should not be used to peek 'ByteString' values or other values+-- for which construction via 'fromString' can result in loss of+-- information.+peekStringy :: forall a e. IsString a => Peeker e a+peekStringy = fmap (fromString . Utf8.toString) . peekByteString+{-# INLINABLE peekStringy #-}++-- | Retrieves a 'T.Text' value as an UTF-8 encoded string.+peekText :: Peeker e T.Text+peekText = (Utf8.toText <$!>) . peekByteString+{-# INLINABLE peekText #-}++-- | Retrieves a Lua string as 'Name'.+peekName :: Peeker e Name+peekName = (Name <$!>) . peekByteString+{-# INLINABLE peekName #-}++--+-- Arbitrary values+--++-- | Retrieves a value by getting a String from Lua, then using+-- 'readMaybe' to convert the String into a Haskell value.+peekRead :: forall a e. Read a => Peeker e a+peekRead = peekString >=> readValue+  where+    readValue s = case readMaybe s of+      Just x  -> pure x+      Nothing -> failPeek $ "Could not read: " <> Utf8.fromString s++--+-- Numbers+--++-- | Retrieves an 'Integral' value from the Lua stack.+peekIntegral :: forall a e. (Integral a, Read a) => Peeker e a+peekIntegral idx = liftLua (ltype idx) >>= \case+  TypeNumber  -> fromIntegral <$!>+                 reportValueOnFailure "Integral" tointeger idx+  TypeString  -> do+    Just str <- liftLua $ tostring idx+    case readMaybe (Utf8.toString str) of+      Nothing -> typeMismatchMessage "Integral" idx >>= failPeek+      Just x  -> return x+  _ -> typeMismatchMessage "Integral" idx >>= failPeek++-- | Retrieve a 'RealFloat' (e.g., 'Float' or 'Double') from the stack.+peekRealFloat :: forall a e. (RealFloat a, Read a) => Peeker e a+peekRealFloat idx = liftLua (ltype idx) >>= \case+  TypeString  -> do+    Just str <- liftLua $ tostring idx+    case readMaybe (Utf8.toString str) of+      Nothing -> typeMismatchMessage "RealFloat" idx >>= failPeek+      Just x  -> return x+  _ -> realToFrac <$!> reportValueOnFailure "RealFloat" tonumber idx++-- | Reads a numerically indexed table @t@ into a list, where the 'length' of+-- the list is equal to @rawlen(t)@. The operation will fail unless all+-- numerical fields between @1@ and @rawlen(t)@ can be retrieved.+peekList :: forall a e. LuaError e => Peeker e a -> Peeker e [a]+peekList peekElement = fmap (retrieving "list") .+  typeChecked "table" istable $ \idx -> do+  let elementsAt [] = return []+      elementsAt (i : is) = do+        x  <- retrieving ("index " <> showInt i) $+              liftLua (rawgeti idx i) *> peekElement top `lastly` pop 1+        xs <- elementsAt is+        return (x:xs)+      showInt (Lua.Integer x) = fromString $ show x+  listLength <- liftLua (rawlen idx)+  elementsAt [1..fromIntegral listLength]++-- | Retrieves a key-value Lua table as 'Map'.+peekMap :: Ord a => Peeker e a -> Peeker e b -> Peeker e (Map a b)+peekMap keyPeeker valuePeeker = retrieving "Map"+  . fmap Map.fromList+  . peekKeyValuePairs keyPeeker valuePeeker++-- | Read a table into a list of pairs.+peekKeyValuePairs :: Peeker e a -> Peeker e b -> Peeker e [(a, b)]+peekKeyValuePairs keyPeeker valuePeeker =+  typeChecked "table" istable $ \idx -> cleanup $ do+    idx' <- liftLua $ absindex idx+    let remainingPairs = nextPair keyPeeker valuePeeker idx' >>= \case+          Nothing -> return []+          Just a  -> (a:) <$!> remainingPairs+    liftLua pushnil+    remainingPairs++-- | 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@. The next key, if it exists, is left at the top of+-- the stack.+--+-- The key must be either nil or must exist in the table, or this+-- function will crash with an unrecoverable error.+nextPair :: Peeker e a -> Peeker e b -> Peeker e (Maybe (a, b))+nextPair keyPeeker valuePeeker idx = retrieving "key-value pair" $ do+  hasNext <- liftLua $ Unsafe.next idx+  if not hasNext+    then return Nothing+    else do+      key   <- retrieving "key"   $ keyPeeker   (nth 2)+      value <- retrieving "value" $ valuePeeker (nth 1)+      return (Just (key, value))+        `lastly` pop 1  -- remove value, leave the key++-- | Retrieves a 'Set' from an idiomatic Lua representation. A+-- set in Lua is idiomatically represented as a table with the+-- elements as keys. Elements with falsy values are omitted.+peekSet :: Ord a => Peeker e a -> Peeker e (Set a)+peekSet elementPeeker = withContext "Set"+  . fmap (Set.fromList . map fst . filter snd)+  . peekKeyValuePairs elementPeeker peekBool++--+-- Combinators+--++-- | Get value at key from a table.+peekFieldRaw :: LuaError e => Peeker e a -> Name -> Peeker e a+peekFieldRaw peeker name idx =+  retrieving ("raw field '" <> name <> "'") $! do+    liftLua $ do+      absidx <- Lua.absindex idx+      pushstring $ fromName name+      rawget absidx+    peeker top `lastly` Lua.pop 1+{-# INLINABLE peekFieldRaw #-}++-- | Get value at integer index key from a table.+peekIndexRaw :: LuaError e => Lua.Integer -> Peeker e a -> Peeker e a+peekIndexRaw i peeker idx = do+  let showInt (Lua.Integer x) = fromString $ show x+  retrieving (fromString $ "raw index '" <> showInt i <> "'") $! do+    liftLua $ rawgeti idx i+    peeker top `lastly` Lua.pop 1+{-# INLINABLE peekIndexRaw #-}++-- | Retrieves a value pair from a table. Expects the values to be+-- stored in a numerically indexed table; does not access metamethods.+peekPair :: LuaError e+         => Peeker e a -> Peeker e b+         -> Peeker e (a, b)+peekPair peekA peekB idx = cleanup $ do+  idx' <- liftLua $ absindex idx+  a <- liftLua (rawgeti idx' 1) *> peekA top+  b <- liftLua (rawgeti idx' 2) *> peekB top+  return (a, b)++-- | Retrieves a value triple from a table. Expects the values to be+-- stored in a numerically indexed table, with no metamethods.+peekTriple :: LuaError e+           => Peeker e a -> Peeker e b -> Peeker e c+           -> Peeker e (a, b, c)+peekTriple peekA peekB peekC idx = cleanup $ do+  idx' <- liftLua $ absindex idx+  a <- liftLua (rawgeti idx' 1) *> peekA top+  b <- liftLua (rawgeti idx' 2) *> peekB top+  c <- liftLua (rawgeti idx' 3) *> peekC top+  return (a,b,c)++-- | Try all peekers and return the result of the first to succeed.+choice :: LuaError e+       => [Peeker e a]+       -> Peeker e a+choice peekers idx = case peekers of+  [] -> failPeek "all choices failed"+  p:ps -> p idx <|> choice ps idx+{-# INLINABLE choice #-}
+ src/HsLua/Marshalling/Push.hs view
@@ -0,0 +1,149 @@+{-|+Module      : HsLua.Marshalling.Push+Copyright   : © 2020-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Stability   : beta+Portability : Portable++Functions which marshal and push Haskell values onto Lua's stack.+-}+module HsLua.Marshalling.Push+  ( Pusher+  -- * Primitives+  , pushBool+  , pushIntegral+  , pushRealFloat+  -- * Strings+  , pushByteString+  , pushLazyByteString+  , pushString+  , pushText+  , pushName+  -- * Collections+  , pushList+  , pushKeyValuePairs+  , pushMap+  , pushSet+  -- * Combinators+  , pushPair+  , pushTriple+  ) where++import Control.Monad (zipWithM_)+import Data.ByteString (ByteString)+import Data.Map (Map, toList)+import Data.Set (Set)+import HsLua.Core as Lua+import Numeric (showGFloat)++import qualified Data.Text as T+import qualified Data.ByteString.Lazy as BL+import qualified HsLua.Core.Utf8 as Utf8++-- | Function to push a value to Lua's stack.+type Pusher e a = a -> LuaE e ()++-- | Pushes a 'Bool' as a Lua boolean.+pushBool :: Pusher e Bool+pushBool = pushboolean++-- | Pushes a 'T.Text' value as a UTF-8 encoded string.+pushText :: Pusher e T.Text+pushText = pushstring . Utf8.fromText++-- | Pushes a 'ByteString' as a raw string.+pushByteString :: Pusher e ByteString+pushByteString = pushstring++-- | Pushes a lazy 'BL.ByteString' as a raw string.+pushLazyByteString :: Pusher e BL.ByteString+pushLazyByteString = pushstring . BL.toStrict++-- | Pushes a 'String' as a UTF-8 encoded Lua string.+pushString :: String -> LuaE e ()+pushString = pushstring . Utf8.fromString++-- | Pushes a 'Name' as a UTF-8 encoded Lua string.+pushName :: Name -> LuaE e ()+pushName (Name n) = pushByteString n++-- | Pushes an @Integer@ to the Lua stack. Values representable as Lua+-- integers are pushed as such; bigger integers are represented using+-- their string representation.+pushIntegral :: (Integral a, Show a) => a -> LuaE e ()+pushIntegral i =+  let maxInt = fromIntegral (maxBound :: Lua.Integer)+      minInt = fromIntegral (minBound :: Lua.Integer)+      i' = fromIntegral i :: Prelude.Integer+  in if i' >= minInt && i' <= maxInt+     then pushinteger $ fromIntegral i+     else pushString  $ show i++-- | Push a floating point number to the Lua stack. Uses a string+-- representation for all types which do not match the float properties+-- of the 'Lua.Number' type.+pushRealFloat :: RealFloat a => a -> LuaE e ()+pushRealFloat f =+  let+    number = 0 :: Lua.Number+    realFloatFitsInNumber = floatRadix number == floatRadix f+      && floatDigits number == floatDigits f+      && floatRange number == floatRange f+  in if realFloatFitsInNumber+     then pushnumber (realToFrac f :: Lua.Number)+     else pushString (showGFloat Nothing f "")++-- | Push list of pairs as default key-value Lua table.+pushKeyValuePairs :: LuaError e+                  => Pusher e a -> Pusher e b -> Pusher e [(a,b)]+pushKeyValuePairs pushKey pushValue m = do+  let addValue (k, v) = pushKey k *> pushValue v *> rawset (-3)+  newtable+  mapM_ addValue m++-- | Push list as numerically indexed table.+pushList :: LuaError e => Pusher e a -> [a] -> LuaE e ()+pushList push xs = do+  let setField i x = push x *> rawseti (-2) i+  newtable+  zipWithM_ setField [1..] xs++-- | Push 'Map' as default key-value Lua table.+pushMap :: LuaError e => Pusher e a -> Pusher e b -> Pusher e (Map a b)+pushMap pushKey pushValue m = pushKeyValuePairs pushKey pushValue $ toList m++-- | Push a 'Set' as idiomatic Lua set, i.e., as a table with the set+-- elements as keys and @true@ as values.+pushSet :: LuaError e => Pusher e a -> Pusher e (Set a)+pushSet pushElement set = do+  let addItem item = pushElement item *> pushboolean True *> rawset (-3)+  newtable+  mapM_ addItem set++--+-- Combinators+--++-- | Pushes a pair of values as a two element list.+pushPair :: LuaError e+         => Pusher e a -> Pusher e b+         -> (a, b)+         -> LuaE e ()+pushPair pushA pushB (a,b) = do+  newtable+  pushA a+  rawseti (nth 2) 1+  pushB b+  rawseti (nth 2) 2++-- | Pushes a value triple as a three element list.+pushTriple :: LuaError e+           => Pusher e a -> Pusher e b -> Pusher e c+           -> (a, b, c)+           -> LuaE e ()+pushTriple pushA pushB pushC (a,b,c) = do+  newtable+  zipWithM_ (\p i -> p *> rawseti (nth 2) i)+            [pushA a, pushB b, pushC c]+            [1..]
+ src/HsLua/Marshalling/Userdata.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-|+Module      : HsLua.Marshalling.Userdata+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 functions to use Haskell values as Lua userdata.+-}+module HsLua.Marshalling.Userdata+  ( pushIterator+  ) where++import Control.Monad (void)+import HsLua.Core as Lua++-- | Pushes three values to the stack that can be used in a generic for+-- loop to lazily iterate over all values in the list. Keeps the+-- remaining list in a userdata state.+pushIterator :: forall a e. LuaError e+             => (a -> LuaE e NumResults)  -- ^ the values to push+             -> [a]                       -- ^ list to iterate over lazily+             -> LuaE e NumResults+pushIterator pushValues xs = do+  -- push initial state+  pushHaskellFunction nextItem+  pushInitialState+  pushnil+  return (NumResults 3)+  where+    nextItem :: LuaE e NumResults+    nextItem = do+      props <- fromuserdata @[a] (nthBottom 1) statename+      case props of+        Nothing -> failLua+          "Error in iterator: could not retrieve iterator state."+        Just [] -> 2 <$ (pushnil *> pushnil)  -- end loop+        Just (y:ys) -> do+          success <- putuserdata @[a] (nthBottom 1) statename ys+          if not success+            then failLua "Error in iterator: could not update iterator state."+            else pushValues y++    statename :: Name+    statename = "HsLua iterator state"++    pushInitialState :: LuaE e ()+    pushInitialState = do+      newhsuserdata @[a] xs+      void (newudmetatable statename)+      setmetatable (nth 2)
+ test/HsLua/Marshalling/PeekTests.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-|+Module      : HsLua.Marshalling.PeekTests+Copyright   : © 2020-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Stability   : alpha+Portability : OverloadedStrings, TypeApplications++Tests for Haskell-value retriever functions.+-}+module HsLua.Marshalling.PeekTests (tests) where++import Control.Applicative (Alternative ((<|>)))+import Data.Maybe (fromMaybe)+import HsLua.Marshalling.Peek+import Test.Tasty.HsLua ((=:), pushLuaExpr, shouldBeResultOf)+import Test.Tasty (TestTree, testGroup)++import qualified HsLua.Core as Lua++-- | Calling Haskell functions from Lua.+tests :: TestTree+tests = testGroup "Peek"+  [ testGroup "helper"+    [ "retrieving" =:+      Failure @() "message" ["context"] `shouldBeResultOf`+      runPeek (retrieving "context" $ failPeek "message")++    , let firstindex idx = do+            Lua.rawgeti idx 1+            fromMaybe 0 <$> Lua.tointeger Lua.top <* Lua.pop 1+      in testGroup "toPeeker"+      [ "passes result through" =:+        Success 1337 `shouldBeResultOf` do+          pushLuaExpr "{1337}"+          runPeeker (toPeeker firstindex) Lua.top++      , "catches error" =:+        let msg = "Lua exception: table expected, got number"+        in+          Failure msg [] `shouldBeResultOf` do+          Lua.pushinteger 1337+          runPeeker (toPeeker firstindex) Lua.top+      ]+    ]++  , testGroup "Peek"+    [ "lazy alternative" =:+      Success @Int 5 `shouldBeResultOf` runPeek+        (return 5 <|> error "nope")+    ]+  ]
+ test/HsLua/Marshalling/PeekersTests.hs view
@@ -0,0 +1,451 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-|+Module      : HsLua.Marshalling.PeekersTests+Copyright   : © 2020-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>++Tests for Haskell-value retriever functions.+-}+module HsLua.Marshalling.PeekersTests (tests) where++import Control.Monad (forM_, zipWithM_)+import HsLua.Marshalling.Peek+import HsLua.Marshalling.Peekers++import Lua.Arbitrary ()+import Test.Tasty.HsLua+  ( (=:), pushLuaExpr, shouldBeResultOf, shouldHoldForResultOf+  , shouldBeErrorMessageOf)+import Test.QuickCheck.Instances ()+import Test.QuickCheck.Monadic (monadicIO, run, assert)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as Char8+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified HsLua.Core as Lua+import qualified HsLua.Core.Utf8 as Utf8++-- | Calling Haskell functions from Lua.+tests :: TestTree+tests = testGroup "Peekers"+  [ testGroup "unit peekers"+    [ "peekNil succeeds on nil" =:+      Success () `shouldBeResultOf` do+        Lua.pushnil+        runPeek $ peekNil Lua.top+    , "peekNil fails on bool" =:+      isFailure `shouldHoldForResultOf` do+        Lua.pushboolean False+        runPeek $ peekNil Lua.top+    , "peekNoneOrNil succeeds on nil" =:+      Success () `shouldBeResultOf` do+        Lua.pushnil+        runPeek $ peekNoneOrNil Lua.top+    , "peekNoneOrNilfails on bool" =:+      isFailure `shouldHoldForResultOf` do+        Lua.pushboolean False+        runPeek $ peekNoneOrNil Lua.top+    ]+  , testGroup "peekBool"+    [ "True" =:+      Success True `shouldBeResultOf` do+        Lua.pushboolean True+        runPeeker peekBool Lua.top++    , "False" =:+      Success False `shouldBeResultOf` do+        Lua.pushboolean False+        runPeeker peekBool Lua.top++    , "Numbers are truthy" =:+      Success True `shouldBeResultOf` do+        Lua.pushnumber 0+        runPeeker peekBool Lua.top++    , "Nil is falsy" =:+      Success False `shouldBeResultOf` do+        Lua.pushnil+        runPeeker peekBool Lua.top++    -- no tests for failing cases, this function always succeeds.+    ]++  , testGroup "peekIntegral"+    [ "negative Int" =:+      Success (-5) `shouldBeResultOf` do+        Lua.pushinteger (-5)+        runPeek $ peekIntegral @Int Lua.top++    , "Int as string" =:+      Success 720 `shouldBeResultOf` do+        Lua.pushstring "720"+        runPeek $ peekIntegral @Int Lua.top++    , "fail on boolean" =:+      let msg = "Integral expected, got boolean"+      in failure msg `shouldBeResultOf` do+        Lua.pushboolean True+        runPeek $ peekIntegral @Int Lua.top++    , "fail on non-numeric string" =:+      let msg = "Integral expected, got string"+      in failure msg `shouldBeResultOf` do+        Lua.pushstring "not a number"+        runPeek $ peekIntegral @Integer Lua.top+    ]++  , testGroup "peekRealFloat"+    [ "negative Float" =:+      Success (-13.37) `shouldBeResultOf` do+        Lua.pushnumber (-13.37)+        runPeek $ peekRealFloat @Float Lua.top++    , "number as string" =:+      Success (-720.0) `shouldBeResultOf` do+        Lua.pushstring "-720"+        runPeek $ peekRealFloat @Float Lua.top++    , "scientific notation string" =:+      Success 0.00071 `shouldBeResultOf` do+        Lua.pushstring "7.1e-4"+        runPeek $ peekRealFloat @Float Lua.top++    , "fail on boolean" =:+      let msg = "RealFloat expected, got boolean"+      in failure msg `shouldBeResultOf` do+        Lua.pushboolean True+        runPeek $ peekRealFloat @Float Lua.top++    , "fail on non-numeric string" =:+      let msg = "RealFloat expected, got string"+      in failure msg `shouldBeResultOf` do+        Lua.pushstring "not a number"+        runPeek $ peekRealFloat @Double Lua.top+    ]++  , testGroup "Strings"+    [ testGroup "peekByteString"+      [ testProperty "retrieve any string" $ \bs -> monadicIO $ do+          retrieved <- run $ Lua.run @Lua.Exception $ do+            Lua.pushstring bs+            runPeeker peekByteString Lua.top+          assert (retrieved == Success bs)++      , testProperty "retrieve integer as string" $ \n -> monadicIO $ do+          retrieved <- run . Lua.run @Lua.Exception $ do+            Lua.pushinteger n+            runPeeker peekByteString Lua.top+          let numberAsByteString = Char8.pack . show @Integer . fromIntegral $ n+          assert (retrieved == Success numberAsByteString)++      , "fails on boolean" =:+      let msg = "string expected, got boolean"+      in failure msg `shouldBeResultOf` do+        Lua.pushboolean True+        runPeeker peekByteString Lua.top+      ]++    , testGroup "peekText"+      [ testProperty "retrieve any string" $ \bs -> monadicIO $ do+          retrieved <- run $ Lua.run @Lua.Exception $ do+            Lua.pushstring bs+            runPeeker peekText Lua.top+          assert (retrieved == Success (Utf8.toText bs))++      , testProperty "retrieve UTF-8 encoded Text" $ \txt -> monadicIO $ do+          retrieved <- run $ Lua.run @Lua.Exception $ do+            Lua.pushstring (Utf8.fromText txt)+            runPeeker peekText Lua.top+          assert (retrieved == Success txt)++      , testProperty "retrieve integer as Text" $ \n -> monadicIO $ do+          retrieved <- run . Lua.run @Lua.Exception $ do+            Lua.pushinteger n+            runPeeker peekText Lua.top+          let numberAsByteString = T.pack . show @Integer . fromIntegral $ n+          assert (retrieved == Success numberAsByteString)++      , "fails on nil" =:+        let msg = "string expected, got nil"+        in failure msg `shouldBeResultOf` do+          Lua.pushnil+          runPeeker peekByteString Lua.top+      ]++    , testGroup "peekString"+      [ testProperty "retrieve UTF-8 encoded string" $ \txt -> monadicIO $ do+          retrieved <- run $ Lua.run @Lua.Exception $ do+            Lua.pushstring (Utf8.fromString txt)+            runPeeker peekString Lua.top+          assert (retrieved == Success txt)++      , "fails on table" =:+        isFailure `shouldHoldForResultOf` do+          _ <- Lua.pushglobaltable+          runPeeker peekString Lua.top++      , "fails on thread" =:+        isFailure `shouldHoldForResultOf` do+          _ <- Lua.pushthread+          runPeeker peekString Lua.top+      ]++    , testGroup "peekStringy"+      [ testProperty "retrieve UTF-8 encoded string as Text" $ \txt ->+          monadicIO $ do+            retrieved <- run $ Lua.run @Lua.Exception $ do+              Lua.pushstring (Utf8.fromText txt)+              runPeeker (peekStringy @T.Text) Lua.top+            assert (retrieved == Success txt)++      , "retrieve ByteString" =:+        Success "This is an ASCII string" `shouldBeResultOf` do+          Lua.pushstring "This is an ASCII string"+          runPeeker (peekStringy @B.ByteString) Lua.top++      , "fails on table" =:+        isFailure `shouldHoldForResultOf` do+          _ <- Lua.pushglobaltable+          runPeeker (peekStringy @B.ByteString) Lua.top+      ]++    , testGroup "peekName"+      [ testProperty "retrieve string as Name" $ \txt ->+          monadicIO $ do+            retrieved <- run $ Lua.run @Lua.Exception $ do+              Lua.pushstring txt+              runPeeker peekName Lua.top+            assert (retrieved == Success (Lua.Name txt))++      , "fails on table" =:+        isFailure `shouldHoldForResultOf` do+          _ <- Lua.pushglobaltable+          runPeeker peekName Lua.top+      ]+    ]++  , testGroup "peekRead"+    [ testProperty "retrieve list of orderings" $ \xs ->+        monadicIO $ do+          retrieved <- run $ Lua.run @Lua.Exception $ do+            Lua.pushstring . Utf8.fromString $ show @[Ordering] xs+            runPeeker peekRead Lua.top+          assert (retrieved == Success xs)++    , "fails on unreadable input" =:+      isFailure `shouldHoldForResultOf` do+        Lua.pushstring "NaN"+        runPeek $ peekRead @Int Lua.top++    , "fails on non-string input" =:+      "string expected, got boolean" `shouldBeErrorMessageOf` do+        Lua.pushboolean True+        runPeeker (peekRead @Int) Lua.top >>= force+    ]++  , testGroup "Containers"+    [ testGroup "peekList"+      [ "empty list" =:+        Success [] `shouldBeResultOf` do+          Lua.newtable+          runPeek $ peekList peekBool Lua.top++      , testProperty "list of strings" $ \lst -> monadicIO $ do+          retrieved <- run $ Lua.run @Lua.Exception $ do+            Lua.newtable+            zipWithM_+              (\i s -> Lua.pushstring s *>+                       Lua.rawseti (Lua.nth 2) i)+              [1..]+              lst+            runPeek $ peekList peekByteString Lua.top+          assert (retrieved == Success lst)++      , "string keys are not in list" =:+        Success [] `shouldBeResultOf` do+          pushLuaExpr "{['1'] = 'hello', ['2'] = 'world'}"+          runPeek $ peekList peekByteString Lua.top++      , "missing pair causes an error" =:+        isFailure `shouldHoldForResultOf` do+          pushLuaExpr "{[1] = 'hello', [2] = 'world', [4] = 'nope'}"+          runPeek $ peekList peekByteString Lua.top+      ]++    , testGroup "peekSet"+      [ "empty set" =:+        Success Set.empty `shouldBeResultOf` do+          Lua.newtable+          runPeek $ peekSet peekBool Lua.top++      , testProperty "set of strings" $ \set -> monadicIO $ do+          retrieved <- run $ Lua.run @Lua.Exception $ do+            Lua.newtable+            forM_ (Set.toList set) $ \x -> do+              Lua.pushstring x+              Lua.pushboolean True+              Lua.rawset (Lua.nth 3)+            runPeek $ peekSet peekByteString Lua.top+          assert (retrieved == Success set)++      , "keys with falsy values are not in set" =:+        Success (Set.fromList [1,3]) `shouldBeResultOf` do+          pushLuaExpr "{['1'] = 'hello', ['2'] = false, [3] = 5}"+          runPeek $ peekSet (peekIntegral @Int) Lua.top++      , "fails if element peeker fails" =:+        let errorStack = [ "Set", "key-value pair", "key"]+            errorMsg = "string expected, got boolean"+        in Failure errorMsg errorStack `shouldBeResultOf` do+          pushLuaExpr "{ NaN = true, [true] = false }"+          runPeek $ peekSet peekText Lua.top+      ]++    , testGroup "peekMap"+      [ "empty map" =:+        Success Map.empty `shouldBeResultOf` do+          Lua.newtable+          runPeek $ peekMap peekText peekText Lua.top++      , "tables become maps" =:+        Success (Map.fromList [("one", 1), ("two", 2)]) `shouldBeResultOf` do+          pushLuaExpr "{ one = 1, two = 2}"+          runPeek $ peekMap peekText (peekIntegral @Int) Lua.top++      , "fails if key peeker fails" =:+        let errorStack = [ "Map", "key-value pair" , "key" ]+            errorMsg = "Integral expected, got string"+        in Failure errorMsg errorStack `shouldBeResultOf` do+          pushLuaExpr "{ NaN = true }"+          runPeek $ peekMap (peekIntegral @Int) peekBool Lua.top++      , "fails if value peeker fails" =:+        let errorStack = [ "Map", "key-value pair", "value" ]+            errorMsg = "string expected, got boolean"+        in Failure errorMsg errorStack `shouldBeResultOf` do+          pushLuaExpr "{ [42] = true }"+          runPeek $ peekMap (peekIntegral @Int) peekText Lua.top+      ]+    ]++  , testGroup "combinators"+    [ testGroup "peekFieldRaw"+      [ "access field" =:+        Success 8 `shouldBeResultOf` do+          pushLuaExpr "{ num = 8 }"+          runPeek $ peekFieldRaw (peekIntegral @Int) "num" Lua.top+      , "object not on top of stack" =:+        Success 9 `shouldBeResultOf` do+          pushLuaExpr "{ int = 9 }"+          Lua.pushnil+          runPeek $ peekFieldRaw (peekIntegral @Int) "int" (Lua.nth 2)+      ]++    , testGroup "peekPair"+      [ "pair from table" =:+        Success ("ninety", 90) `shouldBeResultOf` do+          pushLuaExpr "{'ninety', 90}"+          Lua.pushnil+          runPeek $+            peekPair peekString (peekIntegral @Int) (Lua.nth 2)++      , "fails if a component peeker fails" =:+        Failure "fail" [] `shouldBeResultOf` do+          pushLuaExpr "{ 'second', 2 }"+          runPeek $+            peekPair peekString (const $ failPeek @() "fail") Lua.top+      ]++    , testGroup "peekTriple"+      [ "pair from table" =:+        Success ("hundred", 100, True) `shouldBeResultOf` do+          pushLuaExpr "{'hundred', 100, 1}"+          Lua.pushnil+          runPeek $+            peekTriple peekString (peekIntegral @Int) peekBool (Lua.nth 2)++      , "fails if a component peeker fails" =:+        Failure "fail" [] `shouldBeResultOf` do+          pushLuaExpr "{ 'second', 2, true }"+          runPeek $+            peekTriple peekString+                       (const $ failPeek @() "fail")+                       peekBool+                       Lua.top+      ]+    , testGroup "peekChoice"+      [ "uses first result to succeed" =:+        Success 1337 `shouldBeResultOf` runPeek+          (choice [ const $ failPeek "nope"+                  , const $ failPeek "neither"+                  , const $ return (1337 :: Int)+                  ] Lua.top)++      , "uses peekers" =:+        Success "[]" `shouldBeResultOf` do+          Lua.newtable+          runPeeker+            (choice [ peekString+                    , fmap show . peekList peekBool+                    ])+            Lua.top++      , "fails if all peekers fail" =:+        Failure "all choices failed" [] `shouldBeResultOf` do+          runPeeker (choice [const $ failPeek @() "nope"]) Lua.top+      ]+    ]++  , testGroup "helper"+    [ testGroup "reportValueOnFailure"+      [ "success" =:+        Success 23 `shouldBeResultOf` do+          runPeeker+            (reportValueOnFailure "foo" (const . return $ Just (23 :: Int)))+            (Lua.nthBottom 1)++      , "failure" =:+        Failure "squirrel expected, got number" []+        `shouldBeResultOf` do+          Lua.pushinteger 23+          let peekSquirrel :: Peeker Lua.Exception ()+              peekSquirrel = reportValueOnFailure "squirrel"+                                                  (const $ return Nothing)+          runPeeker peekSquirrel Lua.top+      ]+    ]++  , testGroup "error messages"+    [ "value in list" =:+      mconcat ["Integral expected, got table\n"+              , "\twhile retrieving index 3\n"+              , "\twhile retrieving list"+              ] `shouldBeErrorMessageOf` do+        Lua.openlibs+        Lua.OK <- Lua.dostring $ Utf8.fromString+          "nope = {__tostring = function () return '⚘' end}"+        pushLuaExpr "{5, 8, setmetatable({}, nope), 21}"+        runPeeker (peekList (peekIntegral @Int)) Lua.top >>= force++    , "nil instead of list" =:+      mconcat ["table expected, got nil\n"+              , "\twhile retrieving list"+              ] `shouldBeErrorMessageOf` do+        Lua.pushnil+        runPeeker (peekList peekString) Lua.top >>= force++    , "value in key-value pairs" =:+      mconcat [ "string expected, got boolean\n"+              , "\twhile retrieving value\n"+              , "\twhile retrieving key-value pair"+              ] `shouldBeErrorMessageOf` do+        pushLuaExpr "{ a = true}"+        runPeeker (peekKeyValuePairs peekText peekText) Lua.top >>= force+    ]+  ]
+ test/HsLua/Marshalling/PushTests.hs view
@@ -0,0 +1,272 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-|+Module      : HsLua.Marshalling.PushTests+Copyright   : © 2020-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Stability   : alpha+Portability : OverloadedStrings, TypeApplications++Test pushing Haskell values to the stack.+-}+module HsLua.Marshalling.PushTests (tests) where++import Control.Monad (forM)+import Data.ByteString (ByteString)+import Data.Maybe (fromMaybe)+import HsLua.Core (Lua, Number)+import HsLua.Marshalling.Push++import Lua.Arbitrary ()+import Test.Tasty.HsLua ((=:), pushLuaExpr)+import Test.QuickCheck.Instances ()+import Test.QuickCheck.Monadic (monadicIO, run, assert)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertFailure)+import Test.Tasty.QuickCheck (Arbitrary, testProperty)++#if !MIN_VERSION_base(4,12,0)+import Data.Semigroup (Semigroup ((<>)))+#endif++import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified HsLua.Core as Lua+import qualified HsLua.Core.Utf8 as Utf8++-- | Calling Haskell functions from Lua.+tests :: TestTree+tests = testGroup "Push"+  [ testGroup "pushBool"+    [ "True" =:+      assertLuaEqual (pushBool True) "true"+    , "False" =:+      assertLuaEqual (pushBool False) "false"++    , testSingleElementProperty pushBool+    ]++  , testGroup "pushIntegral"+    [ testGroup "@Int"+      [ "0" =:+        assertLuaEqual (pushIntegral @Int 0) "0"+      , "23" =:+        assertLuaEqual (pushIntegral @Int 23) "23"+      , "-5" =:+        assertLuaEqual (pushIntegral @Int (-5)) "-5"+      , testSingleElementProperty (pushIntegral @Int)+      ]+    , testGroup "@Integer"+      [ "2^128 + 1" =:+        assertLuaEqual (pushIntegral @Integer+                         340282366920938463463374607431768211457)+                       "'340282366920938463463374607431768211457'"+      , "-2^129 + 1" =:+        assertLuaEqual (pushIntegral @Integer+                        (-680564733841876926926749214863536422911))+                       "'-680564733841876926926749214863536422911'"+      , testSingleElementProperty (pushIntegral @Integer)+      ]+    ]++  , testGroup "pushRealFloat"+    [ testGroup "@Number"+      [ "0.0" =:+        assertLuaEqual (pushRealFloat @Number 0.0) "0.0"+      , "42.0" =:+        assertLuaEqual (pushRealFloat @Number 42.0) "42.0"+      , "0.1" =:+        assertLuaEqual (pushRealFloat @Number 0.1) "0.1"+      , "-13.37" =:+        assertLuaEqual (pushRealFloat @Number (-13.37)) "-13.37"+      , testSingleElementProperty (pushRealFloat @Number)+      ]++    -- This test may fail if Lua is compiled with Float as the Number+    -- type. Usually though, numbers are doubles.+    , testGroup "@Float pushes strings"+      [ "0.0" =:+        assertLuaEqual (pushRealFloat @Float 0.0) "'0.0'"+      , "42.0" =:+        assertLuaEqual (pushRealFloat @Float 42.0) "'42.0'"+      , "-0.00071" =:+        assertLuaEqual (pushRealFloat @Float (-0.00071)) "'-7.1e-4'"+      , "-13.37" =:+        assertLuaEqual (pushRealFloat @Float (-13.37)) "'-13.37'"+      , testSingleElementProperty (pushRealFloat @Float)+      ]+    ]++  , testGroup "Strings"+    [ testGroup "pushByteString"+      [ "\"test\"" =:+        assertLuaEqual (pushByteString "test") "\"test\""+      , testSingleElementProperty pushByteString+      ]++    , testGroup "pushString"+      [ "\"test\"" =:+        assertLuaEqual (pushString "test") "\"test\""+      , "unicode" =:+        assertLuaEqual (pushString "ÄÉÏøûßð") (Utf8.fromString "'ÄÉÏøûßð'")+      , testSingleElementProperty pushString+      ]++    , testGroup "pushText"+      [ "\"test\"" =:+        assertLuaEqual (pushText "test") "\"test\""+      , "unicode" =:+        assertLuaEqual (pushText "ÄÉÏøûßð") (Utf8.fromString "'ÄÉÏøûßð'")+      , testSingleElementProperty pushText+      ]++    , testGroup "pushName"+      [ "\"test\"" =:+        assertLuaEqual (pushName "test") "\"test\""+      , "unicode" =:+        assertLuaEqual (pushName "ÄÉÏøûßð") (Utf8.fromString "'ÄÉÏøûßð'")+      , testSingleElementProperty (pushName . Lua.Name)+      ]+    ]++  , testGroup "Collections"+    [ testGroup "pushList"+      [ testProperty "creates a table" $ \x -> monadicIO $ do+          producesTable <- run $ Lua.run @Lua.Exception $ do+            pushList pushBool x+            listType <- Lua.ltype Lua.top+            return $ Lua.TypeTable == listType+          assert producesTable++      , testProperty "numeric indices start at 1" $ \list -> monadicIO $ do+          retrievedList <- run $ Lua.run @Lua.Exception $ do+            pushList (pushIntegral @Lua.Integer) list+            listIdx <- Lua.absindex Lua.top+            forM [1..(fromIntegral $ length list)] $ \n ->+              Lua.rawgeti listIdx n+              *> (fromMaybe 0 <$> Lua.tointeger Lua.top)+              <* Lua.pop 1+          assert $ retrievedList == list++      , testProperty "table size equals list length" $ \list -> monadicIO $ do+          tableSize <- run $ Lua.run @Lua.Exception $ do+            pushList pushString list+            Lua.rawlen Lua.top+          assert $ tableSize == length list++      , testSingleElementProperty (pushList pushText)+      ]++    , testGroup "pushKeyValuePairs"+      [ testProperty "creates a table" $ \x -> monadicIO $ do+          producesTable <- run $ Lua.run @Lua.Exception $ do+            pushKeyValuePairs pushText (pushIntegral @Int) x+            listType <- Lua.ltype Lua.top+            return $ Lua.TypeTable == listType+          assert producesTable++      , testSingleElementProperty $+        pushKeyValuePairs (pushIntegral @Int) pushText+      ]++    , testGroup "pushSet"+      [ testProperty "creates a table" $ \x -> monadicIO $ do+          producesTable <- run $ Lua.run @Lua.Exception $ do+            pushSet pushString x+            listType <- Lua.ltype Lua.top+            return $ Lua.TypeTable == listType+          assert producesTable++      , testProperty "set values become table keys" $ \set -> monadicIO $+          case Set.lookupMin set of+            Nothing -> return ()+            Just el -> do+              hasKey <- run $ Lua.run @Lua.Exception $ do+                pushSet (pushIntegral @Lua.Integer) set+                pushIntegral el+                Lua.gettable (Lua.nth 2)+                Lua.toboolean Lua.top+              assert hasKey++      , testSingleElementProperty (pushSet pushText)+      ]++    , testGroup "pushMap"+      [ testProperty "creates a table" $ \m -> monadicIO $ do+          producesTable <- run $ Lua.run @Lua.Exception $ do+            pushMap pushString pushString m+            listType <- Lua.ltype Lua.top+            return $ Lua.TypeTable == listType+          assert producesTable++      , testProperty "pairs are in table" $ \m -> monadicIO $+          case Map.lookupMax m of+            Nothing -> return ()+            Just (k, v) -> do+              tabVal <- run $ Lua.run @Lua.Exception $ do+                pushMap pushText (pushRealFloat @Lua.Number) m+                pushText k+                Lua.gettable (Lua.nth 2)+                fromMaybe (error "key not found") <$>+                  Lua.tonumber Lua.top+              assert (tabVal == v)++      , testSingleElementProperty (pushMap pushText (pushRealFloat @Double))+      ]+    ]+  , testGroup "Combinators"+    [ testProperty "pushPair" $ \(a, b) -> monadicIO $ do+        mpair <- run $ Lua.run @Lua.Exception $ do+          pushPair pushIntegral pushByteString (a, b)+          ma <- Lua.rawgeti Lua.top 1 *> Lua.tointeger Lua.top <* Lua.pop 1+          mb <- Lua.rawgeti Lua.top 2 *> Lua.tostring Lua.top  <* Lua.pop 1+          return $ (,) <$> ma <*> mb+        assert (mpair == Just (a, b))++    , testProperty "pushTriple" $ \(a, b, c) -> monadicIO $ do+        mpair <- run $ Lua.run @Lua.Exception $ do+          pushTriple pushIntegral pushByteString Lua.pushnumber (a, b, c)+          ma <- Lua.rawgeti Lua.top 1 *> Lua.tointeger Lua.top <* Lua.pop 1+          mb <- Lua.rawgeti Lua.top 2 *> Lua.tostring Lua.top  <* Lua.pop 1+          mc <- Lua.rawgeti Lua.top 3 *> Lua.tonumber Lua.top  <* Lua.pop 1+          return $ (,,) <$> ma <*> mb <*> mc+        assert (mpair == Just (a, b, c))+    ]+  ]++-- | Executes a Lua action and checks whether a the value at the top of the+-- stack equals the value represented by the string.+assertLuaEqual :: Lua () -> ByteString -> Assertion+assertLuaEqual action lit =+  let comparison = Lua.run $ do+        action+        pushLuaExpr lit+        isSame <- Lua.rawequal (Lua.nth 1) (Lua.nth 2)+        if isSame+          then return Nothing+          else do+            expectedType <- Lua.ltype (Lua.nth 1) >>= Lua.typename+            actualType <- Lua.ltype (Lua.nth 2) >>= Lua.typename+            actual <- Lua.tostring' (Lua.nth 2)+            return . Just . Utf8.toString $+              "Expected '" <> lit <> "' (" <> expectedType <>+              ") but got '" <> actual <> "'" <> " (" <> actualType <> ")"+  in comparison >>= \case+    Nothing -> return ()+    Just err -> assertFailure err+++-- | Verifies that the operation adds exactly one element to the Lua stack.+testSingleElementProperty :: (Arbitrary a, Show a)+                          => Pusher Lua.Exception a -> TestTree+testSingleElementProperty push = testProperty "pushes single element" $ \x ->+  monadicIO $ do+    (oldSize, newSize) <- run . Lua.run $ do+      old <- Lua.gettop+      push x+      new <- Lua.gettop+      return (old, new)+    assert (newSize == succ oldSize)
+ test/HsLua/Marshalling/UserdataTests.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}+{-|+Module      : HsLua.Marshalling.UserdataTests+Copyright   : © 2018-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>++Tests that any data type can be pushed to Lua as userdata.+-}+module HsLua.Marshalling.UserdataTests (tests) where++import Control.Monad (when)+import HsLua.Marshalling.Userdata+import Test.Tasty.HsLua ( (=:), shouldBeResultOf )+import Test.Tasty (TestTree, testGroup)++import qualified HsLua.Core as Lua++-- | Specifications for Attributes parsing functions.+tests :: TestTree+tests = testGroup "Userdata"+  [ testGroup "pushIterator"+    [ "iterate over list" =:+      Just "0,1,1,2,3,5,8,13,21" `shouldBeResultOf` do+        let fibs = 0 : 1 : zipWith (+) fibs (tail fibs)+        Lua.openlibs+        Lua.pushHaskellFunction $+          pushIterator (\n -> 1 <$ Lua.pushinteger n) (take 9 fibs)+        Lua.setglobal "fibs"+        stat <- Lua.dostring $ mconcat+          [ "local acc = {}\n"+          , "for n in fibs() do\n"+          , "  table.insert(acc, n)\n"+          , "end\n"+          , "return table.concat(acc, ',')\n"+          ]+        when (stat /= Lua.OK) Lua.throwErrorAsException+        Lua.tostring Lua.top+    ]+  ]
+ test/HsLua/MarshallingTests.hs view
@@ -0,0 +1,26 @@+{-|+Module      : HsLua.MarshallingTests+Copyright   : © 2020-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>+Stability   : alpha+Portability : OverloadedStrings, TypeApplications++Test marshalling of basic values.+-}+module HsLua.MarshallingTests (tests) where++import Test.Tasty (TestTree, testGroup)+import qualified HsLua.Marshalling.PeekTests+import qualified HsLua.Marshalling.PeekersTests+import qualified HsLua.Marshalling.PushTests+import qualified HsLua.Marshalling.UserdataTests++-- | Tests for value marshalling.+tests :: TestTree+tests = testGroup "Marshalling"+  [ HsLua.Marshalling.PeekTests.tests+  , HsLua.Marshalling.PeekersTests.tests+  , HsLua.Marshalling.PushTests.tests+  , HsLua.Marshalling.UserdataTests.tests+  ]
+ test/test-hslua-marshalling.hs view
@@ -0,0 +1,18 @@+{-|+Module      : Main+Copyright   : © 2017-2021 Albert Krewinkel+License     : MIT+Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>++Tests for HsLua.+-}+import Test.Tasty (TestTree, defaultMain, testGroup)++import qualified HsLua.MarshallingTests++main :: IO ()+main = defaultMain tests++-- | HSpec tests+tests :: TestTree+tests = testGroup "HsLua" [HsLua.MarshallingTests.tests]