diff --git a/inline-python.cabal b/inline-python.cabal index e6c0db2..c987d45 100644 --- a/inline-python.cabal +++ b/inline-python.cabal @@ -57,7 +57,7 @@ Library , 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 @@ Library Python.Inline Python.Inline.Literal Python.Inline.QQ + Python.Inline.Eval Python.Inline.Types Other-modules: Python.Internal.CAPI diff --git a/src/Python/Inline/Eval.hs b/src/Python/Inline/Eval.hs new file mode 100644 index 0000000..6bd02af --- /dev/null +++ b/src/Python/Inline/Eval.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Interface to python's @eval@ and @exec@ +module Python.Inline.Eval + ( -- * Python execution + eval + , exec + -- * Source code + , PyQuote(..) + , Namespace(..) + , Main(..) + , Temp(..) + , Dict(..) + , Module(..) + -- ** Data types + , Code + , codeFromText + , codeFromString + , DictBinder + ) where + +import Python.Internal.Types +import Python.Internal.Eval + diff --git a/src/Python/Inline/QQ.hs b/src/Python/Inline/QQ.hs index fdefa12..7cb61d4 100644 --- a/src/Python/Inline/QQ.hs +++ b/src/Python/Inline/QQ.hs @@ -34,11 +34,13 @@ module Python.Inline.QQ , 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 +50,7 @@ import Python.Internal.EvalQQ -- 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 +63,7 @@ pymain = QuasiQuoter -- 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 +75,7 @@ py_ = QuasiQuoter -- 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" @@ -90,3 +92,17 @@ pyf = QuasiQuoter , 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 index ca5970d..f538786 100644 --- a/src/Python/Internal/Eval.hs +++ b/src/Python/Internal/Eval.hs @@ -29,6 +29,17 @@ module Python.Internal.Eval , mustThrowPyError , checkThrowBadPyType , throwOnNULL + -- * Exec & eval + , Namespace(..) + , Main(..) + , Temp(..) + , Dict(..) + , DictPtr(..) + , Module(..) + , ModulePtr(..) + , unsafeWithCode + , eval + , exec -- * Debugging , debugPrintPy ) where @@ -42,6 +53,8 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Cont import Data.Maybe import Data.Function +import Data.ByteString qualified as BS +import Data.ByteString.Unsafe qualified as BS import Foreign.Concurrent qualified as GHC import Foreign.Ptr import Foreign.ForeignPtr @@ -662,6 +675,157 @@ checkThrowBadPyType = do _ -> 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 takes ownership of returned + -- object. + basicNamespaceDict :: a -> Py (Ptr PyObject) + + +-- | Namespace for the top level code execution. +-- +-- @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 bare python object. It's assumed to be a +-- dictionary. This is not checked. +-- +-- @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 +-- +-- @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 +-- +-- @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) + + ---------------------------------------------------------------- -- Debugging ---------------------------------------------------------------- diff --git a/src/Python/Internal/EvalQQ.hs b/src/Python/Internal/EvalQQ.hs index 98dde98..ee475a6 100644 --- 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 @@ module Python.Internal.EvalQQ 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.context (C.baseCtx <> pyCtx) 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) = Program $ ContT $ \fun -> + Py (BS.unsafeUseAsCString bs $ unsafeRunPy . fun) -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 @@ expQQ mode qq_src = do 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/Types.hs b/src/Python/Internal/Types.hs index 3e615fe..d3db0f6 100644 --- 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 @@ module Python.Internal.Types , PyInternalError(..) , Py(..) , pyIO + -- ** Python code wrappers + , PyQuote(..) + , Code(..) + , codeFromText + , codeFromString + , DictBinder(..) -- * inline-C , pyCtx -- * Patterns @@ -33,9 +40,13 @@ import Control.Monad.Primitive (PrimMonad(..),RealWorld) 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 @@ -54,6 +65,9 @@ data PyThreadState 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) @@ -73,7 +87,7 @@ data PyError | PythonNotInitialized -- ^ Python interpreter is not initialized | PythonIsFinalized - -- ^ Python interpreter is not initialized + -- ^ Python interpreter is not initialized deriving stock (Show) deriving anyclass (Exception) @@ -116,6 +130,52 @@ instance PrimMonad Py where {-# INLINE primitive #-} +---------------------------------------------------------------- +-- Code wrappers +---------------------------------------------------------------- + +-- | Quasiquoted python code. It contains source code and closure +-- which populates dictionary with local variables. +-- +-- @since 0.2@ +data PyQuote = PyQuote + { code :: !Code + , binder :: !DictBinder + } + + +-- | UTF-8 encoded python source code. Usually it's produced by +-- Template Haskell's 'TH.lift' function. +-- +-- @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 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 ---------------------------------------------------------------- diff --git a/test/TST/FromPy.hs b/test/TST/FromPy.hs index 0727640..43ddce1 100644 --- a/test/TST/FromPy.hs +++ b/test/TST/FromPy.hs @@ -11,6 +11,9 @@ import Python.Inline import Python.Inline.QQ import Data.Complex (Complex((:+))) +import TST.Util + + tests :: TestTree tests = testGroup "FromPy" [ testGroup "Int" @@ -91,9 +94,6 @@ tests = testGroup "FromPy" ] ] -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 Left PyError{} -> pure () diff --git a/test/TST/Run.hs b/test/TST/Run.hs index 6c8c442..6f5892f 100644 --- a/test/TST/Run.hs +++ b/test/TST/Run.hs @@ -6,10 +6,12 @@ import Control.Concurrent 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 @@ -131,6 +133,37 @@ tests = testGroup "Run python" 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' + |] ] data Stop = Stop diff --git a/test/TST/Util.hs b/test/TST/Util.hs index df918e8..826dfe5 100644 --- a/test/TST/Util.hs +++ b/test/TST/Util.hs @@ -16,3 +16,5 @@ throwsPyIO :: IO () -> IO () 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)