Provided instance to use ForeignPtr as a struct.

1 files changed, 16 insertions, 0 deletions

diff --git a/src/Data/Primitive/Struct.hs b/src/Data/Primitive/Struct.hs
index 154b750..705e65d 100644
--- a/src/Data/Primitive/Struct.hs
+++ b/src/Data/Primitive/Struct.hs
@@ -8,6 +8,7 @@
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE UndecidableInstances  #-}
 module Data.Primitive.Struct where
 
 import Control.Monad.Primitive
@@ -16,6 +17,7 @@ import Data.Primitive.ByteArray.Util
 import Data.Primitive.Types
 import Data.Tagged
 import Data.Typeable
+import Foreign.ForeignPtr
 import Foreign.Ptr
 import Foreign.Storable
 import GHC.TypeLits
@@ -110,3 +112,17 @@ withPointer :: Struct IO base tag -> (Ptr tag -> IO x) -> IO x
 withPointer (Struct (Offset off) ary) f = do
     x <- f (ptr (mutableByteArrayContents ary) `plusPtr` off)
     seq ary $ return x
+
+data ForeignStruct tag = ForeignStruct
+    { fsPtr    :: !(ForeignPtr tag)
+    , fsOffset :: !Int
+    }
+
+instance IsStruct IO ForeignStruct where
+    type BaseOffset ForeignStruct = TypeError (Text "ForeignStruct has no type-level offset information.")
+    type NestedStruct IO ForeignStruct j t = ForeignStruct t
+    setField (ForeignStruct fptr base) (Field (Offset o)) val = withForeignPtr fptr $ \ptr -> do
+        poke (castPtr $ ptr `plusPtr` o `plusPtr` base) $ PrimStorable val
+    getField (ForeignStruct fptr base) (Field (Offset o)) = withForeignPtr fptr $ \ptr -> do
+        getPrimStorable <$> peek (castPtr $ ptr `plusPtr` o `plusPtr` base)
+    nestedField (ForeignStruct fptr base) (Field (Offset o)) _ = ForeignStruct (castForeignPtr fptr) (base + o)