inline-python 0.2.1.0 → 0.3.0.0

raw patch · 22 files changed

+1533/−341 lines, 22 filesdep +deepseqdep ~basedep ~bytestringdep ~containersbuild-type:Customsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq

Dependency ranges changed: base, bytestring, containers, exceptions, stm, tasty, text, vector

API changes (from Hackage documentation)

Files

• ChangeLog.md +31/−1
• Setup.hs +79/−0
• cbits/python.c +178/−0
• include/inline-python.h +52/−0
• inline-python.cabal +50/−32
• src/Python/Inline.hs +63/−4
• src/Python/Inline/Async.hs +22/−0
• src/Python/Inline/Eval.hs +31/−5
• src/Python/Inline/Literal.hs +37/−13
• src/Python/Inline/Monad.hs +76/−0
• src/Python/Inline/Monad/QQ.hs +94/−0
• src/Python/Inline/QQ.hs +68/−16
• src/Python/Internal/CAPI.hs +7/−3
• src/Python/Internal/Eval.hs +507/−201
• src/Python/Internal/EvalQQ.hs +14/−46
• src/Python/Internal/Program.hs +6/−3
• src/Python/Internal/Types.hs +29/−7
• test/TST/Callbacks.hs +13/−2
• test/TST/Module.hs +44/−0
• test/TST/Run.hs +123/−8
• test/TST/Util.hs +7/−0
• test/exe/main.hs +2/−0

@@ -1,3 +1,33 @@+0.3.0.0 [2026.10.15]+--------------------+* Support for asynchronous execution added in module `Python.Inline.Async`.  It+  uses API modelled after `async` package. Such computations could be+  interrupted using `cancelPy` even when they're running python code or haskell+  callback/+* When threaded runtime is used `runPyInMain` could be reliably interrupted by+  asynchronous exceptions.+* Python module `inline_python` is now available. It contains exception types+  used by library: `AsyncCancelled` and `HaskellError` which wraps haskell+  exception from callback.+* `Python.Inline.Monad` and `Python.Inline.Monad.QQ` modules providing monadic+  API. It uses `MonadPy` type class which allows user code to carry around+  python dictionaries with global and local scopes.+* Package now uses `Custom` build type. It now supports configuring python using+  `python3-config` instead of `pkg-config` when `-fpython3-config` manual cabal+  flag is set. Default behavior is unchanged.+* Haskell exception raised in haskell callback will be rethrown if not caught by+  python instead of being converted to `PyError`.+* `evalPyFunction` is added to company of `eval` and `exec`. It uses new+  `PyQuoteFun` data type as parameter.+* `pySource` quasiquoter added. It loads python code from file. +* `createModule` added which gives standard way of defining python code.+* Bug fixes:+ - Memory leak in exception handling is fixed. Python exception object were never+   freed when exception propagated to haskell side.+ - `bindVar` and `codeFromString`, `codeFromText` violated memory safety but+   happened to work correctly when strings were created by TH. Consider upgrade+   if using them.+ 0.2.1.0 [2026.01.13] ---------------- * `From/ToPy` instance for `Integer`&`Natural` added.@@ -21,7 +51,7 @@ 0.1.1 [2025.02.13] ------------------ * Number of deadlocks in `runPyInMain` fixed:-  - It no longer deadlocks is exception is thrown+  - It no longer deadlocks if exception is thrown   - Nested calls no longer deadlock.   - Calling it from python callback. * `ToPy` instance added for `Py b`, `a -> Py b`, `a1 -> a2 -> Py b`

@@ -0,0 +1,79 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings   #-}+import Data.Either++import Distribution.Simple+import Distribution.Simple.Setup+import Distribution.Simple.LocalBuildInfo+import Distribution.PackageDescription+import Distribution.Types.BuildInfo+import Distribution.Types.PackageDescription+import Distribution.Types.CondTree+import Distribution.Types.ForeignLib+import Distribution.Types.UnqualComponentName+import Distribution.Utils.Path+import Distribution.Compat.Lens+import Distribution.Types.BuildInfo.Lens qualified as L++import Data.List (intercalate, nub)+import System.Process+++main :: IO ()+main = defaultMainWithHooks $ simpleUserHooks+  { confHook = patchedConfHook }++++patchedConfHook+  :: (GenericPackageDescription, HookedBuildInfo)+  -> ConfigFlags+  -> IO LocalBuildInfo+patchedConfHook (gpd, hbi) flags+  | Just True <- lookupFlagAssignment ("python3-config") $ configConfigurationsFlags flags+  = do cflags_raw  <- readProcess "python3-config" ["--cflags"] ""+       ldflags_raw <- readProcess "python3-config" ["--embed", "--ldflags"] ""+       -- Split flags+       let (inc_dirs,cflags) = partitionEithers+             [ case flag of+                 '-':'I':path -> Left  path+                 _            -> Right flag+             | flag <- tokenizeArguments cflags_raw+             ]+           (ldflags, (libs, lib_dirs)) = fmap partitionEithers $ partitionEithers+             [ case flag of+                 '-':'l':path -> Right (Left  path)+                 '-':'L':path -> Right (Right path)+                 _            -> Left flag+             | flag <- tokenizeArguments ldflags_raw+             ]+       let tweakLib lib = case lib.libName of+             LMainLibName -> lib & L.ccOptions    %~ (++ cflags)+                                 & L.includeDirs  %~ (++ (toSymb <$> inc_dirs))+                                 & L.ldOptions    %~ (++ ldflags)+                                 & L.extraLibs    %~ (++ libs)+                                 & L.extraLibDirs %~ (++ (toSymb <$> lib_dirs))+             _            -> lib+       confHook simpleUserHooks+         ( gpd { condLibrary = (fmap . fmap) tweakLib (condLibrary  gpd) }+         , hbi+         ) flags+  | otherwise = do+      confHook simpleUserHooks (gpd, hbi) flags++tokenizeArguments :: String -> [String]+tokenizeArguments = words++----------------------------------------------------------------+-- Compatibility++#if MIN_VERSION_Cabal_syntax(3,14,0)+toSymb :: String -> SymbolicPathX 'AllowAbsolute from to+toSymb = makeSymbolicPath+#else+toSymb :: String -> String+toSymb = id+#endif

@@ -210,3 +210,181 @@     PyLong_AsNativeBytes(p, buf, size, -1); #endif }+++static Py_tss_t key_py_async = Py_tss_NEEDS_INIT;++void inline_py_init_state(void *stack) {+    int r = PyThread_tss_set(&key_py_async, stack);+    if( 0 != r ) {+        fprintf(stderr, "inline-python: fatal error: setting thread local storage failed\n");+        exit(1);+    }+}++void inline_py_free_state(void) {+    int r = PyThread_tss_set(&key_py_async, NULL);+    if( 0 != r ) {+        fprintf(stderr, "inline-python: fatal error: setting thread local storage failed\n");+        exit(1);+    }+}++void* inline_py_get_state(void) {+    return PyThread_tss_get(&key_py_async);+}+++void inline_py_initialize(void) {+    int r = PyThread_tss_create(&key_py_async);+    if( 0 != r ) {+        fprintf(stderr, "inline-python: fatal error: Failed to initialized thread local storage\n");+        exit(1);+    }+}++void inline_py_clear_error(void) {+    static PyObject* globals = NULL;+    static PyObject* locals  = NULL;+    static PyObject* code    = NULL;+    if( NULL == code ) {+        globals = PyDict_New();+        locals  = PyDict_New();+        code    = Py_CompileString("None", "<interactive>", Py_eval_input);+    }+    // None is immortal. No need to decrement counter+    PyEval_EvalCode(code, globals, locals);+    PyErr_Clear();+}+++// ================================================================+// inline_python module+// ================================================================++PyObject* (*inline_py_haskell_error_repr)(void*);+PyObject* (*inline_py_haskell_error_tyrepr)(void*);++PyObject* inline_py_AsyncCancelled() {+    static PyObject* AsyncCancelled = 0;+    if( AsyncCancelled == 0 ) {+        AsyncCancelled = PyErr_NewException("inline_python.AsyncCancelled", PyExc_BaseException, 0);+    }+    return AsyncCancelled;+}++typedef struct {+    PyBaseExceptionObject obj;+    void *exception_stableptr;+} HaskellError;++static void haskell_error_dealloc(PyObject *op) {+    HaskellError *self = (HaskellError*) op;+    hs_free_stable_ptr(self->exception_stableptr);+    Py_TYPE(self)->tp_free(self);+}++static PyObject* haskell_error_repr(PyObject *op) {+    HaskellError *self = (HaskellError*) op;+    PyObject* exc_repr = inline_py_haskell_error_repr(self->exception_stableptr);+    PyObject* exc_ty   = inline_py_haskell_error_tyrepr(self->exception_stableptr);+    PyObject* repr     = PyUnicode_FromFormat("<inline_python.HaskellError: %S: %S>", exc_ty, exc_repr);+    Py_DECREF(exc_repr);+    Py_DECREF(exc_ty);+    return repr;+}++static PyTypeObject HaskellError_Type = {+    PyVarObject_HEAD_INIT(NULL, 0)+    .tp_name      = "inline_python.HaskellError",+    .tp_basicsize = sizeof(HaskellError),+    .tp_flags     = Py_TPFLAGS_DEFAULT | Py_TPFLAGS_DISALLOW_INSTANTIATION,+    .tp_doc       = PyDoc_STR("Wrapper for a haskell exception object"),+    .tp_dealloc   = haskell_error_dealloc,+    .tp_repr      = haskell_error_repr+};+++PyObject* inline_py_HaskellError() {+    static int initialized = 0;+    if( 0 == initialized ) {+        if( PyType_Ready(&HaskellError_Type) != 0) {+            // It should success always and we don't have any reasonable+            // way of handing error.+            exit(1);+        }+        initialized = 1;+    }+    return (PyObject*)&HaskellError_Type;+}++PyObject* inline_py_HaskellError_create(void* exc_ptr) {+    PyTypeObject *base = HaskellError_Type.tp_base;+    PyObject *args     = PyTuple_New(0);+    // Call __new__+    PyObject *obj = base->tp_new(&HaskellError_Type, args, NULL);+    if( !obj ) {+        goto err;+    }+    // Call __init__+    if( 0 != base->tp_init(obj, args, NULL) ) {+        goto err;+    }+    // Set custom fields+    HaskellError* h_err = (HaskellError*)obj;+    h_err->exception_stableptr = exc_ptr;+    Py_DECREF(args);+    return obj;+err:+    Py_DECREF(args);+    return NULL;+}++void* inline_py_HaskellError_get_stableptr(PyObject* err) {+    HaskellError *h_err = (HaskellError*) err;+    return h_err->exception_stableptr;+}++++static PyMethodDef inline_python_methods[] = {+    {NULL, NULL, 0, NULL}+};++static int inline_python_module_exec(PyObject *m) {+    // Initialize module only once+    static int initialized = 0;+    if( initialized ) {+        return 0;+    }+    initialized = 1;+    //+    if (PyModule_AddObjectRef(m, "AsyncCancelled", inline_py_AsyncCancelled()) < 0) {+        return -1;+    }+    //+    HaskellError_Type.tp_base = (PyTypeObject*)PyExc_Exception;+    HaskellError_Type.tp_new  = NULL;+    if (PyModule_AddObjectRef(m, "HaskellError", inline_py_HaskellError()) < 0) {+        return -1;+    }+    return 0;+}++static PyModuleDef_Slot inline_python_module_slots[] = {+    {Py_mod_exec, inline_python_module_exec},+    {0, NULL}+};++static struct PyModuleDef inline_python_module = {+    .m_base    = PyModuleDef_HEAD_INIT,+    .m_name    = "inline_python",+    .m_size    = 0,+    .m_slots   = inline_python_module_slots,+    .m_methods = inline_python_methods,+};++PyMODINIT_FUNC PyInit_inline_python(void)+{+    return PyModuleDef_Init(&inline_python_module);+}

