Hack in support for Maybe ForeignPtr

Author: vkleen

src/Language/Rust/Inline.hs

@@ -314,6 +314,7 @@ processQQ safety isPure (QQParse rustRet rustBody rustNamedArgs) = do
     -- Convert the Haskell return type to a marshallable FFI type
     (returnFfi, haskRet') <- do
         marshalForm <- ghcMarshallable haskRet
+        let fptrRet haskRet' = [t|Ptr (Ptr $(pure haskRet'), FunPtr (Ptr $(pure haskRet') -> IO ())) -> IO ()|]
         ret <- case marshalForm of
             BoxedDirect -> [t|IO $(pure haskRet)|]
             BoxedIndirect -> [t|Ptr $(pure haskRet) -> IO ()|]
@@ -324,8 +325,11 @@ processQQ safety isPure (QQParse rustRet rustBody rustNamedArgs) = do
                      in fail ("Cannot put unlifted type ‘" ++ retTy ++ "’ in IO")
             ByteString -> [t|Ptr (Ptr Word8, Word, FunPtr (Ptr Word8 -> Word -> IO ())) -> IO ()|]
             ForeignPtr
-                | AppT _ haskRet' <- haskRet -> [t|Ptr (Ptr $(pure haskRet'), FunPtr (Ptr $(pure haskRet') -> IO ())) -> IO ()|]
+                | AppT _ haskRet' <- haskRet -> fptrRet haskRet'
                 | otherwise -> fail ("Cannot marshal " ++ showTy haskRet ++ " using the ForeignPtr calling convention")
+            OptionalForeignPtr
+                | AppT _ (AppT _ haskRet') <- haskRet -> fptrRet haskRet'
+                | otherwise -> fail ("Cannot marshal " ++ showTy haskRet ++ " as an optional ForeignPtr")
         pure (marshalForm, pure ret)
 
     -- Convert the Haskell arguments to marshallable FFI types
@@ -357,6 +361,11 @@ processQQ safety isPure (QQParse rustRet rustBody rustNamedArgs) = do
                         ptr <- [t|Ptr $(pure haskArg')|]
                         pure (ForeignPtr, ptr)
                     | otherwise -> fail ("Cannot marshal " ++ showTy haskRet ++ " using the ForeignPtr calling convention")
+                OptionalForeignPtr
+                    | AppT _ (AppT _ haskArg') <- haskArg -> do
+                        ptr <- [t|Ptr $(pure haskArg')|]
+                        pure (OptionalForeignPtr, ptr)
+                    | otherwise -> fail ("Cannot marshal " ++ showTy haskRet ++ " as an optional ForeignPtr")
                 _ -> pure (marshalForm, haskArg)
 
     -- Generate the Haskell FFI import declaration and emit it
@@ -408,6 +417,20 @@ processQQ safety isPure (QQParse rustRet rustBody rustNamedArgs) = do
                             newForeignPtr $(varE finalizer) $(varE ptr)
                         )
                     |]
+            | returnFfi == OptionalForeignPtr = do
+                finalizer <- newName "finalizer"
+                ptr <- newName "ptr"
+                ret <- newName "ret"
+                [e|
+                    alloca
+                        ( \($(varP ret)) -> do
+                            $(appsE (varE qqName : reverse (varE ret : acc)))
+                            ($(varP ptr), $(varP finalizer)) <- peek $(varE ret)
+                            if $(varE ptr) == nullPtr
+                                then pure Nothing
+                                else Just <$> newForeignPtr $(varE finalizer) $(varE ptr)
+                        )
+                    |]
             | returnByValue returnFfi = appsE (varE qqName : reverse acc)
             | otherwise = do
                 ret <- newName "ret"
@@ -443,6 +466,15 @@ processQQ safety isPure (QQParse rustRet rustBody rustNamedArgs) = do
                         [e|
                             withForeignPtr $(varE argName) (\($(varP ptr)) -> $(goArgs (varE ptr : acc) args))
                             |]
+                    | marshalForm == OptionalForeignPtr -> do
+                        ptr <- newName "ptr"
+                        fptr <- newName "fptr"
+                        [e|
+                            case $(varE argName) of
+                                Nothing -> let $(varP ptr) = nullPtr in $(goArgs (varE ptr : acc) args)
+                                Just $(varP fptr) ->
+                                    withForeignPtr $(varE fptr) (\($(varP ptr)) -> $(goArgs (varE ptr : acc) args))
+                            |]
                     | passByValue marshalForm -> goArgs (varE argName : acc) args
                     | otherwise -> do
                         x <- newName "x"

src/Language/Rust/Inline/Context.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
 
 module Language.Rust.Inline.Context where
 
@@ -314,17 +315,27 @@ pointers = do
             ]
 
 foreignPointers :: Q Context
-foreignPointers =
-    pure $ Context ([rule], [], [foreignPtr, constPtr, mutPtr])
+foreignPointers = do
+    foreignPtrT <- [t|ForeignPtr|]
+    pure $ Context ([rule], [rev foreignPtrT], [foreignPtr, constPtr, mutPtr])
   where
     rule (Ptr _ t _) context
         | First (Just (t', Nothing)) <- lookupRTypeInContext t context = pure ([t|ForeignPtr $t'|], Nothing)
     rule (Rptr _ _ t _) context
         | First (Just (t', Nothing)) <- lookupRTypeInContext t context = pure ([t|ForeignPtr $t'|], Nothing)
     rule (PathTy Nothing (Path False [PathSegment "ForeignPtr" (Just (AngleBracketed [] [t] [] _)) _] _) _) context
         | First (Just (t', Nothing)) <- lookupRTypeInContext t context = pure ([t|ForeignPtr $t'|], Nothing)
+    rule (PathTy Nothing (Path False [PathSegment "Option" (Just (AngleBracketed [] [PathTy Nothing (Path False [PathSegment "ForeignPtr" (Just (AngleBracketed [] [t] [] _)) _] _) _] [] _)) _] _) _) context
+        | First (Just (t', Nothing)) <- lookupRTypeInContext t context =
+            pure ([t|Maybe (ForeignPtr $t')|], pure . pure $ PathTy Nothing (Path False [PathSegment "ForeignPtr" (Just (AngleBracketed [] [t] [] ())) ()] ()) ())
     rule _ _ = mempty
 
+    rev foreignPtrT (AppT foreignPtr t) context
+        | foreignPtr == foreignPtrT = do
+            t' <- lookupHTypeInContext t context
+            pure (Ptr Mutable <$> t' <*> pure ())
+    rev _ _ _ = mempty
+
     foreignPtr =
         unlines
             [ "#[repr(C)]"
@@ -359,7 +370,7 @@ foreignPointers =
             , ""
             , "impl<T> From<Box<T>> for ForeignPtr<T> {"
             , "  fn from(p: Box<T>) -> ForeignPtr<T> {"
-            , "    extern fn free<T> (ptr: *mut T) {"
+            , "    extern fn free<T>(ptr: *mut T) {"
             , "      let t = unsafe { Box::from_raw(ptr) };"
             , "      drop(t);"
             , "    }"
@@ -374,6 +385,15 @@ foreignPointers =
             , "impl<'a, T> MarshalInto<&'a mut T> for &'a mut T {"
             , "  fn marshal(self) -> &'a mut T { self }"
             , "}"
+            , ""
+            , "impl<T> MarshalInto<ForeignPtr<T>> for Option<ForeignPtr<T>> {"
+            , "  fn marshal(self) -> ForeignPtr<T> {"
+            , "    extern fn panic<T>(_ptr: *mut T) {"
+            , "      panic!(\"Attempted to free a null ForeignPtr\")"
+            , "    }"
+            , "    self.unwrap_or(ForeignPtr(std::ptr::null_mut(), panic))"
+            , "  }"
+            , "}"
             ]
 
 {- | This maps a Rust function type into the corresponding 'FunPtr' wrapped

src/Language/Rust/Inline/Marshal.hs

@@ -38,6 +38,7 @@ data MarshalForm
   | BoxedIndirect      -- ^ value isn't marshallable directly but may be passed indirectly via a 'Ptr'
   | ByteString
   | ForeignPtr
+  | OptionalForeignPtr
   deriving (Eq)
 
 passByValue :: MarshalForm -> Bool
@@ -61,6 +62,7 @@ ghcMarshallable ty = do
    tyconsB <- sequence qTyconsBoxed
    bytestring <- [t| ByteString |]
    fptrCons <- [t| ForeignPtr |]
+   maybeCons <- [t| Maybe |]
 
    case ty of
      _          | ty  `elem` simpleU -> pure UnboxedDirect
@@ -69,6 +71,8 @@ ghcMarshallable ty = do
      AppT con _ | con `elem` tyconsU -> pure UnboxedDirect
                 | con `elem` tyconsB -> pure BoxedDirect
                 | con == fptrCons    -> pure ForeignPtr
+     AppT mb (AppT fptr _)
+                | mb == maybeCons && fptr == fptrCons -> pure OptionalForeignPtr
      _                               -> pure BoxedIndirect
   where
   qSimpleUnboxed = [ [t| Char#   |]

tests/ForeignPtr.hs

@@ -6,13 +6,15 @@ module ForeignPtr where
 
 import Language.Rust.Inline
 
+import Data.Maybe (fromJust)
 import Data.Word (Word64)
 import Foreign (Storable (..))
 import Foreign.ForeignPtr
 import Foreign.Ptr
 import Test.Hspec
 
 extendContext foreignPointers
+extendContext prelude
 extendContext basic
 setCrateModule
 
@@ -36,11 +38,11 @@ foreignPtrTypes = describe "ForeignPtr types" $ do
         withForeignPtr p (`poke` 42)
         let prev =
                 [rust| u64 {
-                        let p = $(p: &mut u64);
-                        let ret = *p;
-                        *p = 43;
-                        ret
-                    } |]
+                    let p = $(p: &mut u64);
+                    let ret = *p;
+                    *p = 43;
+                    ret
+                } |]
         prev `shouldBe` 42
         withForeignPtr p peek >>= (`shouldBe` 43)
 
@@ -56,3 +58,16 @@ foreignPtrTypes = describe "ForeignPtr types" $ do
         let p = [rust| ForeignPtr<u64> { Box::new(42).into() }|]
         val <- withForeignPtr p peek
         val `shouldBe` 42
+
+    it "Can marshal optional ForeignPtr returns" $ do
+        let mp =
+                [rust| Option<ForeignPtr<u64>> {
+                    None
+                } |]
+        mp `shouldBe` Nothing
+
+        let mp =
+                [rust| Option<ForeignPtr<u64>> {
+                    Some(Box::new(42).into())
+                } |]
+        withForeignPtr (fromJust mp) peek >>= (`shouldBe` 42)