Finer grained control over eval/exec

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

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
+

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"
+  }

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,8 @@
 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
@@ -292,7 +305,7 @@
     Py_Finalize();
     } |]
   -- We need to call Py_Finalize on main thread
   RunningN _ eval _ tid_gc -> checkLock $ do
     killThread tid_gc
     resp <- newEmptyMVar
     putMVar eval $ StopReq resp
@@ -472,7 +485,7 @@
       InInitialization -> retry
       InFinalization   -> retry
       Running1         -> throwSTM $ PyInternalError "runPyInMain: Running1"
       RunningN _ eval tid_main _ -> readTVar globalPyLock >>= \case
         LockUninialized -> throwSTM PythonNotInitialized
         LockFinalized   -> throwSTM PythonIsFinalized
         LockedByGC      -> retry
@@ -498,7 +511,7 @@
                    , evalInOtherThread tid_main eval
                    )
     --
     evalInOtherThread tid_main eval = do
       r <- mask_ $ do resp <- newEmptyMVar
                       putMVar eval $ EvalReq py resp
                       takeMVar resp `onException` throwTo tid_main InterruptMain
@@ -662,6 +675,157 @@
     _ -> 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), "<interactive>", 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), "<interactive>", 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
 ----------------------------------------------------------------