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/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs index dff3515..cec1292 100644 --- a/src/Python/Inline/Literal.hs +++ b/src/Python/Inline/Literal.hs @@ -16,12 +16,14 @@ 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 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 @@ -71,7 +73,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. @@ -85,12 +87,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. @@ -121,51 +125,121 @@ 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 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 + + 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 +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 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) + , i >= fromIntegral (minBound :: 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 may be 32 or 64 bit! --- -- TODO: Int{8,16,32} & Word{8,16,32} -- | Encoded as 1-character string instance ToPy Char where @@ -198,7 +272,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 @@ -209,7 +283,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 @@ -226,8 +300,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) @@ -250,8 +324,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) @@ -277,8 +351,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) @@ -302,11 +376,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 @@ -400,14 +474,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 @@ -437,3 +514,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 #-} 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 diff --git a/test/TST/Roundtrip.hs b/test/TST/Roundtrip.hs new file mode 100644 index 0000000..6320e81 --- /dev/null +++ b/test/TST/Roundtrip.hs @@ -0,0 +1,97 @@ +{-# 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" + [ 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 + 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 ]