gstreamer: remove commented function messageParseAsyncStart in Message.chs

darcs-hash:20070720201214-21862-86c3a174d5a556525132da314b7d0363b9e3c844.gz

-- GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer   -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Library General Public License for more details.
--
module Media.Streaming.GStreamer.Message (

  Message,
  MessageClass,
  castToMessage,
  toMessage,
  fromMessage,
  MessageType(..),
  messageTypeGetName,
  messageTypeToQuark,
  messageSrc,
  messageTimestamp,
  messageType,
  messageTypeName,
  messageStructure,
  messageNewApplication,
  messageParseClockLost,
  messageParseClockProvide,
  messageParseError,
  messageParseInfo,
  messageParseNewClock,
  messageParseSegmentDone,
  messageParseSegmentStart,
  messageParseStateChanged,
  messageParseTag,
  messageParseBuffering,
  messageParseWarning,
  messageParseDuration,

  ) where

import Control.Monad (liftM)
{#import Media.Streaming.GStreamer.Types#}
import System.Glib.FFI
import System.Glib.GObject
import System.Glib.UTFString
import System.Glib.GError

{# context lib = "gstreamer" prefix = "gst" #}

messageTypeGetName :: MessageType
                   -> String
messageTypeGetName messageType =
    unsafePerformIO $
        {# call message_type_get_name #} (fromIntegral $ fromEnum messageType) >>=
            peekUTFString

messageTypeToQuark :: MessageType
                   -> Quark
messageTypeToQuark messageType =
    {# call fun message_type_to_quark #} (fromIntegral $ fromEnum messageType)

messageSrc :: Message
           -> Object
messageSrc message =
    unsafePerformIO $ withMessage message {# get GstMessage->src #} >>=
        newObject_ Object

messageTimestamp :: Message
                 -> ClockTime
messageTimestamp message =
    unsafePerformIO $ withMessage message {# get GstMessage->timestamp #}

messageType :: Message
            -> MessageType
messageType message =
    toEnum $ fromIntegral $ unsafePerformIO $
        withMessage message cMessageGetMessageType
foreign import ccall unsafe "_hs_gst_message_get_message_type"
    cMessageGetMessageType :: Ptr Message
                           -> IO {# type GstMessageType #}

messageTypeName :: Message
                -> String
messageTypeName =
    messageTypeGetName . messageType

messageStructure :: Message
                 -> Structure
messageStructure message =
    unsafePerformIO $ {# call message_get_structure #} message >>= newStructure_

messageNewApplication :: Object
                      -> Structure
                      -> IO Message
messageNewApplication object structure =
    (giveStructure structure $ {# call message_new_application #} object) >>=
        newMessage

messageParseClockLost :: Message
                      -> Maybe Clock
messageParseClockLost message =
    unsafePerformIO $ alloca $ \clockPtr ->
        do poke clockPtr nullPtr
           {# call message_parse_clock_lost #} message $ castPtr clockPtr
           liftM Just $ peek clockPtr >>= newClock_

messageParseClockProvide :: Message
                         -> Maybe (Clock, Bool)
messageParseClockProvide message =
    unsafePerformIO $ alloca $ \clockPtr ->
        alloca $ \readyPtr ->
            do poke clockPtr nullPtr
               poke readyPtr $ fromBool False
               {# call message_parse_clock_provide #} message (castPtr clockPtr) readyPtr
               clock <- peek clockPtr >>= maybePeek newClock_
               ready <- peek readyPtr
               return $ maybe Nothing (\clock -> Just (clock, toBool ready)) clock

messageParseError :: Message
                  -> (Maybe GError, Maybe String)
messageParseError message =
    unsafePerformIO $ alloca $ \gErrorPtr ->
        alloca $ \debugPtr ->
            do poke gErrorPtr nullPtr
               poke debugPtr nullPtr
               {# call message_parse_error #} message (castPtr gErrorPtr) debugPtr
               gError <- peek gErrorPtr >>=
                             (maybePeek $ \ptr ->
                              do gError <- peek ptr
                                 {# call g_error_free #} $ castPtr ptr
                                 return gError)
               debug <- peek debugPtr >>= maybePeek readUTFString
               return (gError, debug)

messageParseInfo :: Message
                 -> (Maybe GError, Maybe String)
messageParseInfo message =
    unsafePerformIO $ alloca $ \gErrorPtr ->
        alloca $ \debugPtr ->
            do poke gErrorPtr nullPtr
               poke debugPtr nullPtr
               {# call message_parse_info #} message (castPtr gErrorPtr) debugPtr
               gError <- peek gErrorPtr >>=
                             (maybePeek $ \ptr ->
                              do gError <- peek ptr
                                 {# call g_error_free #} $ castPtr ptr
                                 return gError)
               debug <- peek debugPtr >>= maybePeek readUTFString
               return (gError, debug)

messageParseNewClock :: Message
                     -> Maybe Clock
messageParseNewClock message =
    unsafePerformIO $ alloca $ \clockPtr ->
        do poke clockPtr nullPtr
           {# call message_parse_clock_lost #} message $ castPtr clockPtr
           peek clockPtr >>= maybePeek newClock_

messageParseSegmentDone :: Message
                        -> (Format, Int64)
messageParseSegmentDone message =
    unsafePerformIO $ alloca $ \formatPtr ->
        alloca $ \positionPtr ->
            do poke formatPtr $ fromIntegral $ fromEnum FormatUndefined
               poke positionPtr 0
               {# call message_parse_segment_done #} message formatPtr positionPtr
               format <- peek formatPtr
               position <- peek positionPtr
               return (toEnum $ fromIntegral format, fromIntegral position)

messageParseSegmentStart :: Message
                         -> (Format, Int64)
messageParseSegmentStart message =
    unsafePerformIO $ alloca $ \formatPtr ->
        alloca $ \positionPtr ->
            do poke formatPtr $ fromIntegral $ fromEnum FormatUndefined
               poke positionPtr 0
               {# call message_parse_segment_start #} message formatPtr positionPtr
               format <- peek formatPtr
               position <- peek positionPtr
               return (toEnum $ fromIntegral format, fromIntegral position)

messageParseStateChanged :: Message
                         -> (State, State, State)
messageParseStateChanged message =
    unsafePerformIO $ alloca $ \oldStatePtr ->
        alloca $ \newStatePtr -> alloca $ \pendingPtr ->
            do poke oldStatePtr 0
               poke newStatePtr 0
               poke pendingPtr  0
               {# call message_parse_state_changed #} message oldStatePtr newStatePtr pendingPtr
               oldState <- liftM (toEnum . fromIntegral) $ peek oldStatePtr
               newState <- liftM (toEnum . fromIntegral) $ peek newStatePtr
               pending  <- liftM (toEnum . fromIntegral) $ peek pendingPtr
               return (oldState, newState, pending)

messageParseTag :: Message
                -> TagList
messageParseTag message =
    unsafePerformIO $ alloca $ \tagListPtr ->
        do poke tagListPtr nullPtr
           {# call message_parse_tag #} message $ castPtr tagListPtr
           peek tagListPtr >>= newTagList

messageParseBuffering :: Message
                      -> Int
messageParseBuffering message =
    fromIntegral $ unsafePerformIO $ alloca $ \percentPtr ->
        do poke percentPtr 0
           {# call message_parse_buffering #} message percentPtr
           peek percentPtr

messageParseWarning :: Message
                    -> (Maybe GError, Maybe String)
messageParseWarning message =
    unsafePerformIO $ alloca $ \gErrorPtr ->
        alloca $ \debugPtr ->
            do poke gErrorPtr nullPtr
               poke debugPtr nullPtr
               {# call message_parse_warning #} message (castPtr gErrorPtr) debugPtr
               gError <- peek gErrorPtr >>=
                             (maybePeek $ \ptr ->
                              do gError <- peek ptr
                                 {# call g_error_free #} $ castPtr ptr
                                 return gError)
               debug <- peek debugPtr >>= maybePeek readUTFString
               return (gError, debug)

messageParseDuration :: Message
                     -> (Format, Int64)
messageParseDuration message =
    unsafePerformIO $ alloca $ \formatPtr ->
        alloca $ \positionPtr ->
            do poke formatPtr $ fromIntegral $ fromEnum FormatUndefined
               poke positionPtr 0
               {# call message_parse_duration #} message formatPtr positionPtr
               format <- peek formatPtr
               position <- peek positionPtr
               return (toEnum $ fromIntegral format, fromIntegral position)

-- GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer   -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Library General Public License for more details.
--
module Media.Streaming.GStreamer.Message (

  Message,
  MessageClass,
  castToMessage,
  toMessage,
  fromMessage,
  MessageType(..),
  messageTypeGetName,
  messageTypeToQuark,
  messageSrc,
  messageTimestamp,
  messageType,
  messageTypeName,
  messageStructure,
  messageNewApplication,
  messageParseClockLost,
  messageParseClockProvide,
  messageParseError,
  messageParseInfo,
  messageParseNewClock,
  messageParseSegmentDone,
  messageParseSegmentStart,
  messageParseStateChanged,
  messageParseTag,
  messageParseBuffering,
  messageParseWarning,
  messageParseDuration,
  --messageParseAsyncStart
  ) where

import Control.Monad (liftM)
{#import Media.Streaming.GStreamer.Types#}
import System.Glib.FFI
import System.Glib.GObject
import System.Glib.UTFString
import System.Glib.GError

{# context lib = "gstreamer" prefix = "gst" #}

messageTypeGetName :: MessageType
                   -> String
messageTypeGetName messageType =
    unsafePerformIO $
        {# call message_type_get_name #} (fromIntegral $ fromEnum messageType) >>=
            peekUTFString

messageTypeToQuark :: MessageType
                   -> Quark
messageTypeToQuark messageType =
    {# call fun message_type_to_quark #} (fromIntegral $ fromEnum messageType)

messageSrc :: Message
           -> Object
messageSrc message =
    unsafePerformIO $ withMessage message {# get GstMessage->src #} >>=
        newObject_ Object

messageTimestamp :: Message
                 -> ClockTime
messageTimestamp message =
    unsafePerformIO $ withMessage message {# get GstMessage->timestamp #}

messageType :: Message
            -> MessageType
messageType message =
    toEnum $ fromIntegral $ unsafePerformIO $
        withMessage message cMessageGetMessageType
foreign import ccall unsafe "_hs_gst_message_get_message_type"
    cMessageGetMessageType :: Ptr Message
                           -> IO {# type GstMessageType #}

messageTypeName :: Message
                -> String
messageTypeName =
    messageTypeGetName . messageType

messageStructure :: Message
                 -> Structure
messageStructure message =
    unsafePerformIO $ {# call message_get_structure #} message >>= newStructure_

messageNewApplication :: Object
                      -> Structure
                      -> IO Message
messageNewApplication object structure =
    (giveStructure structure $ {# call message_new_application #} object) >>=
        newMessage

messageParseClockLost :: Message
                      -> Maybe Clock
messageParseClockLost message =
    unsafePerformIO $ alloca $ \clockPtr ->
        do poke clockPtr nullPtr
           {# call message_parse_clock_lost #} message $ castPtr clockPtr
           liftM Just $ peek clockPtr >>= newClock_

messageParseClockProvide :: Message
                         -> Maybe (Clock, Bool)
messageParseClockProvide message =
    unsafePerformIO $ alloca $ \clockPtr ->
        alloca $ \readyPtr ->
            do poke clockPtr nullPtr
               poke readyPtr $ fromBool False
               {# call message_parse_clock_provide #} message (castPtr clockPtr) readyPtr
               clock <- peek clockPtr >>= maybePeek newClock_
               ready <- peek readyPtr
               return $ maybe Nothing (\clock -> Just (clock, toBool ready)) clock

messageParseError :: Message
                  -> (Maybe GError, Maybe String)
messageParseError message =
    unsafePerformIO $ alloca $ \gErrorPtr ->
        alloca $ \debugPtr ->
            do poke gErrorPtr nullPtr
               poke debugPtr nullPtr
               {# call message_parse_error #} message (castPtr gErrorPtr) debugPtr
               gError <- peek gErrorPtr >>=
                             (maybePeek $ \ptr ->
                              do gError <- peek ptr
                                 {# call g_error_free #} $ castPtr ptr
                                 return gError)
               debug <- peek debugPtr >>= maybePeek readUTFString
               return (gError, debug)

messageParseInfo :: Message
                 -> (Maybe GError, Maybe String)
messageParseInfo message =
    unsafePerformIO $ alloca $ \gErrorPtr ->
        alloca $ \debugPtr ->
            do poke gErrorPtr nullPtr
               poke debugPtr nullPtr
               {# call message_parse_info #} message (castPtr gErrorPtr) debugPtr
               gError <- peek gErrorPtr >>=
                             (maybePeek $ \ptr ->
                              do gError <- peek ptr
                                 {# call g_error_free #} $ castPtr ptr
                                 return gError)
               debug <- peek debugPtr >>= maybePeek readUTFString
               return (gError, debug)

messageParseNewClock :: Message
                     -> Maybe Clock
messageParseNewClock message =
    unsafePerformIO $ alloca $ \clockPtr ->
        do poke clockPtr nullPtr
           {# call message_parse_clock_lost #} message $ castPtr clockPtr
           peek clockPtr >>= maybePeek newClock_

messageParseSegmentDone :: Message
                        -> (Format, Int64)
messageParseSegmentDone message =
    unsafePerformIO $ alloca $ \formatPtr ->
        alloca $ \positionPtr ->
            do poke formatPtr $ fromIntegral $ fromEnum FormatUndefined
               poke positionPtr 0
               {# call message_parse_segment_done #} message formatPtr positionPtr
               format <- peek formatPtr
               position <- peek positionPtr
               return (toEnum $ fromIntegral format, fromIntegral position)

messageParseSegmentStart :: Message
                         -> (Format, Int64)
messageParseSegmentStart message =
    unsafePerformIO $ alloca $ \formatPtr ->
        alloca $ \positionPtr ->
            do poke formatPtr $ fromIntegral $ fromEnum FormatUndefined
               poke positionPtr 0
               {# call message_parse_segment_start #} message formatPtr positionPtr
               format <- peek formatPtr
               position <- peek positionPtr
               return (toEnum $ fromIntegral format, fromIntegral position)

messageParseStateChanged :: Message
                         -> (State, State, State)
messageParseStateChanged message =
    unsafePerformIO $ alloca $ \oldStatePtr ->
        alloca $ \newStatePtr -> alloca $ \pendingPtr ->
            do poke oldStatePtr 0
               poke newStatePtr 0
               poke pendingPtr  0
               {# call message_parse_state_changed #} message oldStatePtr newStatePtr pendingPtr
               oldState <- liftM (toEnum . fromIntegral) $ peek oldStatePtr
               newState <- liftM (toEnum . fromIntegral) $ peek newStatePtr
               pending  <- liftM (toEnum . fromIntegral) $ peek pendingPtr
               return (oldState, newState, pending)

messageParseTag :: Message
                -> TagList
messageParseTag message =
    unsafePerformIO $ alloca $ \tagListPtr ->
        do poke tagListPtr nullPtr
           {# call message_parse_tag #} message $ castPtr tagListPtr
           peek tagListPtr >>= newTagList

messageParseBuffering :: Message
                      -> Int
messageParseBuffering message =
    fromIntegral $ unsafePerformIO $ alloca $ \percentPtr ->
        do poke percentPtr 0
           {# call message_parse_buffering #} message percentPtr
           peek percentPtr

messageParseWarning :: Message
                    -> (Maybe GError, Maybe String)
messageParseWarning message =
    unsafePerformIO $ alloca $ \gErrorPtr ->
        alloca $ \debugPtr ->
            do poke gErrorPtr nullPtr
               poke debugPtr nullPtr
               {# call message_parse_warning #} message (castPtr gErrorPtr) debugPtr
               gError <- peek gErrorPtr >>=
                             (maybePeek $ \ptr ->
                              do gError <- peek ptr
                                 {# call g_error_free #} $ castPtr ptr
                                 return gError)
               debug <- peek debugPtr >>= maybePeek readUTFString
               return (gError, debug)

messageParseDuration :: Message
                     -> (Format, Int64)
messageParseDuration message =
    unsafePerformIO $ alloca $ \formatPtr ->
        alloca $ \positionPtr ->
            do poke formatPtr $ fromIntegral $ fromEnum FormatUndefined
               poke positionPtr 0
               {# call message_parse_duration #} message formatPtr positionPtr
               format <- peek formatPtr
               position <- peek positionPtr
               return (toEnum $ fromIntegral format, fromIntegral position)

{-
messageParseAsyncStart :: Message
                       -> Bool
messageParseAsyncStart message =
    toBool $ unsafePerformIO $ alloca $ \newBaseTimePtr ->
        do poke newBaseTimePtr $ fromBool False
           {# call message_parse_async_start #} message newBaseTimePtr
           peek newBaseTimePtr
-}


Added GHC option -fno-warn-missing-signatures to avoid warnings from compiler

{-# LANGUAGE ForeignFunctionInterface #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

#include <mpi.h>
#include "init_wrapper.h"

module Control.Parallel.MPI.Internal
   ( init, initThread, finalize, send, bsend, ssend, rsend, recv,
     commRank, probe, commSize,
     isend, ibsend, issend, irecv, bcast, barrier, wait, test,
     cancel, scatter, gather,
     scatterv, gatherv,
     allgather, allgatherv,
     alltoall, alltoallv,
     wtime, wtick
   ) where

import Prelude hiding (init, error)
import C2HS

{# context prefix = "MPI" #}

init = {# call unsafe init_wrapper as init_wrapper_ #}
initThread = {# call unsafe init_wrapper_thread as init_wrapper_thread_ #}
finalize = {# call unsafe Finalize as finalize_ #}
commSize = {# call unsafe Comm_size as commSize_ #}
commRank = {# call unsafe Comm_rank as commRank_ #}
probe = {# call Probe as probe_ #}
send = {# call unsafe Send as send_ #}
bsend = {# call unsafe Bsend as bsend_ #}
ssend = {# call unsafe Ssend as ssend_ #}
rsend = {# call unsafe Rsend as rsend_ #}
recv = {# call unsafe Recv as recv_ #}
isend = {# call unsafe Isend as isend_ #}
ibsend = {# call unsafe Ibsend as ibsend_ #}
issend = {# call unsafe Issend as issend_ #}
irecv = {# call Irecv as irecv_ #}
bcast = {# call unsafe Bcast as bcast_ #}
barrier = {# call unsafe Barrier as barrier_ #}
wait = {# call unsafe Wait as wait_ #}
test = {# call unsafe Test as test_ #}
cancel = {# call unsafe Cancel as cancel_ #}
scatter = {# call unsafe Scatter as scatter_ #}
gather = {# call unsafe Gather as gather_ #}
scatterv = {# call unsafe Scatterv as scatterv_ #}
gatherv = {# call unsafe Gatherv as gatherv_ #}
allgather = {# call unsafe Allgather as allgather_ #}
allgatherv = {# call unsafe Allgatherv as allgatherv_ #}
alltoall = {# call unsafe Alltoall as alltoall_ #}
alltoallv = {# call unsafe Alltoallv as alltoallv_ #}
wtime = {# call unsafe Wtime as wtime_ #}
wtick = {# call unsafe Wtick as wtick_ #}

{-# LANGUAGE ForeignFunctionInterface #-}

#include <mpi.h>
#include "init_wrapper.h"

module Control.Parallel.MPI.Internal
   ( init, initThread, finalize, send, bsend, ssend, rsend, recv,
     commRank, probe, commSize,
     isend, ibsend, issend, irecv, bcast, barrier, wait, test,
     cancel, scatter, gather,
     scatterv, gatherv,
     allgather, allgatherv,
     alltoall, alltoallv,
     wtime, wtick
   ) where

import Prelude hiding (init, error)
import C2HS

{# context prefix = "MPI" #}

init = {# call unsafe init_wrapper as init_wrapper_ #}
initThread = {# call unsafe init_wrapper_thread as init_wrapper_thread_ #}
finalize = {# call unsafe Finalize as finalize_ #}
commSize = {# call unsafe Comm_size as commSize_ #}
commRank = {# call unsafe Comm_rank as commRank_ #}
probe = {# call Probe as probe_ #}
send = {# call unsafe Send as send_ #}
bsend = {# call unsafe Bsend as bsend_ #}
ssend = {# call unsafe Ssend as ssend_ #}
rsend = {# call unsafe Rsend as rsend_ #}
recv = {# call unsafe Recv as recv_ #}
isend = {# call unsafe Isend as isend_ #}
ibsend = {# call unsafe Ibsend as ibsend_ #}
issend = {# call unsafe Issend as issend_ #}
irecv = {# call Irecv as irecv_ #}
bcast = {# call unsafe Bcast as bcast_ #}
barrier = {# call unsafe Barrier as barrier_ #}
wait = {# call unsafe Wait as wait_ #}
test = {# call unsafe Test as test_ #}
cancel = {# call unsafe Cancel as cancel_ #}
scatter = {# call unsafe Scatter as scatter_ #}
gather = {# call unsafe Gather as gather_ #}
scatterv = {# call unsafe Scatterv as scatterv_ #}
gatherv = {# call unsafe Gatherv as gatherv_ #}
allgather = {# call unsafe Allgather as allgather_ #}
allgatherv = {# call unsafe Allgatherv as allgatherv_ #}
alltoall = {# call unsafe Alltoall as alltoall_ #}
alltoallv = {# call unsafe Alltoallv as alltoallv_ #}
wtime = {# call unsafe Wtime as wtime_ #}
wtick = {# call unsafe Wtick as wtick_ #}


Manually do Int->CInt conversions to avoid dependency on cIntConv

{-# LANGUAGE
    ForeignFunctionInterface
  #-}

module Graphics.QML.Internal.Classes where

import Foreign.C.String
import Foreign.C.Types
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.StablePtr

#include "hsqml.h"

type UniformFunc = Ptr () -> Ptr (Ptr ()) -> IO ()
type PlacementFunc = Ptr () -> IO ()

foreign import ccall "wrapper"
  marshalFunc :: UniformFunc -> IO (FunPtr UniformFunc)

foreign import ccall "wrapper"
  marshalPlacementFunc :: PlacementFunc -> IO (FunPtr PlacementFunc)

{#pointer *HsQMLClassHandle as ^ foreign newtype #}

foreign import ccall "hsqml.h &hsqml_finalise_class_handle"
  hsqmlFinaliseClassHandlePtr :: FunPtr (Ptr (HsQMLClassHandle) -> IO ())

newClassHandle :: Ptr HsQMLClassHandle -> IO (Maybe HsQMLClassHandle)
newClassHandle p =
  if nullPtr == p
    then return Nothing
    else do
      fp <- newForeignPtr hsqmlFinaliseClassHandlePtr p
      return $ Just $ HsQMLClassHandle fp

{#fun unsafe hsqml_create_class as ^
  {id `Ptr CUInt',
   id `Ptr CChar',
   id `Ptr (FunPtr UniformFunc)',
   id `Ptr (FunPtr UniformFunc)'} ->
  `Maybe HsQMLClassHandle' newClassHandle* #}

{#fun unsafe hsqml_allocate_in_place as ^
  {id `Ptr ()',
   id `Ptr ()',
   id `Ptr HsQMLClassHandle'} -> `()' #}

{#fun unsafe hsqml_register_type as ^
  {id `FunPtr PlacementFunc',
   `String',
   fromIntegral `CInt',
   fromIntegral `CInt',
   `String'} -> `()' #}

{#pointer *HsQMLObjectHandle as ^ newtype #}

objToPtr :: a -> (Ptr () -> IO b) -> IO b
objToPtr obj f = do
  sPtr <- newStablePtr obj
  res <- f $ castStablePtrToPtr sPtr
  return res

withHsQMLClassHandle :: HsQMLClassHandle -> (Ptr HsQMLClassHandle -> IO b) -> IO b
{#fun unsafe hsqml_create_object as ^
  {objToPtr* `a',
   withHsQMLClassHandle* `HsQMLClassHandle'} ->
  `HsQMLObjectHandle' id #}

ptrToObj :: Ptr () -> IO a
ptrToObj =
  deRefStablePtr . castPtrToStablePtr

{#fun unsafe hsqml_get_haskell as ^
  {id `HsQMLObjectHandle'} ->
  `a' ptrToObj* #}

ofDynamicMetaObject :: CUInt
ofDynamicMetaObject = 0x01

mfAccessPrivate, mfAccessProtected, mfAccessPublic, mfAccessMask,
  mfMethodMethod, mfMethodSignal, mfMethodSlot, mfMethodConstructor,
  mfMethodTypeMask, mfMethodCompatibility, mfMethodCloned, mfMethodScriptable
  :: CUInt
mfAccessPrivate   = 0x00
mfAccessProtected = 0x01
mfAccessPublic    = 0x02
mfAccessMask      = 0x03
mfMethodMethod      = 0x00
mfMethodSignal      = 0x04
mfMethodSlot        = 0x08
mfMethodConstructor = 0x0c
mfMethodTypeMask    = 0x0c
mfMethodCompatibility = 0x10
mfMethodCloned        = 0x20
mfMethodScriptable    = 0x40

pfInvalid, pfReadable, pfWritable, pfResettable, pfEnumOrFlag, pfStdCppSet,
  pfConstant, pfFinal, pfDesignable, pfResolveDesignable, pfScriptable,
  pfResolveScriptable, pfStored, pfResolveStored, pfEditable,
  pfResolveEditable, pfUser, pfResolveUser, pfNotify :: CUInt
pfInvalid           = 0x00000000
pfReadable          = 0x00000001
pfWritable          = 0x00000002
pfResettable        = 0x00000004
pfEnumOrFlag        = 0x00000008
pfStdCppSet         = 0x00000100
pfConstant          = 0x00000400
pfFinal             = 0x00000800
pfDesignable        = 0x00001000
pfResolveDesignable = 0x00002000
pfScriptable        = 0x00004000
pfResolveScriptable = 0x00008000
pfStored            = 0x00010000
pfResolveStored     = 0x00020000
pfEditable          = 0x00040000
pfResolveEditable   = 0x00080000
pfUser              = 0x00100000
pfResolveUser       = 0x00200000
pfNotify            = 0x00400000

{-# LANGUAGE
    ForeignFunctionInterface
  #-}

module Graphics.QML.Internal.Classes where

import Foreign.C.String
import Foreign.C.Types
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.StablePtr

#include "hsqml.h"

type UniformFunc = Ptr () -> Ptr (Ptr ()) -> IO ()
type PlacementFunc = Ptr () -> IO ()

foreign import ccall "wrapper"
  marshalFunc :: UniformFunc -> IO (FunPtr UniformFunc)

foreign import ccall "wrapper"
  marshalPlacementFunc :: PlacementFunc -> IO (FunPtr PlacementFunc)

{#pointer *HsQMLClassHandle as ^ foreign newtype #}

foreign import ccall "hsqml.h &hsqml_finalise_class_handle"
  hsqmlFinaliseClassHandlePtr :: FunPtr (Ptr (HsQMLClassHandle) -> IO ())

newClassHandle :: Ptr HsQMLClassHandle -> IO (Maybe HsQMLClassHandle)
newClassHandle p =
  if nullPtr == p
    then return Nothing
    else do
      fp <- newForeignPtr hsqmlFinaliseClassHandlePtr p
      return $ Just $ HsQMLClassHandle fp

{#fun unsafe hsqml_create_class as ^
  {id `Ptr CUInt',
   id `Ptr CChar',
   id `Ptr (FunPtr UniformFunc)',
   id `Ptr (FunPtr UniformFunc)'} ->
  `Maybe HsQMLClassHandle' newClassHandle* #}

{#fun unsafe hsqml_allocate_in_place as ^
  {id `Ptr ()',
   id `Ptr ()',
   id `Ptr HsQMLClassHandle'} -> `()' #}

{#fun unsafe hsqml_register_type as ^
  {id `FunPtr PlacementFunc',
   `String',
   `Int',
   `Int',
   `String'} -> `()' #}

{#pointer *HsQMLObjectHandle as ^ newtype #}

objToPtr :: a -> (Ptr () -> IO b) -> IO b
objToPtr obj f = do
  sPtr <- newStablePtr obj
  res <- f $ castStablePtrToPtr sPtr
  return res

withHsQMLClassHandle :: HsQMLClassHandle -> (Ptr HsQMLClassHandle -> IO b) -> IO b
{#fun unsafe hsqml_create_object as ^
  {objToPtr* `a',
   withHsQMLClassHandle* `HsQMLClassHandle'} ->
  `HsQMLObjectHandle' id #}

ptrToObj :: Ptr () -> IO a
ptrToObj =
  deRefStablePtr . castPtrToStablePtr

{#fun unsafe hsqml_get_haskell as ^
  {id `HsQMLObjectHandle'} ->
  `a' ptrToObj* #}

ofDynamicMetaObject :: CUInt
ofDynamicMetaObject = 0x01

mfAccessPrivate, mfAccessProtected, mfAccessPublic, mfAccessMask,
  mfMethodMethod, mfMethodSignal, mfMethodSlot, mfMethodConstructor,
  mfMethodTypeMask, mfMethodCompatibility, mfMethodCloned, mfMethodScriptable
  :: CUInt
mfAccessPrivate   = 0x00
mfAccessProtected = 0x01
mfAccessPublic    = 0x02
mfAccessMask      = 0x03
mfMethodMethod      = 0x00
mfMethodSignal      = 0x04
mfMethodSlot        = 0x08
mfMethodConstructor = 0x0c
mfMethodTypeMask    = 0x0c
mfMethodCompatibility = 0x10
mfMethodCloned        = 0x20
mfMethodScriptable    = 0x40

pfInvalid, pfReadable, pfWritable, pfResettable, pfEnumOrFlag, pfStdCppSet,
  pfConstant, pfFinal, pfDesignable, pfResolveDesignable, pfScriptable,
  pfResolveScriptable, pfStored, pfResolveStored, pfEditable,
  pfResolveEditable, pfUser, pfResolveUser, pfNotify :: CUInt
pfInvalid           = 0x00000000
pfReadable          = 0x00000001
pfWritable          = 0x00000002
pfResettable        = 0x00000004
pfEnumOrFlag        = 0x00000008
pfStdCppSet         = 0x00000100
pfConstant          = 0x00000400
pfFinal             = 0x00000800
pfDesignable        = 0x00001000
pfResolveDesignable = 0x00002000
pfScriptable        = 0x00004000
pfResolveScriptable = 0x00008000
pfStored            = 0x00010000
pfResolveStored     = 0x00020000
pfEditable          = 0x00040000
pfResolveEditable   = 0x00080000
pfUser              = 0x00100000
pfResolveUser       = 0x00200000
pfNotify            = 0x00400000


Fix the get side of all container child attributes. It was accidentally calling 'set' rather than 'get'. doh! :-)

-- -*-haskell-*-
--  GIMP Toolkit (GTK) Container child Properties
--
--  Author : Duncan Coutts
--
--  Created: 16 April 2005
--
--  Copyright (C) 2005 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- #hide

-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Functions for getting and setting container child properties
--
module Graphics.UI.Gtk.Abstract.ContainerChildProperties (
  containerChildGetPropertyBool,
  containerChildSetPropertyBool,

  newAttrFromContainerChildIntProperty,
  newAttrFromContainerChildUIntProperty,
  newAttrFromContainerChildBoolProperty,
  newAttrFromContainerChildEnumProperty,
  newAttrFromContainerChildFlagsProperty,
  newAttrFromContainerChildStringProperty,
  ) where

import Control.Monad (liftM)

import System.Glib.FFI
import System.Glib.Flags
{#import Graphics.UI.Gtk.Types#}
import System.Glib.GType
import qualified System.Glib.GTypeConstants as GType
import System.Glib.GValueTypes
{#import System.Glib.GValue#}		(GValue(GValue), allocaGValue, valueInit)
import System.Glib.Attributes		(Attr, newAttr)

{# context lib="gtk" prefix="gtk" #}

containerChildSetPropertyInternal ::
 (ContainerClass container, WidgetClass child)
 => GType
 -> (GValue -> a -> IO ())
 -> String
 -> child
 -> container
 -> a
 -> IO ()
containerChildSetPropertyInternal gtype valueSet prop child container val =
  withCString prop $ \propertyNamePtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  valueSet gvalue val
  {# call container_child_set_property #}
    (toContainer container)
    (toWidget child)
    propertyNamePtr
    gvalue

containerChildGetPropertyInternal ::
 (ContainerClass container, WidgetClass child)
 => GType
 -> (GValue -> IO a)
 -> String
 -> child
 -> container
 -> IO a
containerChildGetPropertyInternal gtype valueGet prop child container =
  withCString prop $ \propertyNamePtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  {# call container_child_get_property #}
    (toContainer container)
    (toWidget child)
    propertyNamePtr
    gvalue
  valueGet gvalue

-- Versions for specific types:
-- we actually don't use any others than bool at the moment
--

containerChildGetPropertyBool :: (ContainerClass container, WidgetClass child)
 => String -> child -> container -> IO Bool
containerChildGetPropertyBool =
          containerChildGetPropertyInternal GType.bool valueGetBool

containerChildSetPropertyBool :: (ContainerClass container, WidgetClass child)
 => String -> child -> container -> Bool -> IO ()
containerChildSetPropertyBool =
          containerChildSetPropertyInternal GType.bool valueSetBool

-- Convenience functions to make attribute implementations in the other modules
-- shorter and more easily extensible.
--

newAttrFromContainerChildIntProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Int
newAttrFromContainerChildIntProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.int valueGetInt propName child)
  (containerChildSetPropertyInternal GType.int valueSetInt propName child)

newAttrFromContainerChildUIntProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Int
newAttrFromContainerChildUIntProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.uint
    (\gv -> liftM fromIntegral $ valueGetUInt gv) propName child)
  (containerChildSetPropertyInternal GType.uint
    (\gv v -> valueSetUInt gv (fromIntegral v)) propName child)

newAttrFromContainerChildBoolProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Bool
newAttrFromContainerChildBoolProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.bool valueGetBool propName child)
  (containerChildSetPropertyInternal GType.bool valueSetBool propName child)

newAttrFromContainerChildEnumProperty ::
 (ContainerClass container, WidgetClass child, Enum enum)
 => String -> GType -> child -> Attr container enum
newAttrFromContainerChildEnumProperty propName gtype child = newAttr
  (containerChildGetPropertyInternal gtype valueGetEnum propName child)
  (containerChildSetPropertyInternal gtype valueSetEnum propName child)

newAttrFromContainerChildFlagsProperty ::
 (ContainerClass container, WidgetClass child, Flags flag)
 => String -> GType -> child -> Attr container [flag]
newAttrFromContainerChildFlagsProperty propName gtype child = newAttr
  (containerChildGetPropertyInternal gtype valueGetFlags propName child)
  (containerChildSetPropertyInternal gtype valueSetFlags propName child)

newAttrFromContainerChildStringProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container String
newAttrFromContainerChildStringProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.string valueGetString propName child)
  (containerChildSetPropertyInternal GType.string valueSetString propName child)

-- -*-haskell-*-
--  GIMP Toolkit (GTK) Container child Properties
--
--  Author : Duncan Coutts
--
--  Created: 16 April 2005
--
--  Copyright (C) 2005 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- #hide

-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Functions for getting and setting container child properties
--
module Graphics.UI.Gtk.Abstract.ContainerChildProperties (
  containerChildGetPropertyBool,
  containerChildSetPropertyBool,

  newAttrFromContainerChildIntProperty,
  newAttrFromContainerChildUIntProperty,
  newAttrFromContainerChildBoolProperty,
  newAttrFromContainerChildEnumProperty,
  newAttrFromContainerChildFlagsProperty,
  newAttrFromContainerChildStringProperty,
  ) where

import Control.Monad (liftM)

import System.Glib.FFI
import System.Glib.Flags
{#import Graphics.UI.Gtk.Types#}
import System.Glib.GType
import qualified System.Glib.GTypeConstants as GType
import System.Glib.GValueTypes
{#import System.Glib.GValue#}		(GValue(GValue), allocaGValue, valueInit)
import System.Glib.Attributes		(Attr, newAttr)

{# context lib="gtk" prefix="gtk" #}

containerChildSetPropertyInternal ::
 (ContainerClass container, WidgetClass child)
 => GType
 -> (GValue -> a -> IO ())
 -> String
 -> child
 -> container
 -> a
 -> IO ()
containerChildSetPropertyInternal gtype valueSet prop child container val =
  withCString prop $ \propertyNamePtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  valueSet gvalue val
  {# call container_child_set_property #}
    (toContainer container)
    (toWidget child)
    propertyNamePtr
    gvalue

containerChildGetPropertyInternal ::
 (ContainerClass container, WidgetClass child)
 => GType
 -> (GValue -> IO a)
 -> String
 -> child
 -> container
 -> IO a
containerChildGetPropertyInternal gtype valueGet prop child container =
  withCString prop $ \propertyNamePtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  {# call container_child_set_property #}
    (toContainer container)
    (toWidget child)
    propertyNamePtr
    gvalue
  valueGet gvalue

-- Versions for specific types:
-- we actually don't use any others than bool at the moment
--

containerChildGetPropertyBool :: (ContainerClass container, WidgetClass child)
 => String -> child -> container -> IO Bool
containerChildGetPropertyBool =
          containerChildGetPropertyInternal GType.bool valueGetBool

containerChildSetPropertyBool :: (ContainerClass container, WidgetClass child)
 => String -> child -> container -> Bool -> IO ()
containerChildSetPropertyBool =
          containerChildSetPropertyInternal GType.bool valueSetBool

-- Convenience functions to make attribute implementations in the other modules
-- shorter and more easily extensible.
--

newAttrFromContainerChildIntProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Int
newAttrFromContainerChildIntProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.int valueGetInt propName child)
  (containerChildSetPropertyInternal GType.int valueSetInt propName child)

newAttrFromContainerChildUIntProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Int
newAttrFromContainerChildUIntProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.uint
    (\gv -> liftM fromIntegral $ valueGetUInt gv) propName child)
  (containerChildSetPropertyInternal GType.uint
    (\gv v -> valueSetUInt gv (fromIntegral v)) propName child)

newAttrFromContainerChildBoolProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Bool
newAttrFromContainerChildBoolProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.bool valueGetBool propName child)
  (containerChildSetPropertyInternal GType.bool valueSetBool propName child)

newAttrFromContainerChildEnumProperty ::
 (ContainerClass container, WidgetClass child, Enum enum)
 => String -> GType -> child -> Attr container enum
newAttrFromContainerChildEnumProperty propName gtype child = newAttr
  (containerChildGetPropertyInternal gtype valueGetEnum propName child)
  (containerChildSetPropertyInternal gtype valueSetEnum propName child)

newAttrFromContainerChildFlagsProperty ::
 (ContainerClass container, WidgetClass child, Flags flag)
 => String -> GType -> child -> Attr container [flag]
newAttrFromContainerChildFlagsProperty propName gtype child = newAttr
  (containerChildGetPropertyInternal gtype valueGetFlags propName child)
  (containerChildSetPropertyInternal gtype valueSetFlags propName child)

newAttrFromContainerChildStringProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container String
newAttrFromContainerChildStringProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.string valueGetString propName child)
  (containerChildSetPropertyInternal GType.string valueSetString propName child)


gio: System.GIO.File: add more functions; make the functions that do no IO use unsafePerformIO

darcs-hash:20081017185905-21862-ff108916af9d90432a21699a6134e550f62419a7.gz

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gio -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 13-Oct-2008
--
--  Copyright (c) 2008 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GIO, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GIO documentation.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module System.GIO.File (
    File,
    FileClass,
    FileQueryInfoFlags,
    FileCreateFlags,
    FileCopyFlags,
    FileMonitorFlags,
    FilesystemPreviewType,
    FileProgressCallback,
    FileReadMoreCallback,
    fileFromPath,
    fileFromURI,
    fileFromCommandlineArg,
    fileFromParseName,
    fileEqual,
    fileBasename,
    filePath,
    fileURI,
    fileParseName,
    fileGetChild,
    fileGetChildForDisplayName,
    fileHasPrefix,
    fileGetRelativePath,
    fileResolveRelativePath,
    fileIsNative,
    fileHasURIScheme,
    fileURIScheme,
    fileRead,
    fileReadAsync,
    fileReadFinish,
    fileAppendTo,
    fileCreate,
    fileReplace,
    fileAppendToAsync,
    fileAppendToFinish,
    fileCreateAsync,
    fileCreateFinish,
    fileReplaceAsync,
    fileReplaceFinish,
    fileQueryInfo,
    fileQueryInfoAsync,
    fileQueryInfoFinish,
    fileQueryExists,
    fileQueryFilesystemInfo,
    fileQueryFilesystemInfoAsync,
    fileQueryFilesystemInfoFinish,
    fileQueryDefaultHandler,
    fileFindEnclosingMount,
    fileFindEnclosingMountAsync,
    fileFindEnclosingMountFinish,
    fileEnumerateChildren,
    fileEnumerateChildrenAsync,
    fileEnumerateChildrenFinish,
    fileSetDisplayName,
    fileSetDisplayNameAsync,
    fileSetDisplayNameFinish,
    fileDelete,
    fileTrash,
    ) where

import Control.Monad
import qualified Data.ByteString as BS
import Data.Typeable

import System.Glib.FFI
import System.Glib.Flags
import System.Glib.GError
import System.Glib.UTFString

import System.GIO.Base
{#import System.GIO.Types#}

{# context lib = "gio" prefix = "g" #}

{# enum GFileQueryInfoFlags as FileQueryInfoFlags {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}
instance Flags FileQueryInfoFlags

{# enum GFileCreateFlags as FileCreateFlags {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}
instance Flags FileCreateFlags

{# enum GFileCopyFlags as FileCopyFlags {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}
instance Flags FileCopyFlags

{# enum GFileMonitorFlags as FileMonitorFlags {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}
instance Flags FileMonitorFlags

{# enum GFilesystemPreviewType as FilesystemPreviewType {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}

type FileProgressCallback = {# type goffset #} -> {# type goffset #} -> IO ()
type FileReadMoreCallback = BS.ByteString -> IO Bool

fileFromPath :: FilePath -> File
fileFromPath path =
    unsafePerformIO $ withUTFString path $ {# call file_new_for_path #} >=> takeGObject

fileFromURI :: String -> File
fileFromURI uri =
    unsafePerformIO $ withUTFString uri $ {# call file_new_for_uri #} >=> takeGObject

fileFromCommandlineArg :: String -> File
fileFromCommandlineArg arg =
    unsafePerformIO $ withUTFString arg $ {# call file_new_for_commandline_arg #} >=> takeGObject

fileFromParseName :: String -> File
fileFromParseName parseName =
    unsafePerformIO $ withUTFString parseName $ {# call file_parse_name #} >=> takeGObject

fileEqual :: (FileClass file1, FileClass file2)
          => file1 -> file2 -> Bool
fileEqual file1 file2 =
    unsafePerformIO $ liftM toBool $ {# call file_equal #} (toFile file1) (toFile file2)

instance Eq File where
    (==) = fileEqual

fileBasename :: FileClass file => file -> String
fileBasename =
    unsafePerformIO . ({# call file_get_basename #} . toFile >=> readUTFString)

filePath :: FileClass file => file -> FilePath
filePath =
    unsafePerformIO . ({# call file_get_path #} . toFile >=> readUTFString)

fileURI :: FileClass file => file -> String
fileURI =
    unsafePerformIO . ({# call file_get_uri #} . toFile >=> readUTFString)

fileParseName :: FileClass file => file -> String
fileParseName =
    unsafePerformIO . ({# call file_get_parse_name #} . toFile >=> readUTFString)

fileParent :: FileClass file => file -> Maybe File
fileParent =
    unsafePerformIO . ({# call file_get_parent #} . toFile >=> maybePeek takeGObject)

fileGetChild :: FileClass file => file -> String -> File
fileGetChild file name =
    unsafePerformIO $
        withUTFString name $
        {# call file_get_child #} (toFile file) >=> takeGObject

fileGetChildForDisplayName :: FileClass file => file -> String -> Maybe File
fileGetChildForDisplayName file displayName =
    unsafePerformIO $
        withUTFString displayName $ \cDisplayName ->
        propagateGError ({# call file_get_child_for_display_name #} (toFile file) cDisplayName) >>=
        maybePeek takeGObject

fileHasPrefix :: (FileClass file1, FileClass file2) => file1 -> file2 -> Bool
fileHasPrefix file1 file2 =
    unsafePerformIO $
        liftM toBool $ {# call file_has_prefix #} (toFile file1) (toFile file2)

fileGetRelativePath :: (FileClass file1, FileClass file2) => file1 -> file2 -> Maybe FilePath
fileGetRelativePath file1 file2 =
    unsafePerformIO $
        {# call file_get_relative_path #} (toFile file1) (toFile file2) >>=
        maybePeek readUTFString

fileResolveRelativePath :: FileClass file => file -> FilePath -> Maybe File
fileResolveRelativePath file relativePath =
    unsafePerformIO $
        withUTFString relativePath $ \cRelativePath ->
        {# call file_resolve_relative_path #} (toFile file) cRelativePath >>=
        maybePeek takeGObject

fileIsNative :: FileClass file => file -> Bool
fileIsNative =
    unsafePerformIO .
        liftM toBool . {# call file_is_native #} . toFile

fileHasURIScheme :: FileClass file => file -> String -> Bool
fileHasURIScheme file uriScheme =
    unsafePerformIO $
        withUTFString uriScheme $ \cURIScheme ->
        liftM toBool $ {# call file_has_uri_scheme #} (toFile file) cURIScheme

fileURIScheme :: FileClass file => file -> String
fileURIScheme =
    unsafePerformIO . ({# call file_get_uri_scheme #} . toFile >=> readUTFString)

fileRead :: FileClass file => file -> Maybe Cancellable -> IO FileInputStream
fileRead file cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
            propagateGError (g_file_read cFile cCancellable) >>= takeGObject
    where _ = {# call file_read #}

fileReadAsync :: FileClass file
              => file
              -> Int
              -> Maybe Cancellable
              -> AsyncReadyCallback
              -> IO ()
fileReadAsync file ioPriority mbCancellable callback =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject mbCancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_read_async cFile
                            (fromIntegral ioPriority)
                            cCancellable
                            cCallback
                            (castFunPtrToPtr cCallback)
    where _ = {# call file_read_async #}

fileReadFinish :: FileClass file
               => file
               -> AsyncResult
               -> IO FileInputStream
fileReadFinish file asyncResult =
    propagateGError ({# call file_read_finish #} (toFile file) asyncResult) >>= takeGObject

fileAppendTo :: FileClass file
             => file
             -> [FileCreateFlags]
             -> Maybe Cancellable
             -> IO FileOutputStream
fileAppendTo file flags cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_append_to cFile (cFromFlags flags) cCancellable) >>=
        takeGObject
    where _ = {# call file_append_to #}

fileCreate :: FileClass file
           => file
           -> [FileCreateFlags]
           -> Maybe Cancellable
           -> IO FileOutputStream
fileCreate file flags cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_create cFile (cFromFlags flags) cCancellable) >>=
        takeGObject
    where _ = {# call file_create #}

fileReplace :: FileClass file
            => file
            -> Maybe String
            -> Bool
            -> [FileCreateFlags]
            -> Maybe Cancellable
            -> IO FileOutputStream
fileReplace file etag makeBackup flags cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withUTFString etag $ \cEtag ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_replace cFile
                                        cEtag
                                        (fromBool makeBackup)
                                        (cFromFlags flags) cCancellable) >>=
        takeGObject
    where _ = {# call file_replace #}

fileAppendToAsync :: FileClass file
                  => file
                  -> [FileCreateFlags]
                  -> Int
                  -> Maybe Cancellable
                  -> AsyncReadyCallback
                  -> IO ()
fileAppendToAsync file flags ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_append_to_async cFile
                                 (cFromFlags flags)
                                 (fromIntegral ioPriority)
                                 cCancellable
                                 cCallback
                                 (castFunPtrToPtr cCallback)
    where _ = {# call file_append_to_async #}

fileAppendToFinish :: FileClass file
                   => file
                   -> AsyncResult
                   -> IO FileOutputStream
fileAppendToFinish file asyncResult =
    propagateGError ({# call file_append_to_finish #} (toFile file) asyncResult) >>= takeGObject

fileCreateAsync :: FileClass file
                  => file
                  -> [FileCreateFlags]
                  -> Int
                  -> Maybe Cancellable
                  -> AsyncReadyCallback
                  -> IO ()
fileCreateAsync file flags ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_create_async cFile
                              (cFromFlags flags)
                              (fromIntegral ioPriority)
                              cCancellable
                              cCallback
                              (castFunPtrToPtr cCallback)
    where _ = {# call file_create_async #}

fileCreateFinish :: FileClass file
                   => file
                   -> AsyncResult
                   -> IO FileOutputStream
fileCreateFinish file asyncResult =
    propagateGError ({# call file_create_finish #} (toFile file) asyncResult) >>= takeGObject

fileReplaceAsync :: FileClass file
                 => file
                 -> String
                 -> Bool
                 -> [FileCreateFlags]
                 -> Int
                 -> Maybe Cancellable
                 -> AsyncReadyCallback
                 -> IO ()
fileReplaceAsync file etag makeBackup flags ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        withUTFString etag $ \cEtag ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_replace_async cFile
                               cEtag
                               (fromBool makeBackup)
                               (cFromFlags flags)
                               (fromIntegral ioPriority)
                               cCancellable
                               cCallback
                               (castFunPtrToPtr cCallback)
    where _ = {# call file_replace_async #}

fileReplaceFinish :: FileClass file
                  => file
                  -> AsyncResult
                  -> IO FileOutputStream
fileReplaceFinish file asyncResult =
    propagateGError ({# call file_replace_finish #} (toFile file) asyncResult) >>= takeGObject

fileQueryInfo :: FileClass file
              => file
              -> String
              -> [FileQueryInfoFlags]
              -> Maybe Cancellable
              -> IO FileInfo
fileQueryInfo file attributes flags cancellable =
    withGObject (toFile file) $ \cFile ->
        withUTFString attributes $ \cAttributes ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_query_info cFile cAttributes (cFromFlags flags) cCancellable) >>=
        takeGObject
    where _ = {# call file_query_info #}

fileQueryInfoAsync :: FileClass file
                   => file
                   -> String
                   -> [FileQueryInfoFlags]
                   -> Int
                   -> Maybe Cancellable
                   -> AsyncReadyCallback
                   -> IO ()
fileQueryInfoAsync file attributes flags ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        withUTFString attributes $ \cAttributes ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_query_info_async cFile
                                  cAttributes
                                  (cFromFlags flags)
                                  (fromIntegral ioPriority)
                                  cCancellable
                                  cCallback
                                  (castFunPtrToPtr cCallback)
    where _ = {# call file_query_info_async #}

fileQueryInfoFinish :: FileClass file
                    => file
                    -> AsyncResult
                    -> IO FileInfo
fileQueryInfoFinish file asyncResult =
    propagateGError ({#call file_query_info_finish #} (toFile file) asyncResult) >>= takeGObject

fileQueryExists :: FileClass file
                => file
                -> Maybe Cancellable
                -> IO Bool
fileQueryExists file cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
            liftM toBool $ g_file_query_exists cFile cCancellable
    where _ = {# call file_query_exists #}

fileQueryFilesystemInfo :: FileClass file
                        => file
                        -> String
                        -> Maybe Cancellable
                        -> IO FileInfo
fileQueryFilesystemInfo file attributes cancellable =
    withGObject (toFile file) $ \cFile ->
        withUTFString attributes $ \cAttributes ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_query_filesystem_info cFile cAttributes cCancellable) >>=
        takeGObject
    where _ = {# call file_query_filesystem_info #}

fileQueryFilesystemInfoAsync :: FileClass file
                             => file
                             -> String
                             -> Int
                             -> Maybe Cancellable
                             -> AsyncReadyCallback
                             -> IO ()
fileQueryFilesystemInfoAsync file attributes ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        withUTFString attributes $ \cAttributes ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_query_filesystem_info_async cFile
                                             cAttributes
                                             (fromIntegral ioPriority)
                                             cCancellable
                                             cCallback
                                             (castFunPtrToPtr cCallback)
    where _ = {# call file_query_filesystem_info_async #}

fileQueryFilesystemInfoFinish :: FileClass file
                              => file
                              -> AsyncResult
                              -> IO FileInfo
fileQueryFilesystemInfoFinish file asyncResult =
    propagateGError ({# call file_query_filesystem_info_finish #} (toFile file) asyncResult) >>=
        takeGObject

fileQueryDefaultHandler :: FileClass file
                        => file
                        -> Maybe Cancellable
                        -> IO AppInfo
fileQueryDefaultHandler file cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_query_default_handler cFile cCancellable) >>=
        takeGObject
    where _ = {# call file_query_default_handler #}

fileFindEnclosingMount :: FileClass file
                       => file
                       -> Maybe Cancellable
                       -> IO Mount
fileFindEnclosingMount file cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_find_enclosing_mount cFile cCancellable) >>=
        takeGObject
    where _ = {# call file_find_enclosing_mount #}

fileFindEnclosingMountAsync :: FileClass file
                            => file
                            -> Int
                            -> Maybe Cancellable
                            -> AsyncReadyCallback
                            -> IO ()
fileFindEnclosingMountAsync file ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_find_enclosing_mount_async cFile
                                            (fromIntegral ioPriority)
                                            cCancellable
                                            cCallback
                                            (castFunPtrToPtr cCallback)
    where _ = {# call file_find_enclosing_mount_async #}

fileFindEnclosingMountFinish :: FileClass file
                             => file
                             -> AsyncResult
                             -> IO Mount
fileFindEnclosingMountFinish file asyncResult =
    propagateGError ({# call file_find_enclosing_mount_finish #} (toFile file) asyncResult) >>=
        takeGObject

fileEnumerateChildren :: FileClass file
                      => file
                      -> String
                      -> [FileQueryInfoFlags]
                      -> Maybe Cancellable
                      -> IO FileEnumerator
fileEnumerateChildren file attributes flags cancellable =
    withGObject (toFile file) $ \cFile ->
        withUTFString attributes $ \cAttributes ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_enumerate_children cFile cAttributes (cFromFlags flags) cCancellable) >>=
        takeGObject
    where _ = {# call file_enumerate_children #}

fileEnumerateChildrenAsync :: FileClass file
                           => file
                           -> String
                           -> [FileQueryInfoFlags]
                           -> Int
                           -> Maybe Cancellable
                           -> AsyncReadyCallback
                           -> IO ()
fileEnumerateChildrenAsync file attributes flags ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        withUTFString attributes $ \cAttributes ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_enumerate_children_async cFile
                                          cAttributes
                                          (cFromFlags flags)
                                          (fromIntegral ioPriority)
                                          cCancellable
                                          cCallback
                                          (castFunPtrToPtr cCallback)
    where _ = {# call file_enumerate_children_async #}

fileEnumerateChildrenFinish :: FileClass file
                             => file
                             -> AsyncResult
                             -> IO FileEnumerator
fileEnumerateChildrenFinish file asyncResult =
    propagateGError ({# call file_enumerate_children_finish #} (toFile file) asyncResult) >>=
        takeGObject

fileSetDisplayName :: FileClass file
                   => file
                   -> String
                   -> Maybe Cancellable
                   -> IO File
fileSetDisplayName file displayName cancellable =
    withGObject (toFile file) $ \cFile ->
        withUTFString displayName $ \cDisplayName ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_set_display_name cFile cDisplayName cCancellable) >>=
        takeGObject
    where _ = {# call file_set_display_name #}

fileSetDisplayNameAsync :: FileClass file
                        => file
                        -> String
                        -> Int
                        -> Maybe Cancellable
                        -> AsyncReadyCallback
                        -> IO ()
fileSetDisplayNameAsync file displayName ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        withUTFString displayName $ \cDisplayName ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_set_display_name_async cFile
                                        cDisplayName
                                        (fromIntegral ioPriority)
                                        cCancellable
                                        cCallback
                                        (castFunPtrToPtr cCallback)
    where _ = {# call file_set_display_name_async #}

fileSetDisplayNameFinish :: FileClass file
                         => file
                         -> AsyncResult
                         -> IO File
fileSetDisplayNameFinish file asyncResult =
    propagateGError ({# call file_set_display_name_finish #} (toFile file) asyncResult) >>=
        takeGObject

fileDelete :: FileClass file
           => file
           -> Maybe Cancellable
           -> IO ()
fileDelete file cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_delete cFile cCancellable) >> return ()
    where _ = {# call file_delete #}

fileTrash :: FileClass file
           => file
           -> Maybe Cancellable
           -> IO ()
fileTrash file cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_trash cFile cCancellable) >> return ()
    where _ = {# call file_trash #}

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gio -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 13-Oct-2008
--
--  Copyright (c) 2008 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GIO, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GIO documentation.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module System.GIO.File (
    File,
    FileClass,
    FileQueryInfoFlags,
    FileCreateFlags,
    FileCopyFlags,
    FileMonitorFlags,
    FilesystemPreviewType,
    FileProgressCallback,
    FileReadMoreCallback,
    fileNewForPath,
    fileNewForURI,
    fileNewForCommandlineArg,
    fileParseName,
    fileDup,
    fileEqual,
    fileGetBasename,
    fileGetPath,
    fileGetURI,
    fileGetParseName,
    fileGetChild,
    fileGetChildForDisplayName,
    fileHasPrefix,
    fileGetRelativePath,
    fileResolveRelativePath,
    fileIsNative,
    fileHasURIScheme,
    fileGetURIScheme,
    fileRead,
    fileReadAsync,
    fileReadFinish,
    fileAppendTo,
    fileCreate,
    fileReplace,
    fileAppendToAsync,
    fileAppendToFinish,
    fileCreateAsync,
    fileCreateFinish,
    fileReplaceAsync,
    fileReplaceFinish,
    fileQueryInfo,
    fileQueryInfoAsync,
    fileQueryExists,
    fileQueryFilesystemInfo
    ) where

import Control.Monad
import qualified Data.ByteString as BS
import Data.Typeable

import System.Glib.FFI
import System.Glib.Flags
import System.Glib.GError
import System.Glib.UTFString

import System.GIO.Base
{#import System.GIO.Types#}

{# context lib = "gio" prefix = "g" #}

{# enum GFileQueryInfoFlags as FileQueryInfoFlags {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}
instance Flags FileQueryInfoFlags

{# enum GFileCreateFlags as FileCreateFlags {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}
instance Flags FileCreateFlags

{# enum GFileCopyFlags as FileCopyFlags {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}
instance Flags FileCopyFlags

{# enum GFileMonitorFlags as FileMonitorFlags {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}
instance Flags FileMonitorFlags

{# enum GFilesystemPreviewType as FilesystemPreviewType {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}

type FileProgressCallback = {# type goffset #} -> {# type goffset #} -> IO ()
type FileReadMoreCallback = BS.ByteString -> IO Bool

fileNewForPath :: FilePath -> IO File
fileNewForPath path =
    withUTFString path $ {# call file_new_for_path #} >=> takeGObject

fileNewForURI :: String -> IO File
fileNewForURI uri =
    withUTFString uri $ {# call file_new_for_uri #} >=> takeGObject

fileNewForCommandlineArg :: String -> IO File
fileNewForCommandlineArg arg =
    withUTFString arg $ {# call file_new_for_commandline_arg #} >=> takeGObject

fileParseName :: String -> IO File
fileParseName parseName =
    withUTFString parseName $ {# call file_parse_name #} >=> takeGObject

fileDup :: FileClass file
        => file -> IO file
fileDup =
    {# call file_dup #} . toFile >=> takeGObject . castPtr

fileEqual :: (FileClass file1, FileClass file2)
          => file1 -> file2 -> IO Bool
fileEqual file1 file2 =
    liftM toBool $ {# call file_equal #} (toFile file1) (toFile file2)

fileGetBasename :: FileClass file => file -> IO String
fileGetBasename =
    {# call file_get_basename #} . toFile >=> readUTFString

fileGetPath :: FileClass file => file -> IO FilePath
fileGetPath =
    {# call file_get_path #} . toFile >=> readUTFString

fileGetURI :: FileClass file => file -> IO String
fileGetURI =
    {# call file_get_uri #} . toFile >=> readUTFString

fileGetParseName :: FileClass file => file -> IO String
fileGetParseName =
    {# call file_get_parse_name #} . toFile >=> readUTFString

fileGetParent :: FileClass file => file -> IO (Maybe File)
fileGetParent =
    {# call file_get_parent #} . toFile >=> maybePeek takeGObject

fileGetChild :: FileClass file => file -> String -> IO (Maybe File)
fileGetChild file name =
    withUTFString name $ {# call file_get_child #} (toFile file) >=> maybePeek takeGObject

fileGetChildForDisplayName :: FileClass file => file -> String -> IO File
fileGetChildForDisplayName file displayName =
    withUTFString displayName $ \cDisplayName ->
        propagateGError ({# call file_get_child_for_display_name #} (toFile file) cDisplayName) >>=
        takeGObject

fileHasPrefix :: (FileClass file1, FileClass file2) => file1 -> file2 -> IO Bool
fileHasPrefix file1 file2 =
    liftM toBool $ {# call file_has_prefix #} (toFile file1) (toFile file2)

fileGetRelativePath :: (FileClass file1, FileClass file2) => file1 -> file2 -> IO FilePath
fileGetRelativePath file1 file2 =
    {# call file_get_relative_path #} (toFile file1) (toFile file2) >>= readUTFString

fileResolveRelativePath :: FileClass file => file -> FilePath -> IO (Maybe File)
fileResolveRelativePath file relativePath =
    withUTFString relativePath $ \cRelativePath ->
        {# call file_resolve_relative_path #} (toFile file) cRelativePath >>=
        maybePeek takeGObject

fileIsNative :: FileClass file => file -> IO Bool
fileIsNative =
    liftM toBool . {# call file_is_native #} . toFile

fileHasURIScheme :: FileClass file => file -> String -> IO Bool
fileHasURIScheme file uriScheme =
    withUTFString uriScheme $ \cURIScheme ->
        liftM toBool $ {# call file_has_uri_scheme #} (toFile file) cURIScheme

fileGetURIScheme :: FileClass file => file -> IO String
fileGetURIScheme =
    {# call file_get_uri_scheme #} . toFile >=> readUTFString

fileRead :: FileClass file => file -> Maybe Cancellable -> IO FileInputStream
fileRead file cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
            propagateGError (g_file_read cFile cCancellable) >>= takeGObject
    where _ = {# call file_read #}

fileReadAsync :: FileClass file
              => file
              -> Int
              -> Maybe Cancellable
              -> AsyncReadyCallback
              -> IO ()
fileReadAsync file ioPriority mbCancellable callback =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject mbCancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_read_async cFile
                            (fromIntegral ioPriority)
                            cCancellable
                            cCallback
                            (castFunPtrToPtr cCallback)
    where _ = {# call file_read_async #}

fileReadFinish :: FileClass file
               => file
               -> AsyncResult
               -> IO FileInputStream
fileReadFinish file asyncResult =
    propagateGError ({# call file_read_finish #} (toFile file) asyncResult) >>= takeGObject

fileAppendTo :: FileClass file
             => file
             -> [FileCreateFlags]
             -> Maybe Cancellable
             -> IO FileOutputStream
fileAppendTo file flags cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_append_to cFile (cFromFlags flags) cCancellable) >>=
        takeGObject
    where _ = {# call file_append_to #}

fileCreate :: FileClass file
           => file
           -> [FileCreateFlags]
           -> Maybe Cancellable
           -> IO FileOutputStream
fileCreate file flags cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_create cFile (cFromFlags flags) cCancellable) >>=
        takeGObject
    where _ = {# call file_create #}

fileReplace :: FileClass file
            => file
            -> Maybe String
            -> Bool
            -> [FileCreateFlags]
            -> Maybe Cancellable
            -> IO FileOutputStream
fileReplace file etag makeBackup flags cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withUTFString etag $ \cEtag ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_replace cFile
                                        cEtag
                                        (fromBool makeBackup)
                                        (cFromFlags flags) cCancellable) >>=
        takeGObject
    where _ = {# call file_replace #}

fileAppendToAsync :: FileClass file
                  => file
                  -> [FileCreateFlags]
                  -> Int
                  -> Maybe Cancellable
                  -> AsyncReadyCallback
                  -> IO ()
fileAppendToAsync file flags ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_append_to_async cFile
                                 (cFromFlags flags)
                                 (fromIntegral ioPriority)
                                 cCancellable
                                 cCallback
                                 (castFunPtrToPtr cCallback)
    where _ = {# call file_append_to_async #}

fileAppendToFinish :: FileClass file
                   => file
                   -> AsyncResult
                   -> IO FileOutputStream
fileAppendToFinish file asyncResult =
    propagateGError ({# call file_append_to_finish #} (toFile file) asyncResult) >>= takeGObject

fileCreateAsync :: FileClass file
                  => file
                  -> [FileCreateFlags]
                  -> Int
                  -> Maybe Cancellable
                  -> AsyncReadyCallback
                  -> IO ()
fileCreateAsync file flags ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_create_async cFile
                              (cFromFlags flags)
                              (fromIntegral ioPriority)
                              cCancellable
                              cCallback
                              (castFunPtrToPtr cCallback)
    where _ = {# call file_create_async #}

fileCreateFinish :: FileClass file
                   => file
                   -> AsyncResult
                   -> IO FileOutputStream
fileCreateFinish file asyncResult =
    propagateGError ({# call file_create_finish #} (toFile file) asyncResult) >>= takeGObject

fileReplaceAsync :: FileClass file
                 => file
                 -> String
                 -> Bool
                 -> [FileCreateFlags]
                 -> Int
                 -> Maybe Cancellable
                 -> AsyncReadyCallback
                 -> IO ()
fileReplaceAsync file etag makeBackup flags ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        withUTFString etag $ \cEtag ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_replace_async cFile
                               cEtag
                               (fromBool makeBackup)
                               (cFromFlags flags)
                               (fromIntegral ioPriority)
                               cCancellable
                               cCallback
                               (castFunPtrToPtr cCallback)
    where _ = {# call file_replace_async #}

fileReplaceFinish :: FileClass file
                  => file
                  -> AsyncResult
                  -> IO FileOutputStream
fileReplaceFinish file asyncResult =
    propagateGError ({# call file_replace_finish #} (toFile file) asyncResult) >>= takeGObject

fileQueryInfo :: FileClass file
              => file
              -> String
              -> [FileQueryInfoFlags]
              -> Maybe Cancellable
              -> IO FileInfo
fileQueryInfo file attributes flags cancellable =
    withGObject (toFile file) $ \cFile ->
        withUTFString attributes $ \cAttributes ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_query_info cFile cAttributes (cFromFlags flags) cCancellable) >>=
        takeGObject
    where _ = {# call file_query_info #}

fileQueryInfoAsync :: FileClass file
                   => file
                   -> String
                   -> [FileQueryInfoFlags]
                   -> Int
                   -> Maybe Cancellable
                   -> AsyncReadyCallback
                   -> IO ()
fileQueryInfoAsync file attributes flags ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        withUTFString attributes $ \cAttributes ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_query_info_async cFile
                                  cAttributes
                                  (cFromFlags flags)
                                  (fromIntegral ioPriority)
                                  cCancellable
                                  cCallback
                                  (castFunPtrToPtr cCallback)
    where _ = {# call file_query_info_async #}

fileQueryExists :: FileClass file
                => file
                -> Maybe Cancellable
                -> IO Bool
fileQueryExists file cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
            liftM toBool $ g_file_query_exists cFile cCancellable
    where _ = {# call file_query_exists #}

fileQueryFilesystemInfo :: FileClass file
                        => file
                        -> String
                        -> Maybe Cancellable
                        -> IO FileInfo
fileQueryFilesystemInfo file attributes cancellable =
    withGObject (toFile file) $ \cFile ->
        withUTFString attributes $ \cAttributes ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_query_filesystem_info cFile cAttributes cCancellable) >>=
        takeGObject
    where _ = {# call file_query_filesystem_info #}


Correct arguments of a finally statement.

This code has obviously never been tested. Thanks to Bertram Felgenhauer to spot this.

darcs-hash:20090417143511-e5ac5-1f71b04e8d52eee9c8e856ff7aee559ba2b40931.gz

{-# OPTIONS_HADDOCK hide #-}
--  GIMP Toolkit (GTK) Binding for Haskell: binding to libgnomevfs -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GnomeVFS, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GnomeVFS documentation,
--  Copyright (c) 2001 Seth Nickell <snickell@stanford.edu>. The
--  documentation is covered by the GNU Free Documentation License,
--  version 1.2.

-- #hide

-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
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.Types#}
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 {# type GnomeVFSResult #}
                     -> 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 {# type GnomeVFSResult #}
                  -> IO ()
voidResultMarshal cAction =
    genericResultMarshal cAction (return ()) (return ())

newObjectResultMarshal :: (ForeignPtr obj -> obj)
                       -> (Ptr (Ptr obj) -> IO {# type GnomeVFSResult #})
                       -> 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 {# type GnomeVFSVolumeOpCallback #}
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 {# type GnomeVFSVolumeOpCallback #}

{-# OPTIONS_HADDOCK hide #-}
--  GIMP Toolkit (GTK) Binding for Haskell: binding to libgnomevfs -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GnomeVFS, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GnomeVFS documentation,
--  Copyright (c) 2001 Seth Nickell <snickell@stanford.edu>. The
--  documentation is covered by the GNU Free Documentation License,
--  version 1.2.

-- #hide

-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
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.Types#}
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 {# type GnomeVFSResult #}
                     -> 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 {# type GnomeVFSResult #}
                  -> IO ()
voidResultMarshal cAction =
    genericResultMarshal cAction (return ()) (return ())

newObjectResultMarshal :: (ForeignPtr obj -> obj)
                       -> (Ptr (Ptr obj) -> IO {# type GnomeVFSResult #})
                       -> 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 {# type GnomeVFSVolumeOpCallback #}
volumeOpCallbackMarshal successCallback failureCallback =
    let cCallback :: CVolumeOpCallback
        cCallback cSucceeded cError cDetailedError cUserData =
            let succeeded = cToBool cSucceeded
                cCallbackFunPtr = castPtrToFunPtr cUserData
            in 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 {# type GnomeVFSVolumeOpCallback #}