hslua-marshalling-2.3.1/0000755000000000000000000000000007346545000013321 5ustar0000000000000000hslua-marshalling-2.3.1/CHANGELOG.md0000644000000000000000000000537007346545000015137 0ustar0000000000000000# Changelog `hslua-marshalling` uses [PVP Versioning][]. ## hslua-marshalling-2.3.1 Released 2024-01-18. - Relaxed upper bound for text, containers, and bytestring, allowing text-2.1, containers-0.7, and bytestring-0.12. ## hslua-marshalling-2.3.0 Released 2023-03-13. - `Result` is now an instance of `MonadFail`. - New peeker and pusher functions for `NonEmpty`. - Peeker combinators for optional values: The new combinators `peekNilOr`, `peekNoneOr`, and `peekNoneOrNil` can be used to retrieve optional values. ## hslua-marshalling-2.2.1 Released 2022-06-19. - Require hslua-core-2.2.1. - Relax upper bound for mtl, allow mtl-2.3. ## hslua-marshalling-2.2.0 Released 2022-02-19. - `Result` is now an instance of Foldable and Traversable. Both `Result` and `Peek` are made instances of `MonadPlus`. - Require hslua-core-2.2.0. ## hslua-marshalling-2.1.0 Released 29-01-2022. - Updated to hslua-core-2.1.0. - The `Success` constructor of the `Result` type is now strict; the `Failure` constructor remains lazy. - The stack is checked before pushing or retrieving nested structures: Pushing or peeking a deeply nested structure could lead an overflow of the Lua stack. The functions `pushList`, `pushSet`, and `pushKeyValuePairs`, as well as `peekList`, `peekSet`, and `peekKeyValuePairs` now check that sufficient stack space is available before pushing another value to the stack. - The function `toByteString` now requires a slot on the stack if the value at the given index is a number. It checks for available space before pushing to the stack, returning `Nothing` if no space is left on the stack. - The `withContext` function is made more useful and now differs from `retrieving`. The string “retrieving” is added to the error context by `retrieving`, so `withContext` allows to define contexts without this prefix. - New convenience function `pushAsTable`, making it easier to define a pusher function for values marshaled as tables. ## hslua-marshalling-2.0.1 Released 2021-11-04. - Allow `pushIterator` to skip values: If the function that pushes the values of a list item signals that it didn’t push any values, then that value will be skipped. ## hslua-marshalling-2.0.0 Released 2021-10-21. - 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. [PVP Versioning]: https://pvp.haskell.org hslua-marshalling-2.3.1/LICENSE0000644000000000000000000000224107346545000014325 0ustar0000000000000000Copyright © 1994-2022 Lua.org, PUC-Rio. Copyright © 2007-2012 Gracjan Polak Copyright © 2012-2015 Ömer Sinan Ağacan Copyright © 2016-2024 Albert Krewinkel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. hslua-marshalling-2.3.1/README.md0000644000000000000000000000137507346545000014606 0ustar0000000000000000# 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-2.3.1/hslua-marshalling.cabal0000644000000000000000000000753407346545000017731 0ustar0000000000000000cabal-version: 2.2 name: hslua-marshalling version: 2.3.1 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 . homepage: https://hslua.org/ bug-reports: https://github.com/hslua/hslua/issues license: MIT license-file: LICENSE author: Albert Krewinkel, Gracjan Polak, Ömer Sinan Ağacan maintainer: tarleb@hslua.org copyright: © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2024 Albert Krewinkel category: Foreign extra-source-files: README.md , CHANGELOG.md tested-with: GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.8 , GHC == 9.6.3 , GHC == 9.8.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.11 && < 5 , bytestring >= 0.10.2 && < 0.13 , containers >= 0.5.9 && < 0.8 , hslua-core >= 2.2.1 && < 2.4 , mtl >= 2.2 && < 2.4 , text >= 1.2 && < 2.2 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 , StrictData 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 hslua-marshalling-2.3.1/src/HsLua/0000755000000000000000000000000007346545000015124 5ustar0000000000000000hslua-marshalling-2.3.1/src/HsLua/Marshalling.hs0000644000000000000000000000271407346545000017725 0ustar0000000000000000{-| Module : HsLua.Marshalling Copyright : © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel 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 , peekNilOr , peekNoneOr , peekNoneOrNilOr -- ** 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) hslua-marshalling-2.3.1/src/HsLua/Marshalling/0000755000000000000000000000000007346545000017365 5ustar0000000000000000hslua-marshalling-2.3.1/src/HsLua/Marshalling/Peek.hs0000644000000000000000000001362207346545000020611 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-| Module : HsLua.Marshalling.Peek Copyright : © 2020-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel 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 ((<$!>), (<=<), MonadPlus) 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, Foldable, Functor, Traversable) instance Applicative Result where pure = Success {-# INLINE pure #-} Success f <*> s = 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 (<|>) #-} instance MonadPlus Result instance MonadFail Result where fail = failure . Utf8.fromString {-# INLINABLE fail #-} -- -- 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 MonadPlus (Peek e) 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 " $ 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 . ("retrieving " <>) {-# 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 hslua-marshalling-2.3.1/src/HsLua/Marshalling/Peekers.hs0000644000000000000000000003163407346545000021326 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-| Module : HsLua.Marshalling.Peekers Copyright : © 2020-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel 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 , peekNonEmpty , peekMap , peekSet -- ** Combinators , choice , peekFieldRaw , peekIndexRaw , peekNilOr , peekNoneOr , peekNoneOrNilOr , peekPair , peekTriple -- ** Building peek functions , typeChecked , reportValueOnFailure , typeMismatchMessage ) where import Control.Applicative (Alternative (..)) import Control.Monad ((<$!>), (>=>), void) import Data.ByteString (ByteString) import Data.List.NonEmpty (NonEmpty ((:|))) 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) 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. -- Also returns 'Nothing' if the value is a number and there is no stack -- slot left on the Lua stack, which would be needed to convert the -- number to a string without changing the original slot. toByteString :: StackIndex -> LuaE e (Maybe ByteString) toByteString idx = do -- Do an explicit type check, as @tostring@ converts numbers strings -- /in-place/, which we need to avoid. ltype idx >>= \case TypeString -> tostring idx _ -> checkstack 1 >>= \case False -> pure Nothing True -> do 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 = retrieving "list" . peekList' peekElement -- | Like 'peekList', but fails if the list is empty. peekNonEmpty :: LuaError e => Peeker e a -> Peeker e (NonEmpty a) peekNonEmpty peekElement = retrieving "NonEmpty" . (peekList' peekElement >=> \case (x:xs) -> return (x :| xs) [] -> failPeek "empty list") -- | Helper function that retrieves a list, but doesn't set a context. peekList' :: LuaError e => Peeker e a -> Peeker e [a] peekList' peekElement = typeChecked "table" istable $ \idx -> do liftLua $ checkstack' 1 "retrieving a list" 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 :: (LuaError e, 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 :: LuaError e => Peeker e a -> Peeker e b -> Peeker e [(a, b)] peekKeyValuePairs keyPeeker valuePeeker = typeChecked "table" istable $ \idx -> cleanup $ do liftLua $ checkstack' 2 "retrieving key-value pairs" 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 :: (LuaError e, Ord a) => Peeker e a -> Peeker e (Set a) peekSet elementPeeker = retrieving "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 checkstack' 1 "peekFieldRaw" absidx <- Lua.absindex idx pushstring $ fromName name void (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 . void $ rawgeti idx i peeker top `lastly` Lua.pop 1 {-# INLINABLE peekIndexRaw #-} -- | Returns 'empty' if the value at the given index is @nil@; -- otherwise returns the result of peeker @p@. peekNilOr :: Alternative m => Peeker e a -- ^ p -> Peeker e (m a) peekNilOr p idx = liftLua (ltype idx) >>= \case TypeNil -> pure empty _ -> pure <$> p idx -- | Returns 'empty' if the value at the given index is @none@; -- otherwise returns the result of peeker @p@. peekNoneOr :: Alternative m => Peeker e a -- ^ p -> Peeker e (m a) peekNoneOr p idx = liftLua (ltype idx) >>= \case TypeNone -> pure empty _ -> pure <$> p idx -- | Returns 'empty' if the value at the given index is @none@ or -- @nil@; otherwise returns the result of peeker @p@. peekNoneOrNilOr :: Alternative m => Peeker e a -- ^ p -> Peeker e (m a) peekNoneOrNilOr p idx = liftLua (ltype idx) >>= \case TypeNil -> pure empty TypeNone -> pure empty _ -> pure <$> p idx -- | 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 liftLua $ checkstack' 2 "retrieving a pair" 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 liftLua $ checkstack' 3 "retrieving a triple" 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 #-} hslua-marshalling-2.3.1/src/HsLua/Marshalling/Push.hs0000644000000000000000000001223607346545000020644 0ustar0000000000000000{-| Module : HsLua.Marshalling.Push Copyright : © 2020-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel 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 , pushNonEmpty , pushKeyValuePairs , pushMap , pushSet -- * Combinators , pushPair , pushTriple , pushAsTable ) where import Control.Monad (forM_, 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 Data.List.NonEmpty as NonEmpty 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 = checkstack 3 >>= \case False -> failLua "stack overflow while pushing key-value pairs" True -> 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 = checkstack 2 >>= \case False -> failLua "stack overflow while pushing a list" True -> do let setField i x = push x *> rawseti (-2) i newtable zipWithM_ setField [1..] xs -- | Push non-empty list as numerically indexed table. pushNonEmpty :: LuaError e => Pusher e a -> NonEmpty.NonEmpty a -> LuaE e () pushNonEmpty push = pushList push . NonEmpty.toList -- | 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 = checkstack 3 >>= \case False -> failLua "stack overflow while pushing a set" True -> do let addItem item = pushElement item *> pushboolean True *> rawset (-3) newtable mapM_ addItem set -- -- Combinators -- -- | Pushes an object as a table, defined by a list of -- field-names/push-function pairs. pushAsTable :: LuaError e => [(Name, a -> LuaE e ())] -> a -> LuaE e () pushAsTable props obj = do createtable 0 (length props) forM_ props $ \(name, pushValue) -> do pushName name pushValue obj rawset (nth 3) -- | 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..] hslua-marshalling-2.3.1/src/HsLua/Marshalling/Userdata.hs0000644000000000000000000000413307346545000021472 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-| Module : HsLua.Marshalling.Userdata Copyright : © 2007–2012 Gracjan Polak; © 2012–2016 Ömer Sinan Ağacan; © 2017-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel 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. -- -- If the values pusher function returns @'NumResults' 0@ for a list -- item, then this item will be skipped and the values for the next item -- will be pushed. pushIterator :: forall a e. LuaError e => (a -> LuaE e NumResults) -- ^ pusher for the values -> [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 >>= \case 0 -> nextItem -- keep going if nothing was pushed n -> return n statename :: Name statename = "HsLua iterator state" pushInitialState :: LuaE e () pushInitialState = do newhsuserdatauv @[a] xs 0 void (newudmetatable statename) setmetatable (nth 2) hslua-marshalling-2.3.1/test/HsLua/Marshalling/0000755000000000000000000000000007346545000017555 5ustar0000000000000000hslua-marshalling-2.3.1/test/HsLua/Marshalling/PeekTests.hs0000644000000000000000000000331707346545000022024 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-| Module : HsLua.Marshalling.PeekTests Copyright : © 2020-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel 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" ["retrieving context"] `shouldBeResultOf` runPeek (retrieving "context" $ failPeek "message") , "withContext" =: Failure @() "message" ["context"] `shouldBeResultOf` runPeek (withContext "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") ] ] hslua-marshalling-2.3.1/test/HsLua/Marshalling/PeekersTests.hs0000644000000000000000000004364707346545000022550 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-| Module : HsLua.Marshalling.PeekersTests Copyright : © 2020-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel 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.List.NonEmpty as NonEmpty 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 "peekNonEmpty" [ "empty list" =: Failure "empty list" ["retrieving NonEmpty"] `shouldBeResultOf` do Lua.newtable runPeek $ peekNonEmpty peekBool Lua.top , "non-empty list" =: Success (5 NonEmpty.:| [23]) `shouldBeResultOf` do pushLuaExpr "{ 5, 23 }" runPeek $ peekNonEmpty (peekIntegral @Int) 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 = [ "retrieving Set" , "retrieving key-value pair" , "retrieving 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 = [ "retrieving Map" , "retrieving key-value pair" , "retrieving 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 = [ "retrieving Map" , "retrieving key-value pair" , "retrieving 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 "peekNilOr" [ "returns the parser result if the value is not nil" =: Success (Just "a") `shouldBeResultOf` runPeek (liftLua (Lua.pushstring "a") *> peekNilOr peekString Lua.top) , "returns nothing if the value is nil" =: Success Nothing `shouldBeResultOf` runPeek (liftLua Lua.pushnil *> peekNilOr peekString Lua.top) , "fails if the value is none" =: Failure "string expected, got no value" [] `shouldBeResultOf` runPeek (liftLua Lua.gettop >>= peekNilOr @Maybe peekString . (+1)) ] , testGroup "peekNoneOr" [ "returns the parser result if a value is present" =: Success (Just "a") `shouldBeResultOf` runPeek (liftLua (Lua.pushstring "a") *> peekNoneOr peekString Lua.top) , "returns the parser result if the value is nil" =: Success (Just ()) `shouldBeResultOf` runPeek (liftLua Lua.pushnil *> peekNoneOr peekNil Lua.top) , "returns `empty` if the value is missing" =: Success Nothing `shouldBeResultOf` runPeek (liftLua Lua.gettop >>= peekNoneOr @Maybe peekString . (+1)) , "fails if the parser cannot parse the value" =: Failure "string expected, got nil" [] `shouldBeResultOf` runPeek (liftLua Lua.pushnil *> peekNoneOr @Maybe peekString Lua.top) ] , testGroup "peekNoneOrNilOr" [ "returns the parser result if a value is present" =: Success (Just "a") `shouldBeResultOf` runPeek (liftLua (Lua.pushstring "a") *> peekNoneOrNilOr peekString Lua.top) , "returns `empty` if the value is nil" =: Success Nothing `shouldBeResultOf` runPeek (liftLua Lua.pushnil *> peekNoneOrNilOr @Maybe peekString Lua.top) , "returns `empty` if the value is missing" =: Success Nothing `shouldBeResultOf` runPeek (liftLua Lua.gettop >>= peekNoneOrNilOr @Maybe peekString . (+1)) , "fails if the parser cannot parse the value" =: Failure "string expected, got boolean" [] `shouldBeResultOf` runPeek (liftLua (Lua.pushboolean True) *> peekNoneOrNilOr @Maybe peekString 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 ] ] hslua-marshalling-2.3.1/test/HsLua/Marshalling/PushTests.hs0000644000000000000000000002422707346545000022062 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-| Module : HsLua.Marshalling.PushTests Copyright : © 2020-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel 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) 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 "pushNonEmpty" [ testProperty "table size equals list length" $ \list -> monadicIO $ do tableSize <- run $ Lua.run @Lua.Exception $ do pushNonEmpty pushString list Lua.rawlen Lua.top assert $ tableSize == length list ] , 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)) , testProperty "pushAsTable" $ \(a, b) -> monadicIO $ do mpair <- run $ Lua.run @Lua.Exception $ do let fields = [ ("int", Lua.pushinteger . fst) , ("str", Lua.pushstring . snd) ] pushAsTable fields (a, b) ma <- Lua.getfield Lua.top "int" *> Lua.tointeger Lua.top <* Lua.pop 1 mb <- Lua.getfield Lua.top "str" *> Lua.tostring Lua.top <* Lua.pop 1 return $ (,) <$> ma <*> mb assert (mpair == Just (a, b)) ] ] -- | 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) hslua-marshalling-2.3.1/test/HsLua/Marshalling/UserdataTests.hs0000644000000000000000000000341407346545000022706 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-| Module : HsLua.Marshalling.UserdataTests Copyright : © 2018-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel 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 , "skip entry if value pusher returned 0" =: Just "1,3,4" `shouldBeResultOf` do let pushNoTwo 2 = return 0 pushNoTwo i = 1 <$ Lua.pushinteger i Lua.openlibs Lua.pushHaskellFunction $ pushIterator pushNoTwo [1..4] Lua.setglobal "skip" stat <- Lua.dostring $ mconcat [ "local acc = {}\n" , "for n in skip() do table.insert(acc, n) end\n" , "return table.concat(acc, ',')\n" ] when (stat /= Lua.OK) Lua.throwErrorAsException Lua.tostring Lua.top ] ] hslua-marshalling-2.3.1/test/HsLua/0000755000000000000000000000000007346545000015314 5ustar0000000000000000hslua-marshalling-2.3.1/test/HsLua/MarshallingTests.hs0000644000000000000000000000336307346545000021141 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-| Module : HsLua.MarshallingTests Copyright : © 2020-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel Stability : alpha Portability : OverloadedStrings, TypeApplications Test marshalling of basic values. -} module HsLua.MarshallingTests (tests) where import Control.Monad ((<$!>)) import HsLua.Core import HsLua.Marshalling.Peek import HsLua.Marshalling.Peekers import HsLua.Marshalling.Push import Test.Tasty (TestTree, testGroup) import Test.Tasty.HsLua ((=:), shouldBeResultOf) 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 , testGroup "nested" [ "deeply nested list" =: Success (mkDeeplyNested 500) `shouldBeResultOf` do pushNested (mkDeeplyNested 500) runPeek $ peekNested top ] ] mkDeeplyNested :: Int -> Nested mkDeeplyNested i = foldr (\_ n -> List [n]) (Element i) [1..i] pushNested :: LuaError e => Pusher e Nested pushNested = \case Element i -> pushIntegral i List nested -> pushList pushNested nested peekNested :: LuaError e => Peeker e Nested peekNested idx = do liftLua (ltype idx) >>= \case TypeNumber -> Element <$!> peekIntegral idx TypeTable -> (List <$!> peekList peekNested idx) _ -> failPeek "you dun goofed" data Nested = Element Int | List [Nested] deriving (Eq, Show) hslua-marshalling-2.3.1/test/0000755000000000000000000000000007346545000014300 5ustar0000000000000000hslua-marshalling-2.3.1/test/test-hslua-marshalling.hs0000644000000000000000000000057707346545000021235 0ustar0000000000000000{-| Module : Main Copyright : © 2017-2024 Albert Krewinkel License : MIT Maintainer : Albert Krewinkel 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]