diff --git a/inline-python.cabal b/inline-python.cabal index 970e0c7..9ed71fe 100644 --- a/inline-python.cabal +++ b/inline-python.cabal @@ -66,10 +66,10 @@ Library pkgconfig-depends: python3-embed -- Exposed-modules: + Python.Inline Python.Inline.Literal Python.Inline.QQ - Python.Inline - Python.Types + Python.Inline.Types Other-modules: Python.Internal.CAPI Python.Internal.Eval diff --git a/src/Python/Inline.hs b/src/Python/Inline.hs index 4e34726..bb22fdf 100644 --- a/src/Python/Inline.hs +++ b/src/Python/Inline.hs @@ -55,8 +55,8 @@ module Python.Inline , FromPy ) where -import Python.Types import Python.Inline.Literal +import Python.Internal.Types import Python.Internal.Eval diff --git a/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs index 201b6bc..76fed0e 100644 --- a/src/Python/Inline/Literal.hs +++ b/src/Python/Inline/Literal.hs @@ -28,7 +28,6 @@ import GHC.Float (float2Double, double2Float) import Language.C.Inline qualified as C import Language.C.Inline.Unsafe qualified as CU -import Python.Types import Python.Internal.Types import Python.Internal.Eval import Python.Internal.CAPI @@ -104,7 +103,7 @@ fromPy' py = unsafeWithPyObject py basicFromPy -- | Convert haskell value to a python object. toPy :: ToPy a => a -> Py PyObject toPy a = basicToPy a >>= \case - NULL -> throwM =<< convertPy2Haskell + NULL -> mustThrowPyError p -> newPyObject p diff --git a/src/Python/Types.hs b/src/Python/Inline/Types.hs similarity index 88% rename from src/Python/Types.hs rename to src/Python/Inline/Types.hs index f6cd4e2..fe45b45 100644 --- a/src/Python/Types.hs +++ b/src/Python/Inline/Types.hs @@ -1,6 +1,6 @@ -- | -- Data types and utilities. -module Python.Types +module Python.Inline.Types ( -- * @Py@ monad Py , runPy diff --git a/src/Python/Internal/Eval.hs b/src/Python/Internal/Eval.hs index b3d20ed..1c79d93 100644 --- a/src/Python/Internal/Eval.hs +++ b/src/Python/Internal/Eval.hs @@ -40,6 +40,7 @@ import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Trans.Cont +import Data.Maybe import Foreign.Concurrent qualified as GHC import Foreign.Ptr import Foreign.ForeignPtr @@ -53,6 +54,7 @@ import System.IO.Unsafe import Language.C.Inline qualified as C import Language.C.Inline.Unsafe qualified as CU +import Python.Internal.CAPI import Python.Internal.Types import Python.Internal.Util import Python.Internal.Program @@ -231,8 +233,8 @@ callbackEnsurePyLock action = do acquireLock :: ThreadId -> STM () acquireLock tid = readTVar globalPyLock >>= \case - LockUninialized -> error "Python is not started" - LockFinalized -> error "Python is already stopped" + LockUninialized -> throwSTM PythonNotInitialized + LockFinalized -> throwSTM PythonIsFinalized LockedByGC -> retry LockUnlocked -> writeTVar globalPyLock $ Locked tid [] Locked t xs @@ -241,20 +243,20 @@ acquireLock tid = readTVar globalPyLock >>= \case grabLock :: ThreadId -> STM () grabLock tid = readTVar globalPyLock >>= \case - LockUninialized -> error "Python is not started" - LockFinalized -> error "Python is already stopped" + LockUninialized -> throwSTM PythonNotInitialized + LockFinalized -> throwSTM PythonIsFinalized LockedByGC -> retry LockUnlocked -> writeTVar globalPyLock $ Locked tid [] Locked t xs -> writeTVar globalPyLock $ Locked tid (t : xs) releaseLock :: ThreadId -> STM () releaseLock tid = readTVar globalPyLock >>= \case - LockUninialized -> error "Python is not started" - LockFinalized -> error "Python is already stopped" - LockUnlocked -> error "INTERNAL ERROR releasing unlocked" - LockedByGC -> error "INTERNAL ERROR lock held by GC" + LockUninialized -> throwSTM PythonNotInitialized + LockFinalized -> throwSTM PythonIsFinalized + LockUnlocked -> throwSTM $ PyInternalError "releaseLock: releasing LockUnlocked" + LockedByGC -> throwSTM $ PyInternalError "releaseLock: releasing LockedByGC" Locked t xs - | t /= tid -> error "INTERNAL ERROR releasing wrong lock" + | t /= tid -> throwSTM $ PyInternalError "releaseLock: releasing wrong lock" | otherwise -> writeTVar globalPyLock $! case xs of [] -> LockUnlocked t':ts -> Locked t' ts @@ -290,8 +292,8 @@ doInializePython = do -- First we need to grab global python lock on haskell side join $ atomically $ do readTVar globalPyState >>= \case - Finalized -> error "Python was already finalized" - InitFailed -> error "Python was unable to initialize" + Finalized -> throwSTM PythonNotInitialized + InitFailed -> throwSTM PythonIsFinalized InInitialization -> retry InFinalization -> retry Running1{} -> pure $ pure () @@ -401,8 +403,8 @@ doInializePythonIO = do doFinalizePython :: IO () doFinalizePython = join $ atomically $ readTVar globalPyState >>= \case - NotInitialized -> error "Python is not initialized" - InitFailed -> error "Python failed to initialize" + NotInitialized -> throwSTM PythonNotInitialized + InitFailed -> throwSTM PythonIsFinalized Finalized -> pure $ pure () InInitialization -> retry InFinalization -> retry @@ -419,8 +421,8 @@ doFinalizePython = join $ atomically $ readTVar globalPyState >>= \case takeMVar resp where checkLock action = readTVar globalPyLock >>= \case - LockUninialized -> error "Internal error: Lock not initialized" - LockFinalized -> error "Internal error: Lock is already finalized" + LockUninialized -> throwSTM $ PyInternalError "doFinalizePython LockUninialized" + LockFinalized -> throwSTM $ PyInternalError "doFinalizePython LockFinalized" Locked{} -> retry LockedByGC -> retry LockUnlocked -> do @@ -459,12 +461,12 @@ runPyInMain :: Py a -> IO a runPyInMain py -- Multithreaded RTS | rtsSupportsBoundThreads = join $ atomically $ readTVar globalPyState >>= \case - NotInitialized -> error "Python is not initialized" - InitFailed -> error "Python failed to initialize" - Finalized -> error "Python is already finalized" + NotInitialized -> throwSTM PythonNotInitialized + InitFailed -> throwSTM PyInitializationFailed + Finalized -> throwSTM PythonIsFinalized InInitialization -> retry InFinalization -> retry - Running1 -> error "INTERNAL ERROR" + Running1 -> throwSTM $ PyInternalError "runPyInMain: Running1" RunningN _ eval tid_main _ -> do acquireLock tid_main pure @@ -572,10 +574,9 @@ convertHaskell2Py err = Py $ do -- | Convert python exception to haskell exception. Should only be -- called if there's unhandled python exception. Clears exception. -convertPy2Haskell :: Py PyError +convertPy2Haskell :: Py PyException convertPy2Haskell = runProgram $ do p_errors <- withPyAllocaArray @(Ptr PyObject) 3 - p_len <- withPyAlloca @CLong -- Fetch error indicator (p_type, p_value) <- progIO $ do [CU.block| void { @@ -587,40 +588,24 @@ convertPy2Haskell = runProgram $ do -- Traceback is not used ATM pure (p_type,p_value) -- Convert exception type and value to strings. - let pythonStr p = do - p_str <- progIO [CU.block| PyObject* { - PyObject *s = PyObject_Str($(PyObject *p)); - if( PyErr_Occurred() ) { - PyErr_Clear(); - } - return s; - } |] - case p_str of - NULL -> abort UncovertablePyError - _ -> pure p_str - s_type <- takeOwnership =<< pythonStr p_type - s_value <- takeOwnership =<< pythonStr p_value - -- Convert to haskell strings - let toString p = do - c_str <- [CU.block| const char* { - const char* s = PyUnicode_AsUTF8AndSize($(PyObject *p), $(long *p_len)); - if( PyErr_Occurred() ) { - PyErr_Clear(); - } - return s; - } |] - case c_str of - NULL -> pure "" - _ -> peekCString c_str - progIO $ PyError <$> toString s_type <*> toString s_value - + 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 + { ty = fromMaybe bad_str s_type + , str = fromMaybe bad_str s_value + , exception = exc + } -- | Throw python error as haskell exception if it's raised. checkThrowPyError :: Py () checkThrowPyError = Py [CU.exp| PyObject* { PyErr_Occurred() } |] >>= \case NULL -> pure () - _ -> throwM =<< convertPy2Haskell + _ -> throwM . PyError =<< convertPy2Haskell -- | Throw python error as haskell exception if it's raised. If it's -- not that internal error. Another exception will be raised @@ -628,7 +613,7 @@ mustThrowPyError :: Py a mustThrowPyError = Py [CU.exp| PyObject* { PyErr_Occurred() } |] >>= \case NULL -> error $ "mustThrowPyError: no python exception raised." - _ -> throwM =<< convertPy2Haskell + _ -> throwM . PyError =<< convertPy2Haskell -- | Calls mustThrowPyError if pointer is null or returns it unchanged throwOnNULL :: Ptr PyObject -> Py (Ptr PyObject) diff --git a/src/Python/Internal/EvalQQ.hs b/src/Python/Internal/EvalQQ.hs index 187ad09..98dde98 100644 --- a/src/Python/Internal/EvalQQ.hs +++ b/src/Python/Internal/EvalQQ.hs @@ -13,6 +13,7 @@ module Python.Internal.EvalQQ ) where import Control.Monad.IO.Class +import Control.Monad.Catch import Data.Bits import Data.Char import Data.List (intercalate) @@ -29,7 +30,6 @@ import Language.C.Inline.Unsafe qualified as CU import Language.Haskell.TH.Lib qualified as TH import Language.Haskell.TH.Syntax qualified as TH -import Python.Types import Python.Internal.Types import Python.Internal.Program import Python.Internal.Eval @@ -125,7 +125,7 @@ evaluatorPyf getSource = runProgram $ do pyExecExpr p_globals p_locals =<< getSource p_kwargs -- Look up function p_fun <- getFunctionObject p_locals >>= \case - NULL -> error "INTERNAL ERROR: _inline_python_ must be present" + NULL -> throwM $ PyInternalError "_inline_python_ must be present" p -> pure p -- Call python function we just constructed newPyObject =<< throwOnNULL =<< basicCallKwdOnly p_fun p_kwargs @@ -204,7 +204,7 @@ expQQ mode qq_src = do ] case code of ExitSuccess -> pure $ words stdout - ExitFailure{} -> error stderr + ExitFailure{} -> fail stderr let args = [ [| basicBindInDict $(TH.lift nm) $(TH.dyn (chop nm)) |] | nm <- antis ] diff --git a/src/Python/Internal/Program.hs b/src/Python/Internal/Program.hs index 9499a33..1152285 100644 --- a/src/Python/Internal/Program.hs +++ b/src/Python/Internal/Program.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} -- | module Python.Internal.Program ( Program(..) @@ -7,6 +9,7 @@ module Python.Internal.Program -- * Control flow , abort , abortM + , abortOnNull , checkNull , finallyProg , onExceptionProg @@ -17,8 +20,11 @@ module Python.Internal.Program , withPyCString , withPyCStringLen , withPyWCString + -- * Helpers + , pyobjectStrAsHask ) where +import Control.Monad import Control.Monad.Trans.Cont import Control.Monad.Trans.Class import Control.Monad.Catch @@ -30,10 +36,18 @@ import Foreign.C.String import Foreign.C.Types 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 import Python.Internal.CAPI +---------------------------------------------------------------- +C.context (C.baseCtx <> pyCtx) +C.include "" +---------------------------------------------------------------- + -- | This monad wraps 'Py' into 'ContT' in order get early exit, -- applying @finally@ while avoiding building huge ladders. @@ -58,11 +72,15 @@ abort r = Program $ ContT $ \_ -> pure r abortM :: Py r -> Program r a abortM m = Program $ ContT $ \_ -> m +-- | Perform early exit if pointer is null +abortOnNull :: r -> Py (Ptr a) -> Program r (Ptr a) +abortOnNull r action = Program $ ContT $ \cnt -> action >>= \case + NULL -> pure r + p -> cnt p + -- | If result of computation is NULL return NULL immediately. checkNull :: Py (Ptr a) -> Program (Ptr a) (Ptr a) -checkNull action = Program $ ContT $ \cnt -> action >>= \case - NULL -> pure nullPtr - p -> cnt p +checkNull = abortOnNull nullPtr -- | Evaluate finalizer even if exception is thrown. finallyProg @@ -99,3 +117,28 @@ withPyWCString = coerce (withWCString @r) withPyCStringLen :: forall r. String -> Program r CStringLen withPyCStringLen = coerce (withCStringLen @r) + + +---------------------------------------------------------------- +-- More complicated helpers +---------------------------------------------------------------- + +-- | Call @__str__@ method of object and return haskell +-- 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* { + PyObject *s = PyObject_Str($(PyObject *p_obj)); + if( PyErr_Occurred() ) { + PyErr_Clear(); + } + return s; + } |] + c_str <- abortOnNull Nothing $ Py [CU.block| const char* { + const char* s = PyUnicode_AsUTF8($(PyObject *p_str)); + if( PyErr_Occurred() ) { + PyErr_Clear(); + } + return s; + } |] + progIO $ Just <$> peekCString c_str diff --git a/src/Python/Internal/Types.hs b/src/Python/Internal/Types.hs index 553edf1..1c137b0 100644 --- a/src/Python/Internal/Types.hs +++ b/src/Python/Internal/Types.hs @@ -11,6 +11,8 @@ module Python.Internal.Types , unsafeWithPyObject , PyThreadState , PyError(..) + , PyException(..) + , PyInternalError(..) , Py(..) , pyIO -- * inline-C @@ -46,18 +48,15 @@ data PyThreadState -- | Some python object. Since almost everything in python is mutable -- it could only be accessed only in IO monad. newtype PyObject = PyObject (ForeignPtr PyObject) + deriving stock Show unsafeWithPyObject :: forall a. PyObject -> (Ptr PyObject -> Py a) -> Py a unsafeWithPyObject = coerce (unsafeWithForeignPtr @PyObject @a) -- | Python exception converted to haskell. data PyError - = PyError String String + = PyError !PyException -- ^ Python exception. Contains exception type and message as strings. - | UncovertablePyError - -- ^ Python exception that could not be converted to haskell for - -- some reason. Its appearance means that something went - -- seriously wrong. | BadPyType -- ^ It's not possible to convert given python value to a haskell -- value @@ -67,10 +66,26 @@ data PyError -- result in this exception. | PyInitializationFailed -- ^ Initialization of python interpreter failed - deriving stock (Show) - -instance Exception PyError - + | PythonNotInitialized + -- ^ Python interpreter is not initialized + | PythonIsFinalized + -- ^ Python interpreter is not initialized + deriving stock (Show) + deriving anyclass (Exception) + +-- | Python exception converted to haskell value +data PyException = PyException + { ty :: !String -- ^ Exception type as a string + , str :: !String -- ^ String representation of an exception + , exception :: !PyObject -- ^ Exception object + } + deriving stock Show + +-- | Internal error. If this exception is thrown it means there's bug +-- in a library. +data PyInternalError = PyInternalError String + deriving stock (Show) + deriving anyclass (Exception) -- | Monad for code which is interacts with python interpreter. Only -- one haskell thread can interact with python interpreter at a diff --git a/test/TST/FromPy.hs b/test/TST/FromPy.hs index 17bfed8..8329149 100644 --- a/test/TST/FromPy.hs +++ b/test/TST/FromPy.hs @@ -7,7 +7,7 @@ import Test.Tasty import Test.Tasty.HUnit import Python.Inline import Python.Inline.QQ -import Python.Types +import Python.Inline.Types tests :: TestTree tests = testGroup "FromPy" diff --git a/test/TST/Util.hs b/test/TST/Util.hs index 8843f2b..8295cd4 100644 --- a/test/TST/Util.hs +++ b/test/TST/Util.hs @@ -6,7 +6,7 @@ import Control.Monad.Catch import Test.Tasty.HUnit import Python.Inline -import Python.Types +import Python.Inline.Types throwsPy :: Py () -> Py () throwsPy io = (io >> liftIO (assertFailure "Evaluation should raise python exception"))