Moew instances

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

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 #-}

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
 
 
 ----------------------------------------------------------------

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
 
 

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