@@ -17,6 +17,8 @@ #define Py_IsFinalizing(x) 0 #endif +// General initialization of internal on C side+void inline_py_initialize(void);   // ================================================================@@ -81,3 +83,53 @@     void*     buf,     size_t    size );++++// ================================================================+// runPyAsync & Async exceptions+// ================================================================++// Force clear error possibly raised by PyThreadState_SetAsyncExc+//+// Ordinary PyErr_Clear doesn't work. One needed python interpreter to+// perform somce work in order to see raised exception.+void inline_py_clear_error(void);++// Initialize thread local storage as used by runPyAsync+void inline_py_init_state(void *stack);++// Delete thread local storage used by runPyAsync+void inline_py_free_state(void);++// Return stable pointer to stack from TLS+void* inline_py_get_state(void);++++// ================================================================+// inline_python module+// ================================================================++// Function pointers to be set from haskell side++// String representation of an exception+extern PyObject* (*inline_py_haskell_error_repr)(void*);+// String representation of exception type+extern PyObject* (*inline_py_haskell_error_tyrepr)(void*);+++PyMODINIT_FUNC PyInit_inline_python(void);++// Obtain type for async exception.+PyObject* inline_py_AsyncCancelled();++// Obtain type for wrapper for haskell exceptions.+PyObject* inline_py_HaskellError();++// Create python object wrapping haskell exception+PyObject* inline_py_HaskellError_create(void* exc_ptr);++// Get StablePtr held by exception. Python object must be of type+// HaskellError+void* inline_py_HaskellError_get_stableptr(PyObject* err);

@@ -1,8 +1,8 @@ Cabal-Version:  3.0-Build-Type:     Simple-+Build-Type:     Custom+                 Name:           inline-python-Version:        0.2.1.0+Version:        0.3.0.0 Synopsis:       Python interpreter embedded into haskell. Description:   This package embeds python interpreter into haskell program and@@ -24,13 +24,25 @@   py/bound-vars.py  Tested-With:-  GHC == 9.2.8   GHC == 9.4.8   GHC == 9.6.7   GHC == 9.8.4   GHC == 9.10.2   GHC == 9.12.2+  GHC == 9.14.1 ++custom-setup+  setup-depends: base          >=4.15 && <5+               , Cabal         >=3.0  && <4+               , Cabal-syntax  >=3.6  && <4+               , process       >=1.6  && <2++flag python3-config+    Description: Use python3-config instead of pkg-config+    Manual:  True+    Default: False+ source-repository head   type:     git   location: http://github.com/Shimuuar/inline-python@@ -55,8 +67,9 @@ ---------------------------------------------------------------- Library   import:            language-  Build-Depends:     base             >=4.14 && <5+  Build-Depends:     base             >=4.15 && <5                    , primitive        >=0.6.2+                   , deepseq          >=1.4                    , vector           >=0.13.2                    , containers       >=0.5                    , process@@ -72,13 +85,18 @@   include-dirs:      include   c-sources:         cbits/python.c   cc-options:        -g -Wall-  pkgconfig-depends: python3-embed >= 3.10+  -- Else we use python3-config in Setup.hs+  if !flag(python3-config)+    pkgconfig-depends: python3-embed >= 3.10   --   Exposed-modules:     Python.Inline+    Python.Inline.Async+    Python.Inline.Eval     Python.Inline.Literal+    Python.Inline.Monad+    Python.Inline.Monad.QQ     Python.Inline.QQ-    Python.Inline.Eval     Python.Inline.Types   Other-modules:     Python.Internal.CAPI@@ -88,53 +106,53 @@     Python.Internal.Types     Python.Internal.Util ------------------------------------------------------------------library test-  import:           language+common tests   Default-Extensions:     QuasiQuotes+  hs-source-dirs:   test   build-depends:    base                   , inline-python                   , tasty                >=1.2                   , tasty-hunit          >=0.10                   , tasty-quickcheck     >=0.10+                  , stm                   , quickcheck-instances >=0.3.33                   , exceptions                   , containers                   , vector                   , bytestring                   , text-  hs-source-dirs:   test-  Exposed-modules:+++-- Running tests using several threads does very good job at finding threading+-- bugs. Especially deadlocks+test-suite inline-python-tests+  import:           language, tests+  type:             exitcode-stdio-1.0+  Ghc-options:      -threaded -rtsopts -with-rtsopts=-N2+  main-is:          exe/main.hs+  Other-modules:     TST.Run     TST.ToPy     TST.FromPy     TST.Callbacks     TST.Roundtrip     TST.Util---- Running tests using several threads does very good job at finding threading--- bugs. Especially deadlocks-test-suite inline-python-tests-  import:           language-  type:             exitcode-stdio-1.0-  Ghc-options:      -threaded -with-rtsopts=-N2-  hs-source-dirs:   test/exe-  main-is:          main.hs-  build-depends:    base-                  , inline-python-                  , inline-python:test-                  , tasty+    TST.Module  test-suite inline-python-tests1-  import:           language+  import:           language, tests   type:             exitcode-stdio-1.0-  hs-source-dirs:   test/exe-  main-is:          main.hs-  build-depends:    base-                  , inline-python-                  , inline-python:test-                  , tasty+  Ghc-options:      -rtsopts+  main-is:          exe/main.hs+  Other-modules:+    TST.Run+    TST.ToPy+    TST.FromPy+    TST.Callbacks+    TST.Roundtrip+    TST.Util+    TST.Module  benchmark pysmall   import:           language

@@ -105,6 +105,7 @@ -- -- Here's list of common problems and solutions and workarounds. --+-- -- 1. __@inline-python@ cannot find libraries__ -- -- @inline-python@ may look for modules in wrong place. Set@@ -112,9 +113,67 @@ -- right way. -- ----- 2. __Linker error in GHCi__+-- 2. __Picking correct python interpreter__ --+-- Python's version @inline-python@ uses is determined by @libpython3@+-- it's linked with. This is decided when package is build. Normally+-- @pkg-config@ is used and this means using whatever distribution is+-- shipping. It's also possible to use @python3-config@ program by+-- specifying manual cabal flag @-fpython3-config@.+--+-- If it's desired that @inline-python@ should use python installed by+-- conda\/uv\/etc @inline-python@ should be built in environment where+-- desired python version is active and use @-fpython3-config@ flag.+-- This could be done by adding following to cabal.project:+--+-- > constraints: inline-python -fpython3-config+--+--+-- 3. __Linker error in GHCi__+-- -- Attempting to import library using C extensions from ghci may--- result in linker failing to find symbols from @libpython@ like--- @PyFloat_Type@ or some other. Only known workaround is to set--- @LD_PRELOAD=/path/to/libpython3.XX.so@ environment variable.+-- result in linker failing to find symbols from @libpython3@ like+-- @PyFloat_Type@ or some other. There are multiples known+-- workarounds. @libpython3.XX.so@ should be one @inline-python@ was+-- built with.+--+-- - export @LD_PRELOAD=\/path\/to\/libpython3.XX.so@ environment variable. This+-- works fine most of the time but it will also impact programs called from+-- your repl (e.g. using 'process').+--+-- - you can load the relevant symbol only in the current process space using+-- +-- > System.Posix.DynamicLinker.dlopen "/path/to/libpython3.XX.so" [System.Posix.DynamicLinker.RTLD_NOW, System.Posix.DynamicLinker.RTLD_GLOBAL]+--+-- Note that in ghci, you don't need to explicitly import+-- "System.Posix.DynamicLinker" to run this command. If you use this+-- extensively in your project, it is recommended to add that in your+-- @.ghci@, global or local, either as an unconditionally executed+-- command, or as a macro, such as:+--+-- > :def setupPythonDLL \_ -> "" <$ System.Posix.DynamicLinker.dlopen "path/to//lib/libpython3.so" [System.Posix.DynamicLinker.RTLD_NOW, System.Posix.DynamicLinker.RTLD_GLOBAL]@+--+-- 4. __GHCi reload__+--+-- Even if you reload ghci (using @:reload@), the python environment stays+-- initialised. As a result, the python modules imported using 'Python.Inline.QQ.pymain' won't+-- be reloaded, which is often source of confusion.+--+-- You can use python's @importlib.reload(m)@. For example:+--+-- >+-- >         [pymain|+-- >           import json+-- >           import importlib+-- >           import pandas+-- >           import mylib+-- >+-- >           # This force reloads mylib+-- >           importlib.reload(mylib)+-- >       |]+-- +--+-- Note that there is a performance drawback, the side effects of 'import' are+-- redone and python does not give much guarantee about what is happening here.+-- Use it with caution. We recommend using @importlib.reload@ only during+-- development and not in production.

@@ -0,0 +1,22 @@+-- |+-- Asynchronous computation using python. Its API is modelled after+-- @async@ package. It evaluates python on separate OS thread so it's+-- more heavyweight than 'Python.Inline.runPy'. But it's possible to+-- properly interrupt running computation with 'cancelPy' or to use+-- 'withPyAsync' to ensure that async computation properly terminated.+--+-- Since arbitrary IO is available either in @Py@ via @liftIO@ or in+-- haskell callbacks from python code. It's possible to use haskell+-- concurrency primitives to communicate with python thread.+module Python.Inline.Async+  ( PyAsync+  , PyAsyncCancelled(..)+  , runPyAsync+  , withPyAsync+  , waitPy+  , waitPyCatch+  , cancelPy+  , uninterruptibleCancelPy+  ) where++import Python.Internal.Eval

@@ -1,5 +1,6 @@-{-# LANGUAGE QuasiQuotes     #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE TemplateHaskell   #-} -- | -- Interface to python's @eval@ and @exec@ which gives programmer -- control over local and global variables.@@ -7,8 +8,11 @@   ( -- * Python execution     eval   , exec+  , evalPyFunction+  , createModule     -- * Source code   , PyQuote(..)+  , PyQuoteFun(..)   , Code   , codeFromText   , codeFromString@@ -22,8 +26,9 @@   , Module(..)   ) where -import Data.ByteString.Unsafe     qualified as BS+import Data.ByteString            qualified as BS import Data.Text                  (Text)+import Data.Text                  qualified as T import Data.Text.Encoding         qualified as T import Language.C.Inline          qualified as C import Language.C.Inline.Unsafe   qualified as CU@@ -33,7 +38,6 @@ import Python.Internal.Program import Python.Inline.Literal - ---------------------------------------------------------------- C.context (C.baseCtx <> pyCtx) C.include "<inline-python.h>"@@ -46,7 +50,7 @@   -> a    -- ^ Variable value   -> DictBinder bindVar name a = DictBinder $ \p_dict -> runProgram $ do-  p_key <- progIOBracket $ BS.unsafeUseAsCString (T.encodeUtf8 name)+  p_key <- progIOBracket $ BS.useAsCString (T.encodeUtf8 name)   p_obj <- takeOwnership =<< progPy (throwOnNULL =<< basicToPy a)   progPy $ do     r <- Py [CU.block| int {@@ -56,4 +60,26 @@     case r of       0 -> pure ()       _ -> mustThrowPyError+++-- | Create python module from given quote. This function creates new+--   module using @importlib@ machinery and executes quote in context+--   of this module.+createModule+  :: Text+  -> PyQuote+  -> Py Module+createModule name quote = do+  -- It would be nice to use quasiquotes but linker chokes on them.+  -- We have to this hard way+  mdl <- Module <$> evalPyFunction Temp PyQuoteFun+    { code   = codeFromText $ T.unlines+        [ "def _inline_python_(name):"+        , "    import types"+        , "    return types.ModuleType(name)"+        ]+    , binder = bindVar "name" name+    }+  mdl <$ exec mdl mdl quote+ 

@@ -14,6 +14,8 @@   , fromPy'   ) where +import Control.Concurrent+import Control.Concurrent.STM import Control.Exception           (evaluate) import Control.Monad import Control.Monad.Catch@@ -44,6 +46,7 @@ import Foreign.Ptr import Foreign.C.Types import Foreign.Storable+import Foreign.StablePtr import Foreign.Marshal.Alloc     (alloca,mallocBytes) import Foreign.Marshal.Utils     (copyBytes) import GHC.Float                 (float2Double, double2Float)@@ -357,7 +360,7 @@       -1 -> do         neg <- takeOwnership            <=< progPy-             $ throwOnNULL =<< Py [CU.exp| PyObject* { PyNumber_Negative( $(PyObject *p) ) } |]+             $ throwOnNULL =<< Py [C.exp| PyObject* { PyNumber_Negative( $(PyObject *p) ) } |]         BA.ByteArray ba <- progIO $ decodePositiveInteger neg         pure $ GHC.Num.Integer.IN ba       -- Unreachable@@ -449,7 +452,7 @@ -- | Uses python's truthiness conventions instance FromPy Bool where   basicFromPy p = do-    r <- Py [CU.exp| int { PyObject_IsTrue($(PyObject* p)) } |]+    r <- Py [C.exp| int { PyObject_IsTrue($(PyObject* p)) } |]     checkThrowPyError     pure $! r /= 0 @@ -465,7 +468,7 @@   basicFromPy p_tup = runProgram $ do     -- Unpack 2-tuple.     p_args    <- withPyAllocaArray 2-    unpack_ok <- progIO [CU.exp| int {+    unpack_ok <- progIO [C.exp| int {       inline_py_unpack_iterable($(PyObject *p_tup), 2, $(PyObject **p_args))       }|]     progPy $ do checkThrowPyError@@ -490,7 +493,7 @@   basicFromPy p_tup = runProgram $ do     -- Unpack 3-tuple.     p_args    <- withPyAllocaArray 3-    unpack_ok <- progIO [CU.exp| int {+    unpack_ok <- progIO [C.exp| int {       inline_py_unpack_iterable($(PyObject *p_tup), 3, $(PyObject **p_args))       }|]     progPy $ do checkThrowPyError@@ -518,7 +521,7 @@   basicFromPy p_tup = runProgram $ do     -- Unpack 3-tuple.     p_args    <- withPyAllocaArray 4-    unpack_ok <- progIO [CU.exp| int {+    unpack_ok <- progIO [C.exp| int {       inline_py_unpack_iterable($(PyObject *p_tup), 4, $(PyObject **p_args))       }|]     progPy $ do checkThrowPyError@@ -558,7 +561,7 @@ -- | Will accept any iterable instance (FromPy a) => FromPy [a] where   basicFromPy p_list = do-    p_iter <- Py [CU.block| PyObject* {+    p_iter <- Py [C.block| PyObject* {       PyObject* iter = PyObject_GetIter( $(PyObject *p_list) );       if( PyErr_Occurred() ) {           PyErr_Clear();@@ -604,7 +607,7 @@             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+              p_v  -> Py [C.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@@ -615,7 +618,7 @@                  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+                  v <- Py [C.exp| PyObject* { PyDict_GetItem($(PyObject* p_dct), $(PyObject *p)) }|] >>= \case                     NULL -> throwM BadPyType                     p_v  -> basicFromPy p_v                   pure $! Map.insert k v m)@@ -671,19 +674,20 @@ 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)) } |]+  len <- Py [C.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+    Py [C.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)+{-# INLINE vectorToPy #-} vectorToPy vec = runProgram $ do   p_list <- takeOwnership =<< checkNull (Py [CU.exp| PyObject* { PyList_New($(long long n_c)) } |])   progPy $ do@@ -924,8 +928,28 @@  -- | Execute haskell callback function pyCallback :: Program (Ptr PyObject) (Ptr PyObject) -> IO (Ptr PyObject)-pyCallback io = callbackEnsurePyLock $ unsafeRunPy $ ensureGIL $ runProgram io `catch` convertHaskell2Py+pyCallback io+  = mask_+  $ withCallbackStack+  $ unsafeRunPy+  $ ensureGIL+  $ runProgram io `catch` convertHaskell2Py +withCallbackStack :: IO a -> IO a+withCallbackStack = bracket ini fini . const where+  ini = [CU.exp| void* { inline_py_get_state() } |] >>= \case+    NULL -> return NULL+    ptr  -> do+      tid   <- myThreadId+      stack <- deRefStablePtr $ castPtrToStablePtr ptr+      atomically $ modifyTVar' stack (tid:)+      return ptr+  fini NULL = return ()+  fini ptr  = do+    stack <- deRefStablePtr $ castPtrToStablePtr ptr+    atomically $ modifyTVar' stack (drop 1)++ -- | Load argument from python object for haskell evaluation loadArg   :: FromPy a@@ -940,7 +964,7 @@     Left  OutOfRange -> oops     Left  e          -> throwM e     where-      oops = Py [CU.block| PyObject* {+      oops = Py [C.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);@@ -959,7 +983,7 @@   loadArg p i tot  raiseBadNArgs :: CInt -> Int64 -> Py (Ptr PyObject)-raiseBadNArgs expected got = Py [CU.block| PyObject* {+raiseBadNArgs expected got = Py [C.block| PyObject* {   char err[256];   sprintf(err, "Function takes exactly %i arguments (%li given)", $(int expected), $(int64_t got));   PyErr_SetString(PyExc_TypeError, err);

@@ -0,0 +1,76 @@+-- |+module Python.Inline.Monad+  ( -- * Type classes+    Namespace(..)+  , MonadPy(..)+  , evalM+  , execM+  , evalPyFunctionM+  ) where++import Python.Internal.Eval+import Python.Internal.Types++-- | Monad which can carry dictionaries or object of global and local+--   python variables around. It's expected that it's some variant of+--   wrapper around 'Py'.+--+--   For @Py@ global variables are 'Main' and local are 'Temp'+--+--  @since 0.3+class Monad m => MonadPy m where+  -- | Lift @Py@ computation into given monad.+  liftPy :: Py a -> m a+  -- | Provide set of global variables. CPS style is used to avoid+  --   specifying type of global used by monad (and allow picking it+  --   at runtime).+  withGlobals+    :: (forall globals. Namespace globals => globals -> m a)+    -> m a+  -- | Same for local variables+  withLocals+    :: (forall locals. Namespace locals => locals -> m a)+    -> m a++instance MonadPy Py where+  liftPy = id+  withGlobals f = f Main+  withLocals  f = f Temp+++-- | Analog of 'eval' which uses globals and locals carried by 'MonadPy'+--+--  @since 0.3+evalM+  :: (MonadPy m)+  => PyQuote -- ^ Source code+  -> m PyObject+evalM q =+  withGlobals  $ \globals ->+    withLocals $ \locals  ->+      liftPy $ eval globals locals q++-- | Analog of 'exec' which uses globals and locals carried by+--  'MonadPy'+--+--  @since 0.3+execM+  :: (MonadPy m)+  => PyQuote -- ^ Source code+  -> m ()+execM q =+  withGlobals  $ \globals ->+    withLocals $ \locals  ->+      liftPy $ exec globals locals q++-- | Analog of 'evalPyFunction' which uses globals and locals carried by+--  'MonadPy'.+--+--  @since 0.3+evalPyFunctionM+  :: (MonadPy m)+  => PyQuoteFun -- ^ Source code+  -> m PyObject+evalPyFunctionM q =+  withGlobals $ \globals ->+    liftPy $ evalPyFunction globals q

@@ -0,0 +1,94 @@+{-# LANGUAGE TemplateHaskell #-}+-- |+-- These quasiquotes are analogous to ones defined in+-- "Python.Inline.QQ" but they produce splices which are polymorphic+-- in 'MonadPy'. For 'Py' in particular they behave identically. +module Python.Inline.Monad.QQ+  ( -- * Evalution in @Py@ monad+    pymain+  , py_+  , pye+  , pyf+    -- * Creation of @PyQuote@+  , pycode+  , pyfun+  , pySource+  ) where+++import Language.Haskell.TH.Quote++import Python.Internal.EvalQQ+import Python.Internal.Eval+import Python.Inline.Monad+import Python.Inline.QQ (pycode, pyfun, pySource)++++-- | Evaluate sequence of python statements. It uses python's @exec@.+--   Both global and local scope for this quasiquoter are global+--   variables for 'MonadPy'+--+--   It creates value of type @MonadPy m => m ()@+pymain :: QuasiQuoter+pymain = QuasiQuoter+  { quoteExp  = \txt -> [|+     withGlobals $ \globals -> +       liftPy $ exec globals globals $(expQQ Exec txt)+     |]+  , quotePat  = error "quotePat"+  , quoteType = error "quoteType"+  , quoteDec  = error "quoteDec"+  }++-- | Evaluate sequence of python statements. Global and local+--   variables for this quasiquoter are determined by 'MonadPy'+--   instance.+--+--   It creates value of type @MonadPy m => m ()@+py_ :: QuasiQuoter+py_ = QuasiQuoter+  { quoteExp  = \txt -> [|+      withGlobals $ \globals ->+        withLocals $ \locals -> +          liftPy $ exec globals locals $(expQQ Exec txt)+      |]+  , quotePat  = error "quotePat"+  , quoteType = error "quoteType"+  , quoteDec  = error "quoteDec"+  }++-- | Evaluate single python expression. It only accepts single+--   expressions same as python's @eval@. Its globals are variables+--   are determined by 'MonadPy' instance.+--+--   This quote creates object of type @MonadPy m => m PyObject@+pye :: QuasiQuoter+pye = QuasiQuoter+  { quoteExp  = \txt -> [|+      withGlobals $ \globals ->+        withLocals $ \locals -> +          liftPy $ eval globals locals $(expQQ Eval txt)+      |]+  , quotePat  = error "quotePat"+  , quoteType = error "quoteType"+  , quoteDec  = error "quoteDec"+  }++-- | Another quasiquoter which works around that sequence of python+--   statements doesn't have any value associated with it. Content of+--   quasiquote is function body. So to get value out of it one must+--   call return. Its globals are determined by 'MonadPy' instance. +--   Just like python function it always creates new scope.+--+--   This quote creates object of type @Py PyObject@+pyf :: QuasiQuoter+pyf = QuasiQuoter+  { quoteExp  = \txt -> [|+      withGlobals $ \globals ->+        liftPy $ evalPyFunction globals $(expQQ Fun txt)+      |]+  , quotePat  = error "quotePat"+  , quoteType = error "quoteType"+  , quoteDec  = error "quoteDec"+  }

@@ -30,25 +30,38 @@ -- >         do_that() -- >         |] ----- If control over python's global and local variables is--- required. APIs from "Python.Inline.Eval" should be used instead.+--+-- == Variable scope+--+-- Python has two copes: global and local variables. Both are simply+-- @dict[str,Any]@. Quasiquoters use different dictionaries for+-- globals and locals. If tighter control over variables scope is+-- required APIs from "Python.Inline.Eval" should be used instead. module Python.Inline.QQ-  ( pymain+  ( -- * Evalution in @Py@ monad+    pymain   , py_   , pye   , pyf+    -- * Creation of @PyQuote@+    -- $PyQuote   , pycode+  , pyfun+  , pySource   ) where  import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax qualified as TH  import Python.Internal.EvalQQ import Python.Internal.Eval+import Python.Internal.Types  --- | Evaluate sequence of python statements. It works in the same way---   as python's @exec@. All module imports and all variables defined---   in this quasiquote will be visible to later quotes.+-- | Evaluate sequence of python statements. It uses python's @exec@.+--   Both global and local scope for this quasiquoter are variables of+--   @\__main__@ module. Any variables including imported modules will+--   remain visible to later quasiquotes. -- --   It creates value of type @Py ()@ pymain :: QuasiQuoter@@ -59,9 +72,11 @@   , quoteDec  = error "quoteDec"   } --- | Evaluate sequence of python statements. All module imports and---   all variables defined in this quasiquote will be discarded and---   won't be visible in later quotes.+-- | Evaluate sequence of python statements. Global variables for this+--   quasiquoter are one defined in @\__main__@ module and locals use+--   newly allocated dictionary. It will be discarded after execution+--   so variables defined in this quasiquote are visible only inside+--   of it. -- --   It creates value of type @Py ()@ py_ :: QuasiQuoter@@ -73,7 +88,8 @@   }  -- | Evaluate single python expression. It only accepts single---   expressions same as python's @eval@.+--   expressions same as python's @eval@. Its globals are variables in+--   @\__main__@ module and locals are new dictionary same as in @py_@. -- --   This quote creates object of type @Py PyObject@ pye :: QuasiQuoter@@ -85,21 +101,30 @@   }  -- | Another quasiquoter which works around that sequence of python---   statements doesn't have any value associated with it.  Content of+--   statements doesn't have any value associated with it. Content of --   quasiquote is function body. So to get value out of it one must---   call return+--   call return. Its globals are variables in @\__main__@ module and+--   locals are new dictionary same as in @py_@.+--+--   This quote creates object of type @Py PyObject@ pyf :: QuasiQuoter pyf = QuasiQuoter-  { quoteExp  = \txt -> [| evaluatorPyf $(expQQ Fun txt) |]+  { quoteExp  = \txt -> [| evalPyFunction Main $(expQQ Fun txt) |]   , quotePat  = error "quotePat"   , quoteType = error "quoteType"   , quoteDec  = error "quoteDec"   } --- | Create quote of python code suitable for use with---   'Python.Inline.Eval.exec'+-- $PyQuote -----   It creates value of type @PyQuote@+-- 'PyQuote' wraps python code and bould haskell variables. It could+-- be evaluated using 'Python.Inline.Eval.exec',+-- 'Python.Inline.Eval.eval', 'Python.Inline.Eval.evalPyFunction'.+++-- | Create quote of python code. It captures haskell variables in the+--   same way as rest of quasiquotes and creates value of type+--   'Python.Inline.Eval.PyQuote'. -- --   @since 0.2@ pycode :: QuasiQuoter@@ -109,3 +134,30 @@   , quoteType = error "quoteType"   , quoteDec  = error "quoteDec"   }++-- | Create quote of python code suitable for use with+--   'Python.Inline.Eval.exec'+--+--   It creates value of type @PyQuoteFun@+--+--   @since 0.3@+pyfun :: QuasiQuoter+pyfun = QuasiQuoter+  { quoteExp  = \txt -> expQQ Fun txt+  , quotePat  = error "quotePat"+  , quoteType = error "quoteType"+  , quoteDec  = error "quoteDec"+  }++-- | Create value of type 'PyQuote' from file. Created quote doesn't+--   capture any variables.+--+--   @since 0.3+pySource :: FilePath -> TH.Q TH.Exp+pySource path = do+  TH.addDependentFile path+  [| PyQuote+     ($(TH.lift =<< TH.runIO (codeFromString <$> readFile path)))+     mempty+   |]+

@@ -4,6 +4,7 @@ -- Thin wrappers over C API module Python.Internal.CAPI   ( decref+  , xdecref   , incref     -- * Simple wrappers   , basicNewDict@@ -27,8 +28,11 @@   decref :: Ptr PyObject -> Py ()-decref p = Py [CU.exp| void { Py_DECREF($(PyObject* p)) } |]+decref p = Py [C.exp| void { Py_DECREF($(PyObject* p)) } |] +xdecref :: Ptr PyObject -> Py ()+xdecref p = Py [C.exp| void { Py_XDECREF($(PyObject* p)) } |]+ incref :: Ptr PyObject -> Py () incref p = Py [CU.exp| void { Py_INCREF($(PyObject* p)) } |] @@ -39,7 +43,7 @@ basicNewSet = Py [CU.exp| PyObject* { PySet_New(NULL) } |]  basicGetIter :: Ptr PyObject -> Py (Ptr PyObject)-basicGetIter p = Py [CU.exp| PyObject* { PyObject_GetIter( $(PyObject *p)) } |]+basicGetIter p = Py [C.exp| PyObject* { PyObject_GetIter( $(PyObject *p)) } |]  basicIterNext :: Ptr PyObject -> Py (Ptr PyObject) basicIterNext p = Py [C.exp| PyObject* { PyIter_Next($(PyObject* p)) } |]@@ -50,7 +54,7 @@   :: Ptr PyObject -- ^ Function object   -> Ptr PyObject -- ^ Keywords. Must be dictionary   -> Py (Ptr PyObject)-basicCallKwdOnly fun kwd = Py [CU.block| PyObject* {+basicCallKwdOnly fun kwd = Py [C.block| PyObject* {   PyObject* args = PyTuple_Pack(0);   PyObject* res  = PyObject_Call($(PyObject *fun), args, $(PyObject *kwd));   Py_DECREF(args);

@@ -2,12 +2,12 @@ {-# LANGUAGE QuasiQuotes               #-} {-# LANGUAGE RecordWildCards           #-} {-# LANGUAGE TemplateHaskell           #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- | -- Evaluation of python expressions. module Python.Internal.Eval   ( -- * Locks     ensurePyLock-  , callbackEnsurePyLock     -- * Initialization   , initializePython   , finalizePython@@ -16,6 +16,15 @@   , runPy   , runPyInMain   , unsafeRunPy+    -- ** Async+  , PyAsync+  , PyAsyncCancelled(..)+  , waitPy+  , waitPyCatch+  , cancelPy+  , uninterruptibleCancelPy+  , runPyAsync+  , withPyAsync     -- * GC-related   , newPyObject     -- * C-API wrappers@@ -40,13 +49,15 @@   , unsafeWithCode   , eval   , exec+  , evalPyFunction     -- * Debugging   , debugPrintPy   ) where  import Control.Concurrent import Control.Concurrent.STM-import Control.Exception         (interruptible)+import Control.Exception         (interruptible,evaluate)+import Control.DeepSeq import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class@@ -54,11 +65,12 @@ import Data.Maybe import Data.Function import Data.ByteString.Unsafe    qualified as BS+import Data.Typeable import Foreign.Concurrent        qualified as GHC import Foreign.Ptr import Foreign.ForeignPtr+import Foreign.StablePtr import Foreign.C.Types-import Foreign.C.String import Foreign.Marshal.Array import Foreign.Storable import System.Environment@@ -96,37 +108,43 @@ -- Haskell has two runtimes. Single threaded one doesn't cause any -- troubles and won't be discussed further. Multithreaded one -- implement N-M threading and schedules N green thread on M OS--- threads as it see fit.------ One could think that running python code in bound threads and--- making sure that GIL is held would suffice. It doesn't. Doing so--- would quickly results in deadlock. Exact reason for that is not--- understood.------ Another problem is GHC may schedule two threads each running python--- code on same capability. They won't have any problems taking GIL--- and will run concurrently stepping on each other's toes.+-- threads as GHC RTS sees fit. ----- Only way to solve this problem is to introduce another lock on--- haskell side. It's visible to haskell RTS so we won't get deadlocks--- and it makes sure that only one haskell thread interacts with--- python at a time.+-- Runtime may migrate haskell threads between OS threads freely so+-- consecutive calls to python may happen in different threads. This+-- doesn't seem to cause problems so far. In similar way several+-- threads may interleave calls to python in single OS+-- thread. Hopefully it won't cause problems either. --+-- Pre 0.3 version had a global lock allowing only single runPy to+-- execute at any time. --+-- For uses where serious concurrency is required runPyAsync machinery+-- should be used. See NOTE [Py Async] for details.++++-- NOTE: [Main thread]+-- ~~~~~~~~~~~~~~~~~~~ -- -- Also python designate thread in which python interpreter was -- initialized as a main thread. It has special status for example--- some libraries may run only in main thread (e.g. tkinter). But if--- we don't take special precautions we won't know which thread it--- is.---+-- some libraries may run only in main thread (e.g. tkinter). In+-- single threaded runtime everything is simple: we one only one+-- thread anyway. --+-- In multithreaded one we start dedicated thread using forkOS and use+-- standard tools for interacting with it. This requires asynchrony+-- and all complications that come with it. ----- There's of course question how well python threading interacts with--- haskell. No one knows, probably it won't work well.+-- Execution is protected by haskell mutex. Only one thread can+-- evaluate code at time. This is critical for preserving correctness+-- for cancelling main thread. While we hold lock no one else can+-- perform operations with main thread.   + -- NOTE: [GC] -- ~~~~~~~~~~ --@@ -149,23 +167,49 @@ -- NOTE: [Interrupting python] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ ----- Being able to interrupt python when haskell exception arrives is--- surely nice. However it's difficult and comes with tradeoffs.+-- Interrupting program that mixes python and haskell code is in fact+-- very difficult. ----- First of all call must be done in a separate thread otherwise--- there's no one to catch exception and to something. This also means--- that python calls made using plain FFI are not interruptible.+--  + Haskell code cannot receive exceptions while in foreign call. ----- In addition python's ability to notify other threads are limited:+--  + Haskell callback from python created new lightweight+--    thread. Thus we cannot interrupt callback thread since we need+--    to know its thread ID. -- --  + `Py_SetInterrupt` plain doesn't work. It uses signal which trips --    up haskell RTS as well. -----  + `PyThreadState_SetAsyncExc` could be use but it requires special---    setup from thread being interrupted.+--  + `PyThreadState_SetAsyncExc` uses OS thread id (or something+--    similar) as a key. So we must execute code in a bound thread and+--    be sure that no other haskell thread (except callbacks) uses it.+--+-- Together this means it's only possible to interrupt python when+-- it's called in dedicated OS thread. Such as created by `runPyAsync`+-- or in main thread. To do this we need thread ID as used by python.+--+-- To interrupt haskell, whether thread we spawned or any callback+-- we'll have to maintain stack of thread IDs somehow. Obvoiusly+-- such stack has to be done by callback.+--+-- And even if we do have stack we can't reliably interrupt callbacks+-- due to asynchrony. We may look at stack just before callbacks TID+-- is pushed onto it. In that case we'll try interrupt parent+-- thread. Or we can use its value just before TID is popped. In that+-- case we'll interrupt thread that's about to stop or stopped+-- already.+--+-- So it seems only way of dealing with this problem is to try to kill+-- thread on top of stack and whenever new thread appear on top of+-- stack. +--+--+-- As for runPy it seems there's simply no way to forcefully interrupt+-- computation. So it's not interruptible.   ++ ---------------------------------------------------------------- -- Lock and global state ----------------------------------------------------------------@@ -184,15 +228,17 @@   = NotInitialized     -- ^ Initialization is not done. Initial state.   | InInitialization-    -- ^ Interpreter is being initialized.+    -- ^ Interpreter is being initialized. This state is required in+    --   case initialization is started from different threads.   | InitFailed     -- ^ Initialization was attempted but failed for whatever reason.   | Running1     -- ^ Interpreter is running. We're using single threaded RTS   | RunningN !(Chan (Ptr PyObject))              !(MVar EvalReq)-             !ThreadId-             !ThreadId+             !ThreadId   -- Haskell ID of main thread+             !PyThreadId -- Python ID of main thread+             !ThreadId   -- GC thread ID     -- ^ Interpreter is running. We're using multithreaded RTS   | InFinalization     -- ^ Interpreter is being finalized.@@ -211,68 +257,39 @@ data PyLock   = LockUninialized     -- ^ There's no interpreter and lock does not exist.-  | LockUnlocked-    -- ^ Lock could be taked-  | Locked !ThreadId [ThreadId]-    -- ^ Python is locked by given thread. Lock could be taken multiple-    --   times-  | LockedByGC-    -- ^ Python is locked by GC thread.+  | LockReady !(TVar Int) !(TMVar ())+    -- ^ Interpreter is properly initialized and we track number of+    --   threads running python. Same thread may take lock multiple+    --   times: e.g. nested runPy.+    --+    --   Second parameter is mutex for main. We allow only single+    --   request in flight.   | LockFinalized     -- ^ Python interpreter shut down. Taking lock is not possible-  deriving Show  -- | Execute code ensuring that python lock is held by current thread. ensurePyLock :: IO a -> IO a-ensurePyLock action = do-  tid <- myThreadId-  bracket_ (atomically $ acquireLock tid)-           (atomically $ releaseLock tid)-           action---- | Retake lock regardless of thread which hold lock. Lock must be---   already taken. Caller must make sure that thread holding lock is---   block for duration of action.------   This is very unsafe. It must be used only in callbacks from---   python to haskell-callbackEnsurePyLock :: IO a -> IO a-callbackEnsurePyLock action = do-  tid <- myThreadId-  bracket_ (atomically $ grabLock tid)-           (atomically $ releaseLock tid)-           action-+ensurePyLock = bracket_+  (atomically acquireLock)+  (atomically releaseLock) -acquireLock :: ThreadId -> STM ()-acquireLock tid = readTVar globalPyLock >>= \case+acquireLock :: STM ()+acquireLock = readTVar globalPyLock >>= \case   LockUninialized -> throwSTM PythonNotInitialized   LockFinalized   -> throwSTM PythonIsFinalized-  LockedByGC      -> retry-  LockUnlocked    -> writeTVar globalPyLock $ Locked tid []-  Locked t xs-    | t == tid  -> writeTVar globalPyLock $ Locked t (t : xs)-    | otherwise -> retry+  LockReady n _   -> modifyTVar' n succ -grabLock :: ThreadId -> STM ()-grabLock tid = readTVar globalPyLock >>= \case+releaseLock :: STM ()+releaseLock = readTVar globalPyLock >>= \case   LockUninialized -> throwSTM PythonNotInitialized   LockFinalized   -> throwSTM PythonIsFinalized-  LockedByGC      -> retry-  LockUnlocked    -> writeTVar globalPyLock $ Locked tid []-  Locked t xs     -> writeTVar globalPyLock $ Locked tid (t : xs)+  LockReady n _   -> modifyTVar' n pred -releaseLock :: ThreadId -> STM ()-releaseLock tid = readTVar globalPyLock >>= \case-  LockUninialized -> throwSTM PythonNotInitialized-  LockFinalized   -> throwSTM PythonIsFinalized-  LockUnlocked    -> throwSTM $ PyInternalError "releaseLock: releasing LockUnlocked"-  LockedByGC      -> throwSTM $ PyInternalError "releaseLock: releasing LockedByGC"-  Locked t xs-    | t /= tid  -> throwSTM $ PyInternalError "releaseLock: releasing  wrong lock"-    | otherwise -> writeTVar globalPyLock $! case xs of-        []    -> LockUnlocked-        t':ts -> Locked t' ts+ensureInit :: IO ()+ensureInit = readTVarIO globalPyLock >>= \case+  LockUninialized -> throwM PythonNotInitialized+  LockFinalized   -> throwM PythonIsFinalized+  LockReady{}     -> pure ()   @@ -286,8 +303,8 @@ initializePython :: IO () -- See NOTE: [Python and threading] initializePython = [CU.exp| int { Py_IsInitialized() } |] >>= \case-  0 | rtsSupportsBoundThreads -> runInBoundThread $ doInializePython-    | otherwise               -> doInializePython+  0 | rtsSupportsBoundThreads -> runInBoundThread $ doInitializePython+    | otherwise               -> doInitializePython   _ -> pure ()  -- | Destroy python interpreter.@@ -304,7 +321,7 @@     Py_Finalize();     } |]   -- We need to call Py_Finalize on main thread-  RunningN _ lock_eval _ tid_gc -> checkLock $ do+  RunningN _ lock_eval _ _ tid_gc -> checkLock $ do     killThread tid_gc     resp <- newEmptyMVar     putMVar lock_eval $ StopReq resp@@ -313,12 +330,11 @@     checkLock action = readTVar globalPyLock >>= \case       LockUninialized -> throwSTM $ PyInternalError "finalizePython LockUninialized"       LockFinalized   -> throwSTM $ PyInternalError "finalizePython LockFinalized"-      Locked{}        -> retry-      LockedByGC      -> retry-      LockUnlocked    -> do-        writeTVar globalPyLock  LockFinalized-        writeTVar globalPyState Finalized-        pure action+      LockReady n _   -> readTVar n >>= \case+        0 -> do writeTVar globalPyLock  LockFinalized+                writeTVar globalPyState Finalized+                pure action+        _ -> retry  -- | Bracket which ensures that action is executed with properly --   initialized interpreter@@ -326,8 +342,8 @@ withPython = bracket_ initializePython finalizePython  -doInializePython :: IO ()-doInializePython = do+doInitializePython :: IO ()+doInitializePython = do   -- First we need to grab global python lock on haskell side   join $ atomically $ do     readTVar globalPyState >>= \case@@ -340,8 +356,10 @@       NotInitialized   -> do         writeTVar globalPyState InInitialization         let fini st = atomically $ do+              n         <- newTVar 0+              main_lock <- newTMVar ()               writeTVar globalPyState $ st-              writeTVar globalPyLock  $ LockUnlocked+              writeTVar globalPyLock  $ LockReady n main_lock         pure $           (mask_ $ if             -- On multithreaded runtime create bound thread to make@@ -351,56 +369,69 @@                 lock_eval <- newEmptyMVar                 -- Main thread                 tid_main <- forkOS $ mainThread lock_init lock_eval-                takeMVar lock_init >>= \case-                  True  -> pure ()-                  False -> throwM PyInitializationFailed+                tid_py   <- takeMVar lock_init >>= \case+                  Just tid -> pure tid+                  Nothing  -> throwM PyInitializationFailed                 -- GC thread                 gc_chan <- newChan                 tid_gc  <- forkOS $ gcThread gc_chan-                fini $ RunningN gc_chan lock_eval tid_main tid_gc+                fini $ RunningN gc_chan lock_eval tid_main tid_py tid_gc             -- Nothing special is needed on single threaded RTS             | otherwise -> do-                doInializePythonIO >>= \case+                doInitializePythonIO >>= \case                   True  -> pure ()                   False -> throwM PyInitializationFailed                 fini Running1           ) `onException` atomically (writeTVar globalPyState InitFailed)  -- This action is executed on python's main thread-mainThread :: MVar Bool -> MVar EvalReq -> IO ()+mainThread :: MVar (Maybe PyThreadId) -> MVar EvalReq -> IO () mainThread lock_init lock_eval = do-  r_init <- doInializePythonIO-  putMVar lock_init r_init-  case r_init of-    False -> pure ()-    True  -> mask_ $ fix $ \loop ->-      (takeMVar lock_eval `catch` (\InterruptMain -> pure HereWeGoAgain)) >>= \case-        EvalReq py resp -> do-          res <- (Right <$> runPy py) `catch` (pure . Left)-          putMVar resp res-          loop-        StopReq resp -> do-          [C.block| void {-            PyGILState_Ensure();-            Py_Finalize();-            } |]-          putMVar resp ()-        HereWeGoAgain -> loop+  doInitializePythonIO >>= \case+    False -> putMVar lock_init Nothing+    True  -> do+      putMVar lock_init . Just =<< getPyThreadID+      mask_ $ fix $ \loop -> do+        -- Here we discard any late PyAsyncCancelled exceptions+        (takeMVar lock_eval `catch` (\PyAsyncCancelled -> pure HereWeGoAgain)) >>= \case+          EvalReq py resp alive tid_stack -> do+            let action = withAsyncInitTLS tid_stack $ unsafeRunPy $ ensureGIL $ do+                  -- We must clear any error python indication. It+                  -- could be leftover from interrupting previous+                  -- evaluation+                  Py $ [CU.exp| void { inline_py_clear_error() } |]+                  Py $ putMVar alive True+                  py+            res <- try action+              `finally` uninterruptibleMask_ (modifyMVar_ alive (\_ -> pure False))+            putMVar resp res+            loop+          StopReq resp -> do+            [C.block| void {+              PyGILState_Ensure();+              inline_py_clear_error();+              Py_Finalize();+              } |]+            putMVar resp ()+          HereWeGoAgain -> loop  -doInializePythonIO :: IO Bool-doInializePythonIO = do+doInitializePythonIO :: IO Bool+doInitializePythonIO = do   -- FIXME: I'd like more direct access to argv   argv0 <- getProgName   argv  <- getArgs   let n_argv = fromIntegral $ length argv + 1-  -- FIXME: For some reason sys.argv is initialized incorrectly. No-  --        easy way to debug. Will do for now+  hask_err_repr   <- wrapReprFromStablePtr haskellErrorRepr+  hask_err_tyrepr <- wrapReprFromStablePtr haskellErrorTyRepr   r <- evalContT $ do     p_argv0  <- ContT $ withWCString argv0     p_argv   <- traverse (ContT . withWCString) argv     ptr_argv <- ContT $ withArray (p_argv0 : p_argv)     liftIO [C.block| int {+      // Set global constants+      inline_py_haskell_error_repr   = $(PyObject* (*hask_err_repr)(void*));+      inline_py_haskell_error_tyrepr = $(PyObject* (*hask_err_tyrepr)(void*));       // Now fill config       PyStatus status;       PyConfig cfg;@@ -420,12 +451,31 @@       if( PyStatus_Exception(status) ) {           goto error;       };+      // Make builting module visible to python+      PyImport_AppendInittab("inline_python", PyInit_inline_python);       // Initialize interpreter       status = Py_InitializeFromConfig(&cfg);       if( PyStatus_Exception(status) ) {           goto error;       };       PyConfig_Clear(&cfg);+      // This is hack for python<=3.11.+      //+      // Somehow we may end up in stet where thread ID of main thread is not equal+      // to main thread's one. Importing threading seems to fix it. However exact+      // reason for such behavior is unknown+      if( PY_MINOR_VERSION <= 11 ) {+          PyObject *threading = PyImport_ImportModule("threading");+          if( PyErr_Occurred() ) {+              PyErr_Clear();+          }+      }+      // Initialize internals. We also need to import module with our internals+      inline_py_initialize();+      PyObject *inline_python = PyImport_ImportModule("inline_python");+      if( PyErr_Occurred() ) {+          PyErr_Clear();+      }       // Release GIL so other threads may take it       PyEval_SaveThread();       return 0;@@ -436,23 +486,54 @@       } |]   return $! r == 0 +haskellErrorRepr :: Ptr () -> IO (Ptr PyObject)+haskellErrorRepr ptr = unsafeRunPy $ runProgram $ do+  SomeException err <- progIO $ deRefStablePtr $ castPtrToStablePtr ptr+  -- We need to make sure that we evaluated string so that we won't+  -- leak exceptions+  repr  <- progIO $ evaluate $ force $ show err+  p_str <- withPyWCString repr+  progIO [CU.exp| PyObject* { PyUnicode_FromWideChar($(wchar_t *p_str), -1) } |] +haskellErrorTyRepr :: Ptr () -> IO (Ptr PyObject)+haskellErrorTyRepr ptr = unsafeRunPy $ runProgram $ do+  SomeException err <- progIO $ deRefStablePtr $ castPtrToStablePtr ptr+  -- We need to make sure that we evaluated string so that we won't+  -- leak exceptions+  repr  <- progIO $ evaluate $ force $ show $ typeOf err+  p_str <- withPyWCString repr+  progIO [CU.exp| PyObject* { PyUnicode_FromWideChar($(wchar_t *p_str), -1) } |]++type FunWrapper a = a -> IO (FunPtr a)++foreign import ccall "wrapper" wrapReprFromStablePtr+  :: FunWrapper (Ptr () -> IO (Ptr PyObject))+++ ---------------------------------------------------------------- -- Running Py monad ---------------------------------------------------------------- +-- | Request that we send to main thread data EvalReq-  = forall a. EvalReq (Py a) (MVar (Either SomeException a))+  = forall a. EvalReq (Py a) (MVar (Either SomeException a)) (MVar Bool) (TVar [ThreadId])+    -- ^ Request to run code in main thread   | StopReq (MVar ())+    -- ^ Stop evaluation   | HereWeGoAgain+    -- ^ Dummy request. Do nothing -data InterruptMain = InterruptMain-  deriving stock    Show-  deriving anyclass Exception --- | Execute python action. It will take and hold global lock while---   code is executed. Python exceptions raised during execution are---   converted to haskell exception 'PyError'.+-- | Execute python action. This is simplest executor with lowest+--   overhead but it comes with several caveats. When thread executes+--   python code it could not be interrupted since it's in foreign+--   call. Use 'runPyAsync' if you need ability to interrupt. Also+--   python uses GIL so only one thread can evaluate python code at+--   time.+--+--   Python exceptions raised during execution are converted to+--   haskell exception 'PyError'. runPy :: Py a -> IO a -- See NOTE: [Python and threading] runPy py@@ -463,67 +544,245 @@     -- it wasn't. Better than segfault isn't it?     go = ensurePyLock $ mask_ $ unsafeRunPy (ensureGIL py) --- | Same as 'runPy' but will make sure that code is run in python's---   main thread. It's thread in which python's interpreter was---   initialized. Some python's libraries may need that. It has higher---   call overhead compared to 'runPy'.++-- | This function executes python code on python's main thread. It's+--   OS thread in which interpreter was initialized and it has some+--   special status in python. Some libraries could only work when+--   called from main thread. It has higher call overhead compared to+--   'runPy' and only one haskell thread could be executing something+--   on main thread at time.+--+--   When executing on threaded runtime this function could be+--   interrupted by asynchronous exceptions. runPyInMain :: Py a -> IO a--- See NOTE: [Python and threading]+-- See NOTE: [Python and threading, Main thread] runPyInMain py   -- Multithreaded RTS   | rtsSupportsBoundThreads = do-      tid <- myThreadId-      bracket (acquireMain tid) fst snd+      py_tid <- getPyThreadID+      bracket (acquireMain py_tid) fst snd   -- Single-threaded RTS   | otherwise = runPy py   where-    acquireMain tid = atomically $ readTVar globalPyState >>= \case+    acquireMain py_tid = atomically $ readTVar globalPyState >>= \case       NotInitialized   -> throwSTM PythonNotInitialized       InitFailed       -> throwSTM PyInitializationFailed       Finalized        -> throwSTM PythonIsFinalized       InInitialization -> retry       InFinalization   -> retry       Running1         -> throwSTM $ PyInternalError "runPyInMain: Running1"-      RunningN _ eval_lock tid_main _ -> readTVar globalPyLock >>= \case+      RunningN _ eval_lock tid_main tid_main_py _ -> readTVar globalPyLock >>= \case         LockUninialized -> throwSTM PythonNotInitialized         LockFinalized   -> throwSTM PythonIsFinalized-        LockedByGC      -> retry-        -- We need to send closure to main python thread when we're grabbing lock.-        LockUnlocked    -> do-          writeTVar globalPyLock $ Locked tid_main []-          pure ( atomically (releaseLock tid_main)-               , evalInOtherThread tid_main eval_lock-               )-        -- If we513 can grab lock and main thread taken lock we're-        -- already executing on main thread. We can simply execute code-        Locked t ts-          | t /= tid-            -> retry-          | t == tid_main || (tid_main `elem` ts) -> do-              writeTVar globalPyLock $ Locked t (t : ts)-              pure ( atomically (releaseLock t)-                   , unsafeRunPy $ ensureGIL py-                   )+        LockReady _ main_lock+          -- We're on main thread. We can just run computation and not+          -- bother with incrementing thread counter. It's already+          -- incremented in outer scope+          | py_tid == tid_main_py -> pure ( pure ()+                                          , unsafeRunPy $ ensureGIL py+                                          )+          -- Otherwise we need to send closure to main thread for evaluation.+          -- We use mutex to make sure that only single request is executed           | otherwise -> do-              writeTVar globalPyLock $ Locked tid_main (t : ts)-              pure ( atomically (releaseLock tid_main)-                   , evalInOtherThread tid_main eval_lock+              takeTMVar main_lock+              acquireLock+              pure ( atomically (releaseLock >> putTMVar main_lock ())+                   , evalInOtherThread tid_main tid_main_py eval_lock                    )     ---    evalInOtherThread tid_main eval_lock = do-      r <- mask_ $ do resp <- newEmptyMVar-                      putMVar eval_lock $ EvalReq py resp-                      takeMVar resp `onException` throwTo tid_main InterruptMain+    evalInOtherThread tid_main tid_main_py eval_lock = do+      r <- mask_ $ do+        resp      <- newEmptyMVar+        alive     <- newEmptyMVar+        tid_stack <- newTVarIO []+        putMVar eval_lock $ EvalReq py resp alive tid_stack+        takeMVar resp `onException` cancelPy PyAsync+          { asyncTID      = tid_main+          , asyncTidStack = tid_stack+          , asyncPyTID    = pure tid_main_py+          , asyncAlive    = alive+          , asyncWait     = retry -- Not used by cancelPy+          }       either throwM pure r - -- | Execute python action. This function is unsafe and should be only --   called in thread of interpreter. unsafeRunPy :: Py a -> IO a unsafeRunPy (Py io) = io  +----------------------------------------------------------------+-- Async running+---------------------------------------------------------------- +-- NOTE: [Py Async]+-- ~~~~~~~~~~~~~~~~+--+-- In order to run python threads concurrently and to be able to+-- cancel them we need to run python in dedicated thread. See NOTE+-- [Interrupting python] for details.+--+-- `forkOS` seems to provide such functionality although it's not+-- documented explicitly. It allows to provide async-inspired API for+-- interacting with python thread.+--+-- Most complicated part of API is interrupting python. [Interrupting+-- python] gives high level overview. Here more technical details:+--+--  + PyThreadState_SetAsyncExc doesn't queue exception. So it very+--    well may be noop if it finds no such thread. We have to repeat+--    interrupting python.+--+--  + forkOS may reuse OS thread. So we must not attempt interrupt if+--    thread is dead already.+++-- | Exception thrown to a thread doing async python computation. On+--   python side it corresponds to+--   @inline_python.AsyncCancelled@. Latter is automatically converted+--   to @PyAsyncCancelled@.+--+-- @since 0.3+data PyAsyncCancelled = PyAsyncCancelled+  deriving (Show, Eq)++instance Exception PyAsyncCancelled++-- | Handle to asynchronous python computation spawned by+--   'runPyAsync'. It's performed on separate OS thread. Use+--   'waitPy'\/'waitPyCatch' to obtain computation result.+--+-- @since 0.3+data PyAsync a = PyAsync+  { asyncTID      :: !ThreadId          -- Thread ID+  , asyncTidStack :: !(TVar [ThreadId]) -- Stack of callback thread ID+  , asyncPyTID    :: !(IO PyThreadId)   -- Thread ID used by python+  , asyncAlive    :: !(MVar Bool)       -- Holds True while thread is alive+  , asyncWait     :: STM (Either SomeException a)+  }++-- | Wait for result of asynchronous computation. If it threw an+--   exception it will be rethrown by @wait@.+--+-- @since 0.3+waitPy :: PyAsync a -> STM a+waitPy a = either throwSTM pure =<< a.asyncWait++-- | Wait for result of asynchronous computation. Exception thrown by+--   it will be returned as @Left@.+--+-- @since 0.3+waitPyCatch :: PyAsync a -> STM (Either SomeException a)+waitPyCatch = (.asyncWait)++-- | Execute python computation on dedicated OS thread.+--+-- @since 0.3+runPyAsync :: Py a -> IO (PyAsync a)+runPyAsync py = do+  ensureInit+  result    <- newEmptyTMVarIO+  tid_stack <- newTVarIO []+  py_tid_mv <- newEmptyMVar+  alive     <- newEmptyMVar+  -- Worker thread. We must modify liveliness MVar under+  -- uninterruptibleMask otherwise it could be interrupted and+  -- cancelPy will consider thread alive forever+  --+  -- We also clear dangling async python exception in case we have+  -- leftover from previous evaluation+  tid    <- forkOS $ mask_ $+    (do putMVar py_tid_mv =<< getPyThreadID+        a <- try+           $ withAsyncInitTLS tid_stack+           $ ensurePyLock+           $ unsafeRunPy+           $ ensureGIL $ do Py [CU.exp| void { inline_py_clear_error() } |]+                            Py $ putMVar alive True+                            py+        atomically $ putTMVar result a+    ) `finally` uninterruptibleMask_ (modifyMVar_ alive (\_ -> pure False))+  pure PyAsync+    { asyncTID      = tid+    , asyncTidStack = tid_stack+    , asyncPyTID    = readMVar py_tid_mv+    , asyncWait     = takeTMVar result+    , asyncAlive    = alive+    }++-- Initialize thread local storage for thread created by runPyAsync+withAsyncInitTLS :: TVar [ThreadId] -> IO a -> IO a+withAsyncInitTLS stack = bracket ini fini . const+  where+    ini = do+      s_ptr <- newStablePtr stack+      let ptr = castStablePtrToPtr s_ptr+      [CU.exp| void { inline_py_init_state($(void* ptr)) } |]+      pure s_ptr+    fini s_ptr = do+      [CU.exp| void { inline_py_free_state() } |]+      freeStablePtr s_ptr++++-- | Cancel execution of asynchronous computation. It throws+--   'PyAsyncCancelled' to haskell threads including any haskell+--   callbacks from python. Python will interrupted by asynchronously+--   raising @inline_python.AsyncCancelled@.+--+--   Note that python code generally is not written under assumption+--   that it could be smitten with exception at an absolutely any+--   moment. It could cause problems.+--+-- @since 0.3+cancelPy :: PyAsync a -> IO ()+cancelPy PyAsync{asyncTID=tid, asyncTidStack, asyncPyTID, asyncAlive} = do+  -- See NOTE: [Py Async], [Interrupting python]+  PyThreadId py_tid <- asyncPyTID+  -- Interrupting python. We must attempt interrupting only as long as+  -- async thread is alive. Else we may end up interrupting wrong+  -- thread.+  _ <- forkIO $ fix $ \loop -> do+    n <- withMVar asyncAlive $ \case+      False -> return 1+      True  -> [C.block| int {+        int gil = PyGILState_Ensure();+        int n   = PyThreadState_SetAsyncExc($(uint64_t py_tid), inline_py_AsyncCancelled());+        PyGILState_Release(gil);+        return n;+        }|]+    case n of+      0 -> do+        threadDelay 50 -- Avoid hammering interrupt too hard+        loop+      _ -> return ()+  -- Interrupting callbacks. We repeatedly try to kill every callbacks+  -- that appears on top of stack. It seems to be only working way.+  tid_kill_cb <- forkIO $ flip fix Nothing $ \loop t_old -> do+    t <- atomically $ readTVar asyncTidStack >>= \case+      []                    -> retry+      t:_ | Just t == t_old -> retry+          | otherwise       -> pure t+    _ <- forkIO $ throwTo t PyAsyncCancelled+    loop $ Just t+  -- Interrupt haskell+  throwTo tid PyAsyncCancelled+  killThread tid_kill_cb++-- | Variant of 'cancel' which isn't interruptible.+--+-- @since 0.3+uninterruptibleCancelPy :: PyAsync a -> IO ()+uninterruptibleCancelPy = uninterruptibleMask_ . cancelPy++-- | Create new OS thread and execute python code on it. Will use+--   'uninterruptibleCancel' after callback finishes execution.+--+-- @since 0.3+withPyAsync :: Py a -> (PyAsync a -> IO b) -> IO b+withPyAsync py = bracket (runPyAsync py) uninterruptibleCancelPy++ ---------------------------------------------------------------- -- GC-related functions ----------------------------------------------------------------@@ -535,9 +794,9 @@   fptr <- newForeignPtr_ p   GHC.addForeignPtrFinalizer fptr $     readTVarIO globalPyState >>= \case-      RunningN ch _ _ _  -> writeChan ch p-      Running1           -> singleThreadedDecrefCG p-      _                  -> pure ()+      RunningN ch _ _ _ _  -> writeChan ch p+      Running1             -> singleThreadedDecrefCG p+      _                    -> pure ()   pure $ PyObject fptr  -- | Thread doing garbage collection for python object in@@ -550,23 +809,19 @@ decrefGC p = join $ atomically $ readTVar globalPyLock >>= \case   LockUninialized -> pure $ pure ()   LockFinalized   -> pure $ pure ()-  LockedByGC      -> pure $ pure ()-  Locked{}        -> retry-  LockUnlocked    -> do-    writeTVar globalPyLock LockedByGC+  LockReady n _   -> do+    modifyTVar' n succ     pure $ do-      gcDecref p `finally` atomically (writeTVar globalPyLock LockUnlocked)+      gcDecref p `finally` atomically (modifyTVar' n pred)  singleThreadedDecrefCG :: Ptr PyObject -> IO () singleThreadedDecrefCG p = readTVarIO globalPyLock >>= \case   LockUninialized -> pure ()   LockFinalized   -> pure ()-  LockedByGC      -> gcDecref p-  Locked{}        -> gcDecref p-  LockUnlocked    -> gcDecref p+  LockReady{}     -> gcDecref p  gcDecref :: Ptr PyObject -> IO ()-gcDecref p = [CU.block| void {+gcDecref p = [C.block| void {   PyGILState_STATE st = PyGILState_Ensure();   Py_XDECREF( $(PyObject* p) );   PyGILState_Release(st);@@ -583,7 +838,7 @@   -- NOTE: We're cheating here and looking behind the veil.   --       PyGILState_STATE is defined as enum. Let hope it will stay   --       this way.-  gil_state <- Py [CU.exp| int { PyGILState_Ensure() } |]+  gil_state <- Py [C.exp| int { PyGILState_Ensure() } |]   action `finally` Py [CU.exp| void { PyGILState_Release($(int gil_state)) } |]  -- | Drop GIL temporarily@@ -594,9 +849,16 @@   --       this way.   st <- Py [CU.exp| PyThreadState* { PyEval_SaveThread() } |]   Py $ interruptible action-        `finally` [CU.exp| void { PyEval_RestoreThread($(PyThreadState *st)) } |]+        `finally` [C.exp| void { PyEval_RestoreThread($(PyThreadState *st)) } |]  +-- | Removes exception masking and releases GIL temporarily+instance MonadIO Py where+  liftIO = dropGIL . interruptible++getPyThreadID :: IO PyThreadId+getPyThreadID = PyThreadId <$> [CU.exp| uint64_t { PyThread_get_thread_ident() } |]+ ---------------------------------------------------------------- -- Conversion of exceptions ----------------------------------------------------------------@@ -605,35 +867,50 @@ --   NULL. convertHaskell2Py :: SomeException -> Py (Ptr PyObject) convertHaskell2Py err = Py $ do-  withCString ("Haskell exception: "++show err) $ \p_err -> do-    [CU.block| PyObject* {-      PyErr_SetString(PyExc_RuntimeError, $(char *p_err));-      return NULL;-      } |]+  s_ptr <- newStablePtr err+  let ptr = castStablePtrToPtr s_ptr+  [C.block| PyObject* {+    PyObject* exc = inline_py_HaskellError_create($(void* ptr));+    PyErr_SetObject(inline_py_HaskellError(), exc);+    Py_DECREF(exc);+    return NULL;+    } |]  -- | Convert python exception to haskell exception. Should only be --   called if there's unhandled python exception. Clears exception.-convertPy2Haskell :: Py PyException+convertPy2Haskell :: Py SomeException convertPy2Haskell = runProgram $ do   p_errors <- withPyAllocaArray @(Ptr PyObject) 3-  -- Fetch error indicator-  (p_type, p_value) <- progIO $ do-    [CU.block| void {-       PyObject **p = $(PyObject** p_errors);-       PyErr_Fetch(p, p+1, p+2);-       }|]-    p_type  <- peekElemOff p_errors 0-    p_value <- peekElemOff p_errors 1-    -- Traceback is not used ATM-    pure (p_type,p_value)-  -- Convert exception type and value to strings.+  -- Fetch error information+  progIO [CU.block| void {+    PyObject **p = $(PyObject** p_errors);+    PyErr_Fetch(p, p+1, p+2);+    }|]+  -- Fetch exception type.+  --+  -- NOTE: When we set exception using PyThreadState_SetAsyncExc this+  --       field remains NULL on python<=3.11. Thus we must use xdecref+  p_type  <- progPyBracket $ (Py $ peekElemOff p_errors 0) `bracket` decref+  p_value <- progPyBracket $ (Py $ peekElemOff p_errors 1) `bracket` xdecref+  _trace  <- progPyBracket $ (Py $ peekElemOff p_errors 2) `bracket` xdecref+  -- Should we convert to PyAsyncCancelled?+  ty_async_cancelled <- progIO [CU.exp| PyObject* { inline_py_AsyncCancelled() } |]+  when (p_type == ty_async_cancelled) $ do+    abort $ SomeException PyAsyncCancelled+  -- Should we convert to haskell exception?+  ty_hask_err <- progIO [CU.exp| PyObject* { inline_py_HaskellError() } |]+  when (p_type == ty_hask_err) $ do+    s_ptr <- progIO [CU.exp| void* { inline_py_HaskellError_get_stableptr($(PyObject* p_value)) } |]+    err   <- progIO $ deRefStablePtr $ castPtrToStablePtr s_ptr+    abort err+  -- Convert any other python exception   progPy $ do     s_type  <- pyobjectStrAsHask p_type     s_value <- pyobjectStrAsHask p_value     incref p_value     exc     <- newPyObject p_value     let bad_str = "__str__ call failed"-    pure $ PyException+    pure $ SomeException $ PyError $ PyException       { ty        = fromMaybe bad_str s_type       , str       = fromMaybe bad_str s_value       , exception = exc@@ -644,7 +921,7 @@ checkThrowPyError =   Py [CU.exp| PyObject* { PyErr_Occurred() } |] >>= \case     NULL -> pure ()-    _    -> throwM . PyError =<< convertPy2Haskell+    _    -> throwM =<< convertPy2Haskell  -- | Throw python error as haskell exception if it's raised. If it's --   not that internal error. Another exception will be raised@@ -652,7 +929,7 @@ mustThrowPyError =   Py [CU.exp| PyObject* { PyErr_Occurred() } |] >>= \case     NULL -> error $ "mustThrowPyError: no python exception raised."-    _    -> throwM . PyError =<< convertPy2Haskell+    _    -> throwM =<< convertPy2Haskell  -- | Calls mustThrowPyError if pointer is null or returns it unchanged throwOnNULL :: Ptr PyObject -> Py (Ptr PyObject)@@ -696,7 +973,7 @@  instance Namespace Main where   basicNamespaceDict _ =-    throwOnNULL =<< Py [CU.block| PyObject* {+    throwOnNULL =<< Py [C.block| PyObject* {       PyObject* main_module = PyImport_AddModule("__main__");       if( PyErr_Occurred() )           return NULL;@@ -743,7 +1020,7 @@  instance Namespace ModulePtr where   basicNamespaceDict (ModulePtr p) = do-    throwOnNULL =<< Py [CU.block| PyObject* {+    throwOnNULL =<< Py [C.block| PyObject* {       PyObject* dict = PyModule_GetDict($(PyObject* p));       Py_XINCREF(dict);       return dict;@@ -820,6 +1097,35 @@ {-# SPECIALIZE exec :: Main -> Main -> PyQuote -> Py () #-} {-# SPECIALIZE exec :: Main -> Temp -> PyQuote -> Py () #-} +-- | Evaluate code as if it's a function body and bound arguments are+--   parameters to that function. Just like function it could return+--   value and always creates new scope.+--+-- @since 0.3+evalPyFunction+  :: Namespace global+  => global     -- ^ Global variables+  -> PyQuoteFun -- ^ Source code+  -> Py PyObject+evalPyFunction globals (PyQuoteFun code binder) = runProgram $ do+  p_locals <- takeOwnership =<< progPy basicNewDict+  p_kwargs <- takeOwnership =<< progPy basicNewDict+  progPy $ do+    -- Create function in p_locals+    exec globals (DictPtr p_locals) (PyQuote code mempty)+    -- Look up function+    p_fun <- getFunctionObject p_locals >>= \case+      NULL -> throwM $ PyInternalError "_inline_python_ must be present"+      p    -> pure p+    -- Call python function we just constructed+    binder.bind p_kwargs+    newPyObject =<< throwOnNULL =<< basicCallKwdOnly p_fun p_kwargs++getFunctionObject :: Ptr PyObject -> Py (Ptr PyObject)+getFunctionObject p_dict = do+  Py [CU.exp| PyObject* { PyDict_GetItemString($(PyObject *p_dict), "_inline_python_") } |]++ -- | Obtain pointer to code unsafeWithCode :: Code -> Program r (Ptr CChar) unsafeWithCode (Code bs) = Program $ ContT $ \fun ->@@ -831,7 +1137,7 @@ ----------------------------------------------------------------  debugPrintPy :: Ptr PyObject -> Py ()-debugPrintPy p = Py [CU.block| void {+debugPrintPy p = Py [C.block| void {   PyObject_Print($(PyObject *p), stdout, 0);   printf(" [REF=%li]\n", Py_REFCNT($(PyObject *p)) );   } |]

@@ -2,16 +2,12 @@ {-# LANGUAGE TemplateHaskell #-} -- | module Python.Internal.EvalQQ-  ( -- * Evaluators and QQ-    evaluatorPyf-    -- * Code generation-  , expQQ+  ( -- * Code generation+    expQQ   , Mode(..)   ) where  import Control.Monad.IO.Class-import Control.Monad.Catch-import Control.Monad.Trans.Cont (ContT(..)) import Data.Bits import Data.Char import Data.List                 (intercalate)@@ -32,7 +28,6 @@ import Python.Internal.Types import Python.Internal.Program import Python.Internal.Eval-import Python.Internal.CAPI import Python.Inline.Literal  @@ -42,12 +37,16 @@ ----------------------------------------------------------------  -- | Python's variable name encoded using UTF-8. It exists in order to---   avoid working with @String@ at runtime.+--   avoid working with @String@ at runtime. Bytestring should be NULL+--   terminated manually newtype PyVarName = PyVarName BS.ByteString   deriving stock (Show, TH.Lift) +-- | PyVarName is being consumed using 'BS.unsafeUseAsCString' which+--   doesn't NULL terminate underlying buffer and python's C API+--   require it. We have to add terminator ourselves varName :: String -> PyVarName-varName = PyVarName . T.encodeUtf8 . T.pack+varName nm = PyVarName $ flip BS.snoc 0 $ T.encodeUtf8 (T.pack nm)  unsafeWithPyVarName :: PyVarName -> Program r (Ptr CChar) unsafeWithPyVarName (PyVarName bs)@@ -70,31 +69,6 @@   ------------------------------------------------------------------- Evaluators-------------------------------------------------------------------evaluatorPyf :: PyQuote -> Py PyObject-evaluatorPyf (PyQuote code binder) = runProgram $ do-  p_locals <- takeOwnership =<< progPy basicNewDict-  p_kwargs <- takeOwnership =<< progPy basicNewDict-  progPy $ do-    -- Create function in p_locals-    exec Main (DictPtr p_locals) (PyQuote code mempty)-    -- Look up function-    p_fun <- getFunctionObject p_locals >>= \case-      NULL -> throwM $ PyInternalError "_inline_python_ must be present"-      p    -> pure p-    -- Call python function we just constructed-    binder.bind p_kwargs-    newPyObject =<< throwOnNULL =<< basicCallKwdOnly p_fun p_kwargs--getFunctionObject :: Ptr PyObject -> Py (Ptr PyObject)-getFunctionObject p_dict = do-  Py [CU.exp| PyObject* { PyDict_GetItemString($(PyObject *p_dict), "_inline_python_") } |]-------------------------------------------------------------------- -- TH generator ---------------------------------------------------------------- @@ -116,8 +90,7 @@       -> TH.Q TH.Exp expQQ mode qq_src = do   -- We need to preprocess before passing it to python.-  let src     = prepareSource       mode qq_src-      src_var = prepareForVarLookup mode src+  let src = prepareSource mode qq_src   antis  <- liftIO $ do     -- We've embedded script into library and we need to pass source     -- code of QQ to a script. It can contain whatever symbols so to@@ -133,7 +106,7 @@                 , "decode_and_print('" <>                   concat [ [ intToDigit $ fromIntegral (w `shiftR` 4)                            , intToDigit $ fromIntegral (w .&. 15) ]-                         | w <- BS.unpack $ T.encodeUtf8 $ T.pack src_var+                         | w <- BS.unpack $ T.encodeUtf8 $ T.pack src                          ]                   <> "')"                 ]@@ -145,9 +118,10 @@              ]       src_eval = prepareForEval mode antis src   ---  [| PyQuote ($(TH.lift $ codeFromString src_eval))-             (mconcat $(TH.listE args))-   |]+  case mode of+    Eval -> [| PyQuote    ($(TH.lift $ codeFromString src_eval)) (mconcat $(TH.listE args)) |]+    Exec -> [| PyQuote    ($(TH.lift $ codeFromString src_eval)) (mconcat $(TH.listE args)) |]+    Fun  -> [| PyQuoteFun ($(TH.lift $ codeFromString src_eval)) (mconcat $(TH.listE args)) |]   antiSuffix :: String@@ -167,12 +141,6 @@   Eval -> dropWhile isSpace   Exec -> unindent   Fun  -> unindent--prepareForVarLookup :: Mode -> String -> String-prepareForVarLookup = \case-  Eval -> id-  Exec -> id-  Fun  -> ("def __dummy__():\n"++) . indent  prepareForEval :: Mode -> [String] -> String -> String prepareForEval mode vars src = case mode of

@@ -6,6 +6,7 @@   , runProgram   , progPy   , progIO+  , progPyBracket   , progIOBracket     -- * Control flow   , abort@@ -38,7 +39,6 @@ import Foreign.Storable  import Language.C.Inline          qualified as C-import Language.C.Inline.Unsafe   qualified as CU  import Python.Internal.Types import Python.Internal.Util@@ -68,6 +68,9 @@ progIOBracket :: ((a -> IO r) -> IO r) -> Program r a progIOBracket = coerce +progPyBracket :: ((a -> Py r) -> Py r) -> Program r a+progPyBracket = coerce+ -- | Early exit from continuation monad. abort :: r -> Program r a abort r = Program $ ContT $ \_ -> pure r@@ -131,14 +134,14 @@ --   string. Returns Nothing if exception was raisede pyobjectStrAsHask :: Ptr PyObject -> Py (Maybe String) pyobjectStrAsHask p_obj = runProgram $ do-  p_str <- takeOwnership <=< abortOnNull Nothing $ Py [CU.block| PyObject* {+  p_str <- takeOwnership <=< abortOnNull Nothing $ Py [C.block| PyObject* {     PyObject *s = PyObject_Str($(PyObject *p_obj));     if( PyErr_Occurred() ) {         PyErr_Clear();     }     return s;     } |]-  c_str <- abortOnNull Nothing $ Py [CU.block| const char* {+  c_str <- abortOnNull Nothing $ Py [C.block| const char* {     const char* s = PyUnicode_AsUTF8($(PyObject *p_str));     if( PyErr_Occurred() ) {         PyErr_Clear();

@@ -15,10 +15,12 @@   , PyError(..)   , PyException(..)   , PyInternalError(..)+  , PyThreadId(..)   , Py(..)   , pyIO     -- ** Python code wrappers   , PyQuote(..)+  , PyQuoteFun(..)   , Code(..)   , codeFromText   , codeFromString@@ -34,13 +36,14 @@   , pattern TRUE   ) where -import Control.Monad.IO.Class import Control.Monad.Catch import Control.Monad.Primitive (PrimMonad(..),RealWorld)-import Control.Exception import Data.Coerce import Data.Int+import Data.Word import Data.ByteString             qualified as BS+import Data.ByteString.Lazy        qualified as BL+import Data.ByteString.Builder     qualified as BB import Data.Map.Strict             qualified as Map import Data.Text                   qualified as T import Data.Text.Encoding          qualified as T@@ -120,16 +123,17 @@ pyIO :: IO a -> Py a pyIO = Py --- | Removes exception masking-instance MonadIO Py where-  liftIO = Py . interruptible- instance PrimMonad Py where   type PrimState Py = RealWorld   primitive = Py . primitive   {-# INLINE primitive #-}  +-- | Identifier of python's thread as python understands them.+newtype PyThreadId = PyThreadId Word64+  deriving stock (Show,Eq,Ord)++ ---------------------------------------------------------------- -- Code wrappers ----------------------------------------------------------------@@ -146,6 +150,18 @@   }  +-- | Quasiquoted body of python function which could be used by+--   'Python.Inline.Eval.evalPyFunction'. Function body must be+--   wrapped in @_inline_python_@ function which quasiquoter+--   'Python.Inline.QQ.pyfun' does automatically.+--+--   @since 0.3@+data PyQuoteFun = PyQuoteFun+  { code   :: !Code+  , binder :: !DictBinder+  }++ -- | UTF-8 encoded python source code. -- --   @since 0.2@@@ -157,7 +173,13 @@ -- --   @since 0.2@ codeFromText :: T.Text -> Code-codeFromText = Code . T.encodeUtf8+-- NOTE: We consume code with BS.useAsCString and python C API expect+--       NULL-terminated string. We have to add terminator manually+codeFromText code+  = Code+  $ BL.toStrict+  $ BB.toLazyByteString+  $ T.encodeUtf8Builder code <> BB.word8 0  -- | Create properly encoded @Code@. This function doesn't check --   syntactic validity.

@@ -1,6 +1,7 @@ -- | module TST.Callbacks (tests) where +import Control.Exception import Test.Tasty import Test.Tasty.HUnit import Python.Inline@@ -68,11 +69,21 @@   , testCase "Haskell exception in callback(arity=1)" $ runPy $ do        let foo :: Int -> IO Int            foo y = pure $ 10 `div` y-       throwsPy [py_| foo_hs(0) |]+       throwsException DivideByZero [py_| foo_hs(0) |]   , testCase "Haskell exception in callback(arity=2)" $ runPy $ do       let foo :: Int -> Int -> IO Int           foo x y = pure $ x `div` y-      throwsPy [py_| foo_hs(1, 0) |]+      throwsException DivideByZero [py_| foo_hs(1, 0) |]+  , testCase "Haskell exception has correct type" $ runPy $ do+       let foo :: Int -> IO Int+           foo y = pure $ 10 `div` y+       [py_|+         import inline_python+         try:+             foo_hs(0)+         except inline_python.HaskellError as e:+             assert repr(e) == "<inline_python.HaskellError: ArithException: divide by zero>", repr(e)+         |]     ----------------------------------------   , testCase "Call python in callback (arity=1)" $ runPy $ do       let foo :: Int -> IO Int

@@ -0,0 +1,44 @@+-- |+module TST.Module where++import Control.Exception+import Data.Typeable+import Test.Tasty+import Test.Tasty.HUnit+import Python.Inline+import Python.Inline.QQ+import Python.Inline.Async++tests :: TestTree+tests = testGroup "Builtin module"+  [ testCase "Module exists" $ runPy [py_| import inline_python |]+  , testCase "Exceptions" $ runPy [py_|+      import inline_python+      assert issubclass(inline_python.AsyncCancelled, BaseException)+      assert not issubclass(inline_python.AsyncCancelled, Exception)++      assert issubclass(inline_python.HaskellError, Exception),     "HaskellError is Exception"+      assert issubclass(inline_python.HaskellError, BaseException), "HaskellError is BaseException"+      |]+    -- We want to check that inline_python types are stable under+    -- reload using importlib.+  , testCase "importlib.reload stable" $ runPy [py_|+      import inline_python+      import importlib+      ty  = inline_python.AsyncCancelled+      err = ty()+      importlib.reload(inline_python)+      assert ty is inline_python.AsyncCancelled+      assert isinstance(err, inline_python.AsyncCancelled)+      |]+  , testCase "AsyncCancelled is converted to PyAsyncCancelled" $ do+    r :: Either SomeException () <- try $ runPy [py_|+      import inline_python+      raise inline_python.AsyncCancelled()+      |]+    case r of+      Right () -> error "No exception"+      Left  (SomeException e)+        | Just PyAsyncCancelled <- cast e -> pure ()+        | otherwise                       -> throwIO e+  ]

@@ -3,26 +3,42 @@ module TST.Run(tests) where  import Control.Concurrent+import Control.Concurrent.STM import Control.Exception import Control.Monad import Control.Monad.IO.Class import Data.Map.Strict        qualified as Map+import Data.Text              qualified as T import Test.Tasty import Test.Tasty.HUnit import Python.Inline import Python.Inline.QQ import Python.Inline.Eval+import Python.Inline.Async import TST.Util  tests :: TestTree tests = testGroup "Run python"   [ testCase "Empty QQ" $ runPy [py_| |]   , testCase "Second init is noop" $ initializePython-  , testCase "Nested runPy" $ runPy $ liftIO $ runPy $ pure ()+  , testRunPy+  , testScope+  , testEvalExec+  , testMonadic+  , testAsync+  ]++-- Test that python evaluation works in general and its interaction+-- with exceptions+testRunPy :: TestTree+testRunPy = testGroup "Running python"+  [ testCase "Nested runPy" $ runPy $ liftIO $ runPy $ pure ()   , testCase "Nested runPyInMain" $ runPyInMain $ liftIO $ runPyInMain $ pure ()   , testCase "runPyInMain" $ runPyInMain $ [py_|       import threading-      assert threading.main_thread() == threading.current_thread()+      tid_main = threading.main_thread()+      tid_our  = threading.current_thread()+      assert tid_main == tid_our, f"TID[main]={tid_main}, TID[our]={tid_our}"       |]   , testCase "Python exceptions are converted (py)"   $ runPy      $ throwsPy    [py_| 1 / 0 |]   , testCase "Python exceptions are converted (std)"  $ throwsPyIO $ runPy       [py_| 1 / 0 |]@@ -31,18 +47,21 @@       throwsPyIO $ runPyInMain [py_| 1 / 0 |]       runPyInMain [py_| assert True |]     -- Here we test that exceptions are really passed to python's thread without running python-  , testCase "Exception in runPyInMain works" $ do+  , testCase "Exception in runPyInMain works hask" $ do       lock <- newEmptyMVar       tid  <- myThreadId-      _    <- forkIO $ takeMVar lock >> throwTo tid Stop+      _    <- forkIO $ takeMVar lock >> threadDelay 1000 >> throwTo tid Stop       handle (\Stop -> pure ())         $ runPyInMain         $ do liftIO $ putMVar lock ()              liftIO $ threadDelay 10_000_000              error "Should be interrupted"-      runPyInMain $ pure ()-  ---  , testCase "Scope pymain->any" $ runPy $ do+  ]++-- Test that different quasiquotes correctly handle scoping+testScope :: TestTree+testScope = testGroup "Python scope"+  [ testCase "Scope pymain->any" $ runPy $ do       [pymain|              x = 12              x@@ -133,7 +152,11 @@         except NameError:             pass         |]-  , testCase "pyf works" $ do+  ]++testEvalExec :: TestTree+testEvalExec = testGroup "eval/exec"+  [ testCase "pyf works" $ do       let x = 12 :: Int       eq (Just (482412::Int)) [pyf|          xs = [i*x_hs for i in [1, 200, 40000]]@@ -164,8 +187,100 @@         assert m_hs.a == 12         assert m_hs.b == 'asd'         |]+  , testCase "evalPyFunction" $ runPy $ do+      let n = 2 :: Int+      x <- fromPy =<< evalPyFunction Temp [pyfun| return 100 * n_hs |]+      liftIO $ Just (200::Int) @=? x+  , testCase "createModule" $ runPy $ do+      m <- createModule (T.pack "foo") [pycode||]+      [py_|+        import types+        assert isinstance(m_hs, types.ModuleType)+        |]   ] +testAsync :: TestTree+testAsync = testGroup "async" $ guardThreaded+  [ -- We can run async computation at all+    testCase "runPyAsync" $ do+      runPy [pymain| dct = {} |]+      a <- runPyAsync $ [py_| dct[1] = 100 |]+      _ <- atomically $ waitPy a+      n <- runPy $ fromPy =<< [pye| dct[1] |]+      assertEqual "x" (Just (100::Int)) n+      runPy [pymain| del dct |]+  , -- Cancellation of python code+    testCase "cancelPy [python]" $ do+      a <- runPyAsync $ forever $ [py_|+        import time+        while True:+            time.sleep(1e-3)+        |]+      d <- registerDelay 100_000+      threadDelay 100 -- Wait to make sure execution actually started+      cancelPy a+      _ <- atomically $ waitPyCatch a `orElse` do readTVar d >>= \case+                                                    True  -> error "Timeout"+                                                    False -> retry+      return ()+  , -- Cancellation of haskell code+    testCase "cancelPy [haskell]" $ do+      a <- runPyAsync $ do+        liftIO $ forever $ threadDelay 1_000_000+      d <- registerDelay 100_000+      threadDelay 100+      cancelPy a+      _ <- atomically $ waitPyCatch a `orElse` do readTVar d >>= \case+                                                    True  -> error "Timeout"+                                                    False -> retry+      return ()+  , -- Cancellation of haskell code+    testCase "cancelPy [callback]" $ do+      a <- runPyAsync $ do+        let loop = forever $ threadDelay 1_000_000 :: IO ()+        forever [py_| loop_hs() |]+      d <- registerDelay 100_000+      threadDelay 100+      _ <- forkIO $ cancelPy a+      _ <- atomically $ waitPyCatch a `orElse` do readTVar d >>= \case+                                                    True  -> error "Timeout"+                                                    False -> retry+      return ()+  , testCase "Exception in runPyInMain works py" $ do+      lock <- newEmptyMVar+      tid  <- myThreadId+      _    <- forkIO $ takeMVar lock >> threadDelay 1000 >> throwTo tid Stop+      handle (\Stop -> pure ())+        $ runPyInMain+        $ do liftIO $ putMVar lock ()+             [py_|+               import time+               while True:+                   time.sleep(1e-3)+               |]+             error "Should be interrupted"+  ]+++-- Here we only test that quasiquotes produce correct code+testMonadic :: TestTree+testMonadic = testGroup "Monadic"+  [ testCase "pymain" $ runPy [pymain| assert True |]+  , testCase "py_"    $ runPy [py_|    assert True |]+  , testCase "pye" $ runPy $ do+      n <- fromPy =<< [pye| 42 |]+      liftIO $ Just (42::Int) @=? n+  , testCase "pyf" $ runPy $ do+      n <- fromPy =<< [pyf| return 42 |]+      liftIO $ Just (42::Int) @=? n+  ]++ data Stop = Stop   deriving stock    Show   deriving anyclass Exception++guardThreaded :: [TestTree] -> [TestTree]+guardThreaded ts+  | rtsSupportsBoundThreads = ts+  | otherwise               = []

@@ -3,6 +3,7 @@  import Control.Monad.IO.Class import Control.Monad.Catch+import Data.Typeable import Test.Tasty.HUnit  import Python.Inline@@ -10,6 +11,12 @@ throwsPy :: Py () -> Py () throwsPy io = (io >> liftIO (assertFailure "Evaluation should raise python exception"))   `catch` (\(_::PyError) -> pure ())++throwsException :: (Exception e, Eq e) => e -> Py () -> Py ()+throwsException e0 io = (io >> liftIO (assertFailure "Evaluation should raise python exception"))+  `catch` (\(SomeException e) -> case cast e of Just e' | e' == e0 -> pure ()+                                                _                  -> throwM e+          )  throwsPyIO :: IO () -> IO () throwsPyIO io = (io >> assertFailure "Evaluation should raise python exception")

@@ -7,6 +7,7 @@ import TST.ToPy import TST.Callbacks import TST.Roundtrip+import TST.Module import Python.Inline  main :: IO ()@@ -16,4 +17,5 @@   , TST.ToPy.tests   , TST.Roundtrip.tests   , TST.Callbacks.tests+  , TST.Module.tests   ]