Add From/ToPy instances for Bool and 2-tuples (#8)

Author: Shimuuar

cbits/python.c

@@ -43,6 +43,45 @@ PyObject *inline_py_function_wrapper(PyCFunction fun, int flags) {
     return f;    
 }
 
+int inline_py_unpack_iterable(PyObject *iterable, int n, PyObject **out) {
+    // Fill out with NULL. This way we can call XDECREF on them
+    for(int i = 0; i < n; i++) {
+        out[i] = NULL;
+    }
+    // Initialize iterator
+    PyObject* iter = PyObject_GetIter( iterable );
+    if( PyErr_Occurred() ) {
+        return -1;
+    }
+    if( !PyIter_Check(iter) ) {
+        goto err_iter;
+    }
+    // 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;
+}
+
+
 void inline_py_free_capsule(PyObject* py) {
     PyMethodDef *meth = PyCapsule_GetPointer(py, NULL);
     // HACK: We want to release wrappers created by wrapper. It

include/inline-python.h

@@ -10,6 +10,8 @@
 #define INLINE_PY_ERR_COMPILE 1
 #define INLINE_PY_ERR_EVAL    2
 
+
+
 // This macro checks for errors. If python exception is raised it
 // clear it and returns 1 otherwise retruns 0
 #define INLINE_PY_SIMPLE_ERROR_HANDLING() do {      \
@@ -29,6 +31,20 @@ void inline_py_export_exception(
     char** p_msg
     );
 
+// Unpack iterable into array of PyObjects. Iterable must contain
+// exactly N elements.
+//
+// On success returns 0 and fills `out` with N PyObjects
+//
+// On failure returns -1. Python exception is not cleared. It's
+// responsibility of caller to deal with it. Content of `out` is
+// undefined in this case.
+int inline_py_unpack_iterable(
+    PyObject  *iterable,
+    int        n,
+    PyObject **out
+    );
+
 // Allocate python function object which carrries its own PyMethodDef.
 // Returns function object or NULL with error raised.
 //

inline-python.cabal

@@ -84,6 +84,7 @@ library test
   hs-source-dirs:   test
   Exposed-modules:
     TST.Run
+    TST.FromPy
 
 test-suite inline-python-tests
   import:           language

shell.nix

@@ -1,7 +1,8 @@
 let
   pkgs = import <nixpkgs> {};
   py = pkgs.python3.withPackages (py_pkg: with py_pkg;
-    [
+    [ numpy
+      matplotlib
     ]);
 in
 pkgs.mkShell {
@@ -10,4 +11,7 @@ pkgs.mkShell {
     pkg-config
     py
   ];
+  shellHook = ''
+    export PYTHONHOME=${py}
+  '';
 }

src/Python/Inline/Literal.hs

@@ -13,6 +13,7 @@ module Python.Inline.Literal
 import Control.Exception
 import Control.Monad
 import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
 import Control.Monad.Trans.Cont
 import Data.Int
 import Data.Word
@@ -28,6 +29,7 @@ import Language.C.Inline.Unsafe  qualified as CU
 import Python.Types
 import Python.Internal.Types
 import Python.Internal.Eval
+import Python.Internal.Util
 
 
 ----------------------------------------------------------------
@@ -143,6 +145,60 @@ instance ToPy Int where
 instance FromPy Int where
   basicFromPy = (fmap . fmap) fromIntegral . basicFromPy @Int64
 
+-- TODO: Int may be 32 or 64 bit!
+-- TODO: Int{8,16,32} & Word{8,16,32}
+
+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 = Py $ do
+    r <- [CU.block| int {
+      int r = PyObject_IsTrue($(PyObject* p));
+      PyErr_Clear();
+      return r;
+      } |]
+    case r of
+      0 -> pure $ Just False
+      1 -> pure $ Just True
+      _ -> pure $ Nothing
+
+instance (ToPy a, ToPy b) => ToPy (a,b) where
+  basicToPy (a,b) = do
+    basicToPy a >>= \case
+      NULL -> pure NULL
+      p_a  -> basicToPy b >>= \case
+        NULL -> pure $ NULL
+        p_b  -> Py [CU.exp| PyObject* { PyTuple_Pack(2, $(PyObject* p_a), $(PyObject* p_b)) } |]
+
+instance (FromPy a, FromPy b) => FromPy (a,b) where
+  basicFromPy p_tup = evalContT $ do
+    -- Unpack 2-tuple.
+    p_args    <- withPyAllocaArray 2
+    unpack_ok <- liftIO [CU.exp| int {
+      inline_py_unpack_iterable($(PyObject *p_tup), 2, $(PyObject **p_args))
+      }|]
+    -- We may want to extract exception to haskell side later
+    liftIO [CU.exp| void { PyErr_Clear() } |]
+    when (unpack_ok /= 0) $ abort $ pure Nothing
+    -- Unpack 2-elements
+    lift $ do
+      p_a <- liftIO $ peekElemOff p_args 0
+      p_b <- liftIO $ peekElemOff p_args 1
+      let parse = basicFromPy p_a >>= \case
+            Nothing -> pure Nothing
+            Just a  -> basicFromPy p_b >>= \case
+              Nothing -> pure Nothing
+              Just b  -> pure $ Just (a,b)
+          fini  = liftIO [CU.block| void {
+            Py_XDECREF( $(PyObject* p_a) );
+            Py_XDECREF( $(PyObject* p_b) );
+            } |]
+      parse `finallyPy` fini
+
+
 
 ----------------------------------------------------------------
 -- Functions marshalling

src/Python/Internal/Types.hs

@@ -10,17 +10,21 @@ module Python.Internal.Types
     PyObject(..)
   , PyError(..)
   , Py(..)
+  , finallyPy
     -- * inline-C
   , pyCtx
     -- * Patterns
   , pattern INLINE_PY_OK
   , pattern INLINE_PY_ERR_COMPILE
   , pattern INLINE_PY_ERR_EVAL
+  , pattern NULL
   ) where
 
 import Control.Exception
 import Control.Monad.IO.Class
+import Data.Coerce
 import Data.Map.Strict           qualified as Map
+import Foreign.Ptr
 import Foreign.ForeignPtr
 import Foreign.C.Types
 import Language.C.Types
@@ -50,6 +54,8 @@ newtype Py a = Py (IO a)
   deriving newtype (Functor,Applicative,Monad,MonadIO,MonadFail)
 -- See NOTE: [Python and threading]
 
+finallyPy :: forall a b. Py a -> Py b -> Py a
+finallyPy = coerce (finally @a @b)
 
 ----------------------------------------------------------------
 -- inline-C
@@ -67,3 +73,8 @@ pattern INLINE_PY_OK, INLINE_PY_ERR_COMPILE, INLINE_PY_ERR_EVAL :: CInt
 pattern INLINE_PY_OK          = 0
 pattern INLINE_PY_ERR_COMPILE = 1
 pattern INLINE_PY_ERR_EVAL    = 2
+
+
+pattern NULL :: Ptr a
+pattern NULL <- ((== nullPtr) -> True) where
+  NULL = nullPtr

src/Python/Internal/Util.hs

@@ -25,6 +25,9 @@ withWCtring = withArray0 (CWchar 0) . map (fromIntegral . ord)
 withPyAlloca :: forall a r. Storable a => ContT r Py (Ptr a)
 withPyAlloca = coerce (alloca @a @r)
 
+withPyAllocaArray :: forall a r. Storable a => Int -> ContT r Py (Ptr a)
+withPyAllocaArray = coerce (allocaArray @a @r)
+
 withPyCString :: forall r. String -> ContT r Py CString
 withPyCString = coerce (withCString @r)
 

test/TST/FromPy.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE QuasiQuotes #-}
+-- |
+module TST.FromPy (tests) where
+
+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 "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 leak!
+    , testCase "Exception" $ do
+        [pymain|
+               class Bad:
+                   def __bool__(self):
+                       raise Exception("Bad __bool__")
+               |]
+        eq @Bool Nothing =<< [pye| Bad() |]
+        -- Segfaults if exception is not cleared
+        [py_| 1+1 |]
+    ]
+  , testGroup "Tuple2"
+    [ testCase "(2)->2" $ eq @(Int,Bool) (Just (2,True)) =<< [pye| (2,2) |]
+    , testCase "[2]->2" $ eq @(Int,Bool) (Just (2,True)) =<< [pye| [2,2] |]
+    , testCase "(1)->2" $ eq @(Int,Bool) Nothing =<< [pye| (1)     |]
+    , testCase "(3)->2" $ eq @(Int,Bool) Nothing =<< [pye| (1,2,3) |]
+    , testCase "X->2"   $ eq @(Int,Bool) Nothing =<< [pye| 2 |]
+    ]
+  ]
+
+eq :: (Eq a, Show a, FromPy a) => Maybe a -> PyObject -> IO ()
+eq a p = assertEqual "fromPy: " a =<< fromPy p

test/exe/main.hs

@@ -3,9 +3,11 @@ module Main where
 import Test.Tasty
 
 import TST.Run
+import TST.FromPy
 import Python.Inline
 
 main :: IO ()
 main = withPython $ defaultMain $ testGroup "PY"
   [ TST.Run.tests
+  , TST.FromPy.tests
   ]