Add MonadPy and quasiquoters

ChangeLog.md

@@ -1,14 +1,20 @@
 0.3.0.0 [XXXX.XX.XX]
 --------------------
-* Support for asynchronous execution added in module `Python.Inline.Async`.
-  It adds API copied from `async` and interruptible python computations.
-* `runPyInMain` could be reliably interrupted by asynchronous exceptions.
-* Package now uses `Custom` build type. It now supports configuring python using
-  `python3-config` instead of `pkg-config` when `-fpython3-config` manual cabal
-  flag is set. Default behavior is unchanged.
+* Support for asynchronous execution added in module `Python.Inline.Async`.  It
+  uses API modelled after `async` package. Such computations could be
+  interrupted using `cancelPy` even when they're running python code or haskell
+  callback/
+* When threaded runtime is used `runPyInMain` could be reliably interrupted by
+  asynchronous exceptions.
 * Python module `inline_python` is now available. It contains exception types
   used by library: `AsyncCancelled` and `HaskellError` which wraps haskell
   exception from callback.
+* `Python.Inline.Monad` and `Python.Inline.Monad.QQ` modules providing monadic
+  API. It uses `MonadPy` type class which allows user code to carry around
+  python dictionaries with global and local scopes.
+* Package now uses `Custom` build type. It now supports configuring python using
+  `python3-config` instead of `pkg-config` when `-fpython3-config` manual cabal
+  flag is set. Default behavior is unchanged.
 * Haskell exception raised in haskell callback will be rethrown if not caught by
   python instead of being converted to `PyError`.
 * Memory leak in exception handling is fixed. Python exception object were never

inline-python.cabal

@@ -91,11 +91,13 @@ Library
   --
   Exposed-modules:
     Python.Inline
+    Python.Inline.Async
+    Python.Inline.Eval
     Python.Inline.Literal
+    Python.Inline.Monad
+    Python.Inline.Monad.QQ
     Python.Inline.QQ
-    Python.Inline.Eval
     Python.Inline.Types
-    Python.Inline.Async
   Other-modules:
     Python.Internal.CAPI
     Python.Internal.Eval

src/Python/Inline/Eval.hs

@@ -7,6 +7,7 @@ module Python.Inline.Eval
   ( -- * Python execution
     eval
   , exec
+  , evalPyFunction
     -- * Source code
   , PyQuote(..)
   , Code

src/Python/Inline/Monad.hs

@@ -0,0 +1,33 @@
+-- |
+module Python.Inline.Monad
+  ( -- * Type classes
+    Namespace(..)
+  , MonadPy(..)
+  ) where
+
+import Python.Internal.Eval
+import Python.Internal.Types
+
+-- | Monad which can carry dictionaries or object of global and local
+--   python variables around. It's expected that it's some variant of
+--   wrapper around 'Py'.
+--
+--   For @Py@ global variables are 'Main' and local are 'Temp'
+class Monad m => MonadPy m where
+  -- | Lift @Py@ computation into given monad.
+  liftPy :: Py a -> m a
+  -- | Provide set of global variables. CPS style is used to avoid
+  --   specifying type of global used by monad (and allow picking it
+  --   at runtime).
+  withGlobals
+    :: (forall globals. Namespace globals => globals -> m a)
+    -> m a
+  -- | Same for local variables
+  withLocals
+    :: (forall locals. Namespace locals => locals -> m a)
+    -> m a
+
+instance MonadPy Py where
+  liftPy = id
+  withGlobals f = f Main
+  withLocals  f = f Temp

src/Python/Inline/Monad/QQ.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE TemplateHaskell #-}
+-- |
+-- These quasiquotes are analogous to ones defined in
+-- "Python.Inline.QQ" but they produce splices which are polymorphic
+-- in 'MonadPy'. For 'Py' in particular they behave identically. 
+module Python.Inline.Monad.QQ
+  ( pymain
+  , py_
+  , pye
+  , pyf
+  , pycode
+  ) where
+
+
+import Language.Haskell.TH.Quote
+
+import Python.Internal.EvalQQ
+import Python.Internal.Eval
+import Python.Inline.Monad
+import Python.Inline.QQ (pycode)
+
+
+
+-- | Evaluate sequence of python statements. It uses python's @exec@.
+--   Both global and local scope for this quasiquoter are global
+--   variables for 'MonadPy'
+--
+--   It creates value of type @MonadPy m => m ()@
+pymain :: QuasiQuoter
+pymain = QuasiQuoter
+  { quoteExp  = \txt -> [|
+     withGlobals $ \globals -> 
+       liftPy $ exec globals globals $(expQQ Exec txt)
+     |]
+  , quotePat  = error "quotePat"
+  , quoteType = error "quoteType"
+  , quoteDec  = error "quoteDec"
+  }
+
+-- | Evaluate sequence of python statements. Global and local
+--   variables for this quasiquoter are determined by 'MonadPy'
+--   instance.
+--
+--   It creates value of type @MonadPy m => m ()@
+py_ :: QuasiQuoter
+py_ = QuasiQuoter
+  { quoteExp  = \txt -> [|
+      withGlobals $ \globals ->
+        withLocals $ \locals -> 
+          liftPy $ exec globals locals $(expQQ Exec txt)
+      |]
+  , quotePat  = error "quotePat"
+  , quoteType = error "quoteType"
+  , quoteDec  = error "quoteDec"
+  }
+
+-- | Evaluate single python expression. It only accepts single
+--   expressions same as python's @eval@. Its globals are variables
+--   are determined by 'MonadPy' instance.
+--
+--   This quote creates object of type @MonadPy m => m PyObject@
+pye :: QuasiQuoter
+pye = QuasiQuoter
+  { quoteExp  = \txt -> [|
+      withGlobals $ \globals ->
+        withLocals $ \locals -> 
+          liftPy $ eval globals locals $(expQQ Eval txt)
+      |]
+  , quotePat  = error "quotePat"
+  , quoteType = error "quoteType"
+  , quoteDec  = error "quoteDec"
+  }
+
+-- | Another quasiquoter which works around that sequence of python
+--   statements doesn't have any value associated with it. Content of
+--   quasiquote is function body. So to get value out of it one must
+--   call return. Its globals are determined by 'MonadPy' instance. 
+--   Just like python function it always creates new scope.
+--
+--   This quote creates object of type @Py PyObject@
+pyf :: QuasiQuoter
+pyf = QuasiQuoter
+  { quoteExp  = \txt -> [|
+      withGlobals $ \globals ->
+        liftPy $ evalPyFunction globals $(expQQ Fun txt)
+      |]
+  , quotePat  = error "quotePat"
+  , quoteType = error "quoteType"
+  , quoteDec  = error "quoteDec"
+  }

src/Python/Inline/QQ.hs

@@ -52,7 +52,7 @@ import Python.Internal.Eval
 
 
 -- | Evaluate sequence of python statements. It uses python's @exec@.
---   Both global and local state for this quasiquoter are variables of
+--   Both global and local scope for this quasiquoter are variables of
 --   @\__main__@ module. Any variables including imported modules will
 --   remain visible to later quasiquotes.
 --
@@ -102,7 +102,7 @@ pye = QuasiQuoter
 --   This quote creates object of type @Py PyObject@
 pyf :: QuasiQuoter
 pyf = QuasiQuoter
-  { quoteExp  = \txt -> [| evaluatorPyf $(expQQ Fun txt) |]
+  { quoteExp  = \txt -> [| evalPyFunction Main $(expQQ Fun txt) |]
   , quotePat  = error "quotePat"
   , quoteType = error "quoteType"
   , quoteDec  = error "quoteDec"

src/Python/Internal/Eval.hs

@@ -49,6 +49,7 @@ module Python.Internal.Eval
   , unsafeWithCode
   , eval
   , exec
+  , evalPyFunction
     -- * Debugging
   , debugPrintPy
   ) where
@@ -1096,6 +1097,35 @@ exec globals locals q = runProgram $ do
 {-# SPECIALIZE exec :: Main -> Main -> PyQuote -> Py () #-}
 {-# SPECIALIZE exec :: Main -> Temp -> PyQuote -> Py () #-}
 
+-- | Evaluate code as if it's a function body and bound arguments are
+--   parameters to that function. Just like function it could return
+--   value and always creates new scope.
+--
+-- @since 0.3
+evalPyFunction
+  :: Namespace global
+  => global  -- ^ Global variables
+  -> PyQuote -- ^ Source code
+  -> Py PyObject
+evalPyFunction globals (PyQuote code binder) = runProgram $ do
+  p_locals <- takeOwnership =<< progPy basicNewDict
+  p_kwargs <- takeOwnership =<< progPy basicNewDict
+  progPy $ do
+    -- Create function in p_locals
+    exec globals (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
+
+getFunctionObject :: Ptr PyObject -> Py (Ptr PyObject)
+getFunctionObject p_dict = do
+  Py [CU.exp| PyObject* { PyDict_GetItemString($(PyObject *p_dict), "_inline_python_") } |]
+
+
 -- | Obtain pointer to code
 unsafeWithCode :: Code -> Program r (Ptr CChar)
 unsafeWithCode (Code bs) = Program $ ContT $ \fun ->

src/Python/Internal/EvalQQ.hs

@@ -2,15 +2,13 @@
 {-# LANGUAGE TemplateHaskell #-}
 -- |
 module Python.Internal.EvalQQ
-  ( -- * Evaluators and QQ
-    evaluatorPyf
-    -- * Code generation
-  , expQQ
+  ( -- * Code generation
+    expQQ
   , Mode(..)
   ) where
 
 import Control.Monad.IO.Class
 import Control.Monad.Catch
 import Data.Bits
 import Data.Char
 import Data.List                 (intercalate)
@@ -31,7 +29,7 @@
 import Python.Internal.Types
 import Python.Internal.Program
 import Python.Internal.Eval
 import Python.Internal.CAPI
 import Python.Inline.Literal
 
 
@@ -68,31 +66,6 @@
 
 
 
-----------------------------------------------------------------
--- 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
-    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
-
-getFunctionObject :: Ptr PyObject -> Py (Ptr PyObject)
-getFunctionObject p_dict = do
-  Py [CU.exp| PyObject* { PyDict_GetItemString($(PyObject *p_dict), "_inline_python_") } |]
-
-
-
 ----------------------------------------------------------------
 -- TH generator
 ----------------------------------------------------------------

test/TST/Run.hs

@@ -207,7 +207,7 @@ tests = testGroup "Run python"
           forever [py_| loop_hs() |]
         d <- registerDelay 100_000
         threadDelay 100
-        forkIO $ cancelPy a
+        _ <- forkIO $ cancelPy a
         _ <- atomically $ waitPyCatch a `orElse` do readTVar d >>= \case
                                                       True  -> error "Timeout"
                                                       False -> retry
@@ -226,6 +226,17 @@ tests = testGroup "Run python"
                  |]
                error "Should be interrupted"
     ]
+    -- Here we only test that quasiquotes produce correct code
+  , testGroup "Monadic"
+    [ testCase "pymain" $ runPy [pymain| assert True |]
+    , testCase "py_"    $ runPy [py_|    assert True |]
+    , testCase "pye" $ runPy $ do
+        n <- fromPy =<< [pye| 42 |]
+        liftIO $ Just (42::Int) @=? n
+    , testCase "pyf" $ runPy $ do
+        n <- fromPy =<< [pyf| return 42 |]
+        liftIO $ Just (42::Int) @=? n
+    ]
   ]
 
 data Stop = Stop