inline-python (empty) → 0.1
raw patch · 24 files changed
+3091/−0 lines, 24 filesdep +basedep +bytestringdep +containers
Dependencies added: base, bytestring, containers, exceptions, inline-c, inline-python, primitive, process, quickcheck-instances, stm, tasty, tasty-bench, tasty-hunit, tasty-quickcheck, template-haskell, text, transformers, vector
Files
- ChangeLog.md +0/−0
- LICENSE +30/−0
- bench/Main.hs +15/−0
- cbits/python.c +142/−0
- include/inline-python.h +53/−0
- inline-python.cabal +149/−0
- py/bound-vars.py +23/−0
- src/Python/Inline.hs +119/−0
- src/Python/Inline/Literal.hs +664/−0
- src/Python/Inline/QQ.hs +92/−0
- src/Python/Inline/Types.hs +19/−0
- src/Python/Internal/CAPI.hs +58/−0
- src/Python/Internal/Eval.hs +650/−0
- src/Python/Internal/EvalQQ.hs +272/−0
- src/Python/Internal/Program.hs +144/−0
- src/Python/Internal/Types.hs +150/−0
- src/Python/Internal/Util.hs +11/−0
- test/TST/Callbacks.hs +101/−0
- test/TST/FromPy.hs +85/−0
- test/TST/Roundtrip.hs +118/−0
- test/TST/Run.hs +114/−0
- test/TST/ToPy.hs +49/−0
- test/TST/Util.hs +14/−0
- test/exe/main.hs +19/−0
+ ChangeLog.md view
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright 2024 (c) Alexey Khudyakov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ bench/Main.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE QuasiQuotes #-}+module Main where++import Test.Tasty.Bench++import Python.Inline+import Python.Inline.QQ+++main :: IO ()+main = withPython $ do+ py_int <- runPy [pye| 123456 |]+ defaultMain+ [ bench "FromPy Int" $ whnfIO $ runPy $ fromPy' @Int py_int+ ]
+ cbits/python.c view
@@ -0,0 +1,142 @@+#include <inline-python.h>+#include <stdlib.h>++// ================================================================+// Callbacks+//+// General idea: we store function pointer (haskell's FunPtr) in+// PyCapsule and use to call function. Most importantly we must+// release GIL before calling into haskell. Haskell callback will+// happen on different thread (on threaded RTS). So it'll have to+// reacquire GIL there.+// ================================================================++// Same wrapper works for METH_O and METH_NOARGS+static PyObject* callback_METH_CFunction(PyObject* self, PyObject* arg) {+ PyObject *res;+ PyCFunction *fun = PyCapsule_GetPointer(self, NULL);+Py_BEGIN_ALLOW_THREADS+ res = (*fun)(self, arg);+Py_END_ALLOW_THREADS+ return res;+}++static PyObject* callback_METH_FASTCALL(PyObject* self, PyObject** args, Py_ssize_t nargs) {+ PyObject *res;+ PyCFunctionFast *fun = PyCapsule_GetPointer(self, NULL);+Py_BEGIN_ALLOW_THREADS+ res = (*fun)(self, args, nargs);+Py_END_ALLOW_THREADS+ return res;+}++static void capsule_free_FunPtr(PyObject* capsule) {+ PyCFunction *fun = PyCapsule_GetPointer(capsule, NULL);+ // We call directly to haskell RTS to free FunPtr. Only question+ // is how stable is this API.+ freeHaskellFunctionPtr(*fun);+ free(fun);+}++static PyMethodDef method_METH_NOARGS = {+ .ml_name = "[inline_python]",+ .ml_meth = callback_METH_CFunction,+ .ml_flags = METH_NOARGS,+ .ml_doc = "Wrapper for haskell callback"+};++static PyMethodDef method_METH_O = {+ .ml_name = "[inline_python]",+ .ml_meth = callback_METH_CFunction,+ .ml_flags = METH_O,+ .ml_doc = "Wrapper for haskell callback"+};++static PyMethodDef method_METH_FASTCALL = {+ .ml_name = "[inline_python]",+ .ml_meth = (PyCFunction)callback_METH_FASTCALL,+ .ml_flags = METH_FASTCALL,+ .ml_doc = "Wrapper for haskell callback"+};++PyObject *inline_py_callback_METH_NOARGS(PyCFunction fun) {+ PyCFunction *buf = malloc(sizeof(PyCFunction));+ *buf = fun;+ PyObject* self = PyCapsule_New(buf, NULL, &capsule_free_FunPtr);+ if( PyErr_Occurred() )+ return NULL;+ // Python function+ PyObject* f = PyCFunction_New(&method_METH_NOARGS, self);+ Py_DECREF(self);+ return f;+}++PyObject *inline_py_callback_METH_O(PyCFunction fun) {+ PyCFunction *buf = malloc(sizeof(PyCFunction));+ *buf = fun;+ PyObject* self = PyCapsule_New(buf, NULL, &capsule_free_FunPtr);+ if( PyErr_Occurred() )+ return NULL;+ // Python function+ PyObject* f = PyCFunction_New(&method_METH_O, self);+ Py_DECREF(self);+ return f;+}++PyObject *inline_py_callback_METH_FASTCALL(PyCFunctionFast fun) {+ PyCFunctionFast *buf = malloc(sizeof(PyCFunctionFast));+ *buf = fun;+ PyObject* self = PyCapsule_New(buf, NULL, &capsule_free_FunPtr);+ if( PyErr_Occurred() )+ return NULL;+ // Python function+ PyObject* f = PyCFunction_New(&method_METH_FASTCALL, self);+ Py_DECREF(self);+ return f;+}+++// ================================================================+// Marshalling+// ================================================================++int inline_py_unpack_iterable(PyObject *iterable, int n, PyObject **out) {+ // Initialize iterator. If object is not an iterable we treat this+ // as not an exception but as a conversion failure+ PyObject* iter = PyObject_GetIter( iterable );+ if( PyErr_Occurred() ) {+ PyErr_Clear();+ return -1;+ }+ if( !PyIter_Check(iter) ) {+ goto err_iter;+ }+ // Fill out with NULL. This way we can call XDECREF on them+ for(int i = 0; i < n; i++) {+ out[i] = NULL;+ }+ // Fill elements+ for(int i = 0; i < n; i++) {+ out[i] = PyIter_Next(iter);+ if( NULL==out[i] ) {+ goto err_elem;+ }+ }+ // End of iteration+ PyObject* end = PyIter_Next(iter);+ if( NULL != end || PyErr_Occurred() ) {+ goto err_end;+ }+ return 0;+ //----------------------------------------+err_end:+ Py_XDECREF(end);+err_elem:+ for(int i = 0; i < n; i++) {+ Py_XDECREF(out[i]);+ }+err_iter:+ Py_DECREF(iter);+ return -1;+}+
+ include/inline-python.h view
@@ -0,0 +1,53 @@+#pragma once++#define PY_SSIZE_T_CLEAN+#include <Python.h>+#include <Rts.h>+++// Available since 3.13+#ifndef PyCFunctionFast+typedef _PyCFunctionFast PyCFunctionFast;+#endif++// Available since 3.13+//+// We define here compat dummy which always says No+#ifndef Py_IsFinalizing+#define Py_IsFinalizing(x) 0+#endif++++// ================================================================+// Callbacks+// ================================================================++// Wrap haskell callback using METH_NOARGS calling convention+PyObject *inline_py_callback_METH_NOARGS(PyCFunction fun);++// Wrap haskell callback using METH_O calling convention+PyObject *inline_py_callback_METH_O(PyCFunction fun);++// Wrap haskell callback using METH_FASTCALL calling convention+PyObject *inline_py_callback_METH_FASTCALL(PyCFunctionFast fun);++++// ================================================================+// Marhsalling+// ================================================================++// Unpack iterable into array of PyObjects. Iterable must contain+// exactly N elements.+//+// On success returns 0 and fills `out` with N PyObjects+//+// On failure return -1. Content of out is then undefined and it+// doesn't contain live python objects. If failure is due to python+// exception it's not cleared.+int inline_py_unpack_iterable(+ PyObject *iterable,+ int n,+ PyObject **out+ );
+ inline-python.cabal view
@@ -0,0 +1,149 @@+Cabal-Version: 3.0+Build-Type: Simple++Name: inline-python+Version: 0.1+Synopsis: Python interpreter embedded into haskell.+Description:+ This package embeds python interpreter into haskell program and+ allows to write python snippets as quasiquotes. Values could be+ easily transferred between python and haskell. It's possible to+ call haskell from python as well.++License: BSD-3-Clause+License-File: LICENSE+Author: Aleksey Khudyakov <alexey.skladnoy@gmail.com>+Maintainer: Aleksey Khudyakov <alexey.skladnoy@gmail.com>+Homepage: https://github.com/Shimuuar/inline-python+Bug-reports: https://github.com/Shimuuar/inline-python/issues+Category: FFI+extra-doc-files:+ ChangeLog.md+extra-source-files:+ include/inline-python.h+ py/bound-vars.py++source-repository head+ type: git+ location: http://github.com/Shimuuar/inline-python++common language+ Ghc-options: -Wall+ Default-Language: GHC2021+ Default-Extensions:+ NoPolyKinds+ --+ DeriveAnyClass+ DerivingVia+ PatternSynonyms+ ViewPatterns+ LambdaCase+ MultiWayIf+ --+ NoFieldSelectors+ DuplicateRecordFields+ OverloadedRecordDot++----------------------------------------------------------------+Library+ import: language+ Build-Depends: base >=4.14 && <5+ , primitive >=0.6.2+ , vector >=0.13.2+ , containers >=0.5+ , process+ , transformers >=0.4+ , inline-c >=0.9.1+ , stm >=2.4+ , template-haskell -any+ , text >=2+ , bytestring+ , exceptions >=0.10+ , vector >=0.13+ hs-source-dirs: src+ include-dirs: include+ c-sources: cbits/python.c+ cc-options: -g -Wall+ pkgconfig-depends: python3-embed+ --+ Exposed-modules:+ Python.Inline+ Python.Inline.Literal+ Python.Inline.QQ+ Python.Inline.Types+ Other-modules:+ Python.Internal.CAPI+ Python.Internal.Eval+ Python.Internal.EvalQQ+ Python.Internal.Program+ Python.Internal.Types+ Python.Internal.Util++----------------------------------------------------------------+library test+ import: language+ Default-Extensions:+ QuasiQuotes+ build-depends: base+ , inline-python+ , tasty >=1.2+ , tasty-hunit >=0.10+ , tasty-quickcheck >=0.10+ , quickcheck-instances >=0.3.32+ , exceptions+ , containers+ , vector+ hs-source-dirs: test+ Exposed-modules:+ TST.Run+ TST.ToPy+ TST.FromPy+ TST.Callbacks+ TST.Roundtrip+ TST.Util++-- Running tests using several threads does very good job at finding threading+-- bugs. Especially deadlocks+test-suite inline-python-tests+ import: language+ type: exitcode-stdio-1.0+ Ghc-options: -threaded -with-rtsopts=-N2+ hs-source-dirs: test/exe+ main-is: main.hs+ build-depends: base+ , inline-python+ , inline-python:test+ , tasty++test-suite inline-python-tests1+ import: language+ type: exitcode-stdio-1.0+ hs-source-dirs: test/exe+ main-is: main.hs+ build-depends: base+ , inline-python+ , inline-python:test+ , tasty++benchmark pysmall+ import: language+ type: exitcode-stdio-1.0+ Ghc-options: -threaded+ main-is: Main.hs+ hs-source-dirs: bench+ build-depends:+ base >= 2 && < 5+ , inline-python+ , tasty+ , tasty-bench >= 0.2.1++benchmark pysmall1+ import: language+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench+ build-depends:+ base >= 2 && < 5+ , inline-python+ , tasty+ , tasty-bench >= 0.2.1
+ py/bound-vars.py view
@@ -0,0 +1,23 @@+"""+Extract variable names to be bound by haskell code+"""+import ast+import sys+import re+import base64++mode = sys.argv[1]+is_hs = re.compile('.*_hs$')++def extract_hs_vars(code):+ for node in ast.walk(code):+ if isinstance(node, ast.Name) and is_hs.match(node.id):+ yield node.id++def print_hs_vars(src):+ code = ast.parse(src, '<interactive>', mode)+ for nm in set(extract_hs_vars(code)):+ print(nm)++def decode_and_print(codeB64):+ print_hs_vars(base64.b16decode(codeB64, casefold=True).decode('utf8'))
+ src/Python/Inline.hs view
@@ -0,0 +1,119 @@+-- | This library allows to embed as quasiquotes and execute arbitrary+-- python code in haskell programs. Take for example following program:+--+-- > {-# LANGUAGE QuasiQuotes #-}+-- > import Python.Inline+-- > import Python.Inline.QQ+-- >+-- > main :: IO ()+-- > main = withPython $ do+-- > let input = [1..10] :: [Int]+-- > let square :: Int -> Py Int+-- > square x = pure (x * x)+-- > print =<< runPy $ do+-- > fromPy' @[Int] =<< [pye| [ square_hs(x) for x in input_hs ] |]+--+-- Quasiquotation 'Python.Inline.QQ.pye' captures variables @input@+-- and @square@ from environment and produces python object which+-- `fromPy'` converts to haskell list. As one expect it would output:+--+-- > [1,4,9,16,25,36,49,64,81,100]+--+-- Module "Python.Inline.QQ" provides several quasiquoters with+-- different semantics but general rules are:+--+-- 1. All python variables ending with @_hs@ are captured from+-- environment and converted to python objects according to their+-- 'ToPy' instance.+--+-- 2. Syntax errors in embedded python will be caught during+-- compilation.+--+-- 3. All code interacting with python must be in 'Py' monad which+-- could be run using 'runPy'.+--+-- 4. Python interpreter must be initialized before calling any+-- python code.+module Python.Inline+ ( -- * Interpreter initialization+ -- $initialization+ initializePython+ , finalizePython+ , withPython+ -- * Core data types+ , Py+ , runPy+ , runPyInMain+ , PyObject+ , PyError(..)+ , PyException(..)+ -- * Conversion between haskell and python+ -- $conversion+ , toPy+ , fromPyEither+ , fromPy+ , fromPy'+ , ToPy+ , FromPy+ -- * Troubleshooting+ -- $troubleshooting+ ) where++import Python.Inline.Literal+import Python.Internal.Types+import Python.Internal.Eval+++-- $initialization+--+-- Python supports being initialized and shut down multiple times. +-- This however has caveats. Quoting it documentation:+--+-- > Bugs and caveats: The destruction of modules and objects in+-- > modules is done in random order; this may cause destructors+-- > (__del__() methods) to fail when they depend on other objects+-- > (even functions) or modules. Dynamically loaded extension+-- > modules loaded by Python are not unloaded. Small amounts of+-- > memory allocated by the Python interpreter may not be freed (if+-- > you find a leak, please report it). Memory tied up in circular+-- > references between objects is not freed. Some memory allocated+-- > by extension modules may not be freed. Some extensions may not+-- > work properly if their initialization routine is called more+-- > than once.+--+-- More importantly for this library. All pointers held by 'PyObject'+-- becomes invalid after interpreter is shut down. If GC tries to run+-- finalizers after interpreter is intialized again program will+-- surely segfault.+--+-- For that reason it's only possible to initialize python once and+-- attempts to initialize python after is was shut down will raise+-- exceptions.+++-- $conversion+--+-- Python objects are opaque blobs and accessing them may involve+-- running arbitrary python code. Most notable iteration protocol or+-- any of dunder methods. For that reason conversion from python to+-- haskell must happen in 'Py' monad. Conversion also always performs+-- full copy. Conversion from haskell to python is stateful as well.+++-- $troubleshooting+--+-- Here's list of common problems and solutions and workarounds.+--+-- 1. __@inline-python@ cannot find libraries__+--+-- @inline-python@ may look for modules in wrong place. Set+-- environment variables @PYTHONHOME@ or @PYTHONPATH@ to point it+-- right way.+--+--+-- 2. __Linker error in GHCi__+--+-- Attempting to import library using C extensions from ghci may+-- result in linker failing to find symbols from @libpython@ like+-- @PyFloat_Type@ or some other. Only known workaround is to set+-- @LD_PRELOAD=/path/to/libpython3.XX.so@ environment variable.
+ src/Python/Inline/Literal.hs view
@@ -0,0 +1,664 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+-- |+-- Conversion between haskell data types and python values+module Python.Inline.Literal+ ( FromPy(..)+ , ToPy(..)+ , toPy+ , fromPyEither+ , fromPy+ , fromPy'+ ) where++import Control.Monad+import Control.Monad.Catch+import Control.Monad.Trans.Cont+import Data.Bits+import Data.Char+import Data.Int+import Data.Word+import Data.Set qualified as Set+import Data.Map.Strict qualified as Map+import Data.Vector.Generic qualified as VG+import Data.Vector.Generic.Mutable qualified as MVG+import Data.Vector qualified as V+#if MIN_VERSION_vector(0,13,2)+import Data.Vector.Strict qualified as VV+#endif+import Data.Vector.Storable qualified as VS+import Data.Vector.Primitive qualified as VP+import Data.Vector.Unboxed qualified as VU+import Foreign.Ptr+import Foreign.C.Types+import Foreign.Storable+import GHC.Float (float2Double, double2Float)++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.CAPI+import Python.Internal.Program++----------------------------------------------------------------+C.context (C.baseCtx <> pyCtx)+C.include "<inline-python.h>"+----------------------------------------------------------------++-- | Convert haskell value to python value.+class ToPy a where+ -- | Convert haskell value to python object. This function returns+ -- strong reference to newly create objects (except singletons+ -- like @None@, @True@, etc).+ --+ -- Implementations should try to avoid failing conversions.+ -- There're two ways of signalling failure: errors on python side+ -- should return NULL and raise python exception. Haskell code+ -- should just throw exception.+ --+ -- This is low level function. It should be only used when working+ -- with python's C API. Otherwise 'toPy' is preferred.+ basicToPy :: a -> Py (Ptr PyObject)+ -- | Old hack for handling of strings+ basicListToPy :: [a] -> Py (Ptr PyObject)+ basicListToPy xs = runProgram $ do+ let n = fromIntegral $ length xs :: CLLong+ p_list <- takeOwnership =<< checkNull (Py [CU.exp| PyObject* { PyList_New($(long long n)) } |])+ let loop !_ [] = p_list <$ incref p_list+ loop i (a:as) = basicToPy a >>= \case+ NULL -> pure nullPtr+ p_a -> do+ -- NOTE: PyList_SET_ITEM steals reference+ Py [CU.exp| void { PyList_SET_ITEM($(PyObject* p_list), $(long long i), $(PyObject* p_a)) } |]+ loop (i+1) as+ progPy $ loop 0 xs++-- | Convert python object to haskell value.+class FromPy a where+ -- | Convert python value into haskell value. This function should+ -- try to not modify python's data. This function should avoid+ -- throwing haskell exception. Any python exceptions should be+ -- thrown as 'PyError'. When data type couldn't be converted+ -- 'BadPyType' or 'OutOfRange' should be thrown to indicate failure.+ --+ -- This is low level function. It should be only used when working+ -- with python's C API. Otherwise 'fromPy' is preferred.+ basicFromPy :: Ptr PyObject -> Py a++-- | Convert python object to haskell value. All python exceptions+-- which happen during execution will be converted to @PyError@.+fromPyEither :: FromPy a => PyObject -> Py (Either PyError a)+fromPyEither py = unsafeWithPyObject py $ \p ->+ (Right <$> basicFromPy p) `catch` (pure . Left)+++-- | Convert python object to haskell value. Will return @Nothing@ if+-- 'BadPyType' or 'OutOfRange' is thrown. Other python exceptions+-- are rethrown.+fromPy :: FromPy a => PyObject -> Py (Maybe a)+fromPy py = unsafeWithPyObject py $ \p ->+ (Just <$> basicFromPy p) `catch` \case+ BadPyType -> pure Nothing+ OutOfRange -> pure Nothing+ e -> throwM e++-- | Convert python object to haskell value. Throws exception on+-- failure.+fromPy' :: FromPy a => PyObject -> Py a+fromPy' py = unsafeWithPyObject py basicFromPy++-- | Convert haskell value to a python object.+toPy :: ToPy a => a -> Py PyObject+toPy a = basicToPy a >>= \case+ NULL -> mustThrowPyError+ p -> newPyObject p+++----------------------------------------------------------------+-- Instances+----------------------------------------------------------------++instance ToPy PyObject where+ basicToPy o = unsafeWithPyObject o $ \p -> p <$ incref p+instance FromPy PyObject where+ basicFromPy p = incref p >> newPyObject p++instance ToPy () where+ basicToPy () = Py [CU.exp| PyObject* { Py_None } |]++instance ToPy CLong where+ basicToPy i = Py [CU.exp| PyObject* { PyLong_FromLong($(long i)) } |]+instance FromPy CLong where+ basicFromPy p_py = do+ r <- Py [CU.exp| long { PyLong_AsLong($(PyObject *p_py)) } |]+ r <$ checkThrowBadPyType++instance ToPy CLLong where+ basicToPy i = Py [CU.exp| PyObject* { PyLong_FromLongLong($(long long i)) } |]+instance FromPy CLLong where+ basicFromPy p_py = do+ r <- Py [CU.exp| long long { PyLong_AsLongLong($(PyObject *p_py)) } |]+ r <$ checkThrowBadPyType++instance ToPy CULong where+ basicToPy i = Py [CU.exp| PyObject* { PyLong_FromUnsignedLong($(unsigned long i)) } |]+instance FromPy CULong where+ basicFromPy p_py = do+ r <- Py [CU.exp| unsigned long { PyLong_AsUnsignedLong($(PyObject *p_py)) } |]+ r <$ checkThrowBadPyType++instance ToPy CULLong where+ basicToPy i = Py [CU.exp| PyObject* { PyLong_FromUnsignedLongLong($(unsigned long long i)) } |]+instance FromPy CULLong where+ basicFromPy p_py = do+ r <- Py [CU.exp| unsigned long long { PyLong_AsUnsignedLongLong($(PyObject *p_py)) } |]+ r <$ checkThrowBadPyType++instance ToPy CDouble where+ basicToPy i = Py [CU.exp| PyObject* { PyFloat_FromDouble($(double i)) } |]+instance FromPy CDouble where+ basicFromPy p_py = do+ r <- Py [CU.exp| double { PyFloat_AsDouble($(PyObject *p_py)) } |]+ r <$ checkThrowBadPyType++deriving via CLLong instance ToPy Int64+deriving via CLLong instance FromPy Int64+deriving via CULLong instance ToPy Word64+deriving via CULLong instance FromPy Word64++deriving newtype instance ToPy CInt+deriving newtype instance FromPy CInt+deriving newtype instance ToPy CUInt+deriving newtype instance FromPy CUInt+deriving newtype instance ToPy CShort+deriving newtype instance FromPy CShort+deriving newtype instance ToPy CUShort+deriving newtype instance FromPy CUShort+deriving newtype instance ToPy CChar+deriving newtype instance FromPy CChar+deriving newtype instance ToPy CUChar+deriving newtype instance FromPy CUChar+deriving newtype instance ToPy CSChar+deriving newtype instance FromPy CSChar++deriving via CDouble instance ToPy Double+deriving via CDouble instance FromPy Double++instance ToPy Float where basicToPy = basicToPy . float2Double+instance FromPy Float where basicFromPy = fmap double2Float . basicFromPy+++instance ToPy Int where+ basicToPy+ | wordSizeInBits == 64 = basicToPy @Int64 . fromIntegral+ | otherwise = basicToPy @Int32 . fromIntegral+instance FromPy Int where+ basicFromPy+ | wordSizeInBits == 64 = fmap fromIntegral . basicFromPy @Int64+ | otherwise = fmap fromIntegral . basicFromPy @Int32++instance ToPy Word where+ basicToPy+ | wordSizeInBits == 64 = basicToPy @Word64 . fromIntegral+ | otherwise = basicToPy @Word32 . fromIntegral+instance FromPy Word where+ basicFromPy+ | wordSizeInBits == 64 = fmap fromIntegral . basicFromPy @Word64+ | otherwise = fmap fromIntegral . basicFromPy @Word32++instance ToPy Int8 where basicToPy = basicToPy @Int64 . fromIntegral+instance ToPy Int16 where basicToPy = basicToPy @Int64 . fromIntegral+instance ToPy Int32 where basicToPy = basicToPy @Int64 . fromIntegral+instance ToPy Word8 where basicToPy = basicToPy @Word64 . fromIntegral+instance ToPy Word16 where basicToPy = basicToPy @Word64 . fromIntegral+instance ToPy Word32 where basicToPy = basicToPy @Word64 . fromIntegral++instance FromPy Int8 where+ basicFromPy p = basicFromPy @Int64 p >>= \case+ i | i <= fromIntegral (maxBound :: Int8)+ , i >= fromIntegral (minBound :: Int8) -> pure $! fromIntegral i+ | otherwise -> throwM OutOfRange++instance FromPy Int16 where+ basicFromPy p = basicFromPy @Int64 p >>= \case+ i | i <= fromIntegral (maxBound :: Int16)+ , i >= fromIntegral (minBound :: Int16) -> pure $! fromIntegral i+ | otherwise -> throwM OutOfRange++instance FromPy Int32 where+ basicFromPy p = basicFromPy @Int64 p >>= \case+ i | i <= fromIntegral (maxBound :: Int32)+ , i >= fromIntegral (minBound :: Int32) -> pure $! fromIntegral i+ | otherwise -> throwM OutOfRange++instance FromPy Word8 where+ basicFromPy p = basicFromPy @Word64 p >>= \case+ i | i <= fromIntegral (maxBound :: Word8) -> pure $! fromIntegral i+ | otherwise -> throwM OutOfRange++instance FromPy Word16 where+ basicFromPy p = basicFromPy @Word64 p >>= \case+ i | i <= fromIntegral (maxBound :: Word16) -> pure $! fromIntegral i+ | otherwise -> throwM OutOfRange++instance FromPy Word32 where+ basicFromPy p = basicFromPy @Word64 p >>= \case+ i | i <= fromIntegral (maxBound :: Word32) -> pure $! fromIntegral i+ | otherwise -> throwM OutOfRange+++-- | Encoded as 1-character string+instance ToPy Char where+ basicToPy c = do+ let i = fromIntegral (ord c) :: CUInt+ Py [CU.block| PyObject* {+ uint32_t cs[1] = { $(unsigned i) };+ return PyUnicode_DecodeUTF32((char*)cs, 4, NULL, NULL);+ } |]+ basicListToPy str = runProgram $ do+ p_str <- withPyWCString str+ progIO [CU.exp| PyObject* { PyUnicode_FromWideChar($(wchar_t *p_str), -1) } |]+++instance FromPy Char where+ basicFromPy p = do+ r <- Py [CU.block| int {+ PyObject* p = $(PyObject *p);+ if( !PyUnicode_Check(p) )+ return -1;+ if( 1 != PyUnicode_GET_LENGTH(p) )+ return -1;+ switch( PyUnicode_KIND(p) ) {+ case PyUnicode_1BYTE_KIND:+ return PyUnicode_1BYTE_DATA(p)[0];+ case PyUnicode_2BYTE_KIND:+ return PyUnicode_2BYTE_DATA(p)[0];+ case PyUnicode_4BYTE_KIND:+ return PyUnicode_4BYTE_DATA(p)[0];+ }+ return -1;+ } |]+ if | r < 0 -> throwM BadPyType+ | otherwise -> pure $ chr $ fromIntegral r++instance ToPy Bool where+ basicToPy True = Py [CU.exp| PyObject* { Py_True } |]+ basicToPy False = Py [CU.exp| PyObject* { Py_False } |]++-- | Uses python's truthiness conventions+instance FromPy Bool where+ basicFromPy p = do+ r <- Py [CU.exp| int { PyObject_IsTrue($(PyObject* p)) } |]+ checkThrowPyError+ pure $! r /= 0+++instance (ToPy a, ToPy b) => ToPy (a,b) where+ basicToPy (a,b) = runProgram $ do+ p_a <- takeOwnership =<< checkNull (basicToPy a)+ p_b <- takeOwnership =<< checkNull (basicToPy b)+ progIO [CU.exp| PyObject* { PyTuple_Pack(2, $(PyObject* p_a), $(PyObject* p_b)) } |]++-- | Will accept any iterable+instance (FromPy a, FromPy b) => FromPy (a,b) where+ basicFromPy p_tup = runProgram $ do+ -- Unpack 2-tuple.+ p_args <- withPyAllocaArray 2+ unpack_ok <- progIO [CU.exp| int {+ inline_py_unpack_iterable($(PyObject *p_tup), 2, $(PyObject **p_args))+ }|]+ progPy $ do checkThrowPyError+ when (unpack_ok /= 0) $ throwM BadPyType+ -- Parse each element of tuple+ p_a <- takeOwnership =<< progIO (peekElemOff p_args 0)+ p_b <- takeOwnership =<< progIO (peekElemOff p_args 1)+ progPy $ do a <- basicFromPy p_a+ b <- basicFromPy p_b+ pure (a,b)++instance (ToPy a, ToPy b, ToPy c) => ToPy (a,b,c) where+ basicToPy (a,b,c) = runProgram $ do+ p_a <- takeOwnership =<< checkNull (basicToPy a)+ p_b <- takeOwnership =<< checkNull (basicToPy b)+ p_c <- takeOwnership =<< checkNull (basicToPy c)+ progIO [CU.exp| PyObject* {+ PyTuple_Pack(3, $(PyObject *p_a), $(PyObject *p_b), $(PyObject *p_c)) } |]++-- | Will accept any iterable+instance (FromPy a, FromPy b, FromPy c) => FromPy (a,b,c) where+ basicFromPy p_tup = runProgram $ do+ -- Unpack 3-tuple.+ p_args <- withPyAllocaArray 3+ unpack_ok <- progIO [CU.exp| int {+ inline_py_unpack_iterable($(PyObject *p_tup), 3, $(PyObject **p_args))+ }|]+ progPy $ do checkThrowPyError+ when (unpack_ok /= 0) $ throwM BadPyType+ -- Parse each element of tuple+ p_a <- takeOwnership =<< progIO (peekElemOff p_args 0)+ p_b <- takeOwnership =<< progIO (peekElemOff p_args 1)+ p_c <- takeOwnership =<< progIO (peekElemOff p_args 2)+ progPy $ do a <- basicFromPy p_a+ b <- basicFromPy p_b+ c <- basicFromPy p_c+ pure (a,b,c)++instance (ToPy a, ToPy b, ToPy c, ToPy d) => ToPy (a,b,c,d) where+ basicToPy (a,b,c,d) = runProgram $ do+ p_a <- takeOwnership =<< checkNull (basicToPy a)+ p_b <- takeOwnership =<< checkNull (basicToPy b)+ p_c <- takeOwnership =<< checkNull (basicToPy c)+ p_d <- takeOwnership =<< checkNull (basicToPy d)+ progIO [CU.exp| PyObject* {+ PyTuple_Pack(4, $(PyObject *p_a), $(PyObject *p_b), $(PyObject *p_c), $(PyObject *p_d)) } |]++-- | Will accept any iterable+instance (FromPy a, FromPy b, FromPy c, FromPy d) => FromPy (a,b,c,d) where+ basicFromPy p_tup = runProgram $ do+ -- Unpack 3-tuple.+ p_args <- withPyAllocaArray 4+ unpack_ok <- progIO [CU.exp| int {+ inline_py_unpack_iterable($(PyObject *p_tup), 4, $(PyObject **p_args))+ }|]+ progPy $ do checkThrowPyError+ when (unpack_ok /= 0) $ throwM BadPyType+ -- Parse each element of tuple+ p_a <- takeOwnership =<< progIO (peekElemOff p_args 0)+ p_b <- takeOwnership =<< progIO (peekElemOff p_args 1)+ p_c <- takeOwnership =<< progIO (peekElemOff p_args 2)+ p_d <- takeOwnership =<< progIO (peekElemOff p_args 3)+ progPy $ do a <- basicFromPy p_a+ b <- basicFromPy p_b+ c <- basicFromPy p_c+ d <- basicFromPy p_d+ pure (a,b,c,d)++instance (ToPy a) => ToPy [a] where+ basicToPy = basicListToPy++-- | Will accept any iterable+instance (FromPy a) => FromPy [a] where+ basicFromPy p_list = do+ p_iter <- Py [CU.block| PyObject* {+ PyObject* iter = PyObject_GetIter( $(PyObject *p_list) );+ if( PyErr_Occurred() ) {+ PyErr_Clear();+ }+ return iter;+ } |]+ when (nullPtr == p_iter) $ throwM BadPyType+ --+ f <- foldPyIterable p_iter+ (\f p -> do a <- basicFromPy p+ pure (f . (a:)))+ id+ pure $ f []++instance (ToPy a, Ord a) => ToPy (Set.Set a) where+ basicToPy set = runProgram $ do+ p_set <- takeOwnership =<< checkNull basicNewSet+ progPy $ do+ let loop [] = p_set <$ incref p_set+ loop (x:xs) = basicToPy x >>= \case+ NULL -> pure NULL+ p_a -> Py [C.exp| int { PySet_Add($(PyObject *p_set), $(PyObject *p_a)) }|] >>= \case+ 0 -> decref p_a >> loop xs+ _ -> mustThrowPyError+ loop $ Set.toList set++instance (FromPy a, Ord a) => FromPy (Set.Set a) where+ basicFromPy p_set = basicGetIter p_set >>= \case+ NULL -> do Py [C.exp| void { PyErr_Clear() } |]+ throwM BadPyType+ p_iter -> foldPyIterable p_iter+ (\s p -> do a <- basicFromPy p+ pure $! Set.insert a s)+ Set.empty+++instance (ToPy k, ToPy v, Ord k) => ToPy (Map.Map k v) where+ basicToPy dct = runProgram $ do+ p_dict <- takeOwnership =<< checkNull basicNewDict+ progPy $ do+ let loop [] = p_dict <$ incref p_dict+ loop ((k,v):xs) = basicToPy k >>= \case+ NULL -> mustThrowPyError+ p_k -> flip finally (decref p_k) $ basicToPy v >>= \case+ NULL -> mustThrowPyError+ p_v -> Py [CU.exp| int { PyDict_SetItem($(PyObject *p_dict), $(PyObject* p_k), $(PyObject *p_v)) }|] >>= \case+ 0 -> loop xs+ _ -> nullPtr <$ decref p_v+ loop $ Map.toList dct++instance (FromPy k, FromPy v, Ord k) => FromPy (Map.Map k v) where+ basicFromPy p_dct = basicGetIter p_dct >>= \case+ NULL -> do Py [C.exp| void { PyErr_Clear() } |]+ throwM BadPyType+ p_iter -> foldPyIterable p_iter+ (\m p -> do k <- basicFromPy p+ v <- Py [CU.exp| PyObject* { PyDict_GetItem($(PyObject* p_dct), $(PyObject *p)) }|] >>= \case+ NULL -> throwM BadPyType+ p_v -> basicFromPy p_v+ pure $! Map.insert k v m)+ Map.empty++-- | Converts to python's list+instance ToPy a => ToPy (V.Vector a) where+ basicToPy = vectorToPy+-- | Converts to python's list+instance (ToPy a, VS.Storable a) => ToPy (VS.Vector a) where+ basicToPy = vectorToPy+-- | Converts to python's list+instance (ToPy a, VP.Prim a) => ToPy (VP.Vector a) where+ basicToPy = vectorToPy+-- | Converts to python's list+instance (ToPy a, VU.Unbox a) => ToPy (VU.Vector a) where+ basicToPy = vectorToPy+#if MIN_VERSION_vector(0,13,2)+-- | Converts to python's list+instance (ToPy a) => ToPy (VV.Vector a) where+ basicToPy = vectorToPy+#endif++-- | Accepts python's sequence (@len@ and indexing)+instance FromPy a => FromPy (V.Vector a) where+ basicFromPy = vectorFromPy+-- | Accepts python's sequence (@len@ and indexing)+instance (FromPy a, VS.Storable a) => FromPy (VS.Vector a) where+ basicFromPy = vectorFromPy+-- | Accepts python's sequence (@len@ and indexing)+instance (FromPy a, VP.Prim a) => FromPy (VP.Vector a) where+ basicFromPy = vectorFromPy+-- | Accepts python's sequence (@len@ and indexing)+instance (FromPy a, VU.Unbox a) => FromPy (VU.Vector a) where+ basicFromPy = vectorFromPy+#if MIN_VERSION_vector(0,13,2)+-- | Accepts python's sequence (@len@ and indexing)+instance FromPy a => FromPy (VV.Vector a) where+ basicFromPy = vectorFromPy+#endif+++-- | Fold over iterable. Function takes ownership over iterator.+foldPyIterable+ :: Ptr PyObject -- ^ Python iterator (not checked)+ -> (a -> Ptr PyObject -> Py a) -- ^ Step function. It takes borrowed pointer.+ -> a -- ^ Initial value+ -> Py a+foldPyIterable p_iter step a0+ = loop a0 `finally` decref p_iter+ where+ loop a = basicIterNext p_iter >>= \case+ NULL -> a <$ checkThrowPyError+ p -> loop =<< (step a p `finally` decref p)+++vectorFromPy :: (VG.Vector v a, FromPy a) => Ptr PyObject -> Py (v a)+{-# INLINE vectorFromPy #-}+vectorFromPy p_seq = do+ len <- Py [CU.exp| long long { PySequence_Size($(PyObject* p_seq)) } |]+ when (len < 0) $ do+ Py [C.exp| void { PyErr_Clear() } |]+ throwM BadPyType+ -- Read data into vector+ buf <- MVG.generateM (fromIntegral len) $ \i -> do+ let i_c = fromIntegral i+ Py [CU.exp| PyObject* { PySequence_GetItem($(PyObject* p_seq), $(long long i_c)) } |] >>= \case+ NULL -> mustThrowPyError+ p -> basicFromPy p `finally` decref p+ VG.unsafeFreeze buf++vectorToPy :: (VG.Vector v a, ToPy a) => v a -> Py (Ptr PyObject)+vectorToPy vec = runProgram $ do+ p_list <- takeOwnership =<< checkNull (Py [CU.exp| PyObject* { PyList_New($(long long n_c)) } |])+ progPy $ do+ let loop i+ | i >= n = p_list <$ incref p_list+ | otherwise = basicToPy (VG.unsafeIndex vec i) >>= \case+ NULL -> pure nullPtr+ p_a -> do+ let i_c = fromIntegral i :: CLLong+ -- NOTE: PyList_SET_ITEM steals reference+ Py [CU.exp| void { PyList_SET_ITEM($(PyObject* p_list), $(long long i_c), $(PyObject* p_a)) } |]+ loop (i+1)+ loop 0+ where+ n = VG.length vec+ n_c = fromIntegral n :: CLLong++----------------------------------------------------------------+-- Functions marshalling+----------------------------------------------------------------++-- NOTE: [Creation of python functions]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We need to call haskell from python we need to first to create+-- FunPtr on haskell side and wrap it using python's C API. Process is+-- unpleasantly convoluted.+--+-- Function marshalled from haskell side could only be called with+-- using positional arguments. Two calling conventions are supported:+--+-- - METH_O for 1-argument+-- - METH_FASTCALL for 2+ argument functions+--+-- One problem is we need to keep PyMethodDef struct alive while+-- function object is alive and GC it when function object is GC'd.+-- To that end we use horrible hack.+--+-- PyMethodDef is allocated on C heap, wrapped into PyCapsule passed+-- to CFunction as self. It does seems hacky. However it does the trick.+-- Maybe there's other way.++++-- NOTE: [Exceptions in callbacks]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We absolutely must not allow unhandled haskell exceptions in+-- callbacks from python. Else they will hit C wall and terminate+-- program. They MUST be converted to python ones.+--+-- FIXME: figure out masking for python's call. I DON'T want get hit+-- with async exception out of the blue+++-- | Converted to 0-ary function+instance (ToPy b) => ToPy (IO b) where+ basicToPy f = Py $ do+ --+ f_ptr <- wrapCFunction $ \_ _ -> pyCallback $ do+ progPy $ basicToPy =<< dropGIL f+ --+ [CU.exp| PyObject* { inline_py_callback_METH_NOARGS($(PyCFunction f_ptr)) } |]+++-- | Only accepts positional parameters+instance (FromPy a, Show a, ToPy b) => ToPy (a -> IO b) where+ basicToPy f = Py $ do+ --+ f_ptr <- wrapCFunction $ \_ p_a -> pyCallback $ do+ a <- loadArg p_a 0 1+ progPy $ basicToPy =<< dropGIL (f a)+ --+ [CU.exp| PyObject* { inline_py_callback_METH_O($(PyCFunction f_ptr)) } |]++-- | Only accepts positional parameters+instance (FromPy a1, FromPy a2, ToPy b) => ToPy (a1 -> a2 -> IO b) where+ basicToPy f = Py $ do+ --+ f_ptr <- wrapFastcall $ \_ p_arr n -> pyCallback $ do+ when (n /= 2) $ abortM $ raiseBadNArgs 2 n+ a1 <- loadArgFastcall p_arr 0 n+ a2 <- loadArgFastcall p_arr 1 n+ progPy $ basicToPy =<< dropGIL (f a1 a2)+ --+ [CU.exp| PyObject* { inline_py_callback_METH_FASTCALL($(PyCFunctionFast f_ptr)) } |]++----------------------------------------------------------------+-- Helpers+----------------------------------------------------------------+++-- | Execute haskell callback function+pyCallback :: Program (Ptr PyObject) (Ptr PyObject) -> IO (Ptr PyObject)+pyCallback io = callbackEnsurePyLock $ unPy $ ensureGIL $ runProgram io `catch` convertHaskell2Py++-- | Load argument from python object for haskell evaluation+loadArg+ :: FromPy a+ => (Ptr PyObject) -- ^ Python object to decode+ -> Int -- ^ Argument number (0-based)+ -> Int64 -- ^ Total number of arguments+ -> Program (Ptr PyObject) a+loadArg p (fromIntegral -> i) (fromIntegral -> tot) = Program $ ContT $ \success -> do+ try (basicFromPy p) >>= \case+ Right a -> success a+ Left BadPyType -> oops+ Left OutOfRange -> oops+ Left e -> throwM e+ where+ oops = Py [CU.block| PyObject* {+ char err[256];+ sprintf(err, "Failed to decode function argument %i of %li", $(int i)+1, $(int64_t tot));+ PyErr_SetString(PyExc_TypeError, err);+ return NULL;+ } |]++-- | Load i-th argument from array as haskell parameter+loadArgFastcall+ :: FromPy a+ => Ptr (Ptr PyObject) -- ^ Array of arguments+ -> Int -- ^ Argument number (0-based)+ -> Int64 -- ^ Total number of arguments+ -> Program (Ptr PyObject) a+loadArgFastcall p_arr i tot = do+ p <- progIO $ peekElemOff p_arr i+ loadArg p i tot++raiseBadNArgs :: CInt -> Int64 -> Py (Ptr PyObject)+raiseBadNArgs expected got = Py [CU.block| PyObject* {+ char err[256];+ sprintf(err, "Function takes exactly %i arguments (%li given)", $(int expected), $(int64_t got));+ PyErr_SetString(PyExc_TypeError, err);+ return NULL;+ } |]+++type FunWrapper a = a -> IO (FunPtr a)++foreign import ccall "wrapper" wrapCFunction+ :: FunWrapper (Ptr PyObject -> Ptr PyObject -> IO (Ptr PyObject))++foreign import ccall "wrapper" wrapFastcall+ :: FunWrapper (Ptr PyObject -> Ptr (Ptr PyObject) -> Int64 -> IO (Ptr PyObject))+++wordSizeInBits :: Int+wordSizeInBits = finiteBitSize (0 :: Word)+{-# INLINE wordSizeInBits #-}
+ src/Python/Inline/QQ.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE TemplateHaskell #-}+-- |+-- Quasiquoters for embedding python expression into haskell programs.+-- Python is statement oriented and heavily relies on mutable state.+-- This means we need several different quasiquoters.+--+--+-- == Syntax in quasiquotes+--+-- Note on syntax. Python's grammar is indentation sensitive and+-- quasiquote is passed to 'QuasiQuoter' without any adjustment. So+-- this seemingly reasonable code:+--+-- > foo = [py_| do_this()+-- > do_that()+-- > |]+--+-- results in following source code.+--+-- > do_this()+-- > do_that()+--+-- There's no sensible way to adjust indentation, since we don't know+-- original indentation of first line of quasiquote in haskell's code.+-- Thus rule: __First line of multiline quasiquote must be empty__.+-- This is correct way to write code:+--+-- > foo = [py_|+-- > do_this()+-- > do_that()+-- > |]+module Python.Inline.QQ+ ( pymain+ , py_+ , pye+ , pyf+ ) where++import Language.Haskell.TH.Quote++import Python.Internal.EvalQQ+++-- | Evaluate sequence of python statements. It works in the same way+-- as python's @exec@. All module imports and all variables defined+-- in this quasiquote will be visible to later quotes.+--+-- It creates value of type @Py ()@+pymain :: QuasiQuoter+pymain = QuasiQuoter+ { quoteExp = \txt -> [| evaluatorPymain $(expQQ Exec txt) |]+ , quotePat = error "quotePat"+ , quoteType = error "quoteType"+ , quoteDec = error "quoteDec"+ }++-- | Evaluate sequence of python statements. All module imports and+-- all variables defined in this quasiquote will be discarded and+-- won't be visible in later quotes.+--+-- It creates value of type @Py ()@+py_ :: QuasiQuoter+py_ = QuasiQuoter+ { quoteExp = \txt -> [| evaluatorPy_ $(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@.+--+-- This quote creates object of type @Py PyObject@+pye :: QuasiQuoter+pye = QuasiQuoter+ { quoteExp = \txt -> [| evaluatorPye $(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+pyf :: QuasiQuoter+pyf = QuasiQuoter+ { quoteExp = \txt -> [| evaluatorPyf $(expQQ Fun txt) |]+ , quotePat = error "quotePat"+ , quoteType = error "quoteType"+ , quoteDec = error "quoteDec"+ }
+ src/Python/Inline/Types.hs view
@@ -0,0 +1,19 @@+-- |+-- Data types and utilities.+module Python.Inline.Types+ ( -- * @Py@ monad+ Py+ , runPy+ , pyIO+ -- * Python objects+ , PyObject+ , unsafeWithPyObject+ -- * Python exceptions+ , PyError(..)+ , PyException(..)+ , PyInternalError(..)+ ) where++import Python.Internal.Types+import Python.Internal.Eval+
+ src/Python/Internal/CAPI.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+-- |+-- Thin wrappers over C API+module Python.Internal.CAPI+ ( decref+ , incref+ -- * Simple wrappers+ , basicNewDict+ , basicNewSet+ , basicGetIter+ , basicIterNext+ , basicCallKwdOnly+ ) where++import Foreign.Ptr+import Language.C.Inline qualified as C+import Language.C.Inline.Unsafe qualified as CU++import Python.Internal.Types+++----------------------------------------------------------------+C.context (C.baseCtx <> pyCtx)+C.include "<inline-python.h>"+----------------------------------------------------------------+++decref :: Ptr PyObject -> Py ()+decref p = Py [CU.exp| void { Py_DECREF($(PyObject* p)) } |]++incref :: Ptr PyObject -> Py ()+incref p = Py [CU.exp| void { Py_INCREF($(PyObject* p)) } |]++basicNewDict :: Py (Ptr PyObject)+basicNewDict = Py [CU.exp| PyObject* { PyDict_New() } |]++basicNewSet :: Py (Ptr PyObject)+basicNewSet = Py [CU.exp| PyObject* { PySet_New(NULL) } |]++basicGetIter :: Ptr PyObject -> Py (Ptr PyObject)+basicGetIter p = Py [CU.exp| PyObject* { PyObject_GetIter( $(PyObject *p)) } |]++basicIterNext :: Ptr PyObject -> Py (Ptr PyObject)+basicIterNext p = Py [C.exp| PyObject* { PyIter_Next($(PyObject* p)) } |]+++-- | Call python function using only keyword arguments+basicCallKwdOnly+ :: Ptr PyObject -- ^ Function object+ -> Ptr PyObject -- ^ Keywords. Must be dictionary+ -> Py (Ptr PyObject)+basicCallKwdOnly fun kwd = Py [CU.block| PyObject* {+ PyObject* args = PyTuple_Pack(0);+ PyObject* res = PyObject_Call($(PyObject *fun), args, $(PyObject *kwd));+ Py_DECREF(args);+ return res;+ } |]
+ src/Python/Internal/Eval.hs view
@@ -0,0 +1,650 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+-- |+-- Evaluation of python expressions.+module Python.Internal.Eval+ ( -- * Locks+ ensurePyLock+ , callbackEnsurePyLock+ -- * Initialization+ , initializePython+ , finalizePython+ , withPython+ -- * Evaluator+ , runPy+ , runPyInMain+ , unPy+ -- * GC-related+ , newPyObject+ -- * C-API wrappers+ , takeOwnership+ , ensureGIL+ , dropGIL+ -- * Exceptions+ , convertHaskell2Py+ , convertPy2Haskell+ , checkThrowPyError+ , mustThrowPyError+ , checkThrowBadPyType+ , throwOnNULL+ -- * Debugging+ , debugPrintPy+ ) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception (interruptible)+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+import Foreign.C.Types+import Foreign.C.String+import Foreign.Marshal.Array+import Foreign.Storable+import System.Environment+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+++----------------------------------------------------------------+C.context (C.baseCtx <> pyCtx)+C.include "<inline-python.h>"+----------------------------------------------------------------++-- NOTE: [Python and threading]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Python (cpython to be precise) support threading to and it+-- interacts with haskell threading in interesting and generally+-- unpleasant ways. In short python's threads are:+--+-- 1. OS threads. Python is designed to be embeddable and can+-- live with threads scheduled by outside python's runtime.+--+-- 2. Any OS thread interacting with python interpreter must hold+-- global interpreter lock (GIL).+--+-- 3. GIL uses thread local state.+--+-- Haskell has two runtimes. Single threaded one doesn't cause any+-- troubles and won't be discussed further. Multithreaded one+-- implement N-M threading and schedules N green thread on M OS+-- threads as it see fit.+--+-- One could think that running python code in bound threads and+-- making sure that GIL is held would suffice. It doesn't. Doing so+-- would quickly results in deadlock. Exact reason for that is not+-- understood.+--+-- Another problem is GHC may schedule two threads each running python+-- code on same capability. They won't have any problems taking GIL+-- and will run concurrently stepping on each other's toes.+--+-- Only way to solve this problem is to introduce another lock on+-- haskell side. It's visible to haskell RTS so we won't get deadlocks+-- and it makes sure that only one haskell thread interacts with+-- python at a time.+--+--+--+-- Also python designate thread in which python interpreter was+-- initialized as a main thread. It has special status for example+-- some libraries may run only in main thread (e.g. tkinter). But if+-- we don't take special precautions we won't know which thread it+-- is.+--+--+--+-- There's of course question how well python threading interacts with+-- haskell. No one knows, probably it won't work well.++++-- NOTE: [GC]+-- ~~~~~~~~~~+--+-- CPython uses reference counting which should work very well with+-- ForeignPtr. But there's a catch: decrementing counter is only+-- possible if one holds GIL. Taking GIL may block and doing so during+-- GC may eventually will block GC thread and the whole program.+--+-- Current solution is not quite satisfactory: finalizer writes+-- pointer to `Chan` which delivers it to thread which decrements+-- counter. It's not very good solution since we need to take locks+-- for each DECREF which is relatively costly (O(1μs)). But better+-- solutions are not obvious.+--+-- Problem above is only relevant for multithreaded RTS there's no+-- other threads that could hold lock and taking GIL can't fail.++++-- NOTE: [Interrupting python]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Being able to interrupt python when haskell exception arrives is+-- surely nice. However it's difficult and comes with tradeoffs.+--+-- First of all call must be done in a separate thread otherwise+-- there's no one to catch exception and to something. This also means+-- that python calls made using plain FFI are not interruptible.+--+-- In addition python's ability to notify other threads are limited:+--+-- + `Py_SetInterrupt` plain doesn't work. It uses signal which trips+-- up haskell RTS as well.+--+-- + `PyThreadState_SetAsyncExc` could be use but it requires special+-- setup from thread being interrupted.++++----------------------------------------------------------------+-- Lock and global state+----------------------------------------------------------------++globalPyState :: TVar PyState+globalPyState = unsafePerformIO $ newTVarIO NotInitialized+{-# NOINLINE globalPyState #-}++globalPyLock :: TVar PyLock+globalPyLock = unsafePerformIO $ newTVarIO LockUninialized+{-# NOINLINE globalPyLock #-}+++-- | State of python interpreter+data PyState+ = NotInitialized+ -- ^ Initialization is not done. Initial state.+ | InInitialization+ -- ^ Interpreter is being initialized.+ | InitFailed+ -- ^ Initialization was attempted but failed for whatever reason.+ | Running1+ -- ^ Interpreter is running. We're using single threaded RTS+ | RunningN !(Chan (Ptr PyObject))+ !(MVar EvalReq)+ !ThreadId+ !ThreadId+ -- ^ Interpreter is running. We're using multithreaded RTS+ | InFinalization+ -- ^ Interpreter is being finalized.+ | Finalized+ -- ^ Interpreter was shut down.+++-- | Lock. It's necessary for lock to reentrant since thread may take+-- it several times for example by nesting 'runPy'. We use+-- 'ThreadId' as a key to figure out whether thread may retake lock+-- or not.+--+-- Another special case is callbacks. Callback (via 'FunPtr') will+-- start new haskell thread so we need to add primitive for grabbing+-- lock regardless of current 'ThreadId'+data PyLock+ = LockUninialized+ -- ^ There's no interpreter and lock does not exist.+ | LockUnlocked+ -- ^ Lock could be taked+ | Locked !ThreadId [ThreadId]+ -- ^ Python is locked by given thread. Lock could be taken multiple+ -- times+ | LockedByGC+ -- ^ Python is locked by GC thread.+ | LockFinalized+ -- ^ Python interpreter shut down. Taking lock is not possible+ deriving Show++-- | Execute code ensuring that python lock is held by current thread.+ensurePyLock :: IO a -> IO a+ensurePyLock action = do+ tid <- myThreadId+ bracket_ (atomically $ acquireLock tid)+ (atomically $ releaseLock tid)+ action++-- | Retake lock regardless of thread which hold lock. Lock must be+-- already taken. Caller must make sure that thread holding lock is+-- block for duration of action.+--+-- This is very unsafe. It must be used only in callbacks from+-- python to haskell+callbackEnsurePyLock :: IO a -> IO a+callbackEnsurePyLock action = do+ tid <- myThreadId+ bracket_ (atomically $ grabLock tid)+ (atomically $ releaseLock tid)+ action+++acquireLock :: ThreadId -> STM ()+acquireLock tid = readTVar globalPyLock >>= \case+ LockUninialized -> throwSTM PythonNotInitialized+ LockFinalized -> throwSTM PythonIsFinalized+ LockedByGC -> retry+ LockUnlocked -> writeTVar globalPyLock $ Locked tid []+ Locked t xs+ | t == tid -> writeTVar globalPyLock $ Locked t (t : xs)+ | otherwise -> retry++grabLock :: ThreadId -> STM ()+grabLock tid = readTVar globalPyLock >>= \case+ 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 -> throwSTM PythonNotInitialized+ LockFinalized -> throwSTM PythonIsFinalized+ LockUnlocked -> throwSTM $ PyInternalError "releaseLock: releasing LockUnlocked"+ LockedByGC -> throwSTM $ PyInternalError "releaseLock: releasing LockedByGC"+ Locked t xs+ | t /= tid -> throwSTM $ PyInternalError "releaseLock: releasing wrong lock"+ | otherwise -> writeTVar globalPyLock $! case xs of+ [] -> LockUnlocked+ t':ts -> Locked t' ts++++----------------------------------------------------------------+-- Initialization and finalization+----------------------------------------------------------------++-- | Initialize python interpreter. If interpreter is already+-- initialized it's a noop. Calling after python was shut down will+-- result in error.+initializePython :: IO ()+-- See NOTE: [Python and threading]+initializePython = [CU.exp| int { Py_IsInitialized() } |] >>= \case+ 0 | rtsSupportsBoundThreads -> runInBoundThread $ mask_ $ doInializePython+ | otherwise -> mask_ $ doInializePython+ _ -> pure ()++-- | Destroy python interpreter.+finalizePython :: IO ()+finalizePython = mask_ doFinalizePython++-- | Bracket which ensures that action is executed with properly+-- initialized interpreter+withPython :: IO a -> IO a+withPython = bracket_ initializePython finalizePython+++doInializePython :: IO ()+doInializePython = do+ -- First we need to grab global python lock on haskell side+ join $ atomically $ do+ readTVar globalPyState >>= \case+ Finalized -> throwSTM PythonNotInitialized+ InitFailed -> throwSTM PythonIsFinalized+ InInitialization -> retry+ InFinalization -> retry+ Running1{} -> pure $ pure ()+ RunningN{} -> pure $ pure ()+ NotInitialized -> do+ writeTVar globalPyState InInitialization+ let fini st = atomically $ do+ writeTVar globalPyState $ st+ writeTVar globalPyLock $ LockUnlocked++ pure $+ (mask_ $ if+ -- On multithreaded runtime create bound thread to make+ -- sure we can call python in its main thread.+ | rtsSupportsBoundThreads -> do+ lock_init <- newEmptyMVar+ lock_eval <- newEmptyMVar+ -- Main thread+ tid_main <- forkOS $ mainThread lock_init lock_eval+ takeMVar lock_init >>= \case+ True -> pure ()+ False -> throwM PyInitializationFailed+ -- GC thread+ gc_chan <- newChan+ tid_gc <- forkOS $ gcThread gc_chan+ fini $ RunningN gc_chan lock_eval tid_main tid_gc+ -- Nothing special is needed on single threaded RTS+ | otherwise -> do+ doInializePythonIO >>= \case+ True -> pure ()+ False -> throwM PyInitializationFailed+ fini Running1+ ) `onException` atomically (writeTVar globalPyState InitFailed)++-- This action is executed on python's main thread+mainThread :: MVar Bool -> MVar EvalReq -> IO ()+mainThread lock_init lock_eval = do+ r_init <- doInializePythonIO+ putMVar lock_init r_init+ case r_init of+ False -> pure ()+ True -> mask_ $ do+ let loop+ = handle (\InterruptMain -> pure ())+ $ takeMVar lock_eval >>= \case+ EvalReq py resp -> do+ res <- (Right <$> runPy py) `catch` (pure . Left)+ putMVar resp res+ loop+ StopReq resp -> do+ [C.block| void {+ PyGILState_Ensure();+ Py_Finalize();+ } |]+ putMVar resp ()+ loop++++doInializePythonIO :: IO Bool+doInializePythonIO = do+ -- FIXME: I'd like more direct access to argv+ argv0 <- getProgName+ argv <- getArgs+ let n_argv = fromIntegral $ length argv + 1+ -- FIXME: For some reason sys.argv is initialized incorrectly. No+ -- easy way to debug. Will do for now+ r <- evalContT $ do+ p_argv0 <- ContT $ withWCString argv0+ p_argv <- traverse (ContT . withWCString) argv+ ptr_argv <- ContT $ withArray (p_argv0 : p_argv)+ liftIO [C.block| int {+ // Now fill config+ PyStatus status;+ PyConfig cfg;+ PyConfig_InitPythonConfig( &cfg );+ cfg.parse_argv = 0;+ cfg.install_signal_handlers = 0;+ //----------------+ status = PyConfig_SetBytesString(&cfg, &cfg.program_name, "XX");+ if( PyStatus_Exception(status) ) {+ goto error;+ }+ //----------------+ status = PyConfig_SetArgv(&cfg,+ $(int n_argv),+ $(wchar_t** ptr_argv)+ );+ if( PyStatus_Exception(status) ) {+ goto error;+ };+ // Initialize interpreter+ status = Py_InitializeFromConfig(&cfg);+ if( PyStatus_Exception(status) ) {+ goto error;+ };+ PyConfig_Clear(&cfg);+ // Release GIL so other threads may take it+ PyEval_SaveThread();+ return 0;+ // Error case+ error:+ PyConfig_Clear(&cfg);+ return 1;+ } |]+ return $! r == 0++doFinalizePython :: IO ()+doFinalizePython = join $ atomically $ readTVar globalPyState >>= \case+ NotInitialized -> throwSTM PythonNotInitialized+ InitFailed -> throwSTM PythonIsFinalized+ Finalized -> pure $ pure ()+ InInitialization -> retry+ InFinalization -> retry+ -- We can simply call Py_Finalize+ Running1 -> checkLock $ [C.block| void {+ PyGILState_Ensure();+ 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+ takeMVar resp+ where+ checkLock action = readTVar globalPyLock >>= \case+ LockUninialized -> throwSTM $ PyInternalError "doFinalizePython LockUninialized"+ LockFinalized -> throwSTM $ PyInternalError "doFinalizePython LockFinalized"+ Locked{} -> retry+ LockedByGC -> retry+ LockUnlocked -> do+ writeTVar globalPyLock LockFinalized+ writeTVar globalPyState Finalized+ pure action+++----------------------------------------------------------------+-- Running Py monad+----------------------------------------------------------------++data EvalReq+ = forall a. EvalReq (Py a) (MVar (Either SomeException a))+ | StopReq (MVar ())++data InterruptMain = InterruptMain+ deriving stock Show+ deriving anyclass Exception++-- | Execute python action. It will take and hold global lock while+-- code is executed. Python exceptions raised during execution are+-- converted to haskell exception 'PyError'.+runPy :: Py a -> IO a+-- See NOTE: [Python and threading]+runPy py+ | rtsSupportsBoundThreads = runInBoundThread go -- Multithreaded RTS+ | otherwise = go -- Single-threaded RTS+ where+ -- We check whether interpreter is initialized. Throw exception if+ -- it wasn't. Better than segfault isn't it?+ go = ensurePyLock $ unPy (ensureGIL py)++-- | Same as 'runPy' but will make sure that code is run in python's+-- main thread. It's thread in which python's interpreter was+-- initialized. Some python's libraries may need that. It has higher+-- call overhead compared to 'runPy'.+runPyInMain :: Py a -> IO a+-- See NOTE: [Python and threading]+runPyInMain py+ -- Multithreaded RTS+ | rtsSupportsBoundThreads = join $ atomically $ readTVar globalPyState >>= \case+ NotInitialized -> throwSTM PythonNotInitialized+ InitFailed -> throwSTM PyInitializationFailed+ Finalized -> throwSTM PythonIsFinalized+ InInitialization -> retry+ InFinalization -> retry+ Running1 -> throwSTM $ PyInternalError "runPyInMain: Running1"+ RunningN _ eval tid_main _ -> do+ acquireLock tid_main+ pure+ $ flip finally (atomically (releaseLock tid_main))+ $ flip onException (throwTo tid_main InterruptMain)+ $ do resp <- newEmptyMVar+ putMVar eval $ EvalReq py resp+ either throwM pure =<< takeMVar resp+ -- Single-threaded RTS+ | otherwise = runPy py++-- | Execute python action. This function is unsafe and should be only+-- called in thread of interpreter.+unPy :: Py a -> IO a+unPy (Py io) = io++++----------------------------------------------------------------+-- GC-related functions+----------------------------------------------------------------++-- | Wrap raw python object into+newPyObject :: Ptr PyObject -> Py PyObject+-- See NOTE: [GC]+newPyObject p = Py $ do+ fptr <- newForeignPtr_ p+ GHC.addForeignPtrFinalizer fptr $+ readTVarIO globalPyState >>= \case+ RunningN ch _ _ _ -> writeChan ch p+ Running1 -> singleThreadedDecrefCG p+ _ -> pure ()+ pure $ PyObject fptr++-- | Thread doing garbage collection for python object in+-- multithreaded runtime.+gcThread :: Chan (Ptr PyObject) -> IO ()+gcThread ch = forever $ do+ decrefGC =<< readChan ch++decrefGC :: Ptr PyObject -> IO ()+decrefGC p = join $ atomically $ readTVar globalPyLock >>= \case+ LockUninialized -> pure $ pure ()+ LockFinalized -> pure $ pure ()+ LockedByGC -> pure $ pure ()+ Locked{} -> retry+ LockUnlocked -> do+ writeTVar globalPyLock LockedByGC+ pure $ do+ gcDecref p `finally` atomically (writeTVar globalPyLock LockUnlocked)++singleThreadedDecrefCG :: Ptr PyObject -> IO ()+singleThreadedDecrefCG p = readTVarIO globalPyLock >>= \case+ LockUninialized -> pure ()+ LockFinalized -> pure ()+ LockedByGC -> gcDecref p+ Locked{} -> gcDecref p+ LockUnlocked -> gcDecref p++gcDecref :: Ptr PyObject -> IO ()+gcDecref p = [CU.block| void {+ PyGILState_STATE st = PyGILState_Ensure();+ Py_XDECREF( $(PyObject* p) );+ PyGILState_Release(st);+ } |]+++----------------------------------------------------------------+-- C-API wrappers+----------------------------------------------------------------++-- | Ensure that we hold GIL for duration of action+ensureGIL :: Py a -> Py a+ensureGIL action = do+ -- NOTE: We're cheating here and looking behind the veil.+ -- PyGILState_STATE is defined as enum. Let hope it will stay+ -- this way.+ gil_state <- Py [CU.exp| int { PyGILState_Ensure() } |]+ action `finally` Py [CU.exp| void { PyGILState_Release($(int gil_state)) } |]++-- | Drop GIL temporarily+dropGIL :: IO a -> Py a+dropGIL action = do+ -- NOTE: We're cheating here and looking behind the veil.+ -- PyGILState_STATE is defined as enum. Let hope it will stay+ -- this way.+ st <- Py [CU.exp| PyThreadState* { PyEval_SaveThread() } |]+ Py $ interruptible action+ `finally` [CU.exp| void { PyEval_RestoreThread($(PyThreadState *st)) } |]+++----------------------------------------------------------------+-- Conversion of exceptions+----------------------------------------------------------------++-- | Convert haskell exception to python exception. Always returns+-- NULL.+convertHaskell2Py :: SomeException -> Py (Ptr PyObject)+convertHaskell2Py err = Py $ do+ withCString ("Haskell exception: "++show err) $ \p_err -> do+ [CU.block| PyObject* {+ PyErr_SetString(PyExc_RuntimeError, $(char *p_err));+ return NULL;+ } |]++-- | Convert python exception to haskell exception. Should only be+-- called if there's unhandled python exception. Clears exception.+convertPy2Haskell :: Py PyException+convertPy2Haskell = runProgram $ do+ p_errors <- withPyAllocaArray @(Ptr PyObject) 3+ -- Fetch error indicator+ (p_type, p_value) <- progIO $ do+ [CU.block| void {+ PyObject **p = $(PyObject** p_errors);+ PyErr_Fetch(p, p+1, p+2);+ }|]+ p_type <- peekElemOff p_errors 0+ p_value <- peekElemOff p_errors 1+ -- Traceback is not used ATM+ pure (p_type,p_value)+ -- Convert exception type and value to strings.+ 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 . PyError =<< convertPy2Haskell++-- | Throw python error as haskell exception if it's raised. If it's+-- not that internal error. Another exception will be raised+mustThrowPyError :: Py a+mustThrowPyError =+ Py [CU.exp| PyObject* { PyErr_Occurred() } |] >>= \case+ NULL -> error $ "mustThrowPyError: no python exception raised."+ _ -> throwM . PyError =<< convertPy2Haskell++-- | Calls mustThrowPyError if pointer is null or returns it unchanged+throwOnNULL :: Ptr PyObject -> Py (Ptr PyObject)+throwOnNULL = \case+ NULL -> mustThrowPyError+ p -> pure p++checkThrowBadPyType :: Py ()+checkThrowBadPyType = do+ r <- Py [CU.block| int {+ if( PyErr_Occurred() ) {+ PyErr_Clear();+ return 1;+ }+ return 0;+ } |]+ case r of+ 0 -> pure ()+ _ -> throwM BadPyType+++----------------------------------------------------------------+-- Debugging+----------------------------------------------------------------++debugPrintPy :: Ptr PyObject -> Py ()+debugPrintPy p = Py [CU.block| void {+ PyObject_Print($(PyObject *p), stdout, 0);+ printf(" [REF=%li]\n", Py_REFCNT($(PyObject *p)) );+ } |]
+ src/Python/Internal/EvalQQ.hs view
@@ -0,0 +1,272 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+-- |+module Python.Internal.EvalQQ+ ( -- * Evaluators and QQ+ evaluatorPymain+ , evaluatorPy_+ , evaluatorPye+ , evaluatorPyf+ -- * Code generation+ , expQQ+ , Mode(..)+ ) where++import Control.Monad.IO.Class+import Control.Monad.Catch+import Data.Bits+import Data.Char+import Data.List (intercalate)+import Data.ByteString qualified as BS+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Foreign.C.Types+import Foreign.Ptr+import System.Exit+import System.Process (readProcessWithExitCode)++import Language.C.Inline qualified as C+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.Internal.Types+import Python.Internal.Program+import Python.Internal.Eval+import Python.Internal.CAPI+import Python.Inline.Literal+++----------------------------------------------------------------+C.context (C.baseCtx <> pyCtx)+C.include "<inline-python.h>"+----------------------------------------------------------------++----------------------------------------------------------------+-- Evaluators+----------------------------------------------------------------++-- | 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), "<interactive>", Py_file_input);+ if( PyErr_Occurred() ){+ return;+ }+ // Execute statements+ PyObject* res = PyEval_EvalCode(code, globals, locals);+ Py_XDECREF(res);+ Py_DECREF(code);+ } |]+ checkThrowPyError++-- | 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), "<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+++evaluatorPymain :: (Ptr PyObject -> Py String) -> Py ()+evaluatorPymain getSource = do+ p_main <- basicMainDict+ src <- getSource p_main+ pyExecExpr p_main p_main src++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+ progPy $ do+ -- Create function in p_locals+ pyExecExpr p_globals p_locals =<< getSource p_kwargs+ -- 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+ 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_") } |]++++----------------------------------------------------------------+-- TH generator+----------------------------------------------------------------++script :: String+script = $( do let path = "py/bound-vars.py"+ TH.addDependentFile path+ TH.lift =<< TH.runIO (readFile path)+ )++data Mode+ = Eval+ | Exec+ | Fun++-- | Generate TH splice which updates python environment dictionary+-- and returns python source code.+expQQ :: Mode -- ^ Python evaluation mode: @exec@/@eval@+ -> String -- ^ Python source code+ -> TH.Q TH.Exp+expQQ mode qq_src = do+ -- We need to preprocess before passing it to python.+ let src = prepareSource mode qq_src+ src_var = prepareForVarLookup mode src+ antis <- liftIO $ do+ -- We've embedded script into library and we need to pass source+ -- code of QQ to a script. It can contain whatever symbols so to+ -- be safe it's base16 encode. This encoding is very simple and we+ -- don't care much about efficiency here+ (code, stdout, stderr) <- readProcessWithExitCode "python"+ [ "-"+ , case mode of Eval -> "eval"+ Exec -> "exec"+ Fun -> "exec"+ ]+ $ unlines [ script+ , "decode_and_print('" <>+ concat [ [ intToDigit $ fromIntegral (w `shiftR` 4)+ , intToDigit $ fromIntegral (w .&. 15) ]+ | w <- BS.unpack $ T.encodeUtf8 $ T.pack src_var+ ]+ <> "')"+ ]+ case code of+ ExitSuccess -> pure $ words stdout+ ExitFailure{} -> fail stderr+ let args = [ [| basicBindInDict $(TH.lift 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)+ |]+++antiSuffix :: String+antiSuffix = "_hs"++-- | Chop antiquotation variable names to get the corresponding Haskell variable name.+chop :: String -> String+chop name = take (length name - length antiSuffix) name+++----------------------------------------------------------------+-- Python source code transform+----------------------------------------------------------------++prepareSource :: Mode -> String -> String+prepareSource = \case+ Eval -> dropWhile isSpace+ Exec -> unindent+ Fun -> unindent++prepareForVarLookup :: Mode -> String -> String+prepareForVarLookup = \case+ Eval -> id+ Exec -> id+ Fun -> ("def __dummy__():\n"++) . indent++prepareForEval :: Mode -> [String] -> String -> String+prepareForEval mode vars src = case mode of+ Eval -> src+ Exec -> src+ Fun -> "def _inline_python_("<>args<>"):\n"+ <> indent src+ where+ args = intercalate "," vars++-- Python is indentation based and quasiquotes do not strip leading+-- space. We have to do that ourself+unindent :: String -> String+unindent py_src = case lines py_src of+ [] -> ""+ -- Strip all leading space for 1-line scripts+ [l] -> dropWhile isSpace l+ -- For multiline script we require that first line should be empty+ l:ls+ | any (not . isSpace) l -> error "First line of multiline quasiquote must be empty"+ -- FIXME: We break multiline strings here. Badly. We need proper python lexer+ -- FIXME: We probably should just forbid tabs+ | otherwise ->+ let non_empty = filter (any (not . isSpace)) ls+ n = minimum [ length (takeWhile (==' ') s) | s <- non_empty ]+ in unlines $ drop n <$> ls++indent :: String -> String+indent = unlines+ . map (" "++)+ . lines
+ src/Python/Internal/Program.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+-- |+module Python.Internal.Program+ ( Program(..)+ , runProgram+ , progPy+ , progIO+ -- * Control flow+ , abort+ , abortM+ , abortOnNull+ , checkNull+ , finallyProg+ , onExceptionProg+ , takeOwnership+ -- * Allocators+ , withPyAlloca+ , withPyAllocaArray+ , withPyCString+ , withPyCStringLen+ , withPyWCString+ -- * Helpers+ , pyobjectStrAsHask+ ) where++import Control.Monad+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Class+import Control.Monad.Catch+import Data.Coerce+import Foreign.Ptr+import Foreign.Marshal.Array+import Foreign.Marshal+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 "<inline-python.h>"+----------------------------------------------------------------+++-- | This monad wraps 'Py' into 'ContT' in order get early exit,+-- applying @finally@ while avoiding building huge ladders.+newtype Program r a = Program (ContT r Py a)+ deriving newtype (Functor, Applicative, Monad)++runProgram :: Program a a -> Py a+runProgram (Program m) = evalContT m++-- | Does not change masking state+progIO :: IO a -> Program r a+progIO = Program . lift . pyIO++progPy :: Py a -> Program r a+progPy = Program . lift++-- | Early exit from continuation monad.+abort :: r -> Program r a+abort r = Program $ ContT $ \_ -> pure r++-- | Early exit from continuation monad.+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 = abortOnNull nullPtr++-- | Evaluate finalizer even if exception is thrown.+finallyProg+ :: Py b -- ^ Finalizer+ -> Program r ()+finallyProg fini = Program $ ContT $ \c -> c () `finally` fini++-- | Evaluate finalizer if exception is thrown.+onExceptionProg+ :: Py b -- ^ Finalizer+ -> Program r ()+onExceptionProg fini = Program $ ContT $ \c -> c () `onException` fini++-- | Decrement reference counter at end of ContT block+takeOwnership :: Ptr PyObject -> Program r (Ptr PyObject)+takeOwnership p = Program $ ContT $ \c -> c p `finally` decref p+++----------------------------------------------------------------+-- Allocation in context of `ContT _ Py`+----------------------------------------------------------------++withPyAlloca :: forall a r. Storable a => Program r (Ptr a)+withPyAlloca = coerce (alloca @a @r)++withPyAllocaArray :: forall a r. Storable a => Int -> Program r (Ptr a)+withPyAllocaArray = coerce (allocaArray @a @r)++withPyCString :: forall r. String -> Program r CString+withPyCString = coerce (withCString @r)++withPyWCString :: forall r. String -> Program r (Ptr CWchar)+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
+ src/Python/Internal/Types.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Definition of data types used by inline-python. They are moved to+-- separate module since some are required for @inline-c@'s context+-- and we need context for+module Python.Internal.Types+ ( -- * Data type+ PyObject(..)+ , unsafeWithPyObject+ , PyThreadState+ , PyError(..)+ , PyException(..)+ , PyInternalError(..)+ , Py(..)+ , pyIO+ -- * inline-C+ , pyCtx+ -- * Patterns+ , pattern IPY_OK+ , pattern IPY_ERR_COMPILE+ , pattern IPY_ERR_PYTHON+ , pattern NULL+ ) where++import Control.Monad.IO.Class+import Control.Monad.Catch+import Control.Monad.Primitive (PrimMonad(..),RealWorld)+import Control.Exception+import Data.Coerce+import Data.Int+import Data.Map.Strict qualified as Map+import Foreign.Ptr+import Foreign.C.Types+import GHC.ForeignPtr++import Language.C.Types+import Language.C.Inline.Context+++----------------------------------------------------------------+-- Primitives+----------------------------------------------------------------++-- | Pointer tag+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 !PyException+ -- ^ Python exception. Contains exception type and message as strings.+ | BadPyType+ -- ^ It's not possible to convert given python value to a haskell+ -- value+ | OutOfRange+ -- ^ Data type is suitable but value is outside of allowed+ -- range. For example attempting to convert 1000 to @Word8@ will+ -- result in this exception.+ | PyInitializationFailed+ -- ^ Initialization of python interpreter failed+ | 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+-- time. Function that execute @Py@ make sure that this invariant is+-- held. Also note that all code in @Py@ monad is executed with+-- asynchronous exception masked, but 'liftIO' removes mask.+newtype Py a = Py (IO a)+ -- See NOTE: [Python and threading]+ deriving newtype (Functor,Applicative,Monad,MonadFail,+ MonadThrow,MonadCatch,MonadMask)++-- | Inject @IO@ into @Py@ monad without changing masking state+-- (unlike 'liftIO')+pyIO :: IO a -> Py a+pyIO = Py++-- | Removes exception masking+instance MonadIO Py where+ liftIO = Py . interruptible++instance PrimMonad Py where+ type PrimState Py = RealWorld+ primitive = Py . primitive+ {-# INLINE primitive #-}+++----------------------------------------------------------------+-- inline-C+----------------------------------------------------------------++-- | @inline-c@ context for mapping+pyCtx :: Context+pyCtx = mempty { ctxTypesTable = Map.fromList tytabs } where+ tytabs =+ [ ( TypeName "PyObject", [t| PyObject |])+ , ( TypeName "PyThreadState", [t| PyThreadState |])+ , ( TypeName "PyCFunction"+ , [t| FunPtr (Ptr PyObject -> Ptr PyObject -> IO (Ptr PyObject)) |])+ , ( TypeName "PyCFunctionFast"+ , [t| FunPtr (Ptr PyObject -> Ptr (Ptr PyObject) -> Int64 -> IO (Ptr PyObject)) |])+ ]+++----------------------------------------------------------------+-- Patterns+----------------------------------------------------------------++pattern IPY_OK, IPY_ERR_PYTHON, IPY_ERR_COMPILE :: CInt+-- | Success+pattern IPY_OK = 0+-- | Python exception raised+pattern IPY_ERR_PYTHON = 1+-- | Error while compiling python source to byte code. Normally it+-- shouldn't happen.+pattern IPY_ERR_COMPILE = 2+++pattern NULL :: Ptr a+pattern NULL <- ((== nullPtr) -> True) where+ NULL = nullPtr
+ src/Python/Internal/Util.hs view
@@ -0,0 +1,11 @@+-- |+module Python.Internal.Util where++import Data.Char+import Foreign.Ptr+import Foreign.Marshal.Array+import Foreign.C.Types+++withWCString :: String -> (Ptr CWchar -> IO a) -> IO a+withWCString = withArray0 (CWchar 0) . map (fromIntegral . ord)
+ test/TST/Callbacks.hs view
@@ -0,0 +1,101 @@+-- |+module TST.Callbacks (tests) where++import Test.Tasty+import Test.Tasty.HUnit+import Python.Inline+import Python.Inline.QQ++import TST.Util++tests :: TestTree+tests = testGroup "Callbacks"+ [ testCase "Function(arity 0)" $ runPy $ do+ let double = pure 2 :: IO Int+ [py_|+ # OK+ assert double_hs() == 2+ # Wrong arg number+ try:+ double_hs(1,2,3)+ except TypeError as e:+ pass+ |]+ , testCase "Function(arity=1)" $ runPy $ do+ let double = pure . (*2) :: Int -> IO Int+ [py_|+ # OK+ assert double_hs(3) == 6+ # Invalid arg+ try:+ double_hs(None)+ except TypeError as e:+ pass+ # Wrong arg number+ try:+ double_hs(1,2,3)+ except TypeError as e:+ pass+ |]+ , testCase "Function(arity=2)" $ runPy $ do+ let foo :: Int -> Double -> IO Int+ foo x y = pure $ x + round y+ [py_|+ assert foo_hs(3, 100.2) == 103+ assert foo_hs(3, 100) == 103+ # Invalid arg+ try:+ foo_hs(None, 100)+ except TypeError as e:+ pass+ # Wrong arg number+ try:+ foo_hs(1,2,3)+ except TypeError as e:+ pass+ |]+ , testCase "Haskell exception in callback(arity=1)" $ runPy $ do+ let foo :: Int -> IO Int+ foo y = pure $ 10 `div` y+ throwsPy [py_| foo_hs(0) |]+ , testCase "Haskell exception in callback(arity=2)" $ runPy $ do+ let foo :: Int -> Int -> IO Int+ foo x y = pure $ x `div` y+ throwsPy [py_| foo_hs(1, 0) |]+ ----------------------------------------+ , testCase "Call python in callback (arity=1)" $ runPy $ do+ let foo :: Int -> IO Int+ foo x = do Just x' <- runPy $ fromPy =<< [pye| 100 // x_hs |]+ pure x'+ [py_|+ assert foo_hs(5) == 20+ |]+ , testCase "Call python in callback (arity=2" $ runPy $ do+ let foo :: Int -> Int -> IO Int+ foo x y = do Just x' <- runPy $ fromPy =<< [pye| x_hs // y_hs |]+ pure x'+ [py_|+ assert foo_hs(100,5) == 20+ |]+ ----------------------------------------+ , testCase "No leaks (arity=1)" $ runPy $ do+ let foo :: Int -> IO Int+ foo y = pure $ 10 * y+ [py_|+ import sys+ x = 123456+ old_refcount = sys.getrefcount(x)+ foo_hs(x)+ assert old_refcount == sys.getrefcount(x)+ |]+ , testCase "No leaks (arity=2)" $ runPy $ do+ let foo :: Int -> Int -> IO Int+ foo x y = pure $ x * y+ [py_|+ import sys+ x = 123456+ old_refcount = sys.getrefcount(x)+ foo_hs(1,x)+ assert old_refcount == sys.getrefcount(x)+ |]+ ]
+ test/TST/FromPy.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- |+module TST.FromPy (tests) where++import Control.Monad.IO.Class+import Test.Tasty+import Test.Tasty.HUnit+import Python.Inline+import Python.Inline.QQ++tests :: TestTree+tests = testGroup "FromPy"+ [ testGroup "Int"+ [ testCase "Int->Int" $ eq @Int (Just 1234) [pye| 1234 |]+ , testCase "Double->Int" $ eq @Int Nothing [pye| 1234.25 |]+ , testCase "None->Int" $ eq @Int Nothing [pye| None |]+ ]+ , testGroup "Double"+ [ testCase "Int->Double" $ eq @Double (Just 1234) [pye| 1234 |]+ , testCase "Double->Double" $ eq @Double (Just 1234.25) [pye| 1234.25 |]+ , testCase "None->Double" $ eq @Double Nothing [pye| None |]+ ]+ , testGroup "Char"+ [ testCase "0" $ eq @Char Nothing [pye| "" |]+ , testCase "1 1B" $ eq @Char (Just 'a') [pye| "a" |]+ , testCase "2 2B" $ eq @Char (Just 'ы') [pye| "ы" |]+ , testCase "2" $ eq @Char Nothing [pye| "as" |]+ , testCase "None" $ eq @Char Nothing [pye| None |]+ ]+ , testGroup "String"+ [ testCase "asdf" $ eq @String (Just "asdf") [pye| "asdf" |]+ , testCase "фыва" $ eq @String (Just "фыва") [pye| "фыва" |]+ ]+ , testGroup "Bool"+ [ testCase "True->Bool" $ eq @Bool (Just True) [pye| True |]+ , testCase "False->Bool" $ eq @Bool (Just False) [pye| False |]+ , testCase "None->Bool" $ eq @Bool (Just False) [pye| None |]+ -- FIXME: Names defined in pymain leak!+ , testCase "Exception" $ runPy $ do+ [pymain|+ class Bad:+ def __bool__(self):+ raise Exception("Bad __bool__")+ |]+ failE @Bool =<< [pye| Bad() |]+ -- Segfaults if exception is not cleared+ [py_| 1+1 |]+ ]+ , testGroup "Tuple2"+ [ testCase "T2" $ eq @(Int,Bool) (Just (2,True)) [pye| (2,3) |]+ , testCase "L2" $ eq @(Int,Bool) (Just (2,True)) [pye| [2,3] |]+ , testCase "L1" $ eq @(Int,Bool) Nothing [pye| [1] |]+ , testCase "T3" $ eq @(Int,Bool) Nothing [pye| (1,2,3) |]+ , testCase "X" $ eq @(Int,Bool) Nothing [pye| 2 |]+ ]+ , testGroup "Tuple3"+ [ testCase "T3" $ eq @(Int,Int,Int) (Just (1,2,3)) [pye| (1,2,3) |]+ , testCase "L3" $ eq @(Int,Int,Int) (Just (1,2,3)) [pye| [1,2,3] |]+ , testCase "L1" $ eq @(Int,Int,Int) Nothing [pye| [1] |]+ , testCase "T4" $ eq @(Int,Int,Int) Nothing [pye| (1,2,3,4) |]+ , testCase "X" $ eq @(Int,Int,Int) Nothing [pye| 2 |]+ ]+ , testGroup "Tuple4"+ [ testCase "T4" $ eq @(Int,Int,Int,Int) (Just (1,2,3,4)) [pye| (1,2,3,4) |]+ , testCase "L4" $ eq @(Int,Int,Int,Int) (Just (1,2,3,4)) [pye| [1,2,3,4] |]+ , testCase "L1" $ eq @(Int,Int,Int,Int) Nothing [pye| [1] |]+ , testCase "X" $ eq @(Int,Int,Int,Int) Nothing [pye| 2 |]+ ]+ , testGroup "List"+ [ testCase "()" $ eq @[Int] (Just []) [pye| () |]+ , testCase "[]" $ eq @[Int] (Just []) [pye| [] |]+ , testCase "[1]" $ eq @[Int] (Just [1]) [pye| [1] |]+ , testCase "[3]" $ eq @[Int] (Just [1,2,3]) [pye| [1,2,3] |]+ , 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+ Left PyError{} -> pure ()+ r -> liftIO $ assertFailure $ "Should fail with exception, but: " ++ show r+
+ test/TST/Roundtrip.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+-- |+module TST.Roundtrip (tests) where++import Data.Int+import Data.Word+import Data.Typeable+import Data.Set (Set)+import Data.Map.Strict (Map)+import Foreign.C.Types++import Test.Tasty+import Test.Tasty.QuickCheck+import Test.QuickCheck.Instances.Vector ()+import Python.Inline+import Python.Inline.QQ++import Data.Vector qualified as V+#if MIN_VERSION_vector(0,13,2)+import Data.Vector.Strict qualified as VV+#endif+import Data.Vector.Storable qualified as VS+import Data.Vector.Primitive qualified as VP+import Data.Vector.Unboxed qualified as VU+++tests :: TestTree+tests = testGroup "Roundtrip"+ [ testGroup "Roundtrip"+ [ -- Integral types+ testRoundtrip @Int8+ , testRoundtrip @Int16+ , testRoundtrip @Int32+ , testRoundtrip @Int64+ , testRoundtrip @Int+ , testRoundtrip @Word8+ , testRoundtrip @Word16+ , testRoundtrip @Word32+ , testRoundtrip @Word64+ , testRoundtrip @Word+ -- C wrappers+ , testRoundtrip @CChar+ , testRoundtrip @CSChar+ , testRoundtrip @CUChar+ , testRoundtrip @CShort+ , testRoundtrip @CUShort+ , testRoundtrip @CInt+ , testRoundtrip @CUInt+ , testRoundtrip @CLong+ , testRoundtrip @CULong+ , testRoundtrip @CLLong+ , testRoundtrip @CULLong+ -- Floating point+ , testRoundtrip @Double+ , testRoundtrip @Float+ -- Other scalars+ , testRoundtrip @Char+ , testRoundtrip @Bool+ -- Containers+ , testRoundtrip @(Int,Char)+ , testRoundtrip @(Int,(Int,Int))+ , testRoundtrip @(Int,Int,Int)+ , testRoundtrip @(Int,Int,Int,Char)+ , testRoundtrip @[Int]+ , testRoundtrip @[[Int]]+ , testRoundtrip @(Set Int)+ , testRoundtrip @(Map Int Int)+ -- , testRoundtrip @String -- Trips on zero byte as it should+ , testRoundtrip @(V.Vector Int)+ , testRoundtrip @(VS.Vector Int)+ , testRoundtrip @(VP.Vector Int)+ , testRoundtrip @(VU.Vector Int)+#if MIN_VERSION_vector(0,13,2)+-- , testRoundtrip @(VV.Vector Int)+#endif+ ]+ , testGroup "OutOfRange"+ [ testOutOfRange @Int8 @Int16+ , testOutOfRange @Int16 @Int32+ , testOutOfRange @Int32 @Int64+ , testOutOfRange @Word8 @Word16+ , testOutOfRange @Word16 @Word32+ , testOutOfRange @Word32 @Word64+ ]+ ]++testRoundtrip+ :: forall a. (FromPy a, ToPy a, Eq a, Arbitrary a, Show a, Typeable a) => TestTree+testRoundtrip = testProperty (show (typeOf (undefined :: a))) (propRoundtrip @a)++testOutOfRange+ :: forall a wide. (ToPy wide, FromPy a, Eq a, Eq wide, Integral wide, Integral a+ , Typeable a, Typeable wide, Arbitrary wide, Show wide+ )+ => TestTree+testOutOfRange = testProperty+ (show (typeOf (undefined :: a)) ++ " [" ++ show (typeOf (undefined::wide)) ++ "]")+ (propOutOfRange @a @wide)++propRoundtrip :: forall a. (FromPy a, ToPy a, Eq a) => a -> Property+propRoundtrip a = ioProperty $ do+ a' <- runPy $ fromPy' =<< [pye| a_hs |]+ pure $ a == a'+++-- Check that values out of range produce out of range+propOutOfRange+ :: forall a wide. (ToPy wide, FromPy a, Eq a, Eq wide, Integral wide, Integral a)+ => wide -> Property+propOutOfRange wide = ioProperty $ do+ a_py <- runPy $ fromPy @a =<< [pye| wide_hs |]+ pure $ a_hs == a_py+ where+ -- Convert taking range into account+ a_hs = case fromIntegral wide :: a of+ a' | fromIntegral a' == wide -> Just a'+ | otherwise -> Nothing
+ test/TST/Run.hs view
@@ -0,0 +1,114 @@+-- |+-- Tests for variable scope and names+module TST.Run(tests) where++import Control.Monad+import Control.Monad.IO.Class+import Test.Tasty+import Test.Tasty.HUnit+import Python.Inline+import Python.Inline.QQ+import TST.Util++tests :: TestTree+tests = testGroup "Run python"+ [ testCase "Empty QQ" $ runPy [py_| |]+ , testCase "Second init is noop" $ initializePython+ , testCase "Nested runPy" $ runPy $ liftIO $ runPy $ pure ()+ , testCase "runPyInMain" $ runPyInMain $ [py_|+ import threading+ assert threading.main_thread() == threading.current_thread()+ |]+ , testCase "Python exceptions are converted" $ runPy $ throwsPy [py_| 1 / 0 |]+ , testCase "Scope pymain->any" $ runPy $ do+ [pymain|+ x = 12+ x+ |]+ -- Visible+ [py_| x |]+ _ <- [pye| x |]+ [pymain|+ x+ del x+ |]+ -- Disappears+ [pymain|+ try:+ x+ assert False, "x shouln't be visible"+ except NameError:+ pass+ |]+ [py_|+ try:+ x+ assert False, "x shouln't be visible"+ except NameError:+ pass+ |]+ , testCase "Scope py_->any" $ runPy $ do+ [py_|+ x = 12+ x+ |]+ -- Not visible+ throwsPy $ void [pye| x |]+ [py_|+ try:+ x+ assert False, "x shouln't be visible (1)"+ except NameError:+ pass+ |]+ [pymain|+ try:+ x+ assert False, "x shouln't be visible (2)"+ except NameError:+ pass+ |]+ , testCase "Import py_->any" $ runPy $ do+ [py_|+ import sys+ sys+ |]+ -- Not visible+ throwsPy $ void [pye| sys |]+ [py_|+ try:+ sys+ assert False, "sys shouln't be visible (1)"+ except NameError:+ pass+ |]+ [pymain|+ try:+ sys+ assert False, "sys shouln't be visible (2)"+ except NameError:+ pass+ |]+ , testCase "Scope pyf->any" $ runPy $ do+ _ <- [pyf|+ x = 12+ x+ return 12+ |]+ -- Not visible+ throwsPy $ void [pye| x |]+ [py_|+ try:+ x+ assert False, "x shouln't be visible (1)"+ except NameError:+ pass+ |]+ [pymain|+ try:+ x+ assert False, "x shouln't be visible (2)"+ except NameError:+ pass+ |]+ ]
+ test/TST/ToPy.hs view
@@ -0,0 +1,49 @@+-- |+module TST.ToPy (tests) where++import Data.Set qualified as Set+import Data.Map.Strict qualified as Map+import Test.Tasty+import Test.Tasty.HUnit+import Python.Inline+import Python.Inline.QQ+import TST.Util+++tests :: TestTree+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 "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 == 'фыва' |]+ -- Container types+ , testCase "Tuple2" $ runPy $+ let x = (1::Int, 333::Int)+ in [py_| assert x_hs == (1,333) |]+ , testCase "Tuple3" $ runPy $+ let x = (1::Int, 333::Int, True)+ in [py_| assert x_hs == (1,333,True) |]+ , testCase "Tuple4" $ runPy $+ let x = (1::Int, 333::Int, True, 'c')+ in [py_| assert x_hs == (1,333,True,'c') |]+ , testCase "nested Tuple2" $ runPy $+ let x = (1::Int, (333::Int,4.5::Double))+ in [py_| assert x_hs == (1,(333,4.5)) |]+ , testCase "list" $ runPy $+ let x = [1 .. 5::Int]+ in [py_| assert x_hs == [1,2,3,4,5] |]+ , testCase "set<int>" $ runPy $+ let x = Set.fromList [1, 5, 3::Int]+ in [py_| assert x_hs == {1,3,5} |]+ , testCase "set unhashable" $ runPy $+ let x = Set.fromList [[1], [5], [3::Int]]+ in throwsPy [py_| x_hs |]+ , testCase "dict<int,int>" $ runPy $+ let x = Map.fromList [(1,10), (5,50), (3,30)] :: Map.Map Int Int+ in [py_| assert x_hs == {1:10, 3:30, 5:50} |]+ , testCase "dict unhashable" $ runPy $+ let x = Map.fromList [([1],10), ([5],50), ([3],30)] :: Map.Map [Int] Int+ in throwsPy [py_| x_hs |]+ ]
+ test/TST/Util.hs view
@@ -0,0 +1,14 @@+-- |+module TST.Util where++import Control.Monad.IO.Class+import Control.Monad.Catch+import Test.Tasty.HUnit++import Python.Inline+import Python.Inline.Types++throwsPy :: Py () -> Py ()+throwsPy io = (io >> liftIO (assertFailure "Evaluation should raise python exception"))+ `catch` (\(_::PyError) -> pure ())+
+ test/exe/main.hs view
@@ -0,0 +1,19 @@+module Main where++import Test.Tasty++import TST.Run+import TST.FromPy+import TST.ToPy+import TST.Callbacks+import TST.Roundtrip+import Python.Inline++main :: IO ()+main = withPython $ defaultMain $ testGroup "PY"+ [ TST.Run.tests+ , TST.FromPy.tests+ , TST.ToPy.tests+ , TST.Roundtrip.tests+ , TST.Callbacks.tests+ ]