From b2ea1be356aa26ec732f02603a3793b7bcaa3d69 Mon Sep 17 00:00:00 2001
From: Alexey Khudyakov <alexey.skladnoy@gmail.com>
Date: Thu, 2 Jan 2025 14:56:12 +0300
Subject: [PATCH 1/9] Rename constants

---
 include/inline-python.h       | 10 ++++++----
 src/Python/Internal/EvalQQ.hs | 18 +++++++++---------
 src/Python/Internal/Types.hs  | 18 +++++++++++-------
 3 files changed, 26 insertions(+), 20 deletions(-)

diff --git a/include/inline-python.h b/include/inline-python.h
index a6b8452..26e0d88 100644
--- a/include/inline-python.h
+++ b/include/inline-python.h
@@ -5,12 +5,14 @@
 #include <Rts.h>
 
 
-// Standard status codesu
-#define INLINE_PY_OK          0
-#define INLINE_PY_ERR_COMPILE 1
-#define INLINE_PY_ERR_EVAL    2
+// ----------------------------------------------------------------
+// Standard status codes
 
+#define IPY_OK          0
+#define IPY_ERR_PYTHON  1
+#define IPY_ERR_COMPILE 2
 
+// ----------------------------------------------------------------
 
 // This macro checks for errors. If python exception is raised it
 // clear it and returns 1 otherwise retruns 0
diff --git a/src/Python/Internal/EvalQQ.hs b/src/Python/Internal/EvalQQ.hs
index e2d3aae..5ef1c89 100644
--- a/src/Python/Internal/EvalQQ.hs
+++ b/src/Python/Internal/EvalQQ.hs
@@ -65,7 +65,7 @@ pyEvalInMain p_globals p_locals src = evalContT $ do
     if( code == 0 ){
         PyErr_Fetch( &e_type, &e_value, &e_trace);
         inline_py_export_exception(e_type, e_value, e_trace, $(char** p_err));
-        return INLINE_PY_ERR_COMPILE;
+        return IPY_ERR_COMPILE;
     }
     // Execute in context of main
     PyObject* globals = $(PyObject* p_globals);
@@ -75,9 +75,9 @@ pyEvalInMain p_globals p_locals src = evalContT $ do
     if( PyErr_Occurred() ) {
         PyErr_Fetch( &e_type, &e_value, &e_trace);
         inline_py_export_exception(e_type, e_value, e_trace, $(char** p_err));
-        return INLINE_PY_ERR_EVAL;
+        return IPY_ERR_PYTHON;
     }
-    return INLINE_PY_OK;
+    return IPY_OK;
     } |]
   lift $ finiEval p_err r (pure ())
 
@@ -98,7 +98,7 @@ pyEvalExpr p_env src = evalContT $ do
        if( code == 0 ){
            PyErr_Fetch( &e_type, &e_value, &e_trace);
            inline_py_export_exception(e_type, e_value, e_trace, $(char** p_err));
-           return INLINE_PY_ERR_COMPILE;
+           return IPY_ERR_COMPILE;
        }
        // Execute in context of main
        PyObject* main_module = PyImport_AddModule("__main__");
@@ -109,10 +109,10 @@ pyEvalExpr p_env src = evalContT $ do
        if( PyErr_Occurred() ) {
            PyErr_Fetch( &e_type, &e_value, &e_trace);
            inline_py_export_exception(e_type, e_value, e_trace, $(char** p_err));
-           return INLINE_PY_ERR_EVAL;
+           return IPY_ERR_PYTHON;
        }
        Py_INCREF(r);
-       return INLINE_PY_OK;
+       return IPY_OK;
        }|]
   lift $ finiEval p_err r (newPyObject =<< liftIO (peek p_res))
 
@@ -123,14 +123,14 @@ finiEval
   -> Py a
   -> Py a
 finiEval p_err r fini = case r of
-  INLINE_PY_OK          -> fini
-  INLINE_PY_ERR_COMPILE -> Py $ peek p_err >>= \case
+  IPY_OK          -> fini
+  IPY_ERR_COMPILE -> Py $ peek p_err >>= \case
     p | nullPtr == p -> throwIO $ PyError "Compile error"
       | otherwise    -> do
           s <- peekCString p
           free p
           throwIO $ PyError s
-  INLINE_PY_ERR_EVAL   -> Py $ peek p_err >>= \case
+  IPY_ERR_PYTHON -> Py $ peek p_err >>= \case
       p | nullPtr == p -> throwIO $ PyError "Evaluation error"
         | otherwise    -> do
             s <- peekCString p
diff --git a/src/Python/Internal/Types.hs b/src/Python/Internal/Types.hs
index f79715b..bba5c33 100644
--- a/src/Python/Internal/Types.hs
+++ b/src/Python/Internal/Types.hs
@@ -14,9 +14,9 @@ module Python.Internal.Types
     -- * inline-C
   , pyCtx
     -- * Patterns
-  , pattern INLINE_PY_OK
-  , pattern INLINE_PY_ERR_COMPILE
-  , pattern INLINE_PY_ERR_EVAL
+  , pattern IPY_OK
+  , pattern IPY_ERR_COMPILE
+  , pattern IPY_ERR_PYTHON
   , pattern NULL
   ) where
 
@@ -69,10 +69,14 @@ pyCtx = mempty { ctxTypesTable = Map.fromList tytabs } where
     ]
 
 
-pattern INLINE_PY_OK, INLINE_PY_ERR_COMPILE, INLINE_PY_ERR_EVAL :: CInt
-pattern INLINE_PY_OK          = 0
-pattern INLINE_PY_ERR_COMPILE = 1
-pattern INLINE_PY_ERR_EVAL    = 2
+pattern IPY_OK, IPY_ERR_PYTHON, IPY_ERR_COMPILE :: CInt
+-- | Success
+pattern IPY_OK          = 0
+-- | Python exception raised
+pattern IPY_ERR_PYTHON  = 1
+-- | Error while compiling python source to byte code. Normally it
+--   shouldn't happen.
+pattern IPY_ERR_COMPILE = 2
 
 
 pattern NULL :: Ptr a

From 4aed3490e2305515dc1f6c0cea9fd79535175107 Mon Sep 17 00:00:00 2001
From: Alexey Khudyakov <alexey.skladnoy@gmail.com>
Date: Thu, 2 Jan 2025 15:04:48 +0300
Subject: [PATCH 2/9] Clean up initialization code a bit

---
 src/Python/Internal/Eval.hs | 19 +++++++++++++------
 1 file changed, 13 insertions(+), 6 deletions(-)

diff --git a/src/Python/Internal/Eval.hs b/src/Python/Internal/Eval.hs
index 6013e28..82d4c8d 100644
--- a/src/Python/Internal/Eval.hs
+++ b/src/Python/Internal/Eval.hs
@@ -240,20 +240,27 @@ doInializePython = do
       PyStatus status;
       PyConfig cfg;
       PyConfig_InitPythonConfig( &cfg );
-      //--
-      status = PyConfig_SetBytesString(&cfg, &cfg.program_name, "XX");
-      if (PyStatus_Exception(status)) { goto error; }
       cfg.parse_argv = 0;
-      //--
+      //----------------
+      status = PyConfig_SetBytesString(&cfg, &cfg.program_name, "XX");
+      if( PyStatus_Exception(status) ) {
+          goto error;
+      }
+      //----------------
       status = PyConfig_SetArgv(&cfg,
           $(int       n_argv),
           $(wchar_t** ptr_argv)
       );
-      if( PyStatus_Exception(status) ) { goto error; };
+      if( PyStatus_Exception(status) ) {
+          goto error;
+      };
       // Initialize interpreter
       status = Py_InitializeFromConfig(&cfg);
+      if( PyStatus_Exception(status) ) {
+          goto error;
+      };
       PyConfig_Clear(&cfg);
-      return PyStatus_Exception(status);
+      return 0;
       // Error case
       error:
       PyConfig_Clear(&cfg);

From 84357d6b82b7ffdbb3390c51ed07646421270cb7 Mon Sep 17 00:00:00 2001
From: Alexey Khudyakov <alexey.skladnoy@gmail.com>
Date: Thu, 2 Jan 2025 15:33:57 +0300
Subject: [PATCH 3/9] Add module for Program type synonym

---
 inline-python.cabal            |  5 ++--
 src/Python/Inline/Literal.hs   | 34 ++++++++++-------------
 src/Python/Internal/EvalQQ.hs  |  2 +-
 src/Python/Internal/Program.hs | 51 ++++++++++++++++++++++++++++++++++
 src/Python/Internal/Types.hs   |  8 ++++++
 src/Python/Internal/Util.hs    | 24 ----------------
 6 files changed, 77 insertions(+), 47 deletions(-)
 create mode 100644 src/Python/Internal/Program.hs

diff --git a/inline-python.cabal b/inline-python.cabal
index 933b33d..d546a1d 100644
--- a/inline-python.cabal
+++ b/inline-python.cabal
@@ -66,10 +66,11 @@ Library
     Python.Inline
     Python.Types
   Other-modules:
-    Python.Internal.Types
-    Python.Internal.Util
     Python.Internal.Eval
     Python.Internal.EvalQQ
+    Python.Internal.Program
+    Python.Internal.Types
+    Python.Internal.Util
     Paths_inline_python
   Autogen-modules:
     Paths_inline_python
diff --git a/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs
index adfaf47..720fdbf 100644
--- a/src/Python/Inline/Literal.hs
+++ b/src/Python/Inline/Literal.hs
@@ -29,8 +29,7 @@ import Language.C.Inline.Unsafe  qualified as CU
 import Python.Types
 import Python.Internal.Types
 import Python.Internal.Eval
-import Python.Internal.Util
-
+import Python.Internal.Program
 
 ----------------------------------------------------------------
 C.context (C.baseCtx <> pyCtx)
@@ -182,7 +181,7 @@ instance (FromPy a, FromPy b) => FromPy (a,b) where
       }|]
     -- We may want to extract exception to haskell side later
     liftIO [CU.exp| void { PyErr_Clear() } |]
-    when (unpack_ok /= 0) $ abort $ pure Nothing
+    when (unpack_ok /= 0) $ abort Nothing
     -- Unpack 2-elements
     lift $ do
       p_a <- liftIO $ peekElemOff p_args 0
@@ -243,7 +242,7 @@ instance (FromPy a, ToPy b) => ToPy (a -> IO b) where
     -- C function pointer for callback
     f_ptr <- wrapO $ \_ p_a -> pyProg $ do
       a <- liftIO (unPy (basicFromPy p_a)) >>= \case
-        Nothing -> abort $ raiseUndecodedArg 1 1
+        Nothing -> abortM $ raiseUndecodedArg 1 1
         Just a  -> pure a
       liftIO $ unPy . basicToPy =<< f a
     --
@@ -257,7 +256,7 @@ instance (FromPy a1, FromPy a2, ToPy b) => ToPy (a1 -> a2 -> IO b) where
   basicToPy f = Py $ do
     -- Create haskell function
     f_ptr <- wrapFastcall $ \_ p_arr n -> pyProg $ do
-      when (n /= 2) $ abort $ raiseBadNArgs 2 n
+      when (n /= 2) $ abortM $ raiseBadNArgs 2 n
       a <- loadArgFastcall p_arr 0 n
       b <- loadArgFastcall p_arr 1 n
       liftIO $ unPy . basicToPy =<< f a b
@@ -269,40 +268,35 @@ instance (FromPy a1, FromPy a2, ToPy b) => ToPy (a1 -> a2 -> IO b) where
           METH_FASTCALL);
       }|]
 
-type PyProg r a = ContT r IO a
-
-loadArgFastcall :: FromPy a => Ptr (Ptr PyObject) -> Int -> Int64 -> PyProg (Ptr PyObject) a
+loadArgFastcall :: FromPy a => Ptr (Ptr PyObject) -> Int -> Int64 -> Program (Ptr PyObject) a
 loadArgFastcall p_arr i tot = do
   p <- liftIO $ peekElemOff p_arr i
   liftIO (unPy (basicFromPy p)) >>= \case
-    Nothing -> abort $ raiseUndecodedArg (fromIntegral i + 1) (fromIntegral tot)
+    Nothing -> abortM $ raiseUndecodedArg (fromIntegral i + 1) (fromIntegral tot)
     Just a  -> pure a
 
 
-abort :: Monad m => m r -> ContT r m a
-abort m = ContT $ \_ -> m
-
-raiseUndecodedArg :: CInt -> CInt -> IO (Ptr PyObject)
-raiseUndecodedArg n tot = [CU.block| PyObject* {
+raiseUndecodedArg :: CInt -> CInt -> Py (Ptr PyObject)
+raiseUndecodedArg n tot = Py [CU.block| PyObject* {
   char err[256];
   sprintf(err, "Failed to decode function argument %i of %i", $(int n), $(int tot));
   PyErr_SetString(PyExc_TypeError, err);
   return NULL;
   } |]
 
-raiseBadNArgs :: CInt -> Int64 -> IO (Ptr PyObject)
-raiseBadNArgs tot n = [CU.block| PyObject* {
+raiseBadNArgs :: CInt -> Int64 -> Py (Ptr PyObject)
+raiseBadNArgs tot n = Py [CU.block| PyObject* {
   char err[256];
   sprintf(err, "Function takes exactly %i arguments (%li given)", $(int tot), $(int64_t n));
   PyErr_SetString(PyExc_TypeError, err);
   return NULL;
   } |]
 
-pyProg :: PyProg (Ptr PyObject) (Ptr PyObject) -> IO (Ptr PyObject)
-pyProg io = evalContT io `catch` convertHaskellException
+pyProg :: Program (Ptr PyObject) (Ptr PyObject) -> IO (Ptr PyObject)
+pyProg io = unPy $ evalContT io `catchPy` convertHaskellException
 
-convertHaskellException :: SomeException -> IO (Ptr PyObject)
-convertHaskellException err = do
+convertHaskellException :: SomeException -> Py (Ptr PyObject)
+convertHaskellException err = Py $ do
   withCString ("Haskell exception: "++show err) $ \p_err -> do
     [CU.block| PyObject* {
       PyErr_SetString(PyExc_RuntimeError, $(char *p_err));
diff --git a/src/Python/Internal/EvalQQ.hs b/src/Python/Internal/EvalQQ.hs
index 5ef1c89..494ca1a 100644
--- a/src/Python/Internal/EvalQQ.hs
+++ b/src/Python/Internal/EvalQQ.hs
@@ -34,7 +34,7 @@ import Language.Haskell.TH.Syntax qualified as TH
 
 import Python.Types
 import Python.Internal.Types
-import Python.Internal.Util
+import Python.Internal.Program
 import Python.Internal.Eval
 import Python.Inline.Literal
 import Paths_inline_python (getDataFileName)
diff --git a/src/Python/Internal/Program.hs b/src/Python/Internal/Program.hs
new file mode 100644
index 0000000..04e5f92
--- /dev/null
+++ b/src/Python/Internal/Program.hs
@@ -0,0 +1,51 @@
+-- |
+module Python.Internal.Program
+  ( Program
+  , abort
+  , abortM
+  , withPyAlloca
+  , withPyAllocaArray
+  , withPyCString
+  , withPyCStringLen
+  ) where
+
+import Control.Monad.Trans.Cont
+import Data.Coerce
+import Foreign.Ptr
+import Foreign.Marshal.Array
+import Foreign.Marshal
+import Foreign.C.String
+import Foreign.Storable
+
+import Python.Internal.Types
+
+
+-- | Internally we usually wrap 'Py' into 'ContT' in order get early
+--   exit and avoid building ladder of 
+type Program r a = ContT r Py a
+
+
+-- | Early exit from continuation monad.
+abort :: Monad m => r -> ContT r m a
+abort r = ContT $ \_ -> pure r
+
+-- | Early exit from continuation monad.
+abortM :: Monad m => m r -> ContT r m a
+abortM m = ContT $ \_ -> m
+
+
+----------------------------------------------------------------
+-- Allocation in context of `ContT _ Py`
+----------------------------------------------------------------
+
+withPyAlloca :: forall a r. Storable a => Program r (Ptr a)
+withPyAlloca = coerce (alloca @a @r)
+
+withPyAllocaArray :: forall a r. Storable a => Int -> Program r (Ptr a)
+withPyAllocaArray = coerce (allocaArray @a @r)
+
+withPyCString :: forall r. String -> Program r CString
+withPyCString = coerce (withCString @r)
+
+withPyCStringLen :: forall r. String -> Program r CStringLen
+withPyCStringLen = coerce (withCStringLen @r)
diff --git a/src/Python/Internal/Types.hs b/src/Python/Internal/Types.hs
index bba5c33..5bfca7e 100644
--- a/src/Python/Internal/Types.hs
+++ b/src/Python/Internal/Types.hs
@@ -11,6 +11,7 @@ module Python.Internal.Types
   , PyError(..)
   , Py(..)
   , finallyPy
+  , catchPy
     -- * inline-C
   , pyCtx
     -- * Patterns
@@ -54,6 +55,9 @@ newtype Py a = Py (IO a)
   deriving newtype (Functor,Applicative,Monad,MonadIO,MonadFail)
 -- See NOTE: [Python and threading]
 
+catchPy :: forall e a. Exception e => Py a -> (e -> Py a) -> Py a
+catchPy = coerce (catch @e @a)
+
 finallyPy :: forall a b. Py a -> Py b -> Py a
 finallyPy = coerce (finally @a @b)
 
@@ -69,6 +73,10 @@ pyCtx = mempty { ctxTypesTable = Map.fromList tytabs } where
     ]
 
 
+----------------------------------------------------------------
+-- Patterns
+----------------------------------------------------------------
+
 pattern IPY_OK, IPY_ERR_PYTHON, IPY_ERR_COMPILE :: CInt
 -- | Success
 pattern IPY_OK          = 0
diff --git a/src/Python/Internal/Util.hs b/src/Python/Internal/Util.hs
index 9da8638..7d370c6 100644
--- a/src/Python/Internal/Util.hs
+++ b/src/Python/Internal/Util.hs
@@ -1,35 +1,11 @@
 -- |
 module Python.Internal.Util where
 
-import Control.Monad.Trans.Cont
 import Data.Char
-import Data.Coerce
 import Foreign.Ptr
 import Foreign.Marshal.Array
-import Foreign.Marshal
 import Foreign.C.Types
-import Foreign.C.String
-import Foreign.Storable
-
-import Python.Internal.Types
 
 
 withWCtring :: String -> (Ptr CWchar -> IO a) -> IO a
 withWCtring = withArray0 (CWchar 0) . map (fromIntegral . ord)
-
-
-----------------------------------------------------------------
--- Allocation in context of `ContT _ Py`
-----------------------------------------------------------------
-
-withPyAlloca :: forall a r. Storable a => ContT r Py (Ptr a)
-withPyAlloca = coerce (alloca @a @r)
-
-withPyAllocaArray :: forall a r. Storable a => Int -> ContT r Py (Ptr a)
-withPyAllocaArray = coerce (allocaArray @a @r)
-
-withPyCString :: forall r. String -> ContT r Py CString
-withPyCString = coerce (withCString @r)
-
-withPyCStringLen :: forall r. String -> ContT r Py CStringLen
-withPyCStringLen = coerce (withCStringLen @r)

From ede437621164e28792d71530df13ce9e252f2879 Mon Sep 17 00:00:00 2001
From: Alexey Khudyakov <alexey.skladnoy@gmail.com>
Date: Thu, 2 Jan 2025 16:12:33 +0300
Subject: [PATCH 4/9] Add function for conversion of python exception to
 haskell

---
 cbits/python.c                 | 26 -----------
 include/inline-python.h        |  7 ---
 src/Python/Inline/Literal.hs   | 13 +-----
 src/Python/Internal/Eval.hs    | 66 +++++++++++++++++++++++++++
 src/Python/Internal/EvalQQ.hs  | 82 +++++++++++++---------------------
 src/Python/Internal/Program.hs |  1 +
 src/Python/Internal/Types.hs   |  8 ++++
 7 files changed, 108 insertions(+), 95 deletions(-)

diff --git a/cbits/python.c b/cbits/python.c
index fa76907..758c808 100644
--- a/cbits/python.c
+++ b/cbits/python.c
@@ -1,32 +1,6 @@
 #include <inline-python.h>
 #include <stdlib.h>
 
-void inline_py_export_exception(
-    PyObject *e_type,
-    PyObject *e_value,
-    PyObject *e_trace,
-    char** p_msg
-    )
-{
-    // Convert to python string object
-    PyObject *e_str = PyObject_Str(e_value);
-    if( 0 == e_str ) {
-        *p_msg = 0;
-        return;
-    }
-    // Convert to UTF8 C string
-    const char *err_msg = PyUnicode_AsUTF8(e_str);
-    if( 0 == e_str ) {
-        *p_msg = 0;
-        return;
-    }
-    // Copy message
-    int n  = strlen(err_msg);
-    *p_msg = malloc(n+1);
-    strcpy(*p_msg, err_msg);
-    return;
-}
-
 PyObject *inline_py_function_wrapper(PyCFunction fun, int flags) {
     PyMethodDef *meth = malloc(sizeof(PyMethodDef));
     meth->ml_name  = "[inline_python]";
diff --git a/include/inline-python.h b/include/inline-python.h
index 26e0d88..ca8262d 100644
--- a/include/inline-python.h
+++ b/include/inline-python.h
@@ -25,13 +25,6 @@
     return 0;                                       \
 } while(0)
 
-// Convert python exception into form suitable for haskell
-void inline_py_export_exception(
-    PyObject *e_type,
-    PyObject *e_value,
-    PyObject *e_trace,
-    char** p_msg
-    );
 
 // Unpack iterable into array of PyObjects. Iterable must contain
 // exactly N elements.
diff --git a/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs
index 720fdbf..b8fd683 100644
--- a/src/Python/Inline/Literal.hs
+++ b/src/Python/Inline/Literal.hs
@@ -10,7 +10,6 @@ module Python.Inline.Literal
   , fromPy
   ) where
 
-import Control.Exception
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
@@ -19,7 +18,6 @@ import Data.Int
 import Data.Word
 import Foreign.Ptr
 import Foreign.C.Types
-import Foreign.C.String
 import Foreign.Marshal.Alloc
 import Foreign.Storable
 
@@ -29,6 +27,7 @@ import Language.C.Inline.Unsafe  qualified as CU
 import Python.Types
 import Python.Internal.Types
 import Python.Internal.Eval
+
 import Python.Internal.Program
 
 ----------------------------------------------------------------
@@ -293,15 +292,7 @@ raiseBadNArgs tot n = Py [CU.block| PyObject* {
   } |]
 
 pyProg :: Program (Ptr PyObject) (Ptr PyObject) -> IO (Ptr PyObject)
-pyProg io = unPy $ evalContT io `catchPy` convertHaskellException
-
-convertHaskellException :: SomeException -> Py (Ptr PyObject)
-convertHaskellException err = Py $ do
-  withCString ("Haskell exception: "++show err) $ \p_err -> do
-    [CU.block| PyObject* {
-      PyErr_SetString(PyExc_RuntimeError, $(char *p_err));
-      return NULL;
-      } |]
+pyProg io = unPy $ evalContT io `catchPy` convertHaskell2Py
 
 
 type FunWrapper a = a -> IO (FunPtr a)
diff --git a/src/Python/Internal/Eval.hs b/src/Python/Internal/Eval.hs
index 82d4c8d..334a464 100644
--- a/src/Python/Internal/Eval.hs
+++ b/src/Python/Internal/Eval.hs
@@ -14,6 +14,9 @@ module Python.Internal.Eval
   , withPython
     -- * PyObject wrapper
   , newPyObject
+    -- * Exceptions
+  , convertHaskell2Py
+  , convertPy2Haskell
   ) where
 
 import Control.Concurrent
@@ -25,7 +28,10 @@ import Foreign.Concurrent        qualified as GHC
 import Foreign.Ptr
 import Foreign.ForeignPtr
 import Foreign.C.Types
+import Foreign.C.String
 import Foreign.Marshal.Array
+import Foreign.Marshal
+import Foreign.Storable
 import System.Environment
 import System.IO.Unsafe
 
@@ -34,6 +40,7 @@ import Language.C.Inline.Unsafe   qualified as CU
 
 import Python.Internal.Types
 import Python.Internal.Util
+import Python.Internal.Program
 
 ----------------------------------------------------------------
 C.context (C.baseCtx <> pyCtx)
@@ -331,3 +338,62 @@ newPyObject p
 
 py_XDECREF :: FunPtr (Ptr PyObject -> IO ())
 py_XDECREF = [C.funPtr| void inline_py_XDECREF(PyObject* p) { Py_XDECREF(p); } |]
+
+
+
+----------------------------------------------------------------
+-- Conversion of exceptions
+----------------------------------------------------------------
+
+-- | Convert haskell exception to python exception. Always returns
+--   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;
+      } |]
+
+-- | Convert python exception to haskell exception. Should only be
+--   called if there's unhandled python exception. Clears exception.
+convertPy2Haskell :: Py PyError
+convertPy2Haskell = evalContT $ do
+  p_err <- withPyAlloca @(Ptr CChar)
+  -- Return 0 and set error message if there's python error
+  r     <- liftIO [CU.block| int {
+    char **p_msg = $(char **p_err);
+    PyObject *e_type, *e_value, *e_trace;
+    // Fetch python's error
+    PyErr_Fetch( &e_type, &e_value, &e_trace);
+    if( NULL == e_value ) {
+        return -1;
+    }
+    // Convert to python string object
+    PyObject *e_str = PyObject_Str(e_value);
+    if( NULL == e_str ) {
+        *p_msg = 0;
+        return 0;
+    }
+    // Convert to UTF8 C string
+    Py_ssize_t len;
+    const char *err_msg = PyUnicode_AsUTF8AndSize(e_str, &len);
+    if( 0 == e_str ) {
+        Py_DECREF(e_str);
+        *p_msg = 0;
+        return 0;
+    }
+    // Copy message
+    *p_msg = malloc(len+1);
+    strncpy(*p_msg, err_msg, len);
+    Py_DECREF(e_str);
+    return 0;
+    } |]
+  liftIO $ case r of
+    0 -> peek p_err >>= \case
+      NULL  -> pure $ PyError "CANNOT SHOW EXCEPTION"
+      c_err -> do
+        s <- peekCString c_err
+        free c_err
+        pure $ PyError s
+    _ -> error "No python exception raised"
diff --git a/src/Python/Internal/EvalQQ.hs b/src/Python/Internal/EvalQQ.hs
index 494ca1a..f69bbdc 100644
--- a/src/Python/Internal/EvalQQ.hs
+++ b/src/Python/Internal/EvalQQ.hs
@@ -57,14 +57,9 @@ pyEvalInMain
   -> Py ()
 pyEvalInMain p_globals p_locals src = evalContT $ do
   p_py  <- withPyCString src
-  p_err <- withPyAlloca @(Ptr CChar)
   r     <- liftIO [C.block| int {
-    PyObject *e_type, *e_value, *e_trace;
-    // Compile code
     PyObject *code = Py_CompileString($(char* p_py), "<interactive>", Py_file_input);
-    if( code == 0 ){
-        PyErr_Fetch( &e_type, &e_value, &e_trace);
-        inline_py_export_exception(e_type, e_value, e_trace, $(char** p_err));
+    if( PyErr_Occurred() ){
         return IPY_ERR_COMPILE;
     }
     // Execute in context of main
@@ -73,13 +68,11 @@ pyEvalInMain p_globals p_locals src = evalContT $ do
     PyObject* r = PyEval_EvalCode(code, globals, locals);
     Py_XDECREF(r);
     if( PyErr_Occurred() ) {
-        PyErr_Fetch( &e_type, &e_value, &e_trace);
-        inline_py_export_exception(e_type, e_value, e_trace, $(char** p_err));
         return IPY_ERR_PYTHON;
     }
     return IPY_OK;
     } |]
-  lift $ finiEval p_err r (pure ())
+  lift $ finiEval r (pure ())
 
 -- | Evaluate expression with fresh local environment
 pyEvalExpr
@@ -88,54 +81,42 @@ pyEvalExpr
   -> Py PyObject
 pyEvalExpr p_env src = evalContT $ do
   p_py  <- withPyCString src
-  p_err <- withPyAlloca @(Ptr CChar)
   p_res <- withPyAlloca @(Ptr PyObject)
-  r <- liftIO
-    [C.block| int {
-       PyObject *e_type, *e_value, *e_trace;
-       // Compile code
-       PyObject *code = Py_CompileString($(char* p_py), "<interactive>", Py_eval_input);
-       if( code == 0 ){
-           PyErr_Fetch( &e_type, &e_value, &e_trace);
-           inline_py_export_exception(e_type, e_value, e_trace, $(char** p_err));
-           return IPY_ERR_COMPILE;
-       }
-       // Execute in context of main
-       PyObject* main_module = PyImport_AddModule("__main__");
-       PyObject* globals     = PyModule_GetDict(main_module);
-       //
-       PyObject* r = PyEval_EvalCode(code, globals, $(PyObject* p_env));
-       *$(PyObject** p_res) = r;
-       if( PyErr_Occurred() ) {
-           PyErr_Fetch( &e_type, &e_value, &e_trace);
-           inline_py_export_exception(e_type, e_value, e_trace, $(char** p_err));
-           return IPY_ERR_PYTHON;
-       }
-       Py_INCREF(r);
-       return IPY_OK;
-       }|]
-  lift $ finiEval p_err r (newPyObject =<< liftIO (peek p_res))
+  r     <- liftIO [C.block| int {
+    // Compile code
+    PyObject *code = Py_CompileString($(char* p_py), "<interactive>", Py_eval_input);
+    if( PyErr_Occurred() ) {
+        return IPY_ERR_COMPILE;
+    }
+    // Execute in context of main
+    PyObject* main_module = PyImport_AddModule("__main__");
+    if( PyErr_Occurred() ) {
+        return IPY_ERR_PYTHON;
+    }
+    PyObject* globals     = PyModule_GetDict(main_module);
+    if( PyErr_Occurred() ) {
+        return IPY_ERR_PYTHON;
+    }
+    //
+    PyObject* r = PyEval_EvalCode(code, globals, $(PyObject* p_env));
+    if( PyErr_Occurred() ) {
+        return IPY_ERR_PYTHON;
+    }
+    Py_INCREF(r);
+    *$(PyObject **p_res) = r;
+    return IPY_OK;
+    }|]
+  lift $ finiEval r (newPyObject =<< liftIO (peek p_res))
 
 -- | Convert evaluation result and
 finiEval
-  :: Ptr CString
-  -> CInt
+  :: CInt
   -> Py a
   -> Py a
-finiEval p_err r fini = case r of
+finiEval r fini = case r of
   IPY_OK          -> fini
-  IPY_ERR_COMPILE -> Py $ peek p_err >>= \case
-    p | nullPtr == p -> throwIO $ PyError "Compile error"
-      | otherwise    -> do
-          s <- peekCString p
-          free p
-          throwIO $ PyError s
-  IPY_ERR_PYTHON -> Py $ peek p_err >>= \case
-      p | nullPtr == p -> throwIO $ PyError "Evaluation error"
-        | otherwise    -> do
-            s <- peekCString p
-            free p
-            throwIO $ PyError s
+  IPY_ERR_COMPILE -> throwPy =<< convertPy2Haskell
+  IPY_ERR_PYTHON  -> throwPy =<< convertPy2Haskell
   _ -> error $ "pyEvalStr: unexpected error: " ++ show r
 
 basicBindInDict :: ToPy a => String -> a -> Ptr PyObject -> Py ()
@@ -212,4 +193,3 @@ unindent py = case ls of
   where
     n  = minimum [ length (takeWhile (==' ') s) | s <- ls ]
     ls = filter (any (not . isSpace)) $ lines py
-
diff --git a/src/Python/Internal/Program.hs b/src/Python/Internal/Program.hs
index 04e5f92..bb1eb88 100644
--- a/src/Python/Internal/Program.hs
+++ b/src/Python/Internal/Program.hs
@@ -9,6 +9,7 @@ module Python.Internal.Program
   , withPyCStringLen
   ) where
 
+import Control.Exception
 import Control.Monad.Trans.Cont
 import Data.Coerce
 import Foreign.Ptr
diff --git a/src/Python/Internal/Types.hs b/src/Python/Internal/Types.hs
index 5bfca7e..2d5b7ed 100644
--- a/src/Python/Internal/Types.hs
+++ b/src/Python/Internal/Types.hs
@@ -12,6 +12,8 @@ module Python.Internal.Types
   , Py(..)
   , finallyPy
   , catchPy
+  , maskPy_
+  , throwPy
     -- * inline-C
   , pyCtx
     -- * Patterns
@@ -61,6 +63,12 @@ catchPy = coerce (catch @e @a)
 finallyPy :: forall a b. Py a -> Py b -> Py a
 finallyPy = coerce (finally @a @b)
 
+maskPy_ :: forall a. Py a -> Py a
+maskPy_ = coerce (mask_ @a)
+
+throwPy :: Exception e => e -> Py a
+throwPy = Py . throwIO
+
 ----------------------------------------------------------------
 -- inline-C
 ----------------------------------------------------------------

From c22d76740910692741a0e77d6d990acff23a4d8b Mon Sep 17 00:00:00 2001
From: Alexey Khudyakov <alexey.skladnoy@gmail.com>
Date: Thu, 2 Jan 2025 20:00:37 +0300
Subject: [PATCH 5/9] Rework exception handling in coversions

---
 cbits/python.c                 |  13 +--
 include/inline-python.h        |  18 +---
 src/Python/Inline.hs           |   2 +
 src/Python/Inline/Literal.hs   | 184 +++++++++++++++------------------
 src/Python/Internal/Eval.hs    |  60 +++++++++--
 src/Python/Internal/Program.hs |  16 +++
 src/Python/Internal/Types.hs   |  28 +++--
 test/TST/FromPy.hs             |  11 +-
 8 files changed, 194 insertions(+), 138 deletions(-)

diff --git a/cbits/python.c b/cbits/python.c
index 758c808..30a6802 100644
--- a/cbits/python.c
+++ b/cbits/python.c
@@ -18,18 +18,20 @@ PyObject *inline_py_function_wrapper(PyCFunction fun, int flags) {
 }
 
 int inline_py_unpack_iterable(PyObject *iterable, int n, PyObject **out) {
-    // Fill out with NULL. This way we can call XDECREF on them
-    for(int i = 0; i < n; i++) {
-        out[i] = NULL;
-    }
-    // Initialize iterator
+    // Initialize iterator. If object is not an iterable we treat this
+    // as not an exception but as a conversion failure
     PyObject* iter = PyObject_GetIter( iterable );
     if( PyErr_Occurred() ) {
+        PyErr_Clear();
         return -1;
     }
     if( !PyIter_Check(iter) ) {
         goto err_iter;
     }
+    // Fill out with NULL. This way we can call XDECREF on them
+    for(int i = 0; i < n; i++) {
+        out[i] = NULL;
+    }
     // Fill elements
     for(int i = 0; i < n; i++) {
         out[i] = PyIter_Next(iter);
@@ -55,7 +57,6 @@ int inline_py_unpack_iterable(PyObject *iterable, int n, PyObject **out) {
     return -1;
 }
 
-
 void inline_py_free_capsule(PyObject* py) {
     PyMethodDef *meth = PyCapsule_GetPointer(py, NULL);
     // HACK: We want to release wrappers created by wrapper. It
diff --git a/include/inline-python.h b/include/inline-python.h
index ca8262d..2a002c6 100644
--- a/include/inline-python.h
+++ b/include/inline-python.h
@@ -14,26 +14,14 @@
 
 // ----------------------------------------------------------------
 
-// This macro checks for errors. If python exception is raised it
-// clear it and returns 1 otherwise retruns 0
-#define INLINE_PY_SIMPLE_ERROR_HANDLING() do {      \
-    if( PyErr_Occurred() ) {                        \
-          PyObject *e_type, *e_value, *e_trace;     \
-          PyErr_Fetch(&e_type, &e_value, &e_trace); \
-          return 1;                                 \
-    }                                               \
-    return 0;                                       \
-} while(0)
-
-
 // Unpack iterable into array of PyObjects. Iterable must contain
 // exactly N elements.
 //
 // On success returns 0 and fills `out` with N PyObjects
 //
-// On failure returns -1. Python exception is not cleared. It's
-// responsibility of caller to deal with it. Content of `out` is
-// undefined in this case.
+// On failure return -1. Content of out is then undefined and it
+// doesn't contain live python objects. If failure is due to python
+// exception it's not cleared.
 int inline_py_unpack_iterable(
     PyObject  *iterable,
     int        n,
diff --git a/src/Python/Inline.hs b/src/Python/Inline.hs
index 8b4f81c..bf59aba 100644
--- a/src/Python/Inline.hs
+++ b/src/Python/Inline.hs
@@ -8,7 +8,9 @@ module Python.Inline
   , ToPy(..)
   , FromPy(..)
   , toPy
+  , fromPyEither
   , fromPy
+  , fromPy'
   ) where
 
 
diff --git a/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs
index b8fd683..78bd3cb 100644
--- a/src/Python/Inline/Literal.hs
+++ b/src/Python/Inline/Literal.hs
@@ -7,9 +7,12 @@ module Python.Inline.Literal
   ( FromPy(..)
   , ToPy(..)
   , toPy
+  , fromPyEither
   , fromPy
+  , fromPy'
   ) where
 
+import Control.Exception
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
@@ -35,7 +38,7 @@ C.context (C.baseCtx <> pyCtx)
 C.include "<inline-python.h>"
 ----------------------------------------------------------------
 
--- | Convert haskell value to python value. 
+-- | Convert haskell value to python value.
 class ToPy a where
   -- | Convert haskell value to python object. This function returns
   --   strong reference to newly create objects (except singletons
@@ -47,21 +50,37 @@ class ToPy a where
   --   with python's C API. Otherwise 'toPy' is preferred.
   basicToPy :: a -> Py (Ptr PyObject)
 
--- | Convert python object to haskell value. 
+-- | Convert python object to haskell value.
 class FromPy a where
   -- | Convert python value into haskell value. This function should
-  --   not modify python's data and raise both python and haskell
-  --   exceptions.
+  --   try to not modify python's data. This function should avoid
+  --   throwing haskell exception. Any python exceptions should be
+  --   thrown as 'PyError'. When data type couldn't be converted
+  --   'FromPyFailed' should be thrown to indicate failure.
   --
   --   This is low level function. It should be only used when working
   --   with python's C API. Otherwise 'fromPy' is preferred.
-  basicFromPy :: Ptr PyObject -> Py (Maybe a)
+  basicFromPy :: Ptr PyObject -> Py a
 
 -- | Convert python object to haskell value
+fromPyEither :: FromPy a => PyObject -> IO (Either PyError a)
+fromPyEither py = runPy $ unsafeWithPyObject py $ \p ->
+  (Right <$> basicFromPy p) `catchPy` (pure . Left)
+
+
+-- | Convert python object to haskell value. Python exception raised
+--   during execution are thrown as exceptions
 fromPy :: FromPy a => PyObject -> IO (Maybe a)
-fromPy py = runPy $ unsafeWithPyObject py basicFromPy
+fromPy py = runPy $ unsafeWithPyObject py $ \p ->
+  (Just <$> basicFromPy p) `catchPy` \case
+    FromPyFailed -> pure Nothing
+    e            -> throwPy e
+
+-- | Convert python object to haskell value. Throws exception on failure
+fromPy' :: FromPy a => PyObject -> IO a
+fromPy' py = runPy $ unsafeWithPyObject py basicFromPy
 
--- | Convert haskell value to a python object
+-- | Convert haskell value to a python object.
 toPy :: ToPy a => a -> IO PyObject
 toPy a = runPy $ newPyObject =<< basicToPy a
 
@@ -69,67 +88,38 @@ toPy a = runPy $ newPyObject =<< basicToPy a
 instance ToPy CLong where
   basicToPy i = Py [CU.exp| PyObject* { PyLong_FromLong($(long i)) } |]
 instance FromPy CLong where
-  basicFromPy p_py = Py $ evalContT $ do
-    p_out <- ContT $ alloca @CLong
-    r     <- liftIO $ [CU.block| int {
-      * $(long* p_out) = PyLong_AsLong($(PyObject *p_py));
-      INLINE_PY_SIMPLE_ERROR_HANDLING();
-      } |]
-    liftIO $ case r of
-      0 -> Just <$> peek p_out
-      _ -> pure Nothing
+  basicFromPy p_py = do
+    r <- Py [CU.exp| long { PyLong_AsLong($(PyObject *p_py)) } |]
+    r <$ throwPyConvesionFailed
 
 instance ToPy CLLong where
   basicToPy i = Py [CU.exp| PyObject* { PyLong_FromLongLong($(long long i)) } |]
 instance FromPy CLLong where
-  basicFromPy p_py = Py $ evalContT $ do
-    p_out <- ContT $ alloca @CLLong
-    r     <- liftIO $ [CU.block| int {
-      * $(long long* p_out) = PyLong_AsLongLong($(PyObject *p_py));
-      INLINE_PY_SIMPLE_ERROR_HANDLING();
-      } |]
-    liftIO $ case r of
-      0 -> Just <$> peek p_out
-      _ -> pure Nothing
+  basicFromPy p_py = do
+    r <- Py [CU.exp| long long { PyLong_AsLongLong($(PyObject *p_py)) } |]
+    r <$ throwPyConvesionFailed
 
 instance ToPy CULong where
   basicToPy i = Py [CU.exp| PyObject* { PyLong_FromUnsignedLong($(unsigned long i)) } |]
 instance FromPy CULong where
-  basicFromPy p_py = Py $ evalContT $ do
-    p_out <- ContT $ alloca @CULong
-    r     <- liftIO $ [CU.block| int {
-      * $(unsigned long* p_out) = PyLong_AsUnsignedLong($(PyObject *p_py));
-      INLINE_PY_SIMPLE_ERROR_HANDLING();
-      } |]
-    liftIO $ case r of
-      0 -> Just <$> peek p_out
-      _ -> pure Nothing
+  basicFromPy p_py = do
+    r <- Py [CU.exp| unsigned long { PyLong_AsUnsignedLong($(PyObject *p_py)) } |]
+    r <$ throwPyConvesionFailed
 
 instance ToPy CULLong where
   basicToPy i = Py [CU.exp| PyObject* { PyLong_FromUnsignedLongLong($(unsigned long long i)) } |]
 instance FromPy CULLong where
-  basicFromPy p_py = Py $ evalContT $ do
-    p_out <- ContT $ alloca @CULLong
-    r     <- liftIO $ [CU.block| int {
-      * $(unsigned long long* p_out) = PyLong_AsUnsignedLongLong($(PyObject *p_py));
-      INLINE_PY_SIMPLE_ERROR_HANDLING();
-      } |]
-    liftIO $ case r of
-      0 -> Just <$> peek p_out
-      _ -> pure Nothing
+  basicFromPy p_py = do
+    r <- Py [CU.exp| unsigned long long { PyLong_AsUnsignedLongLong($(PyObject *p_py)) } |]
+    r <$ throwPyConvesionFailed
+
 
 instance ToPy CDouble where
   basicToPy i = Py [CU.exp| PyObject* { PyFloat_FromDouble($(double i)) } |]
 instance FromPy CDouble where
-  basicFromPy p_py = Py $ evalContT $ do
-    p_out <- ContT $ alloca @CDouble
-    r     <- liftIO $ [CU.block| int {
-      * $(double* p_out) = PyFloat_AsDouble($(PyObject *p_py));
-      INLINE_PY_SIMPLE_ERROR_HANDLING();
-      } |]
-    liftIO $ case r of
-      0 -> Just <$> peek p_out
-      _ -> pure Nothing
+  basicFromPy p_py = do
+    r <- Py [CU.exp| double { PyFloat_AsDouble($(PyObject *p_py)) } |]
+    r <$ throwPyConvesionFailed
 
 deriving via CLLong  instance ToPy   Int64
 deriving via CLLong  instance FromPy Int64
@@ -141,10 +131,10 @@ deriving via CDouble instance FromPy Double
 instance ToPy Int where
   basicToPy   = basicToPy @Int64 . fromIntegral
 instance FromPy Int where
-  basicFromPy = (fmap . fmap) fromIntegral . basicFromPy @Int64
+  basicFromPy = fmap fromIntegral . basicFromPy @Int64
 
--- TODO: Int may be 32 or 64 bit!
--- TODO: Int{8,16,32} & Word{8,16,32}
+-- -- TODO: Int may be 32 or 64 bit!
+-- -- TODO: Int{8,16,32} & Word{8,16,32}
 
 instance ToPy Bool where
   basicToPy True  = Py [CU.exp| PyObject* { Py_True  } |]
@@ -152,24 +142,21 @@ instance ToPy Bool where
 
 -- | Uses python's truthiness conventions
 instance FromPy Bool where
-  basicFromPy p = Py $ do
-    r <- [CU.block| int {
-      int r = PyObject_IsTrue($(PyObject* p));
-      PyErr_Clear();
-      return r;
-      } |]
-    case r of
-      0 -> pure $ Just False
-      1 -> pure $ Just True
-      _ -> pure $ Nothing
+  basicFromPy p = do
+    r <- Py [CU.exp| int { PyObject_IsTrue($(PyObject* p)) } |]
+    throwPyError
+    pure $! r /= 0
+
 
 instance (ToPy a, ToPy b) => ToPy (a,b) where
-  basicToPy (a,b) = do
-    basicToPy a >>= \case
-      NULL -> pure NULL
-      p_a  -> basicToPy b >>= \case
-        NULL -> pure $ NULL
-        p_b  -> Py [CU.exp| PyObject* { PyTuple_Pack(2, $(PyObject* p_a), $(PyObject* p_b)) } |]
+  basicToPy (a,b) = evalContT $ do
+    p_a <- lift $ basicToPy a
+    onExceptionProg (decref p_a)
+    p_b <- lift $ basicToPy b
+    onExceptionProg (decref p_b)
+    lift $ do
+      r <- Py [CU.exp| PyObject* { PyTuple_Pack(2, $(PyObject* p_a), $(PyObject* p_b)) } |]
+      r <$ throwPyError
 
 instance (FromPy a, FromPy b) => FromPy (a,b) where
   basicFromPy p_tup = evalContT $ do
@@ -178,23 +165,15 @@ instance (FromPy a, FromPy b) => FromPy (a,b) where
     unpack_ok <- liftIO [CU.exp| int {
       inline_py_unpack_iterable($(PyObject *p_tup), 2, $(PyObject **p_args))
       }|]
-    -- We may want to extract exception to haskell side later
-    liftIO [CU.exp| void { PyErr_Clear() } |]
-    when (unpack_ok /= 0) $ abort Nothing
-    -- Unpack 2-elements
-    lift $ do
-      p_a <- liftIO $ peekElemOff p_args 0
-      p_b <- liftIO $ peekElemOff p_args 1
-      let parse = basicFromPy p_a >>= \case
-            Nothing -> pure Nothing
-            Just a  -> basicFromPy p_b >>= \case
-              Nothing -> pure Nothing
-              Just b  -> pure $ Just (a,b)
-          fini  = liftIO [CU.block| void {
-            Py_XDECREF( $(PyObject* p_a) );
-            Py_XDECREF( $(PyObject* p_b) );
-            } |]
-      parse `finallyPy` fini
+    lift $ do throwPyError
+              when (unpack_ok /= 0) $ throwPy FromPyFailed
+    -- Parse each element of tuple
+    p_a <- liftIO $ peekElemOff p_args 0
+    p_b <- liftIO $ peekElemOff p_args 1
+    finallyProg $ decref p_a >> decref p_b
+    lift $ do a <- basicFromPy p_a
+              b <- basicFromPy p_b
+              pure (a,b)
 
 
 
@@ -220,7 +199,7 @@ instance (FromPy a, FromPy b) => FromPy (a,b) where
 -- To that end we use horrible hack.
 --
 -- PyMethodDef is allocated on C heap, wrapped into PyCapsule passed
--- to CFunction as self. It does seems icky. However it does the trick.
+-- to CFunction as self. It does seems hacky. However it does the trick.
 -- Maybe there's other way.
 
 
@@ -239,10 +218,11 @@ instance (FromPy a, FromPy b) => FromPy (a,b) where
 instance (FromPy a, ToPy b) => ToPy (a -> IO b) where
   basicToPy f = Py $ do
     -- C function pointer for callback
-    f_ptr <- wrapO $ \_ p_a -> pyProg $ do
-      a <- liftIO (unPy (basicFromPy p_a)) >>= \case
-        Nothing -> abortM $ raiseUndecodedArg 1 1
-        Just a  -> pure a
+    f_ptr <- wrapO $ \_ p_a -> pyCallback $ do
+      a <- lift (tryPy (basicFromPy p_a)) >>= \case
+        Left  FromPyFailed -> abortM $ raiseUndecodedArg 1 1
+        Left  e            -> lift   $ throwPy e
+        Right a            -> pure a
       liftIO $ unPy . basicToPy =<< f a
     --
     [C.exp| PyObject* {
@@ -254,7 +234,7 @@ instance (FromPy a, ToPy b) => ToPy (a -> IO b) where
 instance (FromPy a1, FromPy a2, ToPy b) => ToPy (a1 -> a2 -> IO b) where
   basicToPy f = Py $ do
     -- Create haskell function
-    f_ptr <- wrapFastcall $ \_ p_arr n -> pyProg $ do
+    f_ptr <- wrapFastcall $ \_ p_arr n -> pyCallback $ do
       when (n /= 2) $ abortM $ raiseBadNArgs 2 n
       a <- loadArgFastcall p_arr 0 n
       b <- loadArgFastcall p_arr 1 n
@@ -270,10 +250,18 @@ instance (FromPy a1, FromPy a2, ToPy b) => ToPy (a1 -> a2 -> IO b) where
 loadArgFastcall :: FromPy a => Ptr (Ptr PyObject) -> Int -> Int64 -> Program (Ptr PyObject) a
 loadArgFastcall p_arr i tot = do
   p <- liftIO $ peekElemOff p_arr i
-  liftIO (unPy (basicFromPy p)) >>= \case
-    Nothing -> abortM $ raiseUndecodedArg (fromIntegral i + 1) (fromIntegral tot)
-    Just a  -> pure a
+  lift (tryPy (basicFromPy p)) >>= \case
+    Right a            -> pure a
+    Left  FromPyFailed -> abortM $ raiseUndecodedArg (fromIntegral i + 1) (fromIntegral tot)
+    Left  e            -> lift   $ throwPy e
+
+
+----------------------------------------------------------------
+-- Helpers
+----------------------------------------------------------------
 
+pyCallback :: Program (Ptr PyObject) (Ptr PyObject) -> IO (Ptr PyObject)
+pyCallback io = unPy $ evalContT io `catchPy` convertHaskell2Py
 
 raiseUndecodedArg :: CInt -> CInt -> Py (Ptr PyObject)
 raiseUndecodedArg n tot = Py [CU.block| PyObject* {
@@ -291,8 +279,6 @@ raiseBadNArgs tot n = Py [CU.block| PyObject* {
   return NULL;
   } |]
 
-pyProg :: Program (Ptr PyObject) (Ptr PyObject) -> IO (Ptr PyObject)
-pyProg io = unPy $ evalContT io `catchPy` convertHaskell2Py
 
 
 type FunWrapper a = a -> IO (FunPtr a)
diff --git a/src/Python/Internal/Eval.hs b/src/Python/Internal/Eval.hs
index 334a464..9c2b5cc 100644
--- a/src/Python/Internal/Eval.hs
+++ b/src/Python/Internal/Eval.hs
@@ -14,9 +14,12 @@ module Python.Internal.Eval
   , withPython
     -- * PyObject wrapper
   , newPyObject
+  , decref
     -- * Exceptions
   , convertHaskell2Py
   , convertPy2Haskell
+  , throwPyError
+  , throwPyConvesionFailed
   ) where
 
 import Control.Concurrent
@@ -113,6 +116,23 @@ C.include "<inline-python.h>"
 
 
 
+-- NOTE: [Async exceptions]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Code interacting with python interpreter interleaves C calls and
+-- haskell code. It's impossible to ensure invariant that python
+-- interpreter demands from us if computation could be interrupted in
+-- arbitrary points.
+--
+-- So solution is to execute such code with async exceptions masked.
+-- `runPy` and friends should ensure that.
+--
+-- This may cause problems with callbacks to haskell. Async exceptions
+-- won't reach worker thread, and python interpreter couldn't be
+-- interrupted as well. We poll for that at beginning of callback.
+-- We'll see whether it causes problems in practice.
+
+
 
 ----------------------------------------------------------------
 -- Data types used for multithreaded RTS
@@ -162,6 +182,8 @@ toDECREF = unsafePerformIO $ newMVar Nil
 
 -- | Execute python action.
 runPy :: Py a -> IO a
+-- See NOTE: [Python and threading]
+-- See NOTE: [Threading and exceptions]
 runPy py
   -- Multithreaded RTS
   | rtsSupportsBoundThreads = do
@@ -181,9 +203,9 @@ runPy py
             Right a -> pure a
         ) `catch` onExc
   -- Single-threaded RTS
-  | otherwise = unPy py
--- See NOTE: [Python and threading]
--- See NOTE: [Threading and exceptions]
+  --
+  -- See NOTE: [Async exceptions]
+  | otherwise = mask_ $ unPy py
 
 
 -- | Execute python action. This function is unsafe and should be only
@@ -291,10 +313,10 @@ evalReq :: IO ()
 evalReq = do
   PyEvalReq{prog=Py io, result, status} <- takeMVar toPythonThread
   -- GC
-  let decref Nil = pure ()
-      decref (p `Cons` ps) = do [CU.exp| void { Py_XDECREF($(PyObject* p)) } |]
-                                decref ps
-  decref =<< modifyMVar toDECREF (\xs -> pure (Nil, xs))
+  let decrefList Nil = pure ()
+      decrefList (p `Cons` ps) = do [CU.exp| void { Py_XDECREF($(PyObject* p)) } |]
+                                    decrefList ps
+  decrefList =<< modifyMVar toDECREF (\xs -> pure (Nil, xs))
   -- Update status of request
   do_eval <- modifyMVar status $ \case
     Running   -> error "Python evaluator: Internal error. Got 'Running' request"
@@ -302,7 +324,7 @@ evalReq = do
     Cancelled -> return (Cancelled,False)
     Pending   -> return (Running,  True)
   when do_eval $ do
-    a <- (Right <$> io) `catches`
+    a <- (Right <$> mask_ io) `catches`
          [ Handler $ \(e :: AsyncException)     -> throwIO e
          , Handler $ \(e :: SomeAsyncException) -> throwIO e
          , Handler $ \(e :: SomeException)      -> pure (Left e)
@@ -322,6 +344,8 @@ evalReq = do
 -- Creation of PyObject
 ----------------------------------------------------------------
 
+decref :: Ptr PyObject -> Py ()
+decref p = Py [CU.exp| void { Py_DECREF($(PyObject* p)) } |]
 
 -- | Wrap raw python object into
 newPyObject :: Ptr PyObject -> Py PyObject
@@ -397,3 +421,23 @@ convertPy2Haskell = evalContT $ do
         free c_err
         pure $ PyError s
     _ -> error "No python exception raised"
+
+-- | Throw python error as haskell exception if it's raised.
+throwPyError :: Py ()
+throwPyError = 
+  Py [CU.exp| PyObject* { PyErr_Occurred() } |] >>= \case
+    NULL -> pure ()
+    _    -> throwPy =<< convertPy2Haskell
+
+throwPyConvesionFailed :: Py ()
+throwPyConvesionFailed = do
+  r <- Py [CU.block| int {
+    if( PyErr_Occurred() ) {
+        PyErr_Clear();
+        return 1;
+    }
+    return 0;
+    } |]
+  case r of
+    0 -> pure ()
+    _ -> throwPy FromPyFailed 
diff --git a/src/Python/Internal/Program.hs b/src/Python/Internal/Program.hs
index bb1eb88..f22b8b1 100644
--- a/src/Python/Internal/Program.hs
+++ b/src/Python/Internal/Program.hs
@@ -1,8 +1,12 @@
 -- |
 module Python.Internal.Program
   ( Program
+    -- * Control flow
   , abort
   , abortM
+  , finallyProg
+  , onExceptionProg
+    -- * Allocators
   , withPyAlloca
   , withPyAllocaArray
   , withPyCString
@@ -34,6 +38,18 @@ abort r = ContT $ \_ -> pure r
 abortM :: Monad m => m r -> ContT r m a
 abortM m = ContT $ \_ -> m
 
+-- | Evaluate finalizer even if exception is thrown.
+finallyProg
+  :: Py b -- ^ Finalizer
+  -> Program r ()
+finallyProg fini = ContT $ \c -> c () `finallyPy` fini
+
+-- | Evaluate finalizer if exception is thrown.
+onExceptionProg
+  :: Py b -- ^ Finalizer
+  -> Program r ()
+onExceptionProg fini = ContT $ \c -> c () `onExceptionPy` fini
+
 
 ----------------------------------------------------------------
 -- Allocation in context of `ContT _ Py`
diff --git a/src/Python/Internal/Types.hs b/src/Python/Internal/Types.hs
index 2d5b7ed..da3e49d 100644
--- a/src/Python/Internal/Types.hs
+++ b/src/Python/Internal/Types.hs
@@ -10,10 +10,11 @@ module Python.Internal.Types
     PyObject(..)
   , PyError(..)
   , Py(..)
-  , finallyPy
   , catchPy
-  , maskPy_
+  , finallyPy
+  , onExceptionPy
   , throwPy
+  , tryPy
     -- * inline-C
   , pyCtx
     -- * Patterns
@@ -43,19 +44,27 @@ import Language.C.Inline.Context
 newtype PyObject = PyObject (ForeignPtr PyObject)
 
 -- | Python exception converted to haskell
-data PyError = PyError String
+data PyError
+  = PyError String
+    -- ^ Python exception
+  | FromPyFailed
+    -- ^ Conversion
   deriving stock (Show)
 
 instance Exception PyError
 
 
 -- | Monad for code which is interacts directly with python
---   interpreter. It's needed because in multithreaded runtime one
---   can't call python's C function from any thread. We need to send
---   it for execution on designated OS thread. 
+--   interpreter. One could assume that code in this monad executes
+--   with async exceptions masked.
+--
+--   We need to treat code interacting with python interpreter
+--   differently from plain @IO@ since it must be executed in single OS
+--   threads. On other hand lifting @IO@ to @Py@ is safe.
 newtype Py a = Py (IO a)
   deriving newtype (Functor,Applicative,Monad,MonadIO,MonadFail)
 -- See NOTE: [Python and threading]
+-- See NOTE: [Async exceptions]
 
 catchPy :: forall e a. Exception e => Py a -> (e -> Py a) -> Py a
 catchPy = coerce (catch @e @a)
@@ -63,12 +72,15 @@ catchPy = coerce (catch @e @a)
 finallyPy :: forall a b. Py a -> Py b -> Py a
 finallyPy = coerce (finally @a @b)
 
-maskPy_ :: forall a. Py a -> Py a
-maskPy_ = coerce (mask_ @a)
+onExceptionPy :: forall a b. Py a -> Py b -> Py a
+onExceptionPy = coerce (onException @a @b)
 
 throwPy :: Exception e => e -> Py a
 throwPy = Py . throwIO
 
+tryPy :: forall e a. Exception e => Py a -> Py (Either e a)
+tryPy = coerce (try @e @a)
+
 ----------------------------------------------------------------
 -- inline-C
 ----------------------------------------------------------------
diff --git a/test/TST/FromPy.hs b/test/TST/FromPy.hs
index 366f6a4..6bf05ec 100644
--- a/test/TST/FromPy.hs
+++ b/test/TST/FromPy.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE QuasiQuotes         #-}
 -- |
 module TST.FromPy (tests) where
 
@@ -30,7 +31,7 @@ tests = testGroup "FromPy"
                    def __bool__(self):
                        raise Exception("Bad __bool__")
                |]
-        eq @Bool Nothing =<< [pye| Bad() |]
+        failE @Bool =<< [pye| Bad() |]
         -- Segfaults if exception is not cleared
         [py_| 1+1 |]
     ]
@@ -45,3 +46,9 @@ tests = testGroup "FromPy"
 
 eq :: (Eq a, Show a, FromPy a) => Maybe a -> PyObject -> IO ()
 eq a p = assertEqual "fromPy: " a =<< fromPy p
+
+failE :: forall a. (Eq a, Show a, FromPy a) => PyObject -> IO ()
+failE p = fromPyEither @a p >>= \case
+  Left PyError{} -> pure ()
+  r              -> assertFailure $ "Should fail with exception, but: " ++ show r
+

From a50e22443950ea76ab61603e0334c6480148671f Mon Sep 17 00:00:00 2001
From: Alexey Khudyakov <alexey.skladnoy@gmail.com>
Date: Thu, 2 Jan 2025 20:14:28 +0300
Subject: [PATCH 6/9] Add ToPy instance for list (and tests)

---
 inline-python.cabal          |  1 +
 src/Python/Inline/Literal.hs | 10 ++++++++++
 test/TST/ToPy.hs             | 21 +++++++++++++++++++++
 test/exe/main.hs             |  2 ++
 4 files changed, 34 insertions(+)
 create mode 100644 test/TST/ToPy.hs

diff --git a/inline-python.cabal b/inline-python.cabal
index d546a1d..b81c4ee 100644
--- a/inline-python.cabal
+++ b/inline-python.cabal
@@ -85,6 +85,7 @@ library test
   hs-source-dirs:   test
   Exposed-modules:
     TST.Run
+    TST.ToPy
     TST.FromPy
 
 test-suite inline-python-tests
diff --git a/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs
index 78bd3cb..b195122 100644
--- a/src/Python/Inline/Literal.hs
+++ b/src/Python/Inline/Literal.hs
@@ -19,6 +19,7 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Cont
 import Data.Int
 import Data.Word
+import Data.Foldable
 import Foreign.Ptr
 import Foreign.C.Types
 import Foreign.Marshal.Alloc
@@ -175,6 +176,15 @@ instance (FromPy a, FromPy b) => FromPy (a,b) where
               b <- basicFromPy p_b
               pure (a,b)
 
+instance (ToPy a) => ToPy [a] where
+  basicToPy xs = evalContT $ do
+    let n = fromIntegral $ length xs :: CLLong
+    p_list <- liftIO [CU.exp| PyObject* { PyList_New($(long long n)) } |]
+    onExceptionProg $ decref p_list
+    lift $ for_ ([0..] `zip` xs) $ \(i,a) -> do
+      p_a <- basicToPy a
+      Py [CU.exp| void { PyList_SET_ITEM($(PyObject* p_list), $(long long i), $(PyObject* p_a)) } |]
+    pure p_list
 
 
 ----------------------------------------------------------------
diff --git a/test/TST/ToPy.hs b/test/TST/ToPy.hs
new file mode 100644
index 0000000..d0b0674
--- /dev/null
+++ b/test/TST/ToPy.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE QuasiQuotes         #-}
+-- |
+module TST.ToPy (tests) where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+import Python.Inline
+import Python.Inline.QQ
+
+tests :: TestTree
+tests = testGroup "ToPy"
+  [ testCase "Int"    $ let i = 1234    :: Int    in [py_| assert i_hs == 1234    |]
+  , testCase "Double" $ let i = 1234.25 :: Double in [py_| assert i_hs == 1234.25 |]
+  , testCase "Tuple2" $ let x = (1::Int, 333::Int)
+                        in [py_| assert x_hs == (1,333) |]
+  , testCase "nested Tuple2" $ let x = (1::Int, (333::Int,4.5::Double))
+                               in [py_| assert x_hs == (1,(333,4.5)) |]
+  , testCase "list" $ let x = [1 .. 5::Int]
+                      in [py_| assert x_hs == [1,2,3,4,5] |]
+  ]
diff --git a/test/exe/main.hs b/test/exe/main.hs
index 85920e1..73427c9 100644
--- a/test/exe/main.hs
+++ b/test/exe/main.hs
@@ -4,10 +4,12 @@ import Test.Tasty
 
 import TST.Run
 import TST.FromPy
+import TST.ToPy
 import Python.Inline
 
 main :: IO ()
 main = withPython $ defaultMain $ testGroup "PY"
   [ TST.Run.tests
   , TST.FromPy.tests
+  , TST.ToPy.tests
   ]

From 9870f5d109bf9c63c7fd31cd00bd65e42930c7a2 Mon Sep 17 00:00:00 2001
From: Alexey Khudyakov <alexey.skladnoy@gmail.com>
Date: Thu, 2 Jan 2025 20:29:00 +0300
Subject: [PATCH 7/9] FromPy for list

---
 src/Python/Inline/Literal.hs | 20 ++++++++++++++++++++
 test/TST/FromPy.hs           |  7 +++++++
 2 files changed, 27 insertions(+)

diff --git a/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs
index b195122..b76771f 100644
--- a/src/Python/Inline/Literal.hs
+++ b/src/Python/Inline/Literal.hs
@@ -186,6 +186,26 @@ instance (ToPy a) => ToPy [a] where
       Py [CU.exp| void { PyList_SET_ITEM($(PyObject* p_list), $(long long i), $(PyObject* p_a)) } |]
     pure p_list
 
+instance (FromPy a) => FromPy [a] where
+  basicFromPy p_list = do
+    p_iter <- Py [CU.block| PyObject* {
+      PyObject* iter = PyObject_GetIter( $(PyObject *p_list) );
+      if( PyErr_Occurred() ) {
+          PyErr_Clear();
+      }
+      return iter;
+      } |]
+    when (nullPtr == p_iter) $ throwPy FromPyFailed
+    --
+    let loop f = do
+          p <- Py [C.exp| PyObject* { PyIter_Next($(PyObject* p_iter)) } |]
+          throwPyError
+          case p of
+            NULL -> pure f
+            _    -> do a <- basicFromPy p `finallyPy` decref p
+                       loop (f . (a:))
+    ($ []) <$> loop id
+
 
 ----------------------------------------------------------------
 -- Functions marshalling
diff --git a/test/TST/FromPy.hs b/test/TST/FromPy.hs
index 6bf05ec..59e8b29 100644
--- a/test/TST/FromPy.hs
+++ b/test/TST/FromPy.hs
@@ -42,6 +42,13 @@ tests = testGroup "FromPy"
     , testCase "(3)->2" $ eq @(Int,Bool) Nothing =<< [pye| (1,2,3) |]
     , testCase "X->2"   $ eq @(Int,Bool) Nothing =<< [pye| 2 |]
     ]
+  , testGroup "List"
+    [ testCase "()"  $ eq @[Int] (Just [])      =<< [pye| ()      |]
+    , testCase "[]"  $ eq @[Int] (Just [])      =<< [pye| []      |]
+    , testCase "[1]" $ eq @[Int] (Just [1])     =<< [pye| [1]     |]
+    , testCase "[3]" $ eq @[Int] (Just [1,2,3]) =<< [pye| [1,2,3] |]
+    , testCase "Int" $ eq @[Int] Nothing        =<< [pye| None    |]
+    ]
   ]
 
 eq :: (Eq a, Show a, FromPy a) => Maybe a -> PyObject -> IO ()

From 57cbe18d1be33e4e2265cffb5a0e25d437c7b4c9 Mon Sep 17 00:00:00 2001
From: Alexey Khudyakov <alexey.skladnoy@gmail.com>
Date: Thu, 2 Jan 2025 20:58:11 +0300
Subject: [PATCH 8/9] FromPy for Char

---
 inline-python.cabal          |  1 +
 src/Python/Inline/Literal.hs | 32 ++++++++++++++++++++++++++++++++
 test/TST/FromPy.hs           | 13 ++++++++++++-
 test/TST/ToPy.hs             | 22 ++++++++++++++--------
 4 files changed, 59 insertions(+), 9 deletions(-)

diff --git a/inline-python.cabal b/inline-python.cabal
index b81c4ee..e25407e 100644
--- a/inline-python.cabal
+++ b/inline-python.cabal
@@ -38,6 +38,7 @@ common language
     PatternSynonyms
     ViewPatterns
     LambdaCase
+    MultiWayIf
     --
     NoFieldSelectors
     DuplicateRecordFields
diff --git a/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs
index b76771f..0cb79d9 100644
--- a/src/Python/Inline/Literal.hs
+++ b/src/Python/Inline/Literal.hs
@@ -17,6 +17,7 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Cont
+import Data.Char
 import Data.Int
 import Data.Word
 import Data.Foldable
@@ -137,6 +138,37 @@ instance FromPy Int where
 -- -- TODO: Int may be 32 or 64 bit!
 -- -- TODO: Int{8,16,32} & Word{8,16,32}
 
+-- | Encoded as 1-character string
+instance ToPy Char where
+  basicToPy c = do
+    let i = fromIntegral (ord c) :: CUInt
+    r <- Py [CU.block| PyObject* {
+       uint32_t cs[1] = { $(unsigned i) };
+       return PyUnicode_DecodeUTF32((char*)cs, 4, NULL, NULL);
+       } |]
+    r <$ throwPyError
+
+instance FromPy Char where
+  basicFromPy p = do
+    r <- Py [CU.block| int {
+      PyObject* p = $(PyObject *p);
+      if( !PyUnicode_Check(p) )
+          return -1;
+      if( 1 != PyUnicode_GET_LENGTH(p) )
+          return -1;
+      switch( PyUnicode_KIND(p) ) {
+      case PyUnicode_1BYTE_KIND:
+          return PyUnicode_1BYTE_DATA(p)[0];
+      case PyUnicode_2BYTE_KIND:
+          return PyUnicode_2BYTE_DATA(p)[0];
+      case PyUnicode_4BYTE_KIND:
+          return PyUnicode_4BYTE_DATA(p)[0];
+      }
+      return -1;
+      } |]
+    if | r < 0     -> throwPy FromPyFailed
+       | otherwise -> pure $ chr $ fromIntegral r
+
 instance ToPy Bool where
   basicToPy True  = Py [CU.exp| PyObject* { Py_True  } |]
   basicToPy False = Py [CU.exp| PyObject* { Py_False } |]
diff --git a/test/TST/FromPy.hs b/test/TST/FromPy.hs
index 59e8b29..2da3940 100644
--- a/test/TST/FromPy.hs
+++ b/test/TST/FromPy.hs
@@ -20,11 +20,22 @@ tests = testGroup "FromPy"
     , testCase "Double->Double" $ eq @Double (Just 1234.25) =<< [pye| 1234.25 |]
     , testCase "None->Double"   $ eq @Double Nothing        =<< [pye| None    |]
     ]
+  , testGroup "Char"
+    [ testCase "0"    $ eq @Char Nothing    =<< [pye| ""   |]
+    , testCase "1 1B" $ eq @Char (Just 'a') =<< [pye| "a"  |]
+    , testCase "2 2B" $ eq @Char (Just 'ы') =<< [pye| "ы"  |]
+    , testCase "2"    $ eq @Char Nothing    =<< [pye| "as" |]
+    , testCase "None" $ eq @Char Nothing    =<< [pye| None |]
+    ]
+  , testGroup "String"
+    [ testCase "asdf" $ eq @String (Just "asdf") =<< [pye| "asdf" |]
+    , testCase "фыва" $ eq @String (Just "фыва") =<< [pye| "фыва" |]
+    ]
   , testGroup "Bool"
     [ testCase "True->Bool"  $ eq @Bool (Just True)  =<< [pye| True  |]
     , testCase "False->Bool" $ eq @Bool (Just False) =<< [pye| False |]
     , testCase "None->Bool"  $ eq @Bool (Just False) =<< [pye| None  |]
-      -- FIXME: Names leak!
+      -- FIXME: Names defined in pymain leak!
     , testCase "Exception" $ do
         [pymain|
                class Bad:
diff --git a/test/TST/ToPy.hs b/test/TST/ToPy.hs
index d0b0674..ee70f80 100644
--- a/test/TST/ToPy.hs
+++ b/test/TST/ToPy.hs
@@ -10,12 +10,18 @@ import Python.Inline.QQ
 
 tests :: TestTree
 tests = testGroup "ToPy"
-  [ testCase "Int"    $ let i = 1234    :: Int    in [py_| assert i_hs == 1234    |]
-  , testCase "Double" $ let i = 1234.25 :: Double in [py_| assert i_hs == 1234.25 |]
-  , testCase "Tuple2" $ let x = (1::Int, 333::Int)
-                        in [py_| assert x_hs == (1,333) |]
-  , testCase "nested Tuple2" $ let x = (1::Int, (333::Int,4.5::Double))
-                               in [py_| assert x_hs == (1,(333,4.5)) |]
-  , testCase "list" $ let x = [1 .. 5::Int]
-                      in [py_| assert x_hs == [1,2,3,4,5] |]
+  [ testCase "Int"          $ let i = 1234    :: Int    in [py_| assert i_hs == 1234    |]
+  , testCase "Double"       $ let i = 1234.25 :: Double in [py_| assert i_hs == 1234.25 |]
+  , testCase "Char ascii"   $ let c = 'a' in [py_| assert c_hs == 'a' |]
+  , testCase "Char unicode" $ let c = 'ы' in [py_| assert c_hs == 'ы' |]
+    -- Container types
+  , testCase "Tuple2" $
+      let x = (1::Int, 333::Int)
+      in [py_| assert x_hs == (1,333) |]
+  , testCase "nested Tuple2" $
+      let x = (1::Int, (333::Int,4.5::Double))
+      in [py_| assert x_hs == (1,(333,4.5)) |]
+  , testCase "list" $
+      let x = [1 .. 5::Int]
+      in [py_| assert x_hs == [1,2,3,4,5] |]
   ]

From 97383628809c209c4c61e3475ad69bc9746ffaef Mon Sep 17 00:00:00 2001
From: Alexey Khudyakov <alexey.skladnoy@gmail.com>
Date: Thu, 2 Jan 2025 21:14:54 +0300
Subject: [PATCH 9/9] Add special case for String

---
 src/Python/Inline/Literal.hs   | 24 ++++++++++++++++--------
 src/Python/Internal/Eval.hs    |  4 ++--
 src/Python/Internal/Program.hs |  6 ++++++
 src/Python/Internal/Util.hs    |  4 ++--
 test/TST/ToPy.hs               | 10 ++++++----
 5 files changed, 32 insertions(+), 16 deletions(-)

diff --git a/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs
index 0cb79d9..e1e45e9 100644
--- a/src/Python/Inline/Literal.hs
+++ b/src/Python/Inline/Literal.hs
@@ -51,6 +51,16 @@ class ToPy a where
   --   This is low level function. It should be only used when working
   --   with python's C API. Otherwise 'toPy' is preferred.
   basicToPy :: a -> Py (Ptr PyObject)
+  -- | Old hack for handling of strings
+  basicListToPy :: [a] -> Py (Ptr PyObject)
+  basicListToPy xs = evalContT $ do
+    let n = fromIntegral $ length xs :: CLLong
+    p_list <- liftIO [CU.exp| PyObject* { PyList_New($(long long n)) } |]
+    onExceptionProg $ decref p_list
+    lift $ for_ ([0..] `zip` xs) $ \(i,a) -> do
+      p_a <- basicToPy a
+      Py [CU.exp| void { PyList_SET_ITEM($(PyObject* p_list), $(long long i), $(PyObject* p_a)) } |]
+    pure p_list
 
 -- | Convert python object to haskell value.
 class FromPy a where
@@ -147,6 +157,11 @@ instance ToPy Char where
        return PyUnicode_DecodeUTF32((char*)cs, 4, NULL, NULL);
        } |]
     r <$ throwPyError
+  basicListToPy str = evalContT $ do
+    p_str <- withPyWCString str
+    p     <- liftIO [CU.exp| PyObject* { PyUnicode_FromWideChar($(wchar_t *p_str), -1) } |]
+    lift $ p <$ throwPyError
+
 
 instance FromPy Char where
   basicFromPy p = do
@@ -209,14 +224,7 @@ instance (FromPy a, FromPy b) => FromPy (a,b) where
               pure (a,b)
 
 instance (ToPy a) => ToPy [a] where
-  basicToPy xs = evalContT $ do
-    let n = fromIntegral $ length xs :: CLLong
-    p_list <- liftIO [CU.exp| PyObject* { PyList_New($(long long n)) } |]
-    onExceptionProg $ decref p_list
-    lift $ for_ ([0..] `zip` xs) $ \(i,a) -> do
-      p_a <- basicToPy a
-      Py [CU.exp| void { PyList_SET_ITEM($(PyObject* p_list), $(long long i), $(PyObject* p_a)) } |]
-    pure p_list
+  basicToPy = basicListToPy
 
 instance (FromPy a) => FromPy [a] where
   basicFromPy p_list = do
diff --git a/src/Python/Internal/Eval.hs b/src/Python/Internal/Eval.hs
index 9c2b5cc..9c29ff2 100644
--- a/src/Python/Internal/Eval.hs
+++ b/src/Python/Internal/Eval.hs
@@ -257,8 +257,8 @@ doInializePython = do
   -- FIXME: For some reason sys.argv is initialized incorrectly. No
   --        easy way to debug. Will do for now
   r <- evalContT $ do
-    p_argv0  <- ContT $ withWCtring argv0
-    p_argv   <- traverse (ContT . withWCtring) argv
+    p_argv0  <- ContT $ withWCString argv0
+    p_argv   <- traverse (ContT . withWCString) argv
     ptr_argv <- ContT $ withArray (p_argv0 : p_argv)
     liftIO [C.block| int {
       // Noop is interpreter is already initialized
diff --git a/src/Python/Internal/Program.hs b/src/Python/Internal/Program.hs
index f22b8b1..81c6fd3 100644
--- a/src/Python/Internal/Program.hs
+++ b/src/Python/Internal/Program.hs
@@ -11,6 +11,7 @@ module Python.Internal.Program
   , withPyAllocaArray
   , withPyCString
   , withPyCStringLen
+  , withPyWCString
   ) where
 
 import Control.Exception
@@ -20,9 +21,11 @@ import Foreign.Ptr
 import Foreign.Marshal.Array
 import Foreign.Marshal
 import Foreign.C.String
+import Foreign.C.Types
 import Foreign.Storable
 
 import Python.Internal.Types
+import Python.Internal.Util
 
 
 -- | Internally we usually wrap 'Py' into 'ContT' in order get early
@@ -64,5 +67,8 @@ withPyAllocaArray = coerce (allocaArray @a @r)
 withPyCString :: forall r. String -> Program r CString
 withPyCString = coerce (withCString @r)
 
+withPyWCString :: forall r. String -> Program r (Ptr CWchar)
+withPyWCString = coerce (withWCString @r)
+
 withPyCStringLen :: forall r. String -> Program r CStringLen
 withPyCStringLen = coerce (withCStringLen @r)
diff --git a/src/Python/Internal/Util.hs b/src/Python/Internal/Util.hs
index 7d370c6..ac7898d 100644
--- a/src/Python/Internal/Util.hs
+++ b/src/Python/Internal/Util.hs
@@ -7,5 +7,5 @@ import Foreign.Marshal.Array
 import Foreign.C.Types
 
 
-withWCtring :: String -> (Ptr CWchar -> IO a) -> IO a
-withWCtring = withArray0 (CWchar 0) . map (fromIntegral . ord)
+withWCString :: String -> (Ptr CWchar -> IO a) -> IO a
+withWCString = withArray0 (CWchar 0) . map (fromIntegral . ord)
diff --git a/test/TST/ToPy.hs b/test/TST/ToPy.hs
index ee70f80..380b1dc 100644
--- a/test/TST/ToPy.hs
+++ b/test/TST/ToPy.hs
@@ -10,10 +10,12 @@ import Python.Inline.QQ
 
 tests :: TestTree
 tests = testGroup "ToPy"
-  [ testCase "Int"          $ let i = 1234    :: Int    in [py_| assert i_hs == 1234    |]
-  , testCase "Double"       $ let i = 1234.25 :: Double in [py_| assert i_hs == 1234.25 |]
-  , testCase "Char ascii"   $ let c = 'a' in [py_| assert c_hs == 'a' |]
-  , testCase "Char unicode" $ let c = 'ы' in [py_| assert c_hs == 'ы' |]
+  [ testCase "Int"            $ let i = 1234    :: Int    in [py_| assert i_hs == 1234    |]
+  , testCase "Double"         $ let i = 1234.25 :: Double in [py_| assert i_hs == 1234.25 |]
+  , testCase "Char ASCII"     $ let c = 'a'    in [py_| assert c_hs == 'a' |]
+  , testCase "Char unicode"   $ let c = 'ы'    in [py_| assert c_hs == 'ы' |]
+  , testCase "String ASCII"   $ let c = "asdf" in [py_| assert c_hs == 'asdf' |]
+  , testCase "String unicode" $ let c = "фыва" in [py_| assert c_hs == 'фыва' |]
     -- Container types
   , testCase "Tuple2" $
       let x = (1::Int, 333::Int)