diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,23 @@ +Copyright © 1994-2020 Lua.org, PUC-Rio. +Copyright © 2007-2012 Gracjan Polak +Copyright © 2012-2015 Ömer Sinan Ağacan +Copyright © 2016-2021 Albert Krewinkel + +Permission is hereby granted, free of charge, to any person obtaining a +copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,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/ diff --git a/hslua-marshalling.cabal b/hslua-marshalling.cabal new file mode 100644 --- /dev/null +++ b/hslua-marshalling.cabal @@ -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 + . +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 diff --git a/src/HsLua/Marshalling.hs b/src/HsLua/Marshalling.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Marshalling.hs @@ -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 + +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) diff --git a/src/HsLua/Marshalling/Peek.hs b/src/HsLua/Marshalling/Peek.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Marshalling/Peek.hs @@ -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 +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 diff --git a/src/HsLua/Marshalling/Peekers.hs b/src/HsLua/Marshalling/Peekers.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Marshalling/Peekers.hs @@ -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 +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 #-} diff --git a/src/HsLua/Marshalling/Push.hs b/src/HsLua/Marshalling/Push.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Marshalling/Push.hs @@ -0,0 +1,149 @@ +{-| +Module : HsLua.Marshalling.Push +Copyright : © 2020-2021 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 + , 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..] diff --git a/src/HsLua/Marshalling/Userdata.hs b/src/HsLua/Marshalling/Userdata.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Marshalling/Userdata.hs @@ -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 +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) diff --git a/test/HsLua/Marshalling/PeekTests.hs b/test/HsLua/Marshalling/PeekTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/Marshalling/PeekTests.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : HsLua.Marshalling.PeekTests +Copyright : © 2020-2021 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" ["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") + ] + ] diff --git a/test/HsLua/Marshalling/PeekersTests.hs b/test/HsLua/Marshalling/PeekersTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/Marshalling/PeekersTests.hs @@ -0,0 +1,451 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-| +Module : HsLua.Marshalling.PeekersTests +Copyright : © 2020-2021 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.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 + ] + ] diff --git a/test/HsLua/Marshalling/PushTests.hs b/test/HsLua/Marshalling/PushTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/Marshalling/PushTests.hs @@ -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 +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) diff --git a/test/HsLua/Marshalling/UserdataTests.hs b/test/HsLua/Marshalling/UserdataTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/Marshalling/UserdataTests.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : HsLua.Marshalling.UserdataTests +Copyright : © 2018-2021 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 + ] + ] diff --git a/test/HsLua/MarshallingTests.hs b/test/HsLua/MarshallingTests.hs new file mode 100644 --- /dev/null +++ b/test/HsLua/MarshallingTests.hs @@ -0,0 +1,26 @@ +{-| +Module : HsLua.MarshallingTests +Copyright : © 2020-2021 Albert Krewinkel +License : MIT +Maintainer : Albert Krewinkel +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 + ] diff --git a/test/test-hslua-marshalling.hs b/test/test-hslua-marshalling.hs new file mode 100644 --- /dev/null +++ b/test/test-hslua-marshalling.hs @@ -0,0 +1,18 @@ +{-| +Module : Main +Copyright : © 2017-2021 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]