diff --git a/inline-python.cabal b/inline-python.cabal index ad689f7..970e0c7 100644 --- a/inline-python.cabal +++ b/inline-python.cabal @@ -71,6 +71,7 @@ Library Python.Inline Python.Types Other-modules: + Python.Internal.CAPI Python.Internal.Eval Python.Internal.EvalQQ Python.Internal.Program @@ -88,6 +89,7 @@ library test , tasty-hunit >=0.10 , tasty-quickcheck >=0.10 , exceptions + , containers hs-source-dirs: test Exposed-modules: TST.Run diff --git a/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs index c1acd8d..201b6bc 100644 --- a/src/Python/Inline/Literal.hs +++ b/src/Python/Inline/Literal.hs @@ -14,13 +14,12 @@ module Python.Inline.Literal import Control.Monad import Control.Monad.Catch -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 Data.Set qualified as Set import Foreign.Ptr import Foreign.C.Types import Foreign.Storable @@ -32,7 +31,7 @@ import Language.C.Inline.Unsafe qualified as CU import Python.Types import Python.Internal.Types import Python.Internal.Eval - +import Python.Internal.CAPI import Python.Internal.Program ---------------------------------------------------------------- @@ -56,17 +55,17 @@ class ToPy a where basicToPy :: a -> Py (Ptr PyObject) -- | Old hack for handling of strings basicListToPy :: [a] -> Py (Ptr PyObject) - basicListToPy xs = evalContT $ do + basicListToPy xs = runProgram $ do let n = fromIntegral $ length xs :: CLLong - p_list <- checkNull (Py [CU.exp| PyObject* { PyList_New($(long long n)) } |]) - onExceptionProg $ decref p_list - let loop !_ [] = pure p_list + 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 - liftIO [CU.exp| void { PyList_SET_ITEM($(PyObject* p_list), $(long long i), $(PyObject* p_a)) } |] + -- 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 - lift $ loop 0 xs + progPy $ loop 0 xs -- | Convert python object to haskell value. class FromPy a where @@ -250,9 +249,9 @@ instance ToPy Char where uint32_t cs[1] = { $(unsigned i) }; return PyUnicode_DecodeUTF32((char*)cs, 4, NULL, NULL); } |] - basicListToPy str = evalContT $ do + basicListToPy str = runProgram $ do p_str <- withPyWCString str - liftIO [CU.exp| PyObject* { PyUnicode_FromWideChar($(wchar_t *p_str), -1) } |] + progIO [CU.exp| PyObject* { PyUnicode_FromWideChar($(wchar_t *p_str), -1) } |] instance FromPy Char where @@ -289,84 +288,84 @@ instance FromPy Bool where instance (ToPy a, ToPy b) => ToPy (a,b) where - basicToPy (a,b) = evalContT $ do + basicToPy (a,b) = runProgram $ do p_a <- takeOwnership =<< checkNull (basicToPy a) p_b <- takeOwnership =<< checkNull (basicToPy b) - liftIO [CU.exp| PyObject* { PyTuple_Pack(2, $(PyObject* p_a), $(PyObject* p_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 = evalContT $ do + basicFromPy p_tup = runProgram $ do -- Unpack 2-tuple. p_args <- withPyAllocaArray 2 - unpack_ok <- liftIO [CU.exp| int { + unpack_ok <- progIO [CU.exp| int { inline_py_unpack_iterable($(PyObject *p_tup), 2, $(PyObject **p_args)) }|] - lift $ do checkThrowPyError - when (unpack_ok /= 0) $ throwM BadPyType + progPy $ do checkThrowPyError + when (unpack_ok /= 0) $ throwM BadPyType -- Parse each element of tuple - p_a <- takeOwnership =<< liftIO (peekElemOff p_args 0) - p_b <- takeOwnership =<< liftIO (peekElemOff p_args 1) - lift $ do a <- basicFromPy p_a - b <- basicFromPy p_b - pure (a,b) + 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) = evalContT $ do + basicToPy (a,b,c) = runProgram $ do p_a <- takeOwnership =<< checkNull (basicToPy a) p_b <- takeOwnership =<< checkNull (basicToPy b) p_c <- takeOwnership =<< checkNull (basicToPy c) - liftIO [CU.exp| PyObject* { + 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 = evalContT $ do + basicFromPy p_tup = runProgram $ do -- Unpack 3-tuple. p_args <- withPyAllocaArray 3 - unpack_ok <- liftIO [CU.exp| int { + unpack_ok <- progIO [CU.exp| int { inline_py_unpack_iterable($(PyObject *p_tup), 3, $(PyObject **p_args)) }|] - lift $ do checkThrowPyError - when (unpack_ok /= 0) $ throwM BadPyType + progPy $ do checkThrowPyError + when (unpack_ok /= 0) $ throwM BadPyType -- Parse each element of tuple - p_a <- takeOwnership =<< liftIO (peekElemOff p_args 0) - p_b <- takeOwnership =<< liftIO (peekElemOff p_args 1) - p_c <- takeOwnership =<< liftIO (peekElemOff p_args 2) - lift $ do a <- basicFromPy p_a - b <- basicFromPy p_b - c <- basicFromPy p_c - pure (a,b,c) + 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) = evalContT $ do + 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) - liftIO [CU.exp| PyObject* { + 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 = evalContT $ do + basicFromPy p_tup = runProgram $ do -- Unpack 3-tuple. p_args <- withPyAllocaArray 4 - unpack_ok <- liftIO [CU.exp| int { + unpack_ok <- progIO [CU.exp| int { inline_py_unpack_iterable($(PyObject *p_tup), 4, $(PyObject **p_args)) }|] - lift $ do checkThrowPyError - when (unpack_ok /= 0) $ throwM BadPyType + progPy $ do checkThrowPyError + when (unpack_ok /= 0) $ throwM BadPyType -- Parse each element of tuple - p_a <- takeOwnership =<< liftIO (peekElemOff p_args 0) - p_b <- takeOwnership =<< liftIO (peekElemOff p_args 1) - p_c <- takeOwnership =<< liftIO (peekElemOff p_args 2) - p_d <- takeOwnership =<< liftIO (peekElemOff p_args 3) - lift $ do a <- basicFromPy p_a - b <- basicFromPy p_b - c <- basicFromPy p_c - d <- basicFromPy p_d - pure (a,b,c,d) + 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) instance (ToPy a) => ToPy [a] where basicToPy = basicListToPy @@ -383,14 +382,45 @@ instance (FromPy a) => FromPy [a] where } |] when (nullPtr == p_iter) $ throwM BadPyType -- - let loop f = do - p <- Py [C.exp| PyObject* { PyIter_Next($(PyObject* p_iter)) } |] - checkThrowPyError - case p of - NULL -> pure f - _ -> do a <- basicFromPy p `finally` decref p - loop (f . (a:)) - ($ []) <$> loop id + 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 + +-- | Fold over iterable. 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) ---------------------------------------------------------------- @@ -436,7 +466,7 @@ instance (ToPy b) => ToPy (IO b) where basicToPy f = Py $ do -- f_ptr <- wrapCFunction $ \_ _ -> pyCallback $ do - lift $ basicToPy =<< dropGIL f + progPy $ basicToPy =<< dropGIL f -- [CU.exp| PyObject* { inline_py_callback_METH_NOARGS($(PyCFunction f_ptr)) } |] @@ -447,7 +477,7 @@ instance (FromPy a, Show a, ToPy b) => ToPy (a -> IO b) where -- f_ptr <- wrapCFunction $ \_ p_a -> pyCallback $ do a <- loadArg p_a 0 1 - lift $ basicToPy =<< dropGIL (f a) + progPy $ basicToPy =<< dropGIL (f a) -- [CU.exp| PyObject* { inline_py_callback_METH_O($(PyCFunction f_ptr)) } |] @@ -459,7 +489,7 @@ instance (FromPy a1, FromPy a2, ToPy b) => ToPy (a1 -> a2 -> IO b) where when (n /= 2) $ abortM $ raiseBadNArgs 2 n a1 <- loadArgFastcall p_arr 0 n a2 <- loadArgFastcall p_arr 1 n - lift $ basicToPy =<< dropGIL (f a1 a2) + progPy $ basicToPy =<< dropGIL (f a1 a2) -- [CU.exp| PyObject* { inline_py_callback_METH_FASTCALL($(PyCFunctionFast f_ptr)) } |] @@ -470,7 +500,7 @@ instance (FromPy a1, FromPy a2, ToPy b) => ToPy (a1 -> a2 -> IO b) where -- | Execute haskell callback function pyCallback :: Program (Ptr PyObject) (Ptr PyObject) -> IO (Ptr PyObject) -pyCallback io = callbackEnsurePyLock $ unPy $ ensureGIL $ evalContT io `catch` convertHaskell2Py +pyCallback io = callbackEnsurePyLock $ unPy $ ensureGIL $ runProgram io `catch` convertHaskell2Py -- | Load argument from python object for haskell evaluation loadArg @@ -479,7 +509,7 @@ loadArg -> Int -- ^ Argument number (0-based) -> Int64 -- ^ Total number of arguments -> Program (Ptr PyObject) a -loadArg p (fromIntegral -> i) (fromIntegral -> tot) = ContT $ \success -> do +loadArg p (fromIntegral -> i) (fromIntegral -> tot) = Program $ ContT $ \success -> do try (basicFromPy p) >>= \case Right a -> success a Left BadPyType -> oops @@ -501,7 +531,7 @@ loadArgFastcall -> Int64 -- ^ Total number of arguments -> Program (Ptr PyObject) a loadArgFastcall p_arr i tot = do - p <- liftIO $ peekElemOff p_arr i + p <- progIO $ peekElemOff p_arr i loadArg p i tot raiseBadNArgs :: CInt -> Int64 -> Py (Ptr PyObject) diff --git a/src/Python/Internal/CAPI.hs b/src/Python/Internal/CAPI.hs new file mode 100644 index 0000000..a3d6eeb --- /dev/null +++ b/src/Python/Internal/CAPI.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Thin wrappers over C API +module Python.Internal.CAPI + ( decref + , incref + -- * Simple wrappers + , basicNewDict + , basicNewSet + , basicGetIter + , basicIterNext + , basicCallKwdOnly + ) where + +import Foreign.Ptr +import Language.C.Inline qualified as C +import Language.C.Inline.Unsafe qualified as CU + +import Python.Internal.Types + + +---------------------------------------------------------------- +C.context (C.baseCtx <> pyCtx) +C.include "" +---------------------------------------------------------------- + + +decref :: Ptr PyObject -> Py () +decref p = Py [CU.exp| void { Py_DECREF($(PyObject* p)) } |] + +incref :: Ptr PyObject -> Py () +incref p = Py [CU.exp| void { Py_INCREF($(PyObject* p)) } |] + +basicNewDict :: Py (Ptr PyObject) +basicNewDict = Py [CU.exp| PyObject* { PyDict_New() } |] + +basicNewSet :: Py (Ptr PyObject) +basicNewSet = Py [CU.exp| PyObject* { PySet_New(NULL) } |] + +basicGetIter :: Ptr PyObject -> Py (Ptr PyObject) +basicGetIter p = Py [CU.exp| PyObject* { PyObject_GetIter( $(PyObject *p)) } |] + +basicIterNext :: Ptr PyObject -> Py (Ptr PyObject) +basicIterNext p = Py [C.exp| PyObject* { PyIter_Next($(PyObject* p)) } |] + + +-- | Call python function using only keyword arguments +basicCallKwdOnly + :: Ptr PyObject -- ^ Function object + -> Ptr PyObject -- ^ Keywords. Must be dictionary + -> Py (Ptr PyObject) +basicCallKwdOnly fun kwd = Py [CU.block| PyObject* { + PyObject* args = PyTuple_Pack(0); + PyObject* res = PyObject_Call($(PyObject *fun), args, $(PyObject *kwd)); + Py_DECREF(args); + return res; + } |] diff --git a/src/Python/Internal/Eval.hs b/src/Python/Internal/Eval.hs index 27cc242..b3d20ed 100644 --- a/src/Python/Internal/Eval.hs +++ b/src/Python/Internal/Eval.hs @@ -19,8 +19,6 @@ module Python.Internal.Eval -- * GC-related , newPyObject -- * C-API wrappers - , decref - , incref , takeOwnership , ensureGIL , dropGIL @@ -30,12 +28,14 @@ module Python.Internal.Eval , checkThrowPyError , mustThrowPyError , checkThrowBadPyType + , throwOnNULL -- * Debugging , debugPrintPy ) where import Control.Concurrent import Control.Concurrent.STM +import Control.Exception (interruptible) import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class @@ -57,6 +57,7 @@ import Python.Internal.Types import Python.Internal.Util import Python.Internal.Program + ---------------------------------------------------------------- C.context (C.baseCtx <> pyCtx) C.include "" @@ -535,12 +536,6 @@ gcDecref p = [CU.block| void { -- C-API wrappers ---------------------------------------------------------------- -decref :: Ptr PyObject -> Py () -decref p = Py [CU.exp| void { Py_DECREF($(PyObject* p)) } |] - -incref :: Ptr PyObject -> Py () -incref p = Py [CU.exp| void { Py_INCREF($(PyObject* p)) } |] - -- | Ensure that we hold GIL for duration of action ensureGIL :: Py a -> Py a ensureGIL action = do @@ -557,11 +552,8 @@ dropGIL action = do -- PyGILState_STATE is defined as enum. Let hope it will stay -- this way. st <- Py [CU.exp| PyThreadState* { PyEval_SaveThread() } |] - Py $ action `finally` [CU.exp| void { PyEval_RestoreThread($(PyThreadState *st)) } |] - --- | Decrement reference counter at end of ContT block -takeOwnership :: Ptr PyObject -> Program r (Ptr PyObject) -takeOwnership p = ContT $ \c -> c p `finally` decref p + Py $ interruptible action + `finally` [CU.exp| void { PyEval_RestoreThread($(PyThreadState *st)) } |] ---------------------------------------------------------------- @@ -581,11 +573,11 @@ convertHaskell2Py err = Py $ do -- | Convert python exception to haskell exception. Should only be -- called if there's unhandled python exception. Clears exception. convertPy2Haskell :: Py PyError -convertPy2Haskell = evalContT $ do +convertPy2Haskell = runProgram $ do p_errors <- withPyAllocaArray @(Ptr PyObject) 3 p_len <- withPyAlloca @CLong -- Fetch error indicator - (p_type, p_value) <- liftIO $ do + (p_type, p_value) <- progIO $ do [CU.block| void { PyObject **p = $(PyObject** p_errors); PyErr_Fetch(p, p+1, p+2); @@ -596,7 +588,7 @@ convertPy2Haskell = evalContT $ do pure (p_type,p_value) -- Convert exception type and value to strings. let pythonStr p = do - p_str <- liftIO [CU.block| PyObject* { + p_str <- progIO [CU.block| PyObject* { PyObject *s = PyObject_Str($(PyObject *p)); if( PyErr_Occurred() ) { PyErr_Clear(); @@ -620,7 +612,7 @@ convertPy2Haskell = evalContT $ do case c_str of NULL -> pure "" _ -> peekCString c_str - liftIO $ PyError <$> toString s_type <*> toString s_value + progIO $ PyError <$> toString s_type <*> toString s_value -- | Throw python error as haskell exception if it's raised. @@ -632,12 +624,18 @@ checkThrowPyError = -- | Throw python error as haskell exception if it's raised. If it's -- not that internal error. Another exception will be raised -mustThrowPyError :: String -> Py a -mustThrowPyError msg = +mustThrowPyError :: Py a +mustThrowPyError = Py [CU.exp| PyObject* { PyErr_Occurred() } |] >>= \case - NULL -> error $ "mustThrowPyError: no python exception raised. " ++ msg + NULL -> error $ "mustThrowPyError: no python exception raised." _ -> throwM =<< convertPy2Haskell +-- | Calls mustThrowPyError if pointer is null or returns it unchanged +throwOnNULL :: Ptr PyObject -> Py (Ptr PyObject) +throwOnNULL = \case + NULL -> mustThrowPyError + p -> pure p + checkThrowBadPyType :: Py () checkThrowBadPyType = do r <- Py [CU.block| int { diff --git a/src/Python/Internal/EvalQQ.hs b/src/Python/Internal/EvalQQ.hs index 7ac6fa9..187ad09 100644 --- a/src/Python/Internal/EvalQQ.hs +++ b/src/Python/Internal/EvalQQ.hs @@ -3,9 +3,7 @@ -- | module Python.Internal.EvalQQ ( -- * Evaluators and QQ - pyExecExpr - , pyEvalExpr - , evaluatorPymain + evaluatorPymain , evaluatorPy_ , evaluatorPye , evaluatorPyf @@ -15,8 +13,6 @@ module Python.Internal.EvalQQ ) where import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Cont import Data.Bits import Data.Char import Data.List (intercalate) @@ -37,6 +33,7 @@ import Python.Types import Python.Internal.Types import Python.Internal.Program import Python.Internal.Eval +import Python.Internal.CAPI import Python.Inline.Literal @@ -56,9 +53,9 @@ pyExecExpr -> Ptr PyObject -- ^ Locals -> String -- ^ Python source code -> Py () -pyExecExpr p_globals p_locals src = evalContT $ do +pyExecExpr p_globals p_locals src = runProgram $ do p_py <- withPyCString src - lift $ do + progPy $ do Py [C.block| void { PyObject* globals = $(PyObject* p_globals); PyObject* locals = $(PyObject* p_locals); @@ -80,9 +77,9 @@ pyEvalExpr -> Ptr PyObject -- ^ Locals -> String -- ^ Python source code -> Py PyObject -pyEvalExpr p_globals p_locals src = evalContT $ do +pyEvalExpr p_globals p_locals src = runProgram $ do p_py <- withPyCString src - lift $ do + progPy $ do p_res <- Py [C.block| PyObject* { PyObject* globals = $(PyObject* p_globals); PyObject* locals = $(PyObject* p_locals); @@ -107,23 +104,23 @@ evaluatorPymain getSource = do pyExecExpr p_main p_main src evaluatorPy_ :: (Ptr PyObject -> Py String) -> Py () -evaluatorPy_ getSource = evalContT $ do - p_globals <- lift basicMainDict - p_locals <- takeOwnership =<< lift basicNewDict - lift $ pyExecExpr p_globals p_locals =<< getSource p_locals +evaluatorPy_ getSource = runProgram $ do + p_globals <- progPy basicMainDict + p_locals <- takeOwnership =<< progPy basicNewDict + progPy $ pyExecExpr p_globals p_locals =<< getSource p_locals evaluatorPye :: (Ptr PyObject -> Py String) -> Py PyObject -evaluatorPye getSource = evalContT $ do - p_globals <- lift basicMainDict - p_locals <- takeOwnership =<< lift basicNewDict - lift $ pyEvalExpr p_globals p_locals =<< getSource p_locals +evaluatorPye getSource = runProgram $ do + p_globals <- progPy basicMainDict + p_locals <- takeOwnership =<< progPy basicNewDict + progPy $ pyEvalExpr p_globals p_locals =<< getSource p_locals evaluatorPyf :: (Ptr PyObject -> Py String) -> Py PyObject -evaluatorPyf getSource = evalContT $ do - p_globals <- lift basicMainDict - p_locals <- takeOwnership =<< lift basicNewDict - p_kwargs <- takeOwnership =<< lift basicNewDict - lift $ do +evaluatorPyf getSource = runProgram $ do + p_globals <- progPy basicMainDict + p_locals <- takeOwnership =<< progPy basicNewDict + p_kwargs <- takeOwnership =<< progPy basicNewDict + progPy $ do -- Create function in p_locals pyExecExpr p_globals p_locals =<< getSource p_kwargs -- Look up function @@ -131,28 +128,21 @@ evaluatorPyf getSource = evalContT $ do NULL -> error "INTERNAL ERROR: _inline_python_ must be present" p -> pure p -- Call python function we just constructed - callFunctionObject p_fun p_kwargs >>= \case - NULL -> mustThrowPyError "evaluatorPyf" - p_res -> newPyObject p_res + newPyObject =<< throwOnNULL =<< basicCallKwdOnly p_fun p_kwargs basicBindInDict :: ToPy a => String -> a -> Ptr PyObject -> Py () -basicBindInDict name a p_dict = evalContT $ do - (p_key) <- withPyCString name - p_obj <- takeOwnership =<< lift (basicToPy a) - lift $ case p_obj of - NULL -> mustThrowPyError "basicBindInDict" - _ -> do - r <- Py [C.block| int { - PyObject* p_obj = $(PyObject* p_obj); - return PyDict_SetItemString($(PyObject* p_dict), $(char* p_key), p_obj); - } |] - case r of - 0 -> pure () - _ -> mustThrowPyError "basicBindInDict" - -basicNewDict :: Py (Ptr PyObject) -basicNewDict = Py [CU.exp| PyObject* { PyDict_New() } |] +basicBindInDict name a p_dict = runProgram $ do + p_key <- withPyCString name + p_obj <- takeOwnership =<< progPy (throwOnNULL =<< basicToPy a) + progPy $ do + r <- Py [C.block| int { + PyObject* p_obj = $(PyObject* p_obj); + return PyDict_SetItemString($(PyObject* p_dict), $(char* p_key), p_obj); + } |] + case r of + 0 -> pure () + _ -> mustThrowPyError -- | Return dict of @__main__@ module basicMainDict :: Py (Ptr PyObject) @@ -167,12 +157,6 @@ getFunctionObject :: Ptr PyObject -> Py (Ptr PyObject) getFunctionObject p_dict = do Py [CU.exp| PyObject* { PyDict_GetItemString($(PyObject *p_dict), "_inline_python_") } |] -callFunctionObject :: Ptr PyObject -> Ptr PyObject -> Py (Ptr PyObject) -callFunctionObject fun kwargs = Py [CU.block| PyObject* { - PyObject* args = PyTuple_Pack(0); - return PyObject_Call($(PyObject *fun), args, $(PyObject *kwargs)); - } |] - ---------------------------------------------------------------- diff --git a/src/Python/Internal/Program.hs b/src/Python/Internal/Program.hs index 303eaee..9499a33 100644 --- a/src/Python/Internal/Program.hs +++ b/src/Python/Internal/Program.hs @@ -1,12 +1,16 @@ -- | module Python.Internal.Program - ( Program + ( Program(..) + , runProgram + , progPy + , progIO -- * Control flow , abort , abortM , checkNull , finallyProg , onExceptionProg + , takeOwnership -- * Allocators , withPyAlloca , withPyAllocaArray @@ -16,6 +20,7 @@ module Python.Internal.Program ) where import Control.Monad.Trans.Cont +import Control.Monad.Trans.Class import Control.Monad.Catch import Data.Coerce import Foreign.Ptr @@ -27,24 +32,35 @@ import Foreign.Storable import Python.Internal.Types import Python.Internal.Util +import Python.Internal.CAPI --- | Internally we usually wrap 'Py' into 'ContT' in order get early --- exit and avoid building ladder of -type Program r a = ContT r Py a +-- | This monad wraps 'Py' into 'ContT' in order get early exit, +-- applying @finally@ while avoiding building huge ladders. +newtype Program r a = Program (ContT r Py a) + deriving newtype (Functor, Applicative, Monad) +runProgram :: Program a a -> Py a +runProgram (Program m) = evalContT m + +-- | Does not change masking state +progIO :: IO a -> Program r a +progIO = Program . lift . pyIO + +progPy :: Py a -> Program r a +progPy = Program . lift -- | Early exit from continuation monad. -abort :: Monad m => r -> ContT r m a -abort r = ContT $ \_ -> pure r +abort :: r -> Program r a +abort r = Program $ ContT $ \_ -> pure r -- | Early exit from continuation monad. -abortM :: Monad m => m r -> ContT r m a -abortM m = ContT $ \_ -> m +abortM :: Py r -> Program r a +abortM m = Program $ ContT $ \_ -> m -- | If result of computation is NULL return NULL immediately. checkNull :: Py (Ptr a) -> Program (Ptr a) (Ptr a) -checkNull action = ContT $ \cnt -> action >>= \case +checkNull action = Program $ ContT $ \cnt -> action >>= \case NULL -> pure nullPtr p -> cnt p @@ -52,13 +68,17 @@ checkNull action = ContT $ \cnt -> action >>= \case finallyProg :: Py b -- ^ Finalizer -> Program r () -finallyProg fini = ContT $ \c -> c () `finally` fini +finallyProg fini = Program $ ContT $ \c -> c () `finally` fini -- | Evaluate finalizer if exception is thrown. onExceptionProg :: Py b -- ^ Finalizer -> Program r () -onExceptionProg fini = ContT $ \c -> c () `onException` fini +onExceptionProg fini = Program $ ContT $ \c -> c () `onException` fini + +-- | Decrement reference counter at end of ContT block +takeOwnership :: Ptr PyObject -> Program r (Ptr PyObject) +takeOwnership p = Program $ ContT $ \c -> c p `finally` decref p ---------------------------------------------------------------- diff --git a/src/Python/Internal/Types.hs b/src/Python/Internal/Types.hs index 108bbe5..553edf1 100644 --- a/src/Python/Internal/Types.hs +++ b/src/Python/Internal/Types.hs @@ -12,6 +12,7 @@ module Python.Internal.Types , PyThreadState , PyError(..) , Py(..) + , pyIO -- * inline-C , pyCtx -- * Patterns @@ -23,6 +24,7 @@ module Python.Internal.Types import Control.Monad.IO.Class import Control.Monad.Catch +import Control.Exception import Data.Coerce import Data.Int import Data.Map.Strict qualified as Map @@ -70,17 +72,24 @@ data PyError instance Exception PyError --- | Monad for code which is interacts directly with python --- interpreter. During its execution python global interpreter lock --- (GIL) is held, async exceptions are masked. It's also always --- executed on bound thread if RTS supports one. --- --- It's needed in order to distinguish between code that needs such --- guarantees and plain IO. +-- | Monad for code which is interacts with python interpreter. Only +-- one haskell thread can interact with python interpreter at a +-- time. Function that execute @Py@ make sure that this invariant is +-- held. Also note that all code in @Py@ monad is executed with +-- asynchronous exception masked, but 'liftIO' removes mask. newtype Py a = Py (IO a) - deriving newtype (Functor,Applicative,Monad,MonadIO,MonadFail, + -- See NOTE: [Python and threading] + deriving newtype (Functor,Applicative,Monad,MonadFail, MonadThrow,MonadCatch,MonadMask) --- See NOTE: [Python and threading] + +-- | Inject @IO@ into @Py@ monad without changing masking state +-- (unlike 'liftIO') +pyIO :: IO a -> Py a +pyIO = Py + +-- | Removes exception masking +instance MonadIO Py where + liftIO = Py . interruptible ---------------------------------------------------------------- diff --git a/src/Python/Types.hs b/src/Python/Types.hs index dc35fbb..f6cd4e2 100644 --- a/src/Python/Types.hs +++ b/src/Python/Types.hs @@ -4,7 +4,8 @@ module Python.Types ( -- * @Py@ monad Py , runPy - , PyObject(..) + , pyIO + , PyObject , unsafeWithPyObject , PyError(..) ) where diff --git a/test/TST/Roundtrip.hs b/test/TST/Roundtrip.hs index 596e1fe..c7cfd4f 100644 --- a/test/TST/Roundtrip.hs +++ b/test/TST/Roundtrip.hs @@ -5,6 +5,7 @@ module TST.Roundtrip (tests) where import Data.Int import Data.Word import Data.Typeable +import Data.Set (Set) import Foreign.C.Types import Test.Tasty @@ -51,6 +52,7 @@ tests = testGroup "Roundtrip" , testRoundtrip @(Int,Int,Int,Char) , testRoundtrip @[Int] , testRoundtrip @[[Int]] + , testRoundtrip @(Set Int) -- , testRoundtrip @String -- Trips on zero byte as it should ] , testGroup "OutOfRange" diff --git a/test/TST/ToPy.hs b/test/TST/ToPy.hs index aba6800..a712fb7 100644 --- a/test/TST/ToPy.hs +++ b/test/TST/ToPy.hs @@ -1,10 +1,13 @@ -- | module TST.ToPy (tests) where +import Data.Set qualified as Set import Test.Tasty import Test.Tasty.HUnit import Python.Inline import Python.Inline.QQ +import TST.Util + tests :: TestTree tests = testGroup "ToPy" @@ -30,4 +33,10 @@ tests = testGroup "ToPy" , testCase "list" $ runPy $ let x = [1 .. 5::Int] in [py_| assert x_hs == [1,2,3,4,5] |] + , testCase "set" $ runPy $ + let x = Set.fromList [1, 5, 3::Int] + in [py_| assert x_hs == {1,3,5} |] + , testCase "set unhashable" $ runPy $ + let x = Set.fromList [[1], [5], [3::Int]] + in throwsPy [py_| assert x_hs == {1,3,5} |] ]