diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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 + ] diff --git a/cbits/python.c b/cbits/python.c new file mode 100644 --- /dev/null +++ b/cbits/python.c @@ -0,0 +1,142 @@ +#include +#include + +// ================================================================ +// 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; +} + diff --git a/include/inline-python.h b/include/inline-python.h new file mode 100644 --- /dev/null +++ b/include/inline-python.h @@ -0,0 +1,53 @@ +#pragma once + +#define PY_SSIZE_T_CLEAN +#include +#include + + +// 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 + ); diff --git a/inline-python.cabal b/inline-python.cabal new file mode 100644 --- /dev/null +++ b/inline-python.cabal @@ -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 +Maintainer: Aleksey Khudyakov +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 diff --git a/py/bound-vars.py b/py/bound-vars.py new file mode 100644 --- /dev/null +++ b/py/bound-vars.py @@ -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, '', 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')) diff --git a/src/Python/Inline.hs b/src/Python/Inline.hs new file mode 100644 --- /dev/null +++ b/src/Python/Inline.hs @@ -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. diff --git a/src/Python/Inline/Literal.hs b/src/Python/Inline/Literal.hs new file mode 100644 --- /dev/null +++ b/src/Python/Inline/Literal.hs @@ -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 "" +---------------------------------------------------------------- + +-- | 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 #-} diff --git a/src/Python/Inline/QQ.hs b/src/Python/Inline/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Python/Inline/QQ.hs @@ -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" + } diff --git a/src/Python/Inline/Types.hs b/src/Python/Inline/Types.hs new file mode 100644 --- /dev/null +++ b/src/Python/Inline/Types.hs @@ -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 + diff --git a/src/Python/Internal/CAPI.hs b/src/Python/Internal/CAPI.hs new file mode 100644 --- /dev/null +++ b/src/Python/Internal/CAPI.hs @@ -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 "" +---------------------------------------------------------------- + + +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; + } |] diff --git a/src/Python/Internal/Eval.hs b/src/Python/Internal/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Python/Internal/Eval.hs @@ -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 "" +---------------------------------------------------------------- + +-- 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)) ); + } |] diff --git a/src/Python/Internal/EvalQQ.hs b/src/Python/Internal/EvalQQ.hs new file mode 100644 --- /dev/null +++ b/src/Python/Internal/EvalQQ.hs @@ -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 "" +---------------------------------------------------------------- + +---------------------------------------------------------------- +-- 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), "", 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), "", 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 diff --git a/src/Python/Internal/Program.hs b/src/Python/Internal/Program.hs new file mode 100644 --- /dev/null +++ b/src/Python/Internal/Program.hs @@ -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 "" +---------------------------------------------------------------- + + +-- | 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 diff --git a/src/Python/Internal/Types.hs b/src/Python/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Python/Internal/Types.hs @@ -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 diff --git a/src/Python/Internal/Util.hs b/src/Python/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Python/Internal/Util.hs @@ -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) diff --git a/test/TST/Callbacks.hs b/test/TST/Callbacks.hs new file mode 100644 --- /dev/null +++ b/test/TST/Callbacks.hs @@ -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) + |] + ] diff --git a/test/TST/FromPy.hs b/test/TST/FromPy.hs new file mode 100644 --- /dev/null +++ b/test/TST/FromPy.hs @@ -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 + diff --git a/test/TST/Roundtrip.hs b/test/TST/Roundtrip.hs new file mode 100644 --- /dev/null +++ b/test/TST/Roundtrip.hs @@ -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 diff --git a/test/TST/Run.hs b/test/TST/Run.hs new file mode 100644 --- /dev/null +++ b/test/TST/Run.hs @@ -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 + |] + ] diff --git a/test/TST/ToPy.hs b/test/TST/ToPy.hs new file mode 100644 --- /dev/null +++ b/test/TST/ToPy.hs @@ -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" $ 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" $ 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 |] + ] diff --git a/test/TST/Util.hs b/test/TST/Util.hs new file mode 100644 --- /dev/null +++ b/test/TST/Util.hs @@ -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 ()) + diff --git a/test/exe/main.hs b/test/exe/main.hs new file mode 100644 --- /dev/null +++ b/test/exe/main.hs @@ -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 + ]