Permalink
Browse files

First pass at the XPCable typeclass for mostly automatic marshaling.

The two instances right now are for Int64 and (XPCable a) => [a]. Unfortunately it looks like marshaling dictionaries is going to require a C function, not sure yet how that will work.
  • Loading branch information...
1 parent 3c9e912 commit 215b68933b878c161f6f3899e93a25d3ea9a9a07 @cbarrett committed Aug 20, 2011
Showing with 81 additions and 37 deletions.
  1. +8 −36 Haskell Service/HsXPC.hs
  2. +68 −0 Haskell Service/XPC.hs
  3. +5 −1 XPC Calc.xcodeproj/project.pbxproj
View
@@ -1,4 +1,4 @@
-{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
module HsXPC
( hsEventHandler
@@ -9,10 +9,9 @@ import Data.Functor
import Foreign
import Foreign.C.Types
import Foreign.C.String
+import XPC
-data XPC
type XPCConnection = Ptr XPC
-type XPCObject = Ptr XPC
type XPCType = Ptr XPC
foreign export ccall hsEventHandler :: XPCConnection -> XPCObject -> IO ()
@@ -23,24 +22,9 @@ foreign import ccall unsafe "xpc/xpc.h xpc_get_type"
foreign import ccall unsafe "xpc/xpc.h &_xpc_type_error"
xpc_type_error :: XPCType
-foreign import ccall unsafe "xpc/xpc.h xpc_array_create"
- xpc_array_create :: Ptr XPCObject -> CSize -> IO XPCObject
-
-foreign import ccall unsafe "xpc/xpc.h xpc_array_get_count"
- xpc_array_get_count :: XPCObject -> CSize
-
-foreign import ccall unsafe "xpc/xpc.h xpc_array_get_int64"
- xpc_array_get_int64 :: XPCObject -> CSize -> CLLong
-
-foreign import ccall unsafe "xpc/xpc.h xpc_array_set_int64"
- xpc_array_set_int64 :: XPCObject -> CSize -> CLLong -> IO ()
-
foreign import ccall unsafe "xpc/xpc.h xpc_dictionary_create_reply"
xpc_dictionary_create_reply :: XPCObject -> IO XPCObject
-foreign import ccall unsafe "xpc/xpc.h xpc_dictionary_get_int64"
- xpc_dictionary_get_int64 :: XPCObject -> CString -> CLLong
-
foreign import ccall unsafe "xpc/xpc.h xpc_dictionary_get_value"
xpc_dictionary_get_value :: XPCObject -> CString -> XPCObject
@@ -50,38 +34,26 @@ foreign import ccall unsafe "xpc/xpc.h xpc_dictionary_set_value"
foreign import ccall unsafe "xpc/connection.h xpc_connection_send_message"
xpc_connection_send_message :: XPCConnection -> XPCObject -> IO ()
-foreign import ccall unsafe "xpc/xpc.h &xpc_release"
- finalizerXPCRelease :: FunPtr (XPCObject -> IO ())
-
-xpcArrayToList xa = fromIntegral . xpc_array_get_int64 xa <$> [0 .. xpc_array_get_count xa - 1]
-
-withNewXPCPtr xpcObjIO f = xpcObjIO >>= newForeignPtr finalizerXPCRelease >>= (flip withForeignPtr) f
-
-withXPCArray xs f = do
- withNewXPCPtr (xpc_array_create nullPtr 0) $ \stack -> do
- forM xs $ xpc_array_set_int64 stack (-1) . fromIntegral
- f stack
-
-sendReply :: XPCConnection -> XPCObject -> (Int -> [Int] -> [Int]) -> IO ()
+sendReply :: XPCConnection -> XPCObject -> (Int64 -> [Int64] -> [Int64]) -> IO ()
sendReply peer event f = do
- op <- withCString "op" $ return . fromIntegral . xpc_dictionary_get_int64 event
- stack <- withCString "stack" $ return . xpcArrayToList . xpc_dictionary_get_value event
+ op <- withCString "op" $ return . fromXPC . xpc_dictionary_get_value event
+ stack <- withCString "stack" $ return . fromXPC . xpc_dictionary_get_value event
withNewXPCPtr (xpc_dictionary_create_reply event) $ \reply -> do
withCString "stack" $ \stackStr -> do
- withXPCArray (f op stack) $ \newStack -> do
+ withXPC (f op stack) $ \newStack -> do
xpc_dictionary_set_value reply stackStr newStack
xpc_connection_send_message peer reply
-consumeBinary :: (Int -> Int -> Int) -> [Int] -> [Int]
+consumeBinary :: (Int64 -> Int64 -> Int64) -> [Int64] -> [Int64]
consumeBinary f xs
| len >= 2 = xs' ++ [lhs `f` rhs]
| otherwise = xs
where (xs', rhs:lhs:_) = splitAt (len - 2) xs
len = length xs
-- TODO ops should be bound to the values in the enum in Shared.h
-calc :: Int -> [Int] -> [Int]
+calc :: Int64 -> [Int64] -> [Int64]
calc 0 = consumeBinary (+)
calc 1 = consumeBinary (-)
calc 2 = consumeBinary (*)
View
@@ -0,0 +1,68 @@
+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, TypeSynonymInstances #-}
+
+module XPC
+ ( Int64
+ , withNewXPCPtr
+ , XPC
+ , XPCable(..)
+ , XPCObject
+ ) where
+
+import Control.Monad
+import Data.Functor
+import Data.Int (Int64)
+import Foreign
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.Storable
+
+data XPC
+type XPCObject = Ptr XPC
+
+foreign import ccall unsafe "xpc/xpc.h xpc_array_create"
+ xpc_array_create :: Ptr XPCObject -> CSize -> IO XPCObject
+
+foreign import ccall unsafe "xpc/xpc.h xpc_array_get_count"
+ xpc_array_get_count :: XPCObject -> CSize
+
+foreign import ccall unsafe "xpc/xpc.h xpc_array_get_value"
+ xpc_array_get_value :: XPCObject -> CSize -> XPCObject
+
+foreign import ccall unsafe "xpc/xpc.h xpc_array_set_value"
+ xpc_array_set_value :: XPCObject -> CSize -> XPCObject -> IO ()
+
+foreign import ccall unsafe "xpc/xpc.h xpc_int64_create"
+ xpc_int64_create :: Int64 -> IO XPCObject
+
+foreign import ccall unsafe "xpc/xpc.h xpc_int64_get_value"
+ xpc_int64_get_value :: XPCObject -> Int64
+
+foreign import ccall unsafe "xpc/xpc.h &xpc_release"
+ finalizerXPCRelease :: FunPtr (XPCObject -> IO ())
+
+withNewXPCPtr xpcObjIO f = xpcObjIO >>= newForeignPtr finalizerXPCRelease >>= (flip withForeignPtr) f
+
+class XPCable a where
+ fromXPC :: XPCObject -> a
+ withXPC :: a -> (XPCObject -> IO b) -> IO b
+
+-- xpc_int64
+instance XPCable Int64 where
+ fromXPC = xpc_int64_get_value
+ withXPC i = withNewXPCPtr (xpc_int64_create i)
+
+-- xpc_array
+instance (XPCable a) => XPCable [a] where
+ fromXPC x = fromXPC . xpc_array_get_value x <$> idxRange
+ where idxRange | len == 0 = []
+ | otherwise = [0 .. len - 1]
+ len = xpc_array_get_count x
+
+ withXPC xs f = allocaArray (length xs) $ \buf -> do
+ mapM (\(idx, p) -> p buf idx) (zip idxRange pokes)
+ withNewXPCPtr (xpc_array_create buf (fromIntegral $ length xs)) f
+ where idxRange = [0 .. length xs - 1]
+ pokes = (\x -> (\buf idx -> withXPC x (pokeElemOff buf idx))) <$> xs
+
+test :: [Int64] -> IO [Int64]
+test xs = withXPC xs (return . fromXPC)
@@ -7,6 +7,7 @@
objects = {
/* Begin PBXBuildFile section */
+ EF1B35261400671E0006438C /* XPC.hs in Resources */ = {isa = PBXBuildFile; fileRef = EF1B35251400671E0006438C /* XPC.hs */; };
EF8DAA2313EE163300FF10E9 /* Cocoa.framework in Frameworks */ = {isa = PBXBuildFile; fileRef = EF8DAA2213EE163300FF10E9 /* Cocoa.framework */; };
EF8DAA2D13EE163300FF10E9 /* InfoPlist.strings in Resources */ = {isa = PBXBuildFile; fileRef = EF8DAA2B13EE163300FF10E9 /* InfoPlist.strings */; };
EF8DAA2F13EE163300FF10E9 /* main.m in Sources */ = {isa = PBXBuildFile; fileRef = EF8DAA2E13EE163300FF10E9 /* main.m */; };
@@ -37,6 +38,7 @@
/* End PBXCopyFilesBuildPhase section */
/* Begin PBXFileReference section */
+ EF1B35251400671E0006438C /* XPC.hs */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = XPC.hs; sourceTree = "<group>"; };
EF60B56413EF43F300B4D22E /* main.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = main.c; sourceTree = "<group>"; };
EF60B56513EF453600B4D22E /* HsXPC.hs */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = HsXPC.hs; sourceTree = "<group>"; };
EF8DAA1E13EE163300FF10E9 /* XPC Calc.app */ = {isa = PBXFileReference; explicitFileType = wrapper.application; includeInIndex = 0; path = "XPC Calc.app"; sourceTree = BUILT_PRODUCTS_DIR; };
@@ -173,6 +175,7 @@
EF60B56413EF43F300B4D22E /* main.c */,
EFEDB30F13EEFE6400430981 /* Supporting Files */,
EF60B56513EF453600B4D22E /* HsXPC.hs */,
+ EF1B35251400671E0006438C /* XPC.hs */,
);
path = "Haskell Service";
sourceTree = "<group>";
@@ -273,6 +276,7 @@
EF8DAA2D13EE163300FF10E9 /* InfoPlist.strings in Resources */,
EF8DAA3313EE163300FF10E9 /* Credits.rtf in Resources */,
EF8DAA3913EE163400FF10E9 /* MainMenu.xib in Resources */,
+ EF1B35261400671E0006438C /* XPC.hs in Resources */,
);
runOnlyForDeploymentPostprocessing = 0;
};
@@ -307,7 +311,7 @@
);
runOnlyForDeploymentPostprocessing = 0;
shellPath = /bin/sh;
- shellScript = "mkdir -p \"$BUILT_PRODUCTS_DIR/$EXECUTABLE_FOLDER_PATH\"\nghc -c -outputdir \"$DERIVED_FILES_DIR\" \"-i$DERIVED_FILES_DIR\" \"$SRCROOT/Haskell Service/HsXPC.hs\"\nghc --make -no-hs-main -outputdir \"$DERIVED_FILES_DIR\" \"-i$DERIVED_FILES_DIR\" -o \"$BUILT_PRODUCTS_DIR/$EXECUTABLE_FOLDER_PATH/$EXECUTABLE_NAME\" \"$SRCROOT/Haskell Service/HsXPC.hs\" \"$SRCROOT/Haskell Service/main.c\"\n";
+ shellScript = "mkdir -p \"$BUILT_PRODUCTS_DIR/$EXECUTABLE_FOLDER_PATH\"\nghc -c -outputdir \"$DERIVED_FILES_DIR\" \"-i$DERIVED_FILES_DIR\" \"$SRCROOT/Haskell Service/XPC.hs\" \"$SRCROOT/Haskell Service/HsXPC.hs\"\nghc --make -no-hs-main -outputdir \"$DERIVED_FILES_DIR\" \"-i$DERIVED_FILES_DIR\" -o \"$BUILT_PRODUCTS_DIR/$EXECUTABLE_FOLDER_PATH/$EXECUTABLE_NAME\" \"$SRCROOT/Haskell Service/XPC.hs\" \"$SRCROOT/Haskell Service/HsXPC.hs\" \"$SRCROOT/Haskell Service/main.c\"\n";
};
/* End PBXShellScriptBuildPhase section */

0 comments on commit 215b689

Please sign in to comment.