inline-python-0.2: src/Python/Inline/Literal.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
-- |
-- Conversion between haskell data types and python values
module Python.Inline.Literal
( FromPy(..)
, ToPy(..)
, toPy
, fromPyEither
, fromPy
, fromPy'
) where
import Control.Exception (evaluate)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Trans.Cont
import Data.Bits
import Data.Char
import Data.Int
import Data.Word
import Data.ByteString qualified as BS
import Data.ByteString.Unsafe qualified as BS
import Data.ByteString.Short qualified as SBS
import Data.ByteString.Lazy qualified as BL
import Data.Set qualified as Set
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.Lazy qualified as TL
import Data.Vector.Generic qualified as VG
import Data.Vector.Generic.Mutable qualified as MVG
import Data.Vector qualified as V
#if MIN_VERSION_vector(0,13,2)
import Data.Vector.Strict qualified as VV
#endif
import Data.Vector.Storable qualified as VS
import Data.Vector.Primitive qualified as VP
import Data.Vector.Unboxed qualified as VU
import Foreign.Ptr
import Foreign.C.Types
import Foreign.Storable
import Foreign.Marshal.Alloc (alloca,mallocBytes)
import Foreign.Marshal.Utils (copyBytes)
import GHC.Float (float2Double, double2Float)
import Data.Complex (Complex((:+)))
import Language.C.Inline qualified as C
import Language.C.Inline.Unsafe qualified as CU
import Python.Internal.Types
import Python.Internal.Eval
import Python.Internal.CAPI
import Python.Internal.Program
----------------------------------------------------------------
C.context (C.baseCtx <> pyCtx)
C.include "<inline-python.h>"
----------------------------------------------------------------
-- | Convert haskell value to python value.
class ToPy a where
-- | Convert haskell value to python object. This function returns
-- strong reference to newly create objects (except singletons
-- like @None@, @True@, etc).
--
-- Implementations should try to avoid failing conversions.
-- There're two ways of signalling failure: errors on python side
-- should return NULL and raise python exception. Haskell code
-- should just throw exception.
--
-- This is low level function. It should be only used when working
-- with python's C API. Otherwise 'toPy' is preferred.
basicToPy :: a -> Py (Ptr PyObject)
-- | Old hack for handling of strings
basicListToPy :: [a] -> Py (Ptr PyObject)
basicListToPy xs = runProgram $ do
let n = fromIntegral $ length xs :: CLLong
p_list <- takeOwnership =<< checkNull (Py [CU.exp| PyObject* { PyList_New($(long long n)) } |])
let loop !_ [] = p_list <$ incref p_list
loop i (a:as) = basicToPy a >>= \case
NULL -> pure nullPtr
p_a -> do
-- NOTE: PyList_SET_ITEM steals reference
Py [CU.exp| void { PyList_SET_ITEM($(PyObject* p_list), $(long long i), $(PyObject* p_a)) } |]
loop (i+1) as
progPy $ loop 0 xs
-- | Convert python object to haskell value.
class FromPy a where
-- | Convert python value into haskell value. This function should
-- 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
-- '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.
basicFromPy :: Ptr PyObject -> Py a
-- | Convert python object to haskell value. All python exceptions
-- which happen during execution will be converted to @PyError@.
fromPyEither :: FromPy a => PyObject -> Py (Either PyError a)
fromPyEither py = unsafeWithPyObject py $ \p ->
(Right <$> basicFromPy p) `catch` (pure . Left)
-- | Convert python object to haskell value. Will return @Nothing@ if
-- 'BadPyType' or 'OutOfRange' is thrown. Other python exceptions
-- are rethrown.
fromPy :: FromPy a => PyObject -> Py (Maybe a)
fromPy py = unsafeWithPyObject py $ \p ->
(Just <$> basicFromPy p) `catch` \case
BadPyType -> pure Nothing
OutOfRange -> pure Nothing
e -> throwM e
-- | Convert python object to haskell value. Throws exception on
-- failure.
fromPy' :: FromPy a => PyObject -> Py a
fromPy' py = unsafeWithPyObject py basicFromPy
-- | Convert haskell value to a python object.
toPy :: ToPy a => a -> Py PyObject
toPy a = basicToPy a >>= \case
NULL -> mustThrowPyError
p -> newPyObject p
----------------------------------------------------------------
-- Instances
----------------------------------------------------------------
instance ToPy PyObject where
basicToPy o = unsafeWithPyObject o $ \p -> p <$ incref p
instance FromPy PyObject where
basicFromPy p = incref p >> newPyObject p
deriving newtype instance ToPy Module
deriving newtype instance FromPy Module
deriving newtype instance ToPy Dict
deriving newtype instance FromPy Dict
instance ToPy () where
basicToPy () = Py [CU.exp| PyObject* { Py_None } |]
instance ToPy CLong where
basicToPy i = Py [CU.exp| PyObject* { PyLong_FromLong($(long i)) } |]
instance FromPy CLong where
basicFromPy p_py = do
r <- Py [CU.exp| long { PyLong_AsLong($(PyObject *p_py)) } |]
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 <$ 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 <$ 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 <$ 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 <$ 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
-- | @since 0.2
instance ToPy (Complex Float) where
basicToPy (x:+y) = basicToPy $ float2Double x :+ float2Double y
-- | @since 0.2
instance FromPy (Complex Float) where
basicFromPy xy_py = do
x :+ y <- basicFromPy xy_py
return $ double2Float x :+ double2Float y
-- | @since 0.2
instance ToPy (Complex Double) where
basicToPy (x:+y) = Py [CU.exp| PyObject* { PyComplex_FromDoubles($(double x'), $(double y')) } |]
where x' = CDouble x
y' = CDouble y
-- | @since 0.2
instance FromPy (Complex Double) where
basicFromPy xy_py = do
CDouble x <- Py [CU.exp| double { PyComplex_RealAsDouble($(PyObject *xy_py)) } |]
checkThrowBadPyType
CDouble y <- Py [CU.exp| double { PyComplex_ImagAsDouble($(PyObject *xy_py)) } |]
checkThrowBadPyType
return $ x :+ y
instance ToPy Int where
basicToPy
| wordSizeInBits == 64 = basicToPy @Int64 . fromIntegral
| otherwise = basicToPy @Int32 . fromIntegral
instance FromPy Int where
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 -> throwM OutOfRange
instance FromPy Int16 where
basicFromPy p = basicFromPy @Int64 p >>= \case
i | i <= fromIntegral (maxBound :: Int16)
, i >= fromIntegral (minBound :: Int16) -> pure $! fromIntegral i
| otherwise -> throwM OutOfRange
instance FromPy Int32 where
basicFromPy p = basicFromPy @Int64 p >>= \case
i | i <= fromIntegral (maxBound :: Int32)
, i >= fromIntegral (minBound :: Int32) -> pure $! fromIntegral i
| otherwise -> throwM OutOfRange
instance FromPy Word8 where
basicFromPy p = basicFromPy @Word64 p >>= \case
i | i <= fromIntegral (maxBound :: Word8) -> pure $! fromIntegral i
| otherwise -> throwM OutOfRange
instance FromPy Word16 where
basicFromPy p = basicFromPy @Word64 p >>= \case
i | i <= fromIntegral (maxBound :: Word16) -> pure $! fromIntegral i
| otherwise -> throwM OutOfRange
instance FromPy Word32 where
basicFromPy p = basicFromPy @Word64 p >>= \case
i | i <= fromIntegral (maxBound :: Word32) -> pure $! fromIntegral i
| otherwise -> throwM OutOfRange
-- | Encoded as 1-character string
instance ToPy Char where
basicToPy c = do
let i = fromIntegral (ord c) :: CUInt
Py [CU.block| PyObject* {
uint32_t cs[1] = { $(unsigned i) };
return PyUnicode_DecodeUTF32((char*)cs, 4, NULL, NULL);
} |]
basicListToPy str = runProgram $ do
p_str <- withPyWCString str
progIO [CU.exp| PyObject* { PyUnicode_FromWideChar($(wchar_t *p_str), -1) } |]
instance FromPy Char where
basicFromPy p = do
r <- Py [CU.block| int {
PyObject* p = $(PyObject *p);
if( !PyUnicode_Check(p) )
return -1;
if( 1 != PyUnicode_GET_LENGTH(p) )
return -1;
switch( PyUnicode_KIND(p) ) {
case PyUnicode_1BYTE_KIND:
return PyUnicode_1BYTE_DATA(p)[0];
case PyUnicode_2BYTE_KIND:
return PyUnicode_2BYTE_DATA(p)[0];
case PyUnicode_4BYTE_KIND:
return PyUnicode_4BYTE_DATA(p)[0];
}
return -1;
} |]
if | r < 0 -> throwM BadPyType
| otherwise -> pure $ chr $ fromIntegral r
instance ToPy Bool where
basicToPy True = Py [CU.exp| PyObject* { Py_True } |]
basicToPy False = Py [CU.exp| PyObject* { Py_False } |]
-- | Uses python's truthiness conventions
instance FromPy Bool where
basicFromPy p = do
r <- Py [CU.exp| int { PyObject_IsTrue($(PyObject* p)) } |]
checkThrowPyError
pure $! r /= 0
instance (ToPy a, ToPy b) => ToPy (a,b) where
basicToPy (a,b) = runProgram $ do
p_a <- takeOwnership =<< checkNull (basicToPy a)
p_b <- takeOwnership =<< checkNull (basicToPy b)
progIO [CU.exp| PyObject* { PyTuple_Pack(2, $(PyObject* p_a), $(PyObject* p_b)) } |]
-- | Will accept any iterable
instance (FromPy a, FromPy b) => FromPy (a,b) where
basicFromPy p_tup = runProgram $ do
-- Unpack 2-tuple.
p_args <- withPyAllocaArray 2
unpack_ok <- progIO [CU.exp| int {
inline_py_unpack_iterable($(PyObject *p_tup), 2, $(PyObject **p_args))
}|]
progPy $ do checkThrowPyError
when (unpack_ok /= 0) $ throwM BadPyType
-- Parse each element of tuple
p_a <- takeOwnership =<< progIO (peekElemOff p_args 0)
p_b <- takeOwnership =<< progIO (peekElemOff p_args 1)
progPy $ do a <- basicFromPy p_a
b <- basicFromPy p_b
pure (a,b)
instance (ToPy a, ToPy b, ToPy c) => ToPy (a,b,c) where
basicToPy (a,b,c) = runProgram $ do
p_a <- takeOwnership =<< checkNull (basicToPy a)
p_b <- takeOwnership =<< checkNull (basicToPy b)
p_c <- takeOwnership =<< checkNull (basicToPy c)
progIO [CU.exp| PyObject* {
PyTuple_Pack(3, $(PyObject *p_a), $(PyObject *p_b), $(PyObject *p_c)) } |]
-- | Will accept any iterable
instance (FromPy a, FromPy b, FromPy c) => FromPy (a,b,c) where
basicFromPy p_tup = runProgram $ do
-- Unpack 3-tuple.
p_args <- withPyAllocaArray 3
unpack_ok <- progIO [CU.exp| int {
inline_py_unpack_iterable($(PyObject *p_tup), 3, $(PyObject **p_args))
}|]
progPy $ do checkThrowPyError
when (unpack_ok /= 0) $ throwM BadPyType
-- Parse each element of tuple
p_a <- takeOwnership =<< progIO (peekElemOff p_args 0)
p_b <- takeOwnership =<< progIO (peekElemOff p_args 1)
p_c <- takeOwnership =<< progIO (peekElemOff p_args 2)
progPy $ do a <- basicFromPy p_a
b <- basicFromPy p_b
c <- basicFromPy p_c
pure (a,b,c)
instance (ToPy a, ToPy b, ToPy c, ToPy d) => ToPy (a,b,c,d) where
basicToPy (a,b,c,d) = runProgram $ do
p_a <- takeOwnership =<< checkNull (basicToPy a)
p_b <- takeOwnership =<< checkNull (basicToPy b)
p_c <- takeOwnership =<< checkNull (basicToPy c)
p_d <- takeOwnership =<< checkNull (basicToPy d)
progIO [CU.exp| PyObject* {
PyTuple_Pack(4, $(PyObject *p_a), $(PyObject *p_b), $(PyObject *p_c), $(PyObject *p_d)) } |]
-- | Will accept any iterable
instance (FromPy a, FromPy b, FromPy c, FromPy d) => FromPy (a,b,c,d) where
basicFromPy p_tup = runProgram $ do
-- Unpack 3-tuple.
p_args <- withPyAllocaArray 4
unpack_ok <- progIO [CU.exp| int {
inline_py_unpack_iterable($(PyObject *p_tup), 4, $(PyObject **p_args))
}|]
progPy $ do checkThrowPyError
when (unpack_ok /= 0) $ throwM BadPyType
-- Parse each element of tuple
p_a <- takeOwnership =<< progIO (peekElemOff p_args 0)
p_b <- takeOwnership =<< progIO (peekElemOff p_args 1)
p_c <- takeOwnership =<< progIO (peekElemOff p_args 2)
p_d <- takeOwnership =<< progIO (peekElemOff p_args 3)
progPy $ do a <- basicFromPy p_a
b <- basicFromPy p_b
c <- basicFromPy p_c
d <- basicFromPy p_d
pure (a,b,c,d)
-- | @Nothing@ is encoded as @None@. @Just a@ same as @a@.
--
-- @since 0.2
instance (ToPy a) => ToPy (Maybe a) where
basicToPy Nothing = Py [CU.exp| PyObject* { Py_None } |]
basicToPy (Just a) = basicToPy a
-- | @None@ is decoded as @Nothing@ rest is attempted to be decoded as @a@
--
-- @since 0.2
instance (FromPy a) => FromPy (Maybe a) where
basicFromPy p =
Py [CU.exp| bool { Py_None == $(PyObject *p) } |] >>= \case
0 -> Just <$> basicFromPy p
_ -> pure Nothing
instance (ToPy a) => ToPy [a] where
basicToPy = basicListToPy
-- | Will accept any iterable
instance (FromPy a) => FromPy [a] where
basicFromPy p_list = do
p_iter <- Py [CU.block| PyObject* {
PyObject* iter = PyObject_GetIter( $(PyObject *p_list) );
if( PyErr_Occurred() ) {
PyErr_Clear();
}
return iter;
} |]
when (nullPtr == p_iter) $ throwM BadPyType
--
f <- foldPyIterable p_iter
(\f p -> do a <- basicFromPy p
pure (f . (a:)))
id
pure $ f []
instance (ToPy a, Ord a) => ToPy (Set.Set a) where
basicToPy set = runProgram $ do
p_set <- takeOwnership =<< checkNull basicNewSet
progPy $ do
let loop [] = p_set <$ incref p_set
loop (x:xs) = basicToPy x >>= \case
NULL -> pure NULL
p_a -> Py [C.exp| int { PySet_Add($(PyObject *p_set), $(PyObject *p_a)) }|] >>= \case
0 -> decref p_a >> loop xs
_ -> mustThrowPyError
loop $ Set.toList set
instance (FromPy a, Ord a) => FromPy (Set.Set a) where
basicFromPy p_set = basicGetIter p_set >>= \case
NULL -> do Py [C.exp| void { PyErr_Clear() } |]
throwM BadPyType
p_iter -> foldPyIterable p_iter
(\s p -> do a <- basicFromPy p
pure $! Set.insert a s)
Set.empty
instance (ToPy k, ToPy v, Ord k) => ToPy (Map.Map k v) where
basicToPy dct = runProgram $ do
p_dict <- takeOwnership =<< checkNull basicNewDict
progPy $ do
let loop [] = p_dict <$ incref p_dict
loop ((k,v):xs) = basicToPy k >>= \case
NULL -> mustThrowPyError
p_k -> flip finally (decref p_k) $ basicToPy v >>= \case
NULL -> mustThrowPyError
p_v -> Py [CU.exp| int { PyDict_SetItem($(PyObject *p_dict), $(PyObject* p_k), $(PyObject *p_v)) }|] >>= \case
0 -> loop xs
_ -> nullPtr <$ decref p_v
loop $ Map.toList dct
instance (FromPy k, FromPy v, Ord k) => FromPy (Map.Map k v) where
basicFromPy p_dct = basicGetIter p_dct >>= \case
NULL -> do Py [C.exp| void { PyErr_Clear() } |]
throwM BadPyType
p_iter -> foldPyIterable p_iter
(\m p -> do k <- basicFromPy p
v <- Py [CU.exp| PyObject* { PyDict_GetItem($(PyObject* p_dct), $(PyObject *p)) }|] >>= \case
NULL -> throwM BadPyType
p_v -> basicFromPy p_v
pure $! Map.insert k v m)
Map.empty
-- | Converts to python's list
instance ToPy a => ToPy (V.Vector a) where
basicToPy = vectorToPy
-- | Converts to python's list
instance (ToPy a, VS.Storable a) => ToPy (VS.Vector a) where
basicToPy = vectorToPy
-- | Converts to python's list
instance (ToPy a, VP.Prim a) => ToPy (VP.Vector a) where
basicToPy = vectorToPy
-- | Converts to python's list
instance (ToPy a, VU.Unbox a) => ToPy (VU.Vector a) where
basicToPy = vectorToPy
#if MIN_VERSION_vector(0,13,2)
-- | Converts to python's list
instance (ToPy a) => ToPy (VV.Vector a) where
basicToPy = vectorToPy
#endif
-- | Accepts python's sequence (@len@ and indexing)
instance FromPy a => FromPy (V.Vector a) where
basicFromPy = vectorFromPy
-- | Accepts python's sequence (@len@ and indexing)
instance (FromPy a, VS.Storable a) => FromPy (VS.Vector a) where
basicFromPy = vectorFromPy
-- | Accepts python's sequence (@len@ and indexing)
instance (FromPy a, VP.Prim a) => FromPy (VP.Vector a) where
basicFromPy = vectorFromPy
-- | Accepts python's sequence (@len@ and indexing)
instance (FromPy a, VU.Unbox a) => FromPy (VU.Vector a) where
basicFromPy = vectorFromPy
#if MIN_VERSION_vector(0,13,2)
-- | Accepts python's sequence (@len@ and indexing)
instance FromPy a => FromPy (VV.Vector a) where
basicFromPy = vectorFromPy
#endif
-- | Fold over python's iterator. Function takes ownership over iterator.
foldPyIterable
:: Ptr PyObject -- ^ Python iterator (not checked)
-> (a -> Ptr PyObject -> Py a) -- ^ Step function. It takes borrowed pointer.
-> a -- ^ Initial value
-> Py a
foldPyIterable p_iter step a0
= loop a0 `finally` decref p_iter
where
loop a = basicIterNext p_iter >>= \case
NULL -> a <$ checkThrowPyError
p -> loop =<< (step a p `finally` decref p)
vectorFromPy :: (VG.Vector v a, FromPy a) => Ptr PyObject -> Py (v a)
{-# INLINE vectorFromPy #-}
vectorFromPy p_seq = do
len <- Py [CU.exp| long long { PySequence_Size($(PyObject* p_seq)) } |]
when (len < 0) $ do
Py [C.exp| void { PyErr_Clear() } |]
throwM BadPyType
-- Read data into vector
buf <- MVG.generateM (fromIntegral len) $ \i -> do
let i_c = fromIntegral i
Py [CU.exp| PyObject* { PySequence_GetItem($(PyObject* p_seq), $(long long i_c)) } |] >>= \case
NULL -> mustThrowPyError
p -> basicFromPy p `finally` decref p
VG.unsafeFreeze buf
vectorToPy :: (VG.Vector v a, ToPy a) => v a -> Py (Ptr PyObject)
vectorToPy vec = runProgram $ do
p_list <- takeOwnership =<< checkNull (Py [CU.exp| PyObject* { PyList_New($(long long n_c)) } |])
progPy $ do
let loop i
| i >= n = p_list <$ incref p_list
| otherwise = basicToPy (VG.unsafeIndex vec i) >>= \case
NULL -> pure nullPtr
p_a -> do
let i_c = fromIntegral i :: CLLong
-- NOTE: PyList_SET_ITEM steals reference
Py [CU.exp| void { PyList_SET_ITEM($(PyObject* p_list), $(long long i_c), $(PyObject* p_a)) } |]
loop (i+1)
loop 0
where
n = VG.length vec
n_c = fromIntegral n :: CLLong
-- | Converted to @bytes@
--
-- @since 0.2
instance ToPy BS.ByteString where
basicToPy bs = pyIO $ BS.unsafeUseAsCStringLen bs $ \(ptr,len) -> do
let c_len = fromIntegral len :: CLLong
py <- [CU.exp| PyObject* { PyBytes_FromStringAndSize($(char* ptr), $(long long c_len)) }|]
case py of
NULL -> unsafeRunPy mustThrowPyError
_ -> return py
-- | Accepts @bytes@ and @bytearray@
--
-- @since 0.2
instance FromPy BS.ByteString where
basicFromPy py = pyIO $ do
[CU.exp| int { PyBytes_Check($(PyObject* py)) } |] >>= \case
TRUE -> do
sz <- [CU.exp| int64_t { PyBytes_GET_SIZE( $(PyObject* py)) } |]
buf <- [CU.exp| char* { PyBytes_AS_STRING($(PyObject* py)) } |]
fini buf (fromIntegral sz)
_ -> [CU.exp| int { PyByteArray_Check($(PyObject* py)) } |] >>= \case
TRUE -> do
sz <- [CU.exp| int64_t { PyByteArray_GET_SIZE( $(PyObject* py)) } |]
buf <- [CU.exp| char* { PyByteArray_AS_STRING($(PyObject* py)) } |]
fini buf (fromIntegral sz)
_ -> throwM BadPyType
where
fini py_buf sz = do
hs_buf <- mallocBytes sz
copyBytes hs_buf py_buf sz
BS.unsafePackMallocCStringLen (hs_buf, sz)
-- | Converted to @bytes@
--
-- @since 0.2
instance ToPy BL.ByteString where
basicToPy = basicToPy . BL.toStrict
-- | Accepts @bytes@ and @bytearray@
--
-- @since 0.2
instance FromPy BL.ByteString where
basicFromPy = fmap BL.fromStrict . basicFromPy
-- | Accepts @bytes@ and @bytearray@
--
-- @since 0.2
instance FromPy SBS.ShortByteString where
basicFromPy py = pyIO $ do
[CU.exp| int { PyBytes_Check($(PyObject* py)) } |] >>= \case
TRUE -> do
sz <- [CU.exp| int64_t { PyBytes_GET_SIZE( $(PyObject* py)) } |]
buf <- [CU.exp| char* { PyBytes_AS_STRING($(PyObject* py)) } |]
fini buf (fromIntegral sz)
_ -> [CU.exp| int { PyByteArray_Check($(PyObject* py)) } |] >>= \case
TRUE -> do
sz <- [CU.exp| int64_t { PyByteArray_GET_SIZE( $(PyObject* py)) } |]
buf <- [CU.exp| char* { PyByteArray_AS_STRING($(PyObject* py)) } |]
fini buf (fromIntegral sz)
_ -> throwM BadPyType
where
fini buf sz = do
bs <- BS.unsafePackCStringLen (buf, sz)
evaluate $ SBS.toShort bs
-- | Converted to @bytes@
--
-- @since 0.2
instance ToPy SBS.ShortByteString where
basicToPy bs = pyIO $ SBS.useAsCStringLen bs $ \(ptr,len) -> do
let c_len = fromIntegral len :: CLLong
py <- [CU.exp| PyObject* { PyBytes_FromStringAndSize($(char* ptr), $(long long c_len)) }|]
case py of
NULL -> unsafeRunPy mustThrowPyError
_ -> return py
-- | @since 0.2@.
instance ToPy T.Text where
-- NOTE: Is there ore efficient way to access
basicToPy str = pyIO $ BS.unsafeUseAsCStringLen bs $ \(ptr,len) -> do
let c_len = fromIntegral len :: CLLong
py <- [CU.exp| PyObject* { PyUnicode_FromStringAndSize($(char* ptr), $(long long c_len)) } |]
case py of
NULL -> unsafeRunPy mustThrowPyError
_ -> pure py
where
bs = T.encodeUtf8 str
-- | @since 0.2@.
instance ToPy TL.Text where
basicToPy = basicToPy . TL.toStrict
-- | @since 0.2@.
instance FromPy T.Text where
basicFromPy py = pyIO $ do
[CU.exp| int { PyUnicode_Check($(PyObject* py)) } |] >>= \case
TRUE -> alloca $ \p_size -> do
buf <- [CU.exp| const char* { PyUnicode_AsUTF8AndSize($(PyObject* py), $(long* p_size)) } |]
sz <- peek p_size
bs <- BS.unsafePackCStringLen (buf, fromIntegral sz)
return $! T.decodeUtf8Lenient bs
_ -> throwM BadPyType
-- | @since 0.2@.
instance FromPy TL.Text where
basicFromPy = fmap TL.fromStrict . basicFromPy
----------------------------------------------------------------
-- Functions marshalling
----------------------------------------------------------------
-- NOTE: [Creation of python functions]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- We need to call haskell from python we need to first to create
-- FunPtr on haskell side and wrap it using python's C API. Process is
-- unpleasantly convoluted.
--
-- Function marshalled from haskell side could only be called with
-- using positional arguments. Two calling conventions are supported:
--
-- - METH_O for 1-argument
-- - METH_FASTCALL for 2+ argument functions
--
-- One problem is we need to keep PyMethodDef struct alive while
-- function object is alive and GC it when function object is GC'd.
-- To that end we use horrible hack.
--
-- PyMethodDef is allocated on C heap, wrapped into PyCapsule passed
-- to CFunction as self. It does seems hacky. However it does the trick.
-- Maybe there's other way.
-- NOTE: [Exceptions in callbacks]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- We absolutely must not allow unhandled haskell exceptions in
-- callbacks from python. Else they will hit C wall and terminate
-- program. They MUST be converted to python ones.
--
-- FIXME: figure out masking for python's call. I DON'T want get hit
-- with async exception out of the blue
-- | Converted to 0-ary function
instance (ToPy b) => ToPy (IO b) where
basicToPy f = Py $ do
--
f_ptr <- wrapCFunction $ \_ _ -> pyCallback $ do
progPy $ basicToPy =<< dropGIL f
--
[CU.exp| PyObject* { inline_py_callback_METH_NOARGS($(PyCFunction f_ptr)) } |]
-- | Only accepts positional parameters
instance (FromPy a, Show a, ToPy b) => ToPy (a -> IO b) where
basicToPy f = Py $ do
--
f_ptr <- wrapCFunction $ \_ p_a -> pyCallback $ do
a <- loadArg p_a 0 1
progPy $ basicToPy =<< dropGIL (f a)
--
[CU.exp| PyObject* { inline_py_callback_METH_O($(PyCFunction f_ptr)) } |]
-- | Only accepts positional parameters
instance (FromPy a1, FromPy a2, ToPy b) => ToPy (a1 -> a2 -> IO b) where
basicToPy f = Py $ do
--
f_ptr <- wrapFastcall $ \_ p_arr n -> pyCallback $ do
when (n /= 2) $ abortM $ raiseBadNArgs 2 n
a1 <- loadArgFastcall p_arr 0 n
a2 <- loadArgFastcall p_arr 1 n
progPy $ basicToPy =<< dropGIL (f a1 a2)
--
[CU.exp| PyObject* { inline_py_callback_METH_FASTCALL($(PyCFunctionFast f_ptr)) } |]
-- | Converted to 0-ary function
instance (ToPy b) => ToPy (Py b) where
basicToPy f = Py $ do
--
f_ptr <- wrapCFunction $ \_ _ -> pyCallback $ do
progPy $ basicToPy =<< f
--
[CU.exp| PyObject* { inline_py_callback_METH_NOARGS($(PyCFunction f_ptr)) } |]
-- | Only accepts positional parameters
instance (FromPy a, Show a, ToPy b) => ToPy (a -> Py b) where
basicToPy f = Py $ do
--
f_ptr <- wrapCFunction $ \_ p_a -> pyCallback $ do
a <- loadArg p_a 0 1
progPy $ basicToPy =<< f a
--
[CU.exp| PyObject* { inline_py_callback_METH_O($(PyCFunction f_ptr)) } |]
-- | Only accepts positional parameters
instance (FromPy a1, FromPy a2, ToPy b) => ToPy (a1 -> a2 -> Py b) where
basicToPy f = Py $ do
--
f_ptr <- wrapFastcall $ \_ p_arr n -> pyCallback $ do
when (n /= 2) $ abortM $ raiseBadNArgs 2 n
a1 <- loadArgFastcall p_arr 0 n
a2 <- loadArgFastcall p_arr 1 n
progPy $ basicToPy =<< f a1 a2
--
[CU.exp| PyObject* { inline_py_callback_METH_FASTCALL($(PyCFunctionFast f_ptr)) } |]
----------------------------------------------------------------
-- Helpers
----------------------------------------------------------------
-- | Execute haskell callback function
pyCallback :: Program (Ptr PyObject) (Ptr PyObject) -> IO (Ptr PyObject)
pyCallback io = callbackEnsurePyLock $ unsafeRunPy $ ensureGIL $ runProgram io `catch` convertHaskell2Py
-- | Load argument from python object for haskell evaluation
loadArg
:: FromPy a
=> (Ptr PyObject) -- ^ Python object to decode
-> Int -- ^ Argument number (0-based)
-> Int64 -- ^ Total number of arguments
-> Program (Ptr PyObject) a
loadArg p (fromIntegral -> i) (fromIntegral -> tot) = Program $ ContT $ \success -> do
try (basicFromPy p) >>= \case
Right a -> success a
Left BadPyType -> oops
Left OutOfRange -> oops
Left e -> throwM 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
:: FromPy a
=> Ptr (Ptr PyObject) -- ^ Array of arguments
-> Int -- ^ Argument number (0-based)
-> Int64 -- ^ Total number of arguments
-> Program (Ptr PyObject) a
loadArgFastcall p_arr i tot = do
p <- progIO $ peekElemOff p_arr i
loadArg p i tot
raiseBadNArgs :: CInt -> Int64 -> Py (Ptr PyObject)
raiseBadNArgs expected got = Py [CU.block| PyObject* {
char err[256];
sprintf(err, "Function takes exactly %i arguments (%li given)", $(int expected), $(int64_t got));
PyErr_SetString(PyExc_TypeError, err);
return NULL;
} |]
type FunWrapper a = a -> IO (FunPtr a)
foreign import ccall "wrapper" wrapCFunction
:: FunWrapper (Ptr PyObject -> Ptr PyObject -> IO (Ptr PyObject))
foreign import ccall "wrapper" wrapFastcall
:: FunWrapper (Ptr PyObject -> Ptr (Ptr PyObject) -> Int64 -> IO (Ptr PyObject))
wordSizeInBits :: Int
wordSizeInBits = finiteBitSize (0 :: Word)
{-# INLINE wordSizeInBits #-}