diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,11 @@ +0.2 [2025.05.04] +---------------- +* `FromPy`/`ToPy` instances added for: `Complex`, both strict and lazy `Text` & + `ByteString`, `ShortByteString`, `Maybe a` +* Module `Python.Inline.Eval` added which support for eval/exec with user + supplied global and local variables. +* QuasiQuotes `Python.Inline.QQ.pycode` added for creating `PyQuote` data type. + 0.1.1.1 [2025.03.10] -------------------- * Crash of python's main thread when one attempts to interrupt it fixed. diff --git a/inline-python.cabal b/inline-python.cabal --- a/inline-python.cabal +++ b/inline-python.cabal @@ -2,7 +2,7 @@ Build-Type: Simple Name: inline-python -Version: 0.1.1.1 +Version: 0.2 Synopsis: Python interpreter embedded into haskell. Description: This package embeds python interpreter into haskell program and @@ -57,7 +57,7 @@ , stm >=2.4 , template-haskell -any , text >=2 - , bytestring + , bytestring >=0.11.2 , exceptions >=0.10 , vector >=0.13 hs-source-dirs: src @@ -70,6 +70,7 @@ Python.Inline Python.Inline.Literal Python.Inline.QQ + Python.Inline.Eval Python.Inline.Types Other-modules: Python.Internal.CAPI @@ -93,6 +94,8 @@ , exceptions , containers , vector + , bytestring + , text hs-source-dirs: test Exposed-modules: TST.Run diff --git a/src/Python/Inline/Eval.hs b/src/Python/Inline/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Python/Inline/Eval.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Interface to python's @eval@ and @exec@ which gives programmer +-- control over local and global variables. +module Python.Inline.Eval + ( -- * Python execution + eval + , exec + -- * Source code + , PyQuote(..) + , Code + , codeFromText + , codeFromString + , DictBinder + , bindVar + -- * Variable namespaces + , Namespace(..) + , Main(..) + , Temp(..) + , Dict(..) + , Module(..) + ) where + +import Data.ByteString.Unsafe qualified as BS +import Data.Text (Text) +import Data.Text.Encoding qualified as T +import Language.C.Inline qualified as C +import Language.C.Inline.Unsafe qualified as CU + +import Python.Internal.Types +import Python.Internal.Eval +import Python.Internal.Program +import Python.Inline.Literal + + +---------------------------------------------------------------- +C.context (C.baseCtx <> pyCtx) +C.include "" +---------------------------------------------------------------- + +-- | Bind variable in dictionary +bindVar + :: (ToPy a) + => Text -- ^ Variable name + -> a -- ^ Variable value + -> DictBinder +bindVar name a = DictBinder $ \p_dict -> runProgram $ do + p_key <- progIOBracket $ BS.unsafeUseAsCString (T.encodeUtf8 name) + p_obj <- takeOwnership =<< progPy (throwOnNULL =<< basicToPy a) + progPy $ do + r <- Py [CU.block| int { + PyObject* p_obj = $(PyObject* p_obj); + return PyDict_SetItemString($(PyObject* p_dict), $(char* p_key), p_obj); + } |] + case r of + 0 -> pure () + _ -> mustThrowPyError + diff --git a/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs --- a/src/Python/Inline/Literal.hs +++ b/src/Python/Inline/Literal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} -- | @@ -13,6 +14,7 @@ , fromPy' ) where +import Control.Exception (evaluate) import Control.Monad import Control.Monad.Catch import Control.Monad.Trans.Cont @@ -20,8 +22,15 @@ import Data.Char import Data.Int import Data.Word +import Data.ByteString qualified as BS +import Data.ByteString.Unsafe qualified as BS +import Data.ByteString.Short qualified as SBS +import Data.ByteString.Lazy qualified as BL import Data.Set qualified as Set import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Text.Lazy qualified as TL import Data.Vector.Generic qualified as VG import Data.Vector.Generic.Mutable qualified as MVG import Data.Vector qualified as V @@ -34,7 +43,10 @@ import Foreign.Ptr import Foreign.C.Types import Foreign.Storable +import Foreign.Marshal.Alloc (alloca,mallocBytes) +import Foreign.Marshal.Utils (copyBytes) import GHC.Float (float2Double, double2Float) +import Data.Complex (Complex((:+))) import Language.C.Inline qualified as C import Language.C.Inline.Unsafe qualified as CU @@ -127,6 +139,11 @@ instance FromPy PyObject where basicFromPy p = incref p >> newPyObject p +deriving newtype instance ToPy Module +deriving newtype instance FromPy Module +deriving newtype instance ToPy Dict +deriving newtype instance FromPy Dict + instance ToPy () where basicToPy () = Py [CU.exp| PyObject* { Py_None } |] @@ -191,7 +208,29 @@ instance ToPy Float where basicToPy = basicToPy . float2Double instance FromPy Float where basicFromPy = fmap double2Float . basicFromPy +-- | @since 0.2 +instance ToPy (Complex Float) where + basicToPy (x:+y) = basicToPy $ float2Double x :+ float2Double y +-- | @since 0.2 +instance FromPy (Complex Float) where + basicFromPy xy_py = do + x :+ y <- basicFromPy xy_py + return $ double2Float x :+ double2Float y +-- | @since 0.2 +instance ToPy (Complex Double) where + basicToPy (x:+y) = Py [CU.exp| PyObject* { PyComplex_FromDoubles($(double x'), $(double y')) } |] + where x' = CDouble x + y' = CDouble y +-- | @since 0.2 +instance FromPy (Complex Double) where + basicFromPy xy_py = do + CDouble x <- Py [CU.exp| double { PyComplex_RealAsDouble($(PyObject *xy_py)) } |] + checkThrowBadPyType + CDouble y <- Py [CU.exp| double { PyComplex_ImagAsDouble($(PyObject *xy_py)) } |] + checkThrowBadPyType + return $ x :+ y + instance ToPy Int where basicToPy | wordSizeInBits == 64 = basicToPy @Int64 . fromIntegral @@ -377,6 +416,24 @@ d <- basicFromPy p_d pure (a,b,c,d) + +-- | @Nothing@ is encoded as @None@. @Just a@ same as @a@. +-- +-- @since 0.2 +instance (ToPy a) => ToPy (Maybe a) where + basicToPy Nothing = Py [CU.exp| PyObject* { Py_None } |] + basicToPy (Just a) = basicToPy a + +-- | @None@ is decoded as @Nothing@ rest is attempted to be decoded as @a@ +-- +-- @since 0.2 +instance (FromPy a) => FromPy (Maybe a) where + basicFromPy p = + Py [CU.exp| bool { Py_None == $(PyObject *p) } |] >>= \case + 0 -> Just <$> basicFromPy p + _ -> pure Nothing + + instance (ToPy a) => ToPy [a] where basicToPy = basicListToPy @@ -483,7 +540,7 @@ #endif --- | Fold over iterable. Function takes ownership over iterator. +-- | Fold over python's iterator. Function takes ownership over iterator. foldPyIterable :: Ptr PyObject -- ^ Python iterator (not checked) -> (a -> Ptr PyObject -> Py a) -- ^ Step function. It takes borrowed pointer. @@ -529,6 +586,119 @@ where n = VG.length vec n_c = fromIntegral n :: CLLong + + +-- | Converted to @bytes@ +-- +-- @since 0.2 +instance ToPy BS.ByteString where + basicToPy bs = pyIO $ BS.unsafeUseAsCStringLen bs $ \(ptr,len) -> do + let c_len = fromIntegral len :: CLLong + py <- [CU.exp| PyObject* { PyBytes_FromStringAndSize($(char* ptr), $(long long c_len)) }|] + case py of + NULL -> unsafeRunPy mustThrowPyError + _ -> return py + +-- | Accepts @bytes@ and @bytearray@ +-- +-- @since 0.2 +instance FromPy BS.ByteString where + basicFromPy py = pyIO $ do + [CU.exp| int { PyBytes_Check($(PyObject* py)) } |] >>= \case + TRUE -> do + sz <- [CU.exp| int64_t { PyBytes_GET_SIZE( $(PyObject* py)) } |] + buf <- [CU.exp| char* { PyBytes_AS_STRING($(PyObject* py)) } |] + fini buf (fromIntegral sz) + _ -> [CU.exp| int { PyByteArray_Check($(PyObject* py)) } |] >>= \case + TRUE -> do + sz <- [CU.exp| int64_t { PyByteArray_GET_SIZE( $(PyObject* py)) } |] + buf <- [CU.exp| char* { PyByteArray_AS_STRING($(PyObject* py)) } |] + fini buf (fromIntegral sz) + _ -> throwM BadPyType + where + fini py_buf sz = do + hs_buf <- mallocBytes sz + copyBytes hs_buf py_buf sz + BS.unsafePackMallocCStringLen (hs_buf, sz) + +-- | Converted to @bytes@ +-- +-- @since 0.2 +instance ToPy BL.ByteString where + basicToPy = basicToPy . BL.toStrict + +-- | Accepts @bytes@ and @bytearray@ +-- +-- @since 0.2 +instance FromPy BL.ByteString where + basicFromPy = fmap BL.fromStrict . basicFromPy + + +-- | Accepts @bytes@ and @bytearray@ +-- +-- @since 0.2 +instance FromPy SBS.ShortByteString where + basicFromPy py = pyIO $ do + [CU.exp| int { PyBytes_Check($(PyObject* py)) } |] >>= \case + TRUE -> do + sz <- [CU.exp| int64_t { PyBytes_GET_SIZE( $(PyObject* py)) } |] + buf <- [CU.exp| char* { PyBytes_AS_STRING($(PyObject* py)) } |] + fini buf (fromIntegral sz) + _ -> [CU.exp| int { PyByteArray_Check($(PyObject* py)) } |] >>= \case + TRUE -> do + sz <- [CU.exp| int64_t { PyByteArray_GET_SIZE( $(PyObject* py)) } |] + buf <- [CU.exp| char* { PyByteArray_AS_STRING($(PyObject* py)) } |] + fini buf (fromIntegral sz) + _ -> throwM BadPyType + where + fini buf sz = do + bs <- BS.unsafePackCStringLen (buf, sz) + evaluate $ SBS.toShort bs + +-- | Converted to @bytes@ +-- +-- @since 0.2 +instance ToPy SBS.ShortByteString where + basicToPy bs = pyIO $ SBS.useAsCStringLen bs $ \(ptr,len) -> do + let c_len = fromIntegral len :: CLLong + py <- [CU.exp| PyObject* { PyBytes_FromStringAndSize($(char* ptr), $(long long c_len)) }|] + case py of + NULL -> unsafeRunPy mustThrowPyError + _ -> return py + + +-- | @since 0.2@. +instance ToPy T.Text where + -- NOTE: Is there ore efficient way to access + basicToPy str = pyIO $ BS.unsafeUseAsCStringLen bs $ \(ptr,len) -> do + let c_len = fromIntegral len :: CLLong + py <- [CU.exp| PyObject* { PyUnicode_FromStringAndSize($(char* ptr), $(long long c_len)) } |] + case py of + NULL -> unsafeRunPy mustThrowPyError + _ -> pure py + where + bs = T.encodeUtf8 str + +-- | @since 0.2@. +instance ToPy TL.Text where + basicToPy = basicToPy . TL.toStrict + +-- | @since 0.2@. +instance FromPy T.Text where + basicFromPy py = pyIO $ do + [CU.exp| int { PyUnicode_Check($(PyObject* py)) } |] >>= \case + TRUE -> alloca $ \p_size -> do + buf <- [CU.exp| const char* { PyUnicode_AsUTF8AndSize($(PyObject* py), $(long* p_size)) } |] + sz <- peek p_size + bs <- BS.unsafePackCStringLen (buf, fromIntegral sz) + return $! T.decodeUtf8Lenient bs + _ -> throwM BadPyType + +-- | @since 0.2@. +instance FromPy TL.Text where + basicFromPy = fmap TL.fromStrict . basicFromPy + + ---------------------------------------------------------------- -- Functions marshalling diff --git a/src/Python/Inline/QQ.hs b/src/Python/Inline/QQ.hs --- a/src/Python/Inline/QQ.hs +++ b/src/Python/Inline/QQ.hs @@ -29,16 +29,21 @@ -- > do_this() -- > do_that() -- > |] +-- +-- If control over python's global and local variables is +-- required. APIs from "Python.Inline.Eval" should be used instead. module Python.Inline.QQ ( pymain , py_ , pye , pyf + , pycode ) where import Language.Haskell.TH.Quote import Python.Internal.EvalQQ +import Python.Internal.Eval -- | Evaluate sequence of python statements. It works in the same way @@ -48,7 +53,7 @@ -- It creates value of type @Py ()@ pymain :: QuasiQuoter pymain = QuasiQuoter - { quoteExp = \txt -> [| evaluatorPymain $(expQQ Exec txt) |] + { quoteExp = \txt -> [| exec Main Main $(expQQ Exec txt) |] , quotePat = error "quotePat" , quoteType = error "quoteType" , quoteDec = error "quoteDec" @@ -61,7 +66,7 @@ -- It creates value of type @Py ()@ py_ :: QuasiQuoter py_ = QuasiQuoter - { quoteExp = \txt -> [| evaluatorPy_ $(expQQ Exec txt) |] + { quoteExp = \txt -> [| exec Main Temp $(expQQ Exec txt) |] , quotePat = error "quotePat" , quoteType = error "quoteType" , quoteDec = error "quoteDec" @@ -73,7 +78,7 @@ -- This quote creates object of type @Py PyObject@ pye :: QuasiQuoter pye = QuasiQuoter - { quoteExp = \txt -> [| evaluatorPye $(expQQ Eval txt) |] + { quoteExp = \txt -> [| eval Main Temp $(expQQ Eval txt) |] , quotePat = error "quotePat" , quoteType = error "quoteType" , quoteDec = error "quoteDec" @@ -86,6 +91,20 @@ pyf :: QuasiQuoter pyf = QuasiQuoter { quoteExp = \txt -> [| evaluatorPyf $(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' +-- +-- It creates value of type @PyQuote@ +-- +-- @since 0.2@ +pycode :: QuasiQuoter +pycode = QuasiQuoter + { quoteExp = \txt -> expQQ Exec txt , quotePat = error "quotePat" , quoteType = error "quoteType" , quoteDec = error "quoteDec" diff --git a/src/Python/Internal/Eval.hs b/src/Python/Internal/Eval.hs --- a/src/Python/Internal/Eval.hs +++ b/src/Python/Internal/Eval.hs @@ -29,6 +29,17 @@ , mustThrowPyError , checkThrowBadPyType , throwOnNULL + -- * Exec & eval + , Namespace(..) + , Main(..) + , Temp(..) + , Dict(..) + , DictPtr(..) + , Module(..) + , ModulePtr(..) + , unsafeWithCode + , eval + , exec -- * Debugging , debugPrintPy ) where @@ -42,6 +53,7 @@ import Control.Monad.Trans.Cont import Data.Maybe import Data.Function +import Data.ByteString.Unsafe qualified as BS import Foreign.Concurrent qualified as GHC import Foreign.Ptr import Foreign.ForeignPtr @@ -292,10 +304,10 @@ Py_Finalize(); } |] -- We need to call Py_Finalize on main thread - RunningN _ eval _ tid_gc -> checkLock $ do + RunningN _ lock_eval _ tid_gc -> checkLock $ do killThread tid_gc resp <- newEmptyMVar - putMVar eval $ StopReq resp + putMVar lock_eval $ StopReq resp takeMVar resp where checkLock action = readTVar globalPyLock >>= \case @@ -472,7 +484,7 @@ InInitialization -> retry InFinalization -> retry Running1 -> throwSTM $ PyInternalError "runPyInMain: Running1" - RunningN _ eval tid_main _ -> readTVar globalPyLock >>= \case + RunningN _ eval_lock tid_main _ -> readTVar globalPyLock >>= \case LockUninialized -> throwSTM PythonNotInitialized LockFinalized -> throwSTM PythonIsFinalized LockedByGC -> retry @@ -480,9 +492,9 @@ LockUnlocked -> do writeTVar globalPyLock $ Locked tid_main [] pure ( atomically (releaseLock tid_main) - , evalInOtherThread tid_main eval + , evalInOtherThread tid_main eval_lock ) - -- If we can grab lock and main thread taken lock we're + -- 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 @@ -495,12 +507,12 @@ | otherwise -> do writeTVar globalPyLock $ Locked tid_main (t : ts) pure ( atomically (releaseLock tid_main) - , evalInOtherThread tid_main eval + , evalInOtherThread tid_main eval_lock ) -- - evalInOtherThread tid_main eval = do + evalInOtherThread tid_main eval_lock = do r <- mask_ $ do resp <- newEmptyMVar - putMVar eval $ EvalReq py resp + putMVar eval_lock $ EvalReq py resp takeMVar resp `onException` throwTo tid_main InterruptMain either throwM pure r @@ -660,6 +672,158 @@ case r of 0 -> pure () _ -> throwM BadPyType + + +---------------------------------------------------------------- +-- Eval/exec +---------------------------------------------------------------- + +-- | Type class for values representing python dictionaries containing +-- global or local variables. +-- +-- @since 0.2@ +class Namespace a where + -- | Returns dictionary object. Caller should take ownership of + -- returned object. + basicNamespaceDict :: a -> Py (Ptr PyObject) + + +-- | Namespace for the top level code execution. It corresponds to +-- @\__dict\__@ field of a @\__main\__@ module. +-- +-- @since 0.2@ +data Main = Main + +instance Namespace Main where + basicNamespaceDict _ = + throwOnNULL =<< Py [CU.block| PyObject* { + PyObject* main_module = PyImport_AddModule("__main__"); + if( PyErr_Occurred() ) + return NULL; + PyObject* dict = PyModule_GetDict(main_module); + Py_XINCREF(dict); + return dict; + }|] + + +-- | Temporary namespace which get destroyed after execution +-- +-- @since 0.2@ +data Temp = Temp + +instance Namespace Temp where + basicNamespaceDict _ = basicNewDict + + +-- | Newtype wrapper for bare python object. It's assumed to be a +-- dictionary. This is not checked. +-- +-- @since 0.2@ +newtype DictPtr = DictPtr (Ptr PyObject) + +instance Namespace DictPtr where + basicNamespaceDict (DictPtr p) = p <$ incref p + + +-- | Newtype wrapper for python dictionary. It's not checked whether +-- object is actually dictionary. +-- +-- @since 0.2@ +newtype Dict = Dict PyObject + +instance Namespace Dict where + basicNamespaceDict (Dict d) + -- NOTE: We're incrementing counter inside bracket so we're safe. + = unsafeWithPyObject d (basicNamespaceDict . DictPtr) + +-- | Newtype wrapper over module object. +-- +-- @since 0.2@ +newtype ModulePtr = ModulePtr (Ptr PyObject) + +instance Namespace ModulePtr where + basicNamespaceDict (ModulePtr p) = do + throwOnNULL =<< Py [CU.block| PyObject* { + PyObject* dict = PyModule_GetDict($(PyObject* p)); + Py_XINCREF(dict); + return dict; + }|] + +-- | Newtype wrapper over module object. +newtype Module = Module PyObject + +instance Namespace Module where + basicNamespaceDict (Module d) + -- NOTE: We're incrementing counter inside bracket so we're safe. + = unsafeWithPyObject d (basicNamespaceDict . ModulePtr) + + +-- | Evaluate python expression. This is wrapper over python's @eval@. +-- +-- @since 0.2@ +eval :: (Namespace global, Namespace local) + => global -- ^ Data type providing global variables dictionary + -> local -- ^ Data type providing local variables dictionary + -> PyQuote -- ^ Source code + -> Py PyObject +eval globals locals q = runProgram $ do + p_py <- unsafeWithCode q.code + p_globals <- takeOwnership =<< progPy (basicNamespaceDict globals) + p_locals <- takeOwnership =<< progPy (basicNamespaceDict locals) + progPy $ do + q.binder.bind p_locals + p_res <- Py [C.block| PyObject* { + PyObject* globals = $(PyObject* p_globals); + PyObject* locals = $(PyObject* p_locals); + // Compile code + PyObject *code = Py_CompileString($(char* p_py), "", Py_eval_input); + if( PyErr_Occurred() ) { + return NULL; + } + // Evaluate expression + PyObject* r = PyEval_EvalCode(code, globals, locals); + Py_DECREF(code); + return r; + }|] + checkThrowPyError + newPyObject p_res +{-# SPECIALIZE eval :: Main -> Temp -> PyQuote -> Py PyObject #-} + +-- | Evaluate sequence of python statements This is wrapper over python's @exec@. +-- +-- @since 0.2@ +exec :: (Namespace global, Namespace local) + => global -- ^ Data type providing global variables dictionary + -> local -- ^ Data type providing local variables dictionary + -> PyQuote -- ^ Source code + -> Py () +exec globals locals q = runProgram $ do + p_py <- unsafeWithCode q.code + p_globals <- takeOwnership =<< progPy (basicNamespaceDict globals) + p_locals <- takeOwnership =<< progPy (basicNamespaceDict locals) + progPy $ do + q.binder.bind p_locals + Py[C.block| void { + PyObject* globals = $(PyObject* p_globals); + PyObject* locals = $(PyObject* p_locals); + // Compile code + PyObject *code = Py_CompileString($(char* p_py), "", Py_file_input); + if( PyErr_Occurred() ){ + return; + } + // Execute statements + PyObject* res = PyEval_EvalCode(code, globals, locals); + Py_XDECREF(res); + Py_DECREF(code); + } |] + checkThrowPyError +{-# SPECIALIZE exec :: Main -> Main -> PyQuote -> Py () #-} +{-# SPECIALIZE exec :: Main -> Temp -> PyQuote -> Py () #-} + +-- | Obtain pointer to code +unsafeWithCode :: Code -> Program r (Ptr CChar) +unsafeWithCode (Code bs) = Program $ ContT $ \fun -> + Py (BS.unsafeUseAsCString bs $ unsafeRunPy . fun) ---------------------------------------------------------------- diff --git a/src/Python/Internal/EvalQQ.hs b/src/Python/Internal/EvalQQ.hs --- a/src/Python/Internal/EvalQQ.hs +++ b/src/Python/Internal/EvalQQ.hs @@ -3,10 +3,7 @@ -- | module Python.Internal.EvalQQ ( -- * Evaluators and QQ - evaluatorPymain - , evaluatorPy_ - , evaluatorPye - , evaluatorPyf + evaluatorPyf -- * Code generation , expQQ , Mode(..) @@ -14,10 +11,12 @@ 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) import Data.ByteString qualified as BS +import Data.ByteString.Unsafe qualified as BS import Data.Text qualified as T import Data.Text.Encoding qualified as T import Foreign.C.Types @@ -42,117 +41,53 @@ C.include "" ---------------------------------------------------------------- ----------------------------------------------------------------- --- Evaluators ----------------------------------------------------------------- +-- | Python's variable name encoded using UTF-8. It exists in order to +-- avoid working with @String@ at runtime. +newtype PyVarName = PyVarName BS.ByteString + deriving stock (Show, TH.Lift) --- | Evaluate expression within context of @__main__@ module. All --- variables defined in this evaluator persist. -pyExecExpr - :: Ptr PyObject -- ^ Globals - -> Ptr PyObject -- ^ Locals - -> String -- ^ Python source code - -> Py () -pyExecExpr p_globals p_locals src = runProgram $ do - p_py <- withPyCString src - progPy $ do - Py [C.block| void { - PyObject* globals = $(PyObject* p_globals); - PyObject* locals = $(PyObject* p_locals); - // Compile code - PyObject *code = Py_CompileString($(char* p_py), "", Py_file_input); - if( PyErr_Occurred() ){ - return; - } - // Execute statements - PyObject* res = PyEval_EvalCode(code, globals, locals); - Py_XDECREF(res); - Py_DECREF(code); - } |] - checkThrowPyError +varName :: String -> PyVarName +varName = PyVarName . T.encodeUtf8 . T.pack --- | Evaluate expression with fresh local environment -pyEvalExpr - :: Ptr PyObject -- ^ Globals - -> Ptr PyObject -- ^ Locals - -> String -- ^ Python source code - -> Py PyObject -pyEvalExpr p_globals p_locals src = runProgram $ do - p_py <- withPyCString src - progPy $ do - p_res <- Py [C.block| PyObject* { - PyObject* globals = $(PyObject* p_globals); - PyObject* locals = $(PyObject* p_locals); - // Compile code - PyObject *code = Py_CompileString($(char* p_py), "", Py_eval_input); - if( PyErr_Occurred() ) { - return NULL; - } - // Evaluate expression - PyObject* r = PyEval_EvalCode(code, globals, locals); - Py_DECREF(code); - return r; - }|] - checkThrowPyError - newPyObject p_res +unsafeWithPyVarName :: PyVarName -> Program r (Ptr CChar) +unsafeWithPyVarName (PyVarName bs) + = progIOBracket (BS.unsafeUseAsCString bs) -evaluatorPymain :: (Ptr PyObject -> Py String) -> Py () -evaluatorPymain getSource = do - p_main <- basicMainDict - src <- getSource p_main - pyExecExpr p_main p_main src +bindVar :: ToPy a => PyVarName -> a -> DictBinder +bindVar var a = DictBinder $ \p_dict -> runProgram $ do + p_key <- unsafeWithPyVarName var + p_obj <- takeOwnership =<< progPy (throwOnNULL =<< basicToPy a) + progPy $ do + r <- Py [CU.block| int { + PyObject* p_obj = $(PyObject* p_obj); + return PyDict_SetItemString($(PyObject* p_dict), $(char* p_key), p_obj); + } |] + case r of + 0 -> pure () + _ -> mustThrowPyError -evaluatorPy_ :: (Ptr PyObject -> Py String) -> Py () -evaluatorPy_ getSource = runProgram $ do - p_globals <- progPy basicMainDict - p_locals <- takeOwnership =<< progPy basicNewDict - progPy $ pyExecExpr p_globals p_locals =<< getSource p_locals -evaluatorPye :: (Ptr PyObject -> Py String) -> Py PyObject -evaluatorPye getSource = runProgram $ do - p_globals <- progPy basicMainDict - p_locals <- takeOwnership =<< progPy basicNewDict - progPy $ pyEvalExpr p_globals p_locals =<< getSource p_locals -evaluatorPyf :: (Ptr PyObject -> Py String) -> Py PyObject -evaluatorPyf getSource = runProgram $ do - p_globals <- progPy basicMainDict - p_locals <- takeOwnership =<< progPy basicNewDict - p_kwargs <- takeOwnership =<< progPy basicNewDict +---------------------------------------------------------------- +-- 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 - pyExecExpr p_globals p_locals =<< getSource p_kwargs + 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 - -basicBindInDict :: ToPy a => String -> a -> Ptr PyObject -> Py () -basicBindInDict name a p_dict = runProgram $ do - p_key <- withPyCString name - p_obj <- takeOwnership =<< progPy (throwOnNULL =<< basicToPy a) - progPy $ do - r <- Py [C.block| int { - PyObject* p_obj = $(PyObject* p_obj); - return PyDict_SetItemString($(PyObject* p_dict), $(char* p_key), p_obj); - } |] - case r of - 0 -> pure () - _ -> mustThrowPyError - --- | Return dict of @__main__@ module -basicMainDict :: Py (Ptr PyObject) -basicMainDict = Py [CU.block| PyObject* { - PyObject* main_module = PyImport_AddModule("__main__"); - if( PyErr_Occurred() ) - return NULL; - return PyModule_GetDict(main_module); - }|] - getFunctionObject :: Ptr PyObject -> Py (Ptr PyObject) getFunctionObject p_dict = do Py [CU.exp| PyObject* { PyDict_GetItemString($(PyObject *p_dict), "_inline_python_") } |] @@ -205,14 +140,13 @@ case code of ExitSuccess -> pure $ words stdout ExitFailure{} -> fail stderr - let args = [ [| basicBindInDict $(TH.lift nm) $(TH.dyn (chop nm)) |] + let args = [ [| bindVar $(TH.lift (varName nm)) $(TH.dyn (chop nm)) |] | nm <- antis ] src_eval = prepareForEval mode antis src -- - [| \p_dict -> do - mapM_ ($ p_dict) $(TH.listE args) - pure $(TH.lift src_eval) + [| PyQuote ($(TH.lift $ codeFromString src_eval)) + (mconcat $(TH.listE args)) |] diff --git a/src/Python/Internal/Program.hs b/src/Python/Internal/Program.hs --- a/src/Python/Internal/Program.hs +++ b/src/Python/Internal/Program.hs @@ -6,6 +6,7 @@ , runProgram , progPy , progIO + , progIOBracket -- * Control flow , abort , abortM @@ -63,6 +64,9 @@ progPy :: Py a -> Program r a progPy = Program . lift + +progIOBracket :: ((a -> IO r) -> IO r) -> Program r a +progIOBracket = coerce -- | Early exit from continuation monad. abort :: r -> Program r a diff --git a/src/Python/Internal/Types.hs b/src/Python/Internal/Types.hs --- a/src/Python/Internal/Types.hs +++ b/src/Python/Internal/Types.hs @@ -9,6 +9,7 @@ module Python.Internal.Types ( -- * Data type PyObject(..) + , withPyObject , unsafeWithPyObject , PyThreadState , PyError(..) @@ -16,6 +17,12 @@ , PyInternalError(..) , Py(..) , pyIO + -- ** Python code wrappers + , PyQuote(..) + , Code(..) + , codeFromText + , codeFromString + , DictBinder(..) -- * inline-C , pyCtx -- * Patterns @@ -23,6 +30,8 @@ , pattern IPY_ERR_COMPILE , pattern IPY_ERR_PYTHON , pattern NULL + , pattern FALSE + , pattern TRUE ) where import Control.Monad.IO.Class @@ -31,9 +40,13 @@ import Control.Exception import Data.Coerce import Data.Int +import Data.ByteString qualified as BS import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Foreign.Ptr import Foreign.C.Types +import Language.Haskell.TH.Syntax qualified as TH import GHC.ForeignPtr import Language.C.Types @@ -52,6 +65,9 @@ newtype PyObject = PyObject (ForeignPtr PyObject) deriving stock Show +withPyObject :: forall a. PyObject -> (Ptr PyObject -> Py a) -> Py a +withPyObject = coerce (withForeignPtr @PyObject @a) + unsafeWithPyObject :: forall a. PyObject -> (Ptr PyObject -> Py a) -> Py a unsafeWithPyObject = coerce (unsafeWithForeignPtr @PyObject @a) @@ -71,7 +87,7 @@ | PythonNotInitialized -- ^ Python interpreter is not initialized | PythonIsFinalized - -- ^ Python interpreter is not initialized + -- ^ Python interpreter is not initialized deriving stock (Show) deriving anyclass (Exception) @@ -115,6 +131,53 @@ ---------------------------------------------------------------- +-- Code wrappers +---------------------------------------------------------------- + +-- | Quasiquoted python code. It contains source code and closure +-- which populates dictionary with local variables. @PyQuote@ value +-- which captures local variables could be created using +-- 'Python.Inline.QQ.pycode' quasiquoter. +-- +-- @since 0.2@ +data PyQuote = PyQuote + { code :: !Code + , binder :: !DictBinder + } + + +-- | UTF-8 encoded python source code. +-- +-- @since 0.2@ +newtype Code = Code BS.ByteString + deriving stock (Show, TH.Lift) + +-- | Create properly encoded @Code@. This function doesn't check +-- syntactic validity. +-- +-- @since 0.2@ +codeFromText :: T.Text -> Code +codeFromText = Code . T.encodeUtf8 + +-- | Create properly encoded @Code@. This function doesn't check +-- syntactic validity. +-- +-- @since 0.2@ +codeFromString :: String -> Code +codeFromString = codeFromText . T.pack + +-- | Closure which stores values in provided python dictionary. +-- +-- @since 0.2@ +newtype DictBinder = DictBinder { bind :: Ptr PyObject -> Py () } + +instance Semigroup DictBinder where + f <> g = DictBinder $ \p -> f.bind p >> g.bind p +instance Monoid DictBinder where + mempty = DictBinder $ \_ -> pure () + + +---------------------------------------------------------------- -- inline-C ---------------------------------------------------------------- @@ -148,3 +211,9 @@ pattern NULL :: Ptr a pattern NULL <- ((== nullPtr) -> True) where NULL = nullPtr + +pattern FALSE :: CInt +pattern FALSE = 0 + +pattern TRUE :: CInt +pattern TRUE <- ((/= 0) -> True) diff --git a/test/TST/FromPy.hs b/test/TST/FromPy.hs --- a/test/TST/FromPy.hs +++ b/test/TST/FromPy.hs @@ -1,13 +1,19 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} -- | module TST.FromPy (tests) where +import Data.ByteString qualified as BS import Control.Monad.IO.Class import Test.Tasty import Test.Tasty.HUnit import Python.Inline import Python.Inline.QQ +import Data.Complex (Complex((:+))) +import TST.Util + + tests :: TestTree tests = testGroup "FromPy" [ testGroup "Int" @@ -20,6 +26,13 @@ , testCase "Double->Double" $ eq @Double (Just 1234.25) [pye| 1234.25 |] , testCase "None->Double" $ eq @Double Nothing [pye| None |] ] + , testGroup "Complex" + [ testCase "Int->Complex" $ eq @(Complex Double) (Just 1234) [pye| 1234 |] + , testCase "Double->Complex" $ eq @(Complex Double) (Just 1234.25) [pye| 1234.25 |] + , testCase "Complex->Complex" $ eq @(Complex Double) (Just $ 1234.5 :+ 6789) + [pye| 1234.5+6789.0j |] + , testCase "None->Complex" $ eq @(Complex Double) Nothing [pye| None |] + ] , testGroup "Char" [ testCase "0" $ eq @Char Nothing [pye| "" |] , testCase "1 1B" $ eq @Char (Just 'a') [pye| "a" |] @@ -31,6 +44,12 @@ [ testCase "asdf" $ eq @String (Just "asdf") [pye| "asdf" |] , testCase "фыва" $ eq @String (Just "фыва") [pye| "фыва" |] ] + , testGroup "ByteString" + [ testCase "empty" $ eq @BS.ByteString (Just "") [pye| b'' |] + , testCase "x00" $ eq @BS.ByteString (Just $ BS.pack [0]) [pye| b'\x00' |] + , testCase "empty arr" $ eq @BS.ByteString (Just "") [pye| bytearray(b'') |] + , testCase "x00 arr" $ eq @BS.ByteString (Just $ BS.pack [0]) [pye| bytearray(b'\x00') |] + ] , testGroup "Bool" [ testCase "True->Bool" $ eq @Bool (Just True) [pye| True |] , testCase "False->Bool" $ eq @Bool (Just False) [pye| False |] @@ -74,9 +93,6 @@ , testCase "Int" $ eq @[Int] Nothing [pye| None |] ] ] - -eq :: (Eq a, Show a, FromPy a) => Maybe a -> (Py PyObject) -> IO () -eq a action = assertEqual "fromPy: " a =<< runPy (fromPy =<< action) failE :: forall a. (Eq a, Show a, FromPy a) => PyObject -> Py () failE p = fromPyEither @a p >>= \case diff --git a/test/TST/Roundtrip.hs b/test/TST/Roundtrip.hs --- a/test/TST/Roundtrip.hs +++ b/test/TST/Roundtrip.hs @@ -8,14 +8,22 @@ import Data.Typeable import Data.Set (Set) import Data.Map.Strict (Map) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Complex (Complex) import Foreign.C.Types import Test.Tasty import Test.Tasty.QuickCheck import Test.QuickCheck.Instances.Vector () +import Test.QuickCheck.Instances.ByteString () +import Test.QuickCheck.Instances.Text () import Python.Inline import Python.Inline.QQ +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.ByteString.Short qualified as SBS import Data.Vector qualified as V #if MIN_VERSION_vector(0,13,2) import Data.Vector.Strict qualified as VV @@ -54,6 +62,9 @@ -- Floating point , testRoundtrip @Double , testRoundtrip @Float + -- Complex + , testRoundtrip @(Complex Double) + , testRoundtrip @(Complex Float) -- Other scalars , testRoundtrip @Char , testRoundtrip @Bool @@ -62,8 +73,11 @@ , testRoundtrip @(Int,(Int,Int)) , testRoundtrip @(Int,Int,Int) , testRoundtrip @(Int,Int,Int,Char) + , testRoundtrip @(Maybe Int) + , testRoundtrip @(Maybe T.Text) , testRoundtrip @[Int] , testRoundtrip @[[Int]] + , testRoundtrip @[Complex Double] , testRoundtrip @(Set Int) , testRoundtrip @(Map Int Int) -- , testRoundtrip @String -- Trips on zero byte as it should @@ -74,6 +88,11 @@ #if MIN_VERSION_vector(0,13,2) -- , testRoundtrip @(VV.Vector Int) #endif + , testRoundtrip @BS.ByteString + , testRoundtrip @BL.ByteString + , testRoundtrip @SBS.ShortByteString + , testRoundtrip @T.Text + , testRoundtrip @TL.Text ] , testGroup "OutOfRange" [ testOutOfRange @Int8 @Int16 diff --git a/test/TST/Run.hs b/test/TST/Run.hs --- a/test/TST/Run.hs +++ b/test/TST/Run.hs @@ -6,10 +6,12 @@ import Control.Exception import Control.Monad import Control.Monad.IO.Class +import Data.Map.Strict qualified as Map import Test.Tasty import Test.Tasty.HUnit import Python.Inline import Python.Inline.QQ +import Python.Inline.Eval import TST.Util tests :: TestTree @@ -130,6 +132,37 @@ assert False, "x shouln't be visible (2)" except NameError: pass + |] + , testCase "pyf works" $ do + let x = 12 :: Int + eq (Just (482412::Int)) [pyf| + xs = [i*x_hs for i in [1, 200, 40000]] + return sum(xs) + |] + , testCase "exec with Dict" $ runPy $ do + dct <- [pye| {} |] + exec Main (Dict dct) [pycode| + a = 12 + b = 13 + |] + throwsPy $ exec Main (Module dct) [pycode| |] + d <- fromPy dct + liftIO $ assertEqual "dict" (Just (Map.fromList [("a",12::Int),("b",13)])) d + , testCase "exec with Module" $ runPy $ do + m <- [pyf| + import importlib.util + spec = importlib.util.spec_from_loader("dyn", loader=None) + return importlib.util.module_from_spec(spec) + |] + exec Main (Module m) [pycode| + a = 12 + b = 'asd' + |] + [py_| + import types + isinstance(m_hs, types.ModuleType) + assert m_hs.a == 12 + assert m_hs.b == 'asd' |] ] diff --git a/test/TST/ToPy.hs b/test/TST/ToPy.hs --- a/test/TST/ToPy.hs +++ b/test/TST/ToPy.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} -- | module TST.ToPy (tests) where -import Data.Set qualified as Set -import Data.Map.Strict qualified as Map +import Data.ByteString qualified as BS +import Data.Set qualified as Set +import Data.Map.Strict qualified as Map +import Data.Complex (Complex((:+))) import Test.Tasty import Test.Tasty.HUnit import Python.Inline @@ -14,10 +17,18 @@ tests = testGroup "ToPy" [ testCase "Int" $ runPy $ let i = 1234 :: Int in [py_| assert i_hs == 1234 |] , testCase "Double" $ runPy $ let i = 1234.25 :: Double in [py_| assert i_hs == 1234.25 |] + , testCase "Complex" $ runPy $ + let z = 5.5 :+ 7.5 :: Complex Double + in [py_| assert (z_hs.real == 5.5); assert (z_hs.imag == 7.5)|] , testCase "Char ASCII" $ runPy $ let c = 'a' in [py_| assert c_hs == 'a' |] , testCase "Char unicode" $ runPy $ let c = 'ы' in [py_| assert c_hs == 'ы' |] - , testCase "String ASCII" $ runPy $ let c = "asdf" in [py_| assert c_hs == 'asdf' |] - , testCase "String unicode" $ runPy $ let c = "фыва" in [py_| assert c_hs == 'фыва' |] + , testCase "String ASCII" $ runPy $ let c = "asdf"::String in [py_| assert c_hs == 'asdf' |] + , testCase "String unicode" $ runPy $ let c = "фыва"::String in [py_| assert c_hs == 'фыва' |] + -- Byte objects + , testCase "empty ByteString" $ runPy $ + let bs = BS.empty in [py_| assert bs_hs == b'' |] + , testCase "0 ByteString" $ runPy $ + let bs = BS.pack [0] in [py_| assert bs_hs == b'\x00' |] -- Container types , testCase "Tuple2" $ runPy $ let x = (1::Int, 333::Int) diff --git a/test/TST/Util.hs b/test/TST/Util.hs --- a/test/TST/Util.hs +++ b/test/TST/Util.hs @@ -6,7 +6,6 @@ import Test.Tasty.HUnit import Python.Inline -import Python.Inline.Types throwsPy :: Py () -> Py () throwsPy io = (io >> liftIO (assertFailure "Evaluation should raise python exception")) @@ -16,3 +15,5 @@ throwsPyIO io = (io >> assertFailure "Evaluation should raise python exception") `catch` (\(_::PyError) -> pure ()) +eq :: (Eq a, Show a, FromPy a) => Maybe a -> (Py PyObject) -> IO () +eq a action = assertEqual "fromPy: " a =<< runPy (fromPy =<< action)