module System.Gnome.VFS.Marshal (
cToEnum,
cFromEnum,
cToBool,
cFromBool,
cToFlags,
cFromFlags,
genericResultMarshal,
voidResultMarshal,
newObjectResultMarshal,
volumeOpCallbackMarshal
) where
import Control.Exception
import Control.Monad (liftM)
import Data.Dynamic
import System.Glib.FFI
import System.Glib.Flags (Flags, toFlags, fromFlags)
import System.Glib.UTFString (peekUTFString)
import System.Gnome.VFS.BasicTypes
import System.Gnome.VFS.Error
import Prelude hiding (error)
cToEnum :: (Integral a, Enum b) => a -> b
cToEnum = toEnum . fromIntegral
cFromEnum :: (Enum a, Integral b) => a -> b
cFromEnum = fromIntegral . fromEnum
cToBool :: Integral a => a -> Bool
cToBool = toBool . fromIntegral
cFromBool :: Integral a => Bool -> a
cFromBool = fromIntegral . fromBool
cToFlags :: (Integral a, Flags b) => a -> [b]
cToFlags = toFlags . fromIntegral
cFromFlags :: (Flags a, Integral b) => [a] -> b
cFromFlags = fromIntegral . fromFlags
genericResultMarshal :: IO (CInt)
-> IO a
-> IO b
-> IO a
genericResultMarshal cAction cSuccessAction cFailureAction =
do result <- liftM cToEnum $ cAction
case result of
Ok -> cSuccessAction
errorCode -> do cFailureAction
error result
voidResultMarshal :: IO (CInt)
-> IO ()
voidResultMarshal cAction =
genericResultMarshal cAction (return ()) (return ())
newObjectResultMarshal :: (ForeignPtr obj -> obj)
-> (Ptr (Ptr obj) -> IO (CInt))
-> IO obj
newObjectResultMarshal objConstructor cNewObj =
alloca $ \cObjPtr ->
do poke cObjPtr nullPtr
genericResultMarshal (cNewObj cObjPtr)
(do cObj <- peek cObjPtr
assert (cObj /= nullPtr) $ return ()
newObj <- newForeignPtr_ cObj
return $ objConstructor newObj)
(do cObj <- peek cObjPtr
assert (cObj == nullPtr) $ return ())
volumeOpCallbackMarshal :: VolumeOpSuccessCallback
-> VolumeOpFailureCallback
-> IO ((FunPtr (CInt -> ((Ptr CChar) -> ((Ptr CChar) -> ((Ptr ()) -> (IO ())))))))
volumeOpCallbackMarshal successCallback failureCallback =
let cCallback :: CVolumeOpCallback
cCallback cSucceeded cError cDetailedError cUserData =
let succeeded = cToBool cSucceeded
cCallbackFunPtr = castPtrToFunPtr cUserData
in (flip finally) (freeHaskellFunPtr cCallbackFunPtr) $
if succeeded
then assert (and [cError == nullPtr, cDetailedError == nullPtr]) $
successCallback
else assert (and [cError /= nullPtr, cDetailedError /= nullPtr]) $
do error <- peekUTFString cError
detailedError <- peekUTFString cDetailedError
failureCallback error detailedError
in makeVolumeOpCallback cCallback
foreign import ccall safe "wrapper"
makeVolumeOpCallback :: CVolumeOpCallback
-> IO ((FunPtr (CInt -> ((Ptr CChar) -> ((Ptr CChar) -> ((Ptr ()) -> (IO ())))))))