From 4c355fd5f160b8f7d4f72f4b11ab5058590310f9 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Mon, 6 Jan 2025 21:02:11 +0300 Subject: [PATCH 1/6] Add ToPy for smaller number types --- src/Python/Inline/Literal.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs index dff3515..d059b87 100644 --- a/src/Python/Inline/Literal.hs +++ b/src/Python/Inline/Literal.hs @@ -22,6 +22,7 @@ import Data.Word import Foreign.Ptr import Foreign.C.Types import Foreign.Storable +import GHC.Float (float2Double, double2Float) import Language.C.Inline qualified as C import Language.C.Inline.Unsafe qualified as CU @@ -159,12 +160,23 @@ deriving via CULLong instance FromPy Word64 deriving via CDouble instance ToPy Double deriving via CDouble instance FromPy Double + +-- TODO: Int may be 32 or 64 bit! instance ToPy Int where basicToPy = basicToPy @Int64 . fromIntegral instance FromPy Int where basicFromPy = fmap fromIntegral . basicFromPy @Int64 --- -- TODO: Int may be 32 or 64 bit! +instance ToPy Int8 where basicToPy = basicToPy @Int64 . fromIntegral +instance ToPy Int16 where basicToPy = basicToPy @Int64 . fromIntegral +instance ToPy Int32 where basicToPy = basicToPy @Int64 . fromIntegral +instance ToPy Word8 where basicToPy = basicToPy @Word64 . fromIntegral +instance ToPy Word16 where basicToPy = basicToPy @Word64 . fromIntegral +instance ToPy Word32 where basicToPy = basicToPy @Word64 . fromIntegral +instance ToPy Float where basicToPy = basicToPy @Double . float2Double + + + -- -- TODO: Int{8,16,32} & Word{8,16,32} -- | Encoded as 1-character string From b4ce2726619ef6563f9903a03a27dd5d2240fb7a Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Mon, 6 Jan 2025 21:15:46 +0300 Subject: [PATCH 2/6] Add OutOfRange exception and rename FromPyFailed -> BadPyType --- src/Python/Inline/Literal.hs | 60 +++++++++++++++++++---------------- src/Python/Internal/Eval.hs | 14 ++++---- src/Python/Internal/EvalQQ.hs | 4 +-- src/Python/Internal/Types.hs | 14 +++++--- 4 files changed, 51 insertions(+), 41 deletions(-) diff --git a/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs index d059b87..dfaed0d 100644 --- a/src/Python/Inline/Literal.hs +++ b/src/Python/Inline/Literal.hs @@ -72,7 +72,7 @@ class FromPy a where -- try to not modify python's data. This function should avoid -- throwing haskell exception. Any python exceptions should be -- thrown as 'PyError'. When data type couldn't be converted - -- 'FromPyFailed' should be thrown to indicate failure. + -- 'BadPyType' or 'OutOfRange' should be thrown to indicate failure. -- -- This is low level function. It should be only used when working -- with python's C API. Otherwise 'fromPy' is preferred. @@ -86,12 +86,14 @@ fromPyEither py = runPy $ unsafeWithPyObject py $ \p -> -- | Convert python object to haskell value. Will return @Nothing@ if --- 'FromPyFailed' is thrown. Other python exceptions are rethrown. +-- 'BadPyType' or 'OutOfRange' is thrown. Other python exceptions +-- are rethrown. fromPy :: FromPy a => PyObject -> IO (Maybe a) fromPy py = runPy $ unsafeWithPyObject py $ \p -> (Just <$> basicFromPy p) `catchPy` \case - FromPyFailed -> pure Nothing - e -> throwPy e + BadPyType -> pure Nothing + OutOfRange -> pure Nothing + e -> throwPy e -- | Convert python object to haskell value. Throws exception on -- failure. @@ -122,36 +124,35 @@ instance ToPy CLong where instance FromPy CLong where basicFromPy p_py = do r <- Py [CU.exp| long { PyLong_AsLong($(PyObject *p_py)) } |] - r <$ throwPyConvesionFailed + r <$ checkThrowBadPyType instance ToPy CLLong where basicToPy i = Py [CU.exp| PyObject* { PyLong_FromLongLong($(long long i)) } |] instance FromPy CLLong where basicFromPy p_py = do r <- Py [CU.exp| long long { PyLong_AsLongLong($(PyObject *p_py)) } |] - r <$ throwPyConvesionFailed + r <$ checkThrowBadPyType instance ToPy CULong where basicToPy i = Py [CU.exp| PyObject* { PyLong_FromUnsignedLong($(unsigned long i)) } |] instance FromPy CULong where basicFromPy p_py = do r <- Py [CU.exp| unsigned long { PyLong_AsUnsignedLong($(PyObject *p_py)) } |] - r <$ throwPyConvesionFailed + r <$ checkThrowBadPyType instance ToPy CULLong where basicToPy i = Py [CU.exp| PyObject* { PyLong_FromUnsignedLongLong($(unsigned long long i)) } |] instance FromPy CULLong where basicFromPy p_py = do r <- Py [CU.exp| unsigned long long { PyLong_AsUnsignedLongLong($(PyObject *p_py)) } |] - r <$ throwPyConvesionFailed - + r <$ checkThrowBadPyType instance ToPy CDouble where basicToPy i = Py [CU.exp| PyObject* { PyFloat_FromDouble($(double i)) } |] instance FromPy CDouble where basicFromPy p_py = do r <- Py [CU.exp| double { PyFloat_AsDouble($(PyObject *p_py)) } |] - r <$ throwPyConvesionFailed + r <$ checkThrowBadPyType deriving via CLLong instance ToPy Int64 deriving via CLLong instance FromPy Int64 @@ -210,7 +211,7 @@ instance FromPy Char where } return -1; } |] - if | r < 0 -> throwPy FromPyFailed + if | r < 0 -> throwPy BadPyType | otherwise -> pure $ chr $ fromIntegral r instance ToPy Bool where @@ -221,7 +222,7 @@ instance ToPy Bool where instance FromPy Bool where basicFromPy p = do r <- Py [CU.exp| int { PyObject_IsTrue($(PyObject* p)) } |] - throwPyError + checkThrowPyError pure $! r /= 0 @@ -238,8 +239,8 @@ instance (FromPy a, FromPy b) => FromPy (a,b) where unpack_ok <- liftIO [CU.exp| int { inline_py_unpack_iterable($(PyObject *p_tup), 2, $(PyObject **p_args)) }|] - lift $ do throwPyError - when (unpack_ok /= 0) $ throwPy FromPyFailed + lift $ do checkThrowPyError + when (unpack_ok /= 0) $ throwPy BadPyType -- Parse each element of tuple p_a <- takeOwnership =<< liftIO (peekElemOff p_args 0) p_b <- takeOwnership =<< liftIO (peekElemOff p_args 1) @@ -262,8 +263,8 @@ instance (FromPy a, FromPy b, FromPy c) => FromPy (a,b,c) where unpack_ok <- liftIO [CU.exp| int { inline_py_unpack_iterable($(PyObject *p_tup), 3, $(PyObject **p_args)) }|] - lift $ do throwPyError - when (unpack_ok /= 0) $ throwPy FromPyFailed + lift $ do checkThrowPyError + when (unpack_ok /= 0) $ throwPy BadPyType -- Parse each element of tuple p_a <- takeOwnership =<< liftIO (peekElemOff p_args 0) p_b <- takeOwnership =<< liftIO (peekElemOff p_args 1) @@ -289,8 +290,8 @@ instance (FromPy a, FromPy b, FromPy c, FromPy d) => FromPy (a,b,c,d) where unpack_ok <- liftIO [CU.exp| int { inline_py_unpack_iterable($(PyObject *p_tup), 4, $(PyObject **p_args)) }|] - lift $ do throwPyError - when (unpack_ok /= 0) $ throwPy FromPyFailed + lift $ do checkThrowPyError + when (unpack_ok /= 0) $ throwPy BadPyType -- Parse each element of tuple p_a <- takeOwnership =<< liftIO (peekElemOff p_args 0) p_b <- takeOwnership =<< liftIO (peekElemOff p_args 1) @@ -314,11 +315,11 @@ instance (FromPy a) => FromPy [a] where } return iter; } |] - when (nullPtr == p_iter) $ throwPy FromPyFailed + when (nullPtr == p_iter) $ throwPy BadPyType -- let loop f = do p <- Py [C.exp| PyObject* { PyIter_Next($(PyObject* p_iter)) } |] - throwPyError + checkThrowPyError case p of NULL -> pure f _ -> do a <- basicFromPy p `finallyPy` decref p @@ -412,14 +413,17 @@ loadArg -> Program (Ptr PyObject) a loadArg p (fromIntegral -> i) (fromIntegral -> tot) = ContT $ \success -> do tryPy (basicFromPy p) >>= \case - Right a -> success a - Left FromPyFailed -> Py [CU.block| PyObject* { - char err[256]; - sprintf(err, "Failed to decode function argument %i of %li", $(int i)+1, $(int64_t tot)); - PyErr_SetString(PyExc_TypeError, err); - return NULL; - } |] - Left e -> throwPy e + Right a -> success a + Left BadPyType -> oops + Left OutOfRange -> oops + Left e -> throwPy e + where + oops = Py [CU.block| PyObject* { + char err[256]; + sprintf(err, "Failed to decode function argument %i of %li", $(int i)+1, $(int64_t tot)); + PyErr_SetString(PyExc_TypeError, err); + return NULL; + } |] -- | Load i-th argument from array as haskell parameter loadArgFastcall diff --git a/src/Python/Internal/Eval.hs b/src/Python/Internal/Eval.hs index aa79cfb..98d6b57 100644 --- a/src/Python/Internal/Eval.hs +++ b/src/Python/Internal/Eval.hs @@ -22,9 +22,9 @@ module Python.Internal.Eval -- * Exceptions , convertHaskell2Py , convertPy2Haskell - , throwPyError + , checkThrowPyError , mustThrowPyError - , throwPyConvesionFailed + , checkThrowBadPyType -- * Debugging , debugPrintPy ) where @@ -349,8 +349,8 @@ convertPy2Haskell = evalContT $ do -- | Throw python error as haskell exception if it's raised. -throwPyError :: Py () -throwPyError = +checkThrowPyError :: Py () +checkThrowPyError = Py [CU.exp| PyObject* { PyErr_Occurred() } |] >>= \case NULL -> pure () _ -> throwPy =<< convertPy2Haskell @@ -363,8 +363,8 @@ mustThrowPyError msg = NULL -> error $ "mustThrowPyError: no python exception raised. " ++ msg _ -> throwPy =<< convertPy2Haskell -throwPyConvesionFailed :: Py () -throwPyConvesionFailed = do +checkThrowBadPyType :: Py () +checkThrowBadPyType = do r <- Py [CU.block| int { if( PyErr_Occurred() ) { PyErr_Clear(); @@ -374,7 +374,7 @@ throwPyConvesionFailed = do } |] case r of 0 -> pure () - _ -> throwPy FromPyFailed + _ -> throwPy BadPyType ---------------------------------------------------------------- diff --git a/src/Python/Internal/EvalQQ.hs b/src/Python/Internal/EvalQQ.hs index a26f803..7ac6fa9 100644 --- a/src/Python/Internal/EvalQQ.hs +++ b/src/Python/Internal/EvalQQ.hs @@ -72,7 +72,7 @@ pyExecExpr p_globals p_locals src = evalContT $ do Py_XDECREF(res); Py_DECREF(code); } |] - throwPyError + checkThrowPyError -- | Evaluate expression with fresh local environment pyEvalExpr @@ -96,7 +96,7 @@ pyEvalExpr p_globals p_locals src = evalContT $ do Py_DECREF(code); return r; }|] - throwPyError + checkThrowPyError newPyObject p_res diff --git a/src/Python/Internal/Types.hs b/src/Python/Internal/Types.hs index 2ee84b1..6d27ce4 100644 --- a/src/Python/Internal/Types.hs +++ b/src/Python/Internal/Types.hs @@ -58,10 +58,16 @@ data PyError = PyError String String -- ^ Python exception. Contains exception type and message as strings. | UncovertablePyError - -- ^ Python error could not be converted to haskell for some reason - | FromPyFailed - -- ^ Conversion from python value to failed because python type is - -- invalid. + -- ^ Python exception that could not be converted to haskell for + -- some reason. Its appearance means that something went + -- seriously wrong. + | BadPyType + -- ^ It's not possible to convert given python value to a haskell + -- value + | OutOfRange + -- ^ Data type is suitable but value is outside of allowed + -- range. For example attempting to convert 1000 to @Word8@ will + -- result in this exception. deriving stock (Show) instance Exception PyError From 6b7c6fa5d8d28c3b40bf25440764440f92c65819 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Mon, 6 Jan 2025 21:24:44 +0300 Subject: [PATCH 3/6] Full complement of Int types --- src/Python/Inline/Literal.hs | 75 +++++++++++++++++++++++++++++++++--- 1 file changed, 70 insertions(+), 5 deletions(-) diff --git a/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs index dfaed0d..4182f97 100644 --- a/src/Python/Inline/Literal.hs +++ b/src/Python/Inline/Literal.hs @@ -16,6 +16,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Cont +import Data.Bits import Data.Char import Data.Int import Data.Word @@ -158,15 +159,46 @@ deriving via CLLong instance ToPy Int64 deriving via CLLong instance FromPy Int64 deriving via CULLong instance ToPy Word64 deriving via CULLong instance FromPy Word64 + +deriving newtype instance ToPy CInt +deriving newtype instance FromPy CInt +deriving newtype instance ToPy CUInt +deriving newtype instance FromPy CUInt +deriving newtype instance ToPy CShort +deriving newtype instance FromPy CShort +deriving newtype instance ToPy CUShort +deriving newtype instance FromPy CUShort +deriving newtype instance ToPy CChar +deriving newtype instance FromPy CChar +deriving newtype instance ToPy CUChar +deriving newtype instance FromPy CUChar +deriving newtype instance ToPy CSChar +deriving newtype instance FromPy CSChar + deriving via CDouble instance ToPy Double deriving via CDouble instance FromPy Double +instance ToPy Float where basicToPy = basicToPy . float2Double +instance FromPy Float where basicFromPy = fmap double2Float . basicFromPy + --- TODO: Int may be 32 or 64 bit! instance ToPy Int where - basicToPy = basicToPy @Int64 . fromIntegral + basicToPy + | wordSizeInBits == 64 = basicToPy @Int64 . fromIntegral + | otherwise = basicToPy @Int32 . fromIntegral instance FromPy Int where - basicFromPy = fmap fromIntegral . basicFromPy @Int64 + basicFromPy + | wordSizeInBits == 64 = fmap fromIntegral . basicFromPy @Int64 + | otherwise = fmap fromIntegral . basicFromPy @Int32 + +instance ToPy Word where + basicToPy + | wordSizeInBits == 64 = basicToPy @Word64 . fromIntegral + | otherwise = basicToPy @Word32 . fromIntegral +instance FromPy Word where + basicFromPy + | wordSizeInBits == 64 = fmap fromIntegral . basicFromPy @Word64 + | otherwise = fmap fromIntegral . basicFromPy @Word32 instance ToPy Int8 where basicToPy = basicToPy @Int64 . fromIntegral instance ToPy Int16 where basicToPy = basicToPy @Int64 . fromIntegral @@ -174,11 +206,39 @@ instance ToPy Int32 where basicToPy = basicToPy @Int64 . fromIntegral instance ToPy Word8 where basicToPy = basicToPy @Word64 . fromIntegral instance ToPy Word16 where basicToPy = basicToPy @Word64 . fromIntegral instance ToPy Word32 where basicToPy = basicToPy @Word64 . fromIntegral -instance ToPy Float where basicToPy = basicToPy @Double . float2Double +instance FromPy Int8 where + basicFromPy p = basicFromPy @Int64 p >>= \case + i | i <= fromIntegral (maxBound :: Int8) + , i >= fromIntegral (minBound :: Int8) -> pure $! fromIntegral i + | otherwise -> throwPy OutOfRange + +instance FromPy Int16 where + basicFromPy p = basicFromPy @Int64 p >>= \case + i | i <= fromIntegral (maxBound :: Int16) + , i >= fromIntegral (minBound :: Int16) -> pure $! fromIntegral i + | otherwise -> throwPy OutOfRange + +instance FromPy Int32 where + basicFromPy p = basicFromPy @Int64 p >>= \case + i | i <= fromIntegral (maxBound :: Int32) -> pure $! fromIntegral i + | otherwise -> throwPy OutOfRange +instance FromPy Word8 where + basicFromPy p = basicFromPy @Word64 p >>= \case + i | i <= fromIntegral (maxBound :: Word8) -> pure $! fromIntegral i + | otherwise -> throwPy OutOfRange + +instance FromPy Word16 where + basicFromPy p = basicFromPy @Word64 p >>= \case + i | i <= fromIntegral (maxBound :: Word16) -> pure $! fromIntegral i + | otherwise -> throwPy OutOfRange + +instance FromPy Word32 where + basicFromPy p = basicFromPy @Word64 p >>= \case + i | i <= fromIntegral (maxBound :: Word32) -> pure $! fromIntegral i + | otherwise -> throwPy OutOfRange --- -- TODO: Int{8,16,32} & Word{8,16,32} -- | Encoded as 1-character string instance ToPy Char where @@ -453,3 +513,8 @@ foreign import ccall "wrapper" wrapCFunction foreign import ccall "wrapper" wrapFastcall :: FunWrapper (Ptr PyObject -> Ptr (Ptr PyObject) -> Int64 -> IO (Ptr PyObject)) + + +wordSizeInBits :: Int +wordSizeInBits = finiteBitSize (0 :: Word) +{-# INLINE wordSizeInBits #-} From d4940fb92fc92976ee1d043f638cd4be14df9528 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Tue, 7 Jan 2025 15:30:19 +0300 Subject: [PATCH 4/6] Tests for roundtrip conversion --- inline-python.cabal | 2 ++ test/TST/Roundtrip.hs | 63 +++++++++++++++++++++++++++++++++++++++++++ test/exe/main.hs | 2 ++ 3 files changed, 67 insertions(+) create mode 100644 test/TST/Roundtrip.hs diff --git a/inline-python.cabal b/inline-python.cabal index 7b384a0..8c48018 100644 --- a/inline-python.cabal +++ b/inline-python.cabal @@ -83,12 +83,14 @@ library test , inline-python , tasty >=1.2 , tasty-hunit >=0.10 + , tasty-quickcheck >=0.10 hs-source-dirs: test Exposed-modules: TST.Run TST.ToPy TST.FromPy TST.Callbacks + TST.Roundtrip TST.Util test-suite inline-python-tests diff --git a/test/TST/Roundtrip.hs b/test/TST/Roundtrip.hs new file mode 100644 index 0000000..761817c --- /dev/null +++ b/test/TST/Roundtrip.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- | +module TST.Roundtrip (tests) where + +import Data.Int +import Data.Word +import Data.Typeable +import Foreign.C.Types + +import Test.Tasty +import Test.Tasty.QuickCheck +import Python.Inline +import Python.Inline.QQ + +tests :: TestTree +tests = testGroup "Roundtrip" + [ -- Integral types + testRoundtrip @Int8 + , testRoundtrip @Int16 + , testRoundtrip @Int32 + , testRoundtrip @Int64 + , testRoundtrip @Int + , testRoundtrip @Word8 + , testRoundtrip @Word16 + , testRoundtrip @Word32 + , testRoundtrip @Word64 + , testRoundtrip @Word + -- C wrappers + , testRoundtrip @CChar + , testRoundtrip @CSChar + , testRoundtrip @CUChar + , testRoundtrip @CShort + , testRoundtrip @CUShort + , testRoundtrip @CInt + , testRoundtrip @CUInt + , testRoundtrip @CLong + , testRoundtrip @CULong + , testRoundtrip @CLLong + , testRoundtrip @CULLong + -- Floating point + , testRoundtrip @Double + , testRoundtrip @Float + -- Other scalars + , testRoundtrip @Char + , testRoundtrip @Bool + -- Containers + , testRoundtrip @(Int,Char) + , testRoundtrip @(Int,(Int,Int)) + , testRoundtrip @(Int,Int,Int) + , testRoundtrip @(Int,Int,Int,Char) + , testRoundtrip @[Int] + , testRoundtrip @[[Int]] + -- , testRoundtrip @String -- Trips on zero byte as it should + ] + +testRoundtrip + :: forall a. (FromPy a, ToPy a, Eq a, Arbitrary a, Show a, Typeable a) => TestTree +testRoundtrip = testProperty (show (typeOf (undefined :: a))) (propRoundtrip @a) + +propRoundtrip :: forall a. (FromPy a, ToPy a, Eq a) => a -> Property +propRoundtrip a = ioProperty $ do + a' <- fromPy' =<< [pye| a_hs |] + pure $ a == a' diff --git a/test/exe/main.hs b/test/exe/main.hs index 96b2cf8..fb69716 100644 --- a/test/exe/main.hs +++ b/test/exe/main.hs @@ -6,6 +6,7 @@ import TST.Run import TST.FromPy import TST.ToPy import TST.Callbacks +import TST.Roundtrip import Python.Inline main :: IO () @@ -13,5 +14,6 @@ main = withPython $ defaultMain $ testGroup "PY" [ TST.Run.tests , TST.FromPy.tests , TST.ToPy.tests + , TST.Roundtrip.tests , TST.Callbacks.tests ] From d497f8bab57750a12551a29d4a6d0dc375ef4b0a Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Tue, 7 Jan 2025 15:46:06 +0300 Subject: [PATCH 5/6] Tests for out of range --- test/TST/Roundtrip.hs | 110 +++++++++++++++++++++++++++--------------- 1 file changed, 72 insertions(+), 38 deletions(-) diff --git a/test/TST/Roundtrip.hs b/test/TST/Roundtrip.hs index 761817c..6320e81 100644 --- a/test/TST/Roundtrip.hs +++ b/test/TST/Roundtrip.hs @@ -14,50 +14,84 @@ import Python.Inline.QQ tests :: TestTree tests = testGroup "Roundtrip" - [ -- Integral types - testRoundtrip @Int8 - , testRoundtrip @Int16 - , testRoundtrip @Int32 - , testRoundtrip @Int64 - , testRoundtrip @Int - , testRoundtrip @Word8 - , testRoundtrip @Word16 - , testRoundtrip @Word32 - , testRoundtrip @Word64 - , testRoundtrip @Word - -- C wrappers - , testRoundtrip @CChar - , testRoundtrip @CSChar - , testRoundtrip @CUChar - , testRoundtrip @CShort - , testRoundtrip @CUShort - , testRoundtrip @CInt - , testRoundtrip @CUInt - , testRoundtrip @CLong - , testRoundtrip @CULong - , testRoundtrip @CLLong - , testRoundtrip @CULLong - -- Floating point - , testRoundtrip @Double - , testRoundtrip @Float - -- Other scalars - , testRoundtrip @Char - , testRoundtrip @Bool - -- Containers - , testRoundtrip @(Int,Char) - , testRoundtrip @(Int,(Int,Int)) - , testRoundtrip @(Int,Int,Int) - , testRoundtrip @(Int,Int,Int,Char) - , testRoundtrip @[Int] - , testRoundtrip @[[Int]] - -- , testRoundtrip @String -- Trips on zero byte as it should + [ testGroup "Roundtrip" + [ -- Integral types + testRoundtrip @Int8 + , testRoundtrip @Int16 + , testRoundtrip @Int32 + , testRoundtrip @Int64 + , testRoundtrip @Int + , testRoundtrip @Word8 + , testRoundtrip @Word16 + , testRoundtrip @Word32 + , testRoundtrip @Word64 + , testRoundtrip @Word + -- C wrappers + , testRoundtrip @CChar + , testRoundtrip @CSChar + , testRoundtrip @CUChar + , testRoundtrip @CShort + , testRoundtrip @CUShort + , testRoundtrip @CInt + , testRoundtrip @CUInt + , testRoundtrip @CLong + , testRoundtrip @CULong + , testRoundtrip @CLLong + , testRoundtrip @CULLong + -- Floating point + , testRoundtrip @Double + , testRoundtrip @Float + -- Other scalars + , testRoundtrip @Char + , testRoundtrip @Bool + -- Containers + , testRoundtrip @(Int,Char) + , testRoundtrip @(Int,(Int,Int)) + , testRoundtrip @(Int,Int,Int) + , testRoundtrip @(Int,Int,Int,Char) + , testRoundtrip @[Int] + , testRoundtrip @[[Int]] + -- , testRoundtrip @String -- Trips on zero byte as it should + ] + , testGroup "OutOfRange" + [ testOutOfRange @Int8 @Int16 + , testOutOfRange @Int16 @Int32 + , testOutOfRange @Int32 @Int64 + , testOutOfRange @Word8 @Word16 + , testOutOfRange @Word16 @Word32 + , testOutOfRange @Word32 @Word64 + ] ] - + testRoundtrip :: forall a. (FromPy a, ToPy a, Eq a, Arbitrary a, Show a, Typeable a) => TestTree testRoundtrip = testProperty (show (typeOf (undefined :: a))) (propRoundtrip @a) +testOutOfRange + :: forall a wide. (ToPy wide, FromPy a, Eq a, Eq wide, Integral wide, Integral a + , Typeable a, Typeable wide, Arbitrary wide, Show wide + ) + => TestTree +testOutOfRange = testProperty + (show (typeOf (undefined :: a)) ++ " [" ++ show (typeOf (undefined::wide)) ++ "]") + (propOutOfRange @a @wide) + propRoundtrip :: forall a. (FromPy a, ToPy a, Eq a) => a -> Property propRoundtrip a = ioProperty $ do a' <- fromPy' =<< [pye| a_hs |] pure $ a == a' + + +-- Check that values out of range produce out of range +propOutOfRange + :: forall a wide. (ToPy wide, FromPy a, Eq a, Eq wide, Integral wide, Integral a) + => wide -> Property +propOutOfRange wide = ioProperty $ do + a_py <- fromPy @a =<< [pye| wide_hs |] + pure $ a_hs == a_py + where + -- Convert taking range into account + a_hs = case fromIntegral wide :: a of + a' | fromIntegral a' == wide -> Just a' + | otherwise -> Nothing + From 2b420643c556329445c20758b4625ebf0093ab99 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Tue, 7 Jan 2025 15:47:32 +0300 Subject: [PATCH 6/6] Fix bug in Int32 instance --- src/Python/Inline/Literal.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs index 4182f97..cec1292 100644 --- a/src/Python/Inline/Literal.hs +++ b/src/Python/Inline/Literal.hs @@ -221,7 +221,8 @@ instance FromPy Int16 where instance FromPy Int32 where basicFromPy p = basicFromPy @Int64 p >>= \case - i | i <= fromIntegral (maxBound :: Int32) -> pure $! fromIntegral i + i | i <= fromIntegral (maxBound :: Int32) + , i >= fromIntegral (minBound :: Int32) -> pure $! fromIntegral i | otherwise -> throwPy OutOfRange instance FromPy Word8 where