compute capability as floating point major.minor

Ignore-this: 84831b1ccc3b58b3f360e156c677c43d

darcs-hash:20090720041734-115f9-c9e4ce4a1c15171ea16b2782b20e630eda5bf646.gz

{-
 - CUDA data types
 -}

{-# LANGUAGE ForeignFunctionInterface #-}

module Foreign.CUDA.Types
  (
    Status(..),
    CopyDirection(..),
    ComputeMode(..),
    DeviceFlags(..),
    DeviceProperties(..),
    Stream,

    DevicePtr, newDevicePtr, withDevicePtr
  ) where

import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Internal.Offsets

#include "cbits/stubs.h"
#include <cuda_runtime_api.h>
{#context lib="cudart" prefix="cuda"#}

--------------------------------------------------------------------------------
-- Enumerations
--------------------------------------------------------------------------------

--
-- Error Codes
--
{# enum cudaError as Status
    { cudaSuccess as Success }
    with prefix="cudaError" deriving (Eq, Show) #}

--
-- Memory copy
--
{# enum cudaMemcpyKind as CopyDirection {}
    with prefix="cudaMemcpy" deriving (Eq, Show) #}

--
-- Compute mode
--
{# enum ComputeMode {}
    with prefix="cudaComputeMode" deriving (Eq, Show) #}

--
-- Device execution flags
--
{# enum DeviceFlags {}
    with prefix="cudaDeviceFlag" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Device Properties
--------------------------------------------------------------------------------

{# pointer *cudaDeviceProp as ^ foreign -> DeviceProperties nocode #}

--
-- Store all device properties
--
data DeviceProperties = DeviceProperties
  {
    deviceName               :: String,
    computeCapability        :: Float,
    totalGlobalMem           :: Integer,
    totalConstMem            :: Integer,
    sharedMemPerBlock        :: Integer,
    regsPerBlock             :: Int,
    warpSize                 :: Int,
    maxThreadsPerBlock       :: Int,
    maxThreadsDim            :: (Int,Int,Int),
    maxGridSize              :: (Int,Int,Int),
    clockRate                :: Int,
    multiProcessorCount      :: Int,
    memPitch                 :: Integer,
    textureAlignment         :: Integer,
    computeMode              :: ComputeMode,
    deviceOverlap            :: Bool,
    kernelExecTimeoutEnabled :: Bool,
    integrated               :: Bool,
    canMapHostMemory         :: Bool
  }
  deriving (Show)

instance Storable DeviceProperties where
    sizeOf _    = {#sizeof cudaDeviceProp#}
    alignment _ = alignment (undefined :: Ptr ())

    peek p      = do
        gm <- cIntConv     `fmap` {#get cudaDeviceProp.totalGlobalMem#} p
        sm <- cIntConv     `fmap` {#get cudaDeviceProp.sharedMemPerBlock#} p
        rb <- cIntConv     `fmap` {#get cudaDeviceProp.regsPerBlock#} p
        ws <- cIntConv     `fmap` {#get cudaDeviceProp.warpSize#} p
        mp <- cIntConv     `fmap` {#get cudaDeviceProp.memPitch#} p
        tb <- cIntConv     `fmap` {#get cudaDeviceProp.maxThreadsPerBlock#} p
        cl <- cIntConv     `fmap` {#get cudaDeviceProp.clockRate#} p
        cm <- cIntConv     `fmap` {#get cudaDeviceProp.totalConstMem#} p
        v1 <- fromIntegral `fmap` {#get cudaDeviceProp.major#} p
        v2 <- fromIntegral `fmap` {#get cudaDeviceProp.minor#} p
        ta <- cIntConv     `fmap` {#get cudaDeviceProp.textureAlignment#} p
        ov <- cToBool      `fmap` {#get cudaDeviceProp.deviceOverlap#} p
        pc <- cIntConv     `fmap` {#get cudaDeviceProp.multiProcessorCount#} p
        ke <- cToBool      `fmap` {#get cudaDeviceProp.kernelExecTimeoutEnabled#} p
        tg <- cToBool      `fmap` {#get cudaDeviceProp.integrated#} p
        hm <- cToBool      `fmap` {#get cudaDeviceProp.canMapHostMemory#} p
        md <- cToEnum      `fmap` {#get cudaDeviceProp.computeMode#} p

        --
        -- C->Haskell returns the wrong type when accessing static arrays in
        -- structs, returning the dereferenced element but with a Ptr type. Work
        -- around this with manual pointer arithmetic...
        --
        n            <- peekCString (p `plusPtr` devNameOffset)
        (t1:t2:t3:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxThreadDimOffset :: Ptr CInt)
        (g1:g2:g3:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxGridSizeOffset  :: Ptr CInt)

        return DeviceProperties
            {
              deviceName               = n,
              computeCapability        = v1 + v2 / max 10 (10^ ((ceiling . logBase 10) v2 :: Int)),
              totalGlobalMem           = gm,
              totalConstMem            = cm,
              sharedMemPerBlock        = sm,
              regsPerBlock             = rb,
              warpSize                 = ws,
              maxThreadsPerBlock       = tb,
              maxThreadsDim            = (t1,t2,t3),
              maxGridSize              = (g1,g2,g3),
              clockRate                = cl,
              multiProcessorCount      = pc,
              memPitch                 = mp,
              textureAlignment         = ta,
              computeMode              = md,
              deviceOverlap            = ov,
              kernelExecTimeoutEnabled = ke,
              integrated               = tg,
              canMapHostMemory         = hm
            }

--------------------------------------------------------------------------------
-- Memory Management
--------------------------------------------------------------------------------

newtype DevicePtr = DevicePtr (ForeignPtr ())

withDevicePtr :: DevicePtr -> (Ptr () -> IO b) -> IO b
withDevicePtr (DevicePtr fptr) = withForeignPtr fptr

newDevicePtr      :: FinalizerPtr () -> Ptr () -> IO DevicePtr
newDevicePtr fp p =  newForeignPtr fp p >>= \dp -> return (DevicePtr dp)

--------------------------------------------------------------------------------
-- Stream Management
--------------------------------------------------------------------------------

type Stream = {# type cudaStream_t #}

{-
 - CUDA data types
 -}

{-# LANGUAGE ForeignFunctionInterface #-}

module Foreign.CUDA.Types
  (
    Status(..),
    CopyDirection(..),
    ComputeMode(..),
    DeviceFlags(..),
    DeviceProperties(..),
    Stream,

    DevicePtr, newDevicePtr, withDevicePtr
  ) where

import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Internal.Offsets

#include "cbits/stubs.h"
#include <cuda_runtime_api.h>
{#context lib="cudart" prefix="cuda"#}

--------------------------------------------------------------------------------
-- Enumerations
--------------------------------------------------------------------------------

--
-- Error Codes
--
{# enum cudaError as Status
    { cudaSuccess as Success }
    with prefix="cudaError" deriving (Eq, Show) #}

--
-- Memory copy
--
{# enum cudaMemcpyKind as CopyDirection {}
    with prefix="cudaMemcpy" deriving (Eq, Show) #}

--
-- Compute mode
--
{# enum ComputeMode {}
    with prefix="cudaComputeMode" deriving (Eq, Show) #}

--
-- Device execution flags
--
{# enum DeviceFlags {}
    with prefix="cudaDeviceFlag" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Device Properties
--------------------------------------------------------------------------------

{# pointer *cudaDeviceProp as ^ foreign -> DeviceProperties nocode #}

--
-- Store all device properties
--
data DeviceProperties = DeviceProperties
  {
    deviceName               :: String,
    computeCapability        :: (Int,Int),
    totalGlobalMem           :: Integer,
    totalConstMem            :: Integer,
    sharedMemPerBlock        :: Integer,
    regsPerBlock             :: Int,
    warpSize                 :: Int,
    maxThreadsPerBlock       :: Int,
    maxThreadsDim            :: (Int,Int,Int),
    maxGridSize              :: (Int,Int,Int),
    clockRate                :: Int,
    multiProcessorCount      :: Int,
    memPitch                 :: Integer,
    textureAlignment         :: Integer,
    computeMode              :: ComputeMode,
    deviceOverlap            :: Bool,
    kernelExecTimeoutEnabled :: Bool,
    integrated               :: Bool,
    canMapHostMemory         :: Bool
  }
  deriving (Show)

instance Storable DeviceProperties where
    sizeOf _    = {#sizeof cudaDeviceProp#}
    alignment _ = alignment (undefined :: Ptr ())

    peek p      = do
        gm <- cIntConv `fmap` {#get cudaDeviceProp.totalGlobalMem#} p
        sm <- cIntConv `fmap` {#get cudaDeviceProp.sharedMemPerBlock#} p
        rb <- cIntConv `fmap` {#get cudaDeviceProp.regsPerBlock#} p
        ws <- cIntConv `fmap` {#get cudaDeviceProp.warpSize#} p
        mp <- cIntConv `fmap` {#get cudaDeviceProp.memPitch#} p
        tb <- cIntConv `fmap` {#get cudaDeviceProp.maxThreadsPerBlock#} p
        cl <- cIntConv `fmap` {#get cudaDeviceProp.clockRate#} p
        cm <- cIntConv `fmap` {#get cudaDeviceProp.totalConstMem#} p
        v1 <- cIntConv `fmap` {#get cudaDeviceProp.major#} p
        v2 <- cIntConv `fmap` {#get cudaDeviceProp.minor#} p
        ta <- cIntConv `fmap` {#get cudaDeviceProp.textureAlignment#} p
        ov <- cToBool  `fmap` {#get cudaDeviceProp.deviceOverlap#} p
        pc <- cIntConv `fmap` {#get cudaDeviceProp.multiProcessorCount#} p
        ke <- cToBool  `fmap` {#get cudaDeviceProp.kernelExecTimeoutEnabled#} p
        tg <- cToBool  `fmap` {#get cudaDeviceProp.integrated#} p
        hm <- cToBool  `fmap` {#get cudaDeviceProp.canMapHostMemory#} p
        md <- cToEnum  `fmap` {#get cudaDeviceProp.computeMode#} p

        --
        -- C->Haskell returns the wrong type when accessing static arrays in
        -- structs, returning the dereferenced element but with a Ptr type. Work
        -- around this with manual pointer arithmetic...
        --
        n            <- peekCString (p `plusPtr` devNameOffset)
        (t1:t2:t3:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxThreadDimOffset :: Ptr CInt)
        (g1:g2:g3:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxGridSizeOffset  :: Ptr CInt)

        return DeviceProperties
            {
              deviceName               = n,
              computeCapability        = (v1,v2),
              totalGlobalMem           = gm,
              totalConstMem            = cm,
              sharedMemPerBlock        = sm,
              regsPerBlock             = rb,
              warpSize                 = ws,
              maxThreadsPerBlock       = tb,
              maxThreadsDim            = (t1,t2,t3),
              maxGridSize              = (g1,g2,g3),
              clockRate                = cl,
              multiProcessorCount      = pc,
              memPitch                 = mp,
              textureAlignment         = ta,
              computeMode              = md,
              deviceOverlap            = ov,
              kernelExecTimeoutEnabled = ke,
              integrated               = tg,
              canMapHostMemory         = hm
            }

--------------------------------------------------------------------------------
-- Memory Management
--------------------------------------------------------------------------------

newtype DevicePtr = DevicePtr (ForeignPtr ())

withDevicePtr :: DevicePtr -> (Ptr () -> IO b) -> IO b
withDevicePtr (DevicePtr fptr) = withForeignPtr fptr

newDevicePtr      :: FinalizerPtr () -> Ptr () -> IO DevicePtr
newDevicePtr fp p =  newForeignPtr fp p >>= \dp -> return (DevicePtr dp)

--------------------------------------------------------------------------------
-- Stream Management
--------------------------------------------------------------------------------

type Stream = {# type cudaStream_t #}


gstreamer: fix types for event handlers in Element.chs

-- GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer   -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Version $Revision$ from $Date$
--
--  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.Element (

  Element,
  ElementClass,
  castToElement,
  toElement,
  fromElement,
  ElementFlags(..),
  State(..),
  StateChange(..),
  StateChangeReturn(..),
  elementAddPad,
  elementGetPad,
  elementGetCompatiblePad,
  elementGetCompatiblePadTemplate,
  elementGetRequestPad,
  elementGetStaticPad,
  elementNoMorePads,
  elementReleaseRequestPad,
  elementRemovePad,
  elementIteratePads,
  elementIterateSinkPads,
  elementIterateSrcPads,
  elementLink,
  elementUnlink,
  elementLinkPads,
  elementUnlinkPads,
  elementLinkPadsFiltered,
  elementLinkFiltered,
  elementSetBaseTime,
  elementGetBaseTime,
  elementSetBus,
  elementGetBus,
  elementGetFactory,
  elementSetIndex,
  elementIsIndexable,
  elementRequiresClock,
  elementSetClock,
  elementGetClock,
  elementProvidesClock,
  elementProvideClock,
  elementSetState,
  elementGetState,
  elementSetLockedState,
  elementIsLockedState,
  elementAbortState,
  elementStateGetName,
  elementStateChangeReturnGetName,
  elementSyncStateWithParent,
  elementGetQueryTypes,
  elementQuery,
  elementQueryConvert,
  elementQueryPosition,
  elementQueryDuration,
  elementSendEvent,
  elementSeekSimple,
  elementSeek,
  onElementNoMorePads,
  afterElementNoMorePads,
  onElementPadAdded,
  afterElementPadAdded,
  onElementPadRemoved,
  afterElementPadRemoved

  ) where

import Control.Monad         ( liftM )
import Data.Maybe            ( fromMaybe )
import System.Glib.FFI
import System.Glib.Flags
import System.Glib.UTFString ( withUTFString
                             , peekUTFString )
{#import System.Glib.Signals#}
{#import System.Glib.GObject#}
{#import Media.Streaming.GStreamer.Types#}
{#import Media.Streaming.GStreamer.Signals#}
import GHC.Base              ( unsafeCoerce# )

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

elementAddPad :: (ElementClass elementT, PadClass padT) =>
                 elementT
              -> padT
              -> IO Bool
elementAddPad element pad =
    liftM toBool $ {# call element_add_pad #} (toElement element) (toPad pad)

elementGetPad :: ElementClass elementT =>
                 elementT
              -> String
              -> IO (Maybe Pad)
elementGetPad element name =
    (withUTFString name $ {# call element_get_pad #} (toElement element)) >>=
        maybePeek newPad

elementGetCompatiblePad :: (ElementClass elementT, PadClass padT) =>
                           elementT
                        -> padT
                        -> Caps
                        -> IO (Maybe Pad)
elementGetCompatiblePad element pad caps =
    {# call element_get_compatible_pad #} (toElement element) (toPad pad) caps >>=
        maybePeek newPad

elementGetCompatiblePadTemplate :: (ElementClass elementT, PadTemplateClass padTemplateT) =>
                                   elementT
                                -> padTemplateT
                                -> IO (Maybe PadTemplate)
elementGetCompatiblePadTemplate element padTemplate =
    {# call element_get_compatible_pad_template #} (toElement element) (toPadTemplate padTemplate) >>=
        maybePeek newPadTemplate

elementGetRequestPad :: ElementClass elementT =>
                        elementT
                     -> String
                     -> IO (Maybe Pad)
elementGetRequestPad element name =
    (withUTFString name $ {# call element_get_request_pad #} (toElement element)) >>=
        maybePeek newPad_ -- no finalizer; use elementReleaseRequestPad

elementGetStaticPad :: ElementClass elementT =>
                       elementT
                    -> String
                    -> IO (Maybe Pad)
elementGetStaticPad element name =
    (withUTFString name $ {# call element_get_static_pad #} (toElement element)) >>=
        maybePeek newPad

elementNoMorePads :: ElementClass elementT =>
                     elementT
                  -> IO ()
elementNoMorePads element =
    {# call element_no_more_pads #} (toElement element)

elementReleaseRequestPad :: (ElementClass elementT, PadClass padT) =>
                            elementT
                         -> padT
                         -> IO ()
elementReleaseRequestPad element pad =
    {# call element_release_request_pad #} (toElement element) (toPad pad)

elementRemovePad :: (ElementClass elementT, PadClass padT) =>
                    elementT
                 -> padT
                 -> IO Bool
elementRemovePad element pad =
    liftM toBool $ {# call element_remove_pad #} (toElement element) (toPad pad)

elementIteratePads :: (ElementClass elementT) =>
                      elementT
                   -> IO (Iterator Pad)
elementIteratePads element =
    {# call element_iterate_pads #} (toElement element) >>= newIterator

elementIterateSinkPads :: (ElementClass elementT) =>
                          elementT
                       -> IO (Iterator Pad)
elementIterateSinkPads element =
    {# call element_iterate_sink_pads #} (toElement element) >>= newIterator

elementIterateSrcPads :: (ElementClass elementT) =>
                          elementT
                       -> IO (Iterator Pad)
elementIterateSrcPads element =
    {# call element_iterate_sink_pads #} (toElement element) >>= newIterator

elementLink :: (ElementClass elementT1, ElementClass elementT2) =>
               elementT1
            -> elementT2
            -> IO Bool
elementLink element1 element2 =
    liftM toBool $ {# call element_link #} (toElement element1) (toElement element2)

elementUnlink :: (ElementClass elementT1, ElementClass elementT2) =>
                 elementT1
              -> elementT2
              -> IO ()
elementUnlink element1 element2 =
    {# call element_unlink #} (toElement element1) (toElement element2)

elementLinkPads :: (ElementClass elementT1, ElementClass elementT2) =>
                   elementT1
                -> String
                -> elementT2
                -> String
                -> IO Bool
elementLinkPads src srcPadName dest destPadName =
    withUTFString destPadName $ \cDestPadName ->
        withUTFString srcPadName $ \cSrcPadName ->
            liftM toBool $ {# call element_link_pads #} (toElement src) cSrcPadName (toElement dest) cDestPadName

elementUnlinkPads :: (ElementClass elementT1, ElementClass elementT2) =>
                     elementT1
                  -> String
                  -> elementT2
                  -> String
                  -> IO ()
elementUnlinkPads src srcPadName dest destPadName =
    withUTFString destPadName $ \cDestPadName ->
        withUTFString srcPadName $ \cSrcPadName ->
            {# call element_unlink_pads #} (toElement src) cSrcPadName (toElement dest) cDestPadName

elementLinkPadsFiltered :: (ElementClass elementT1, ElementClass elementT2) =>
                           elementT1
                        -> String
                        -> elementT2
                        -> String
                        -> Caps
                        -> IO Bool
elementLinkPadsFiltered src srcPadName dest destPadName filter =
    withUTFString destPadName $ \cDestPadName ->
        withUTFString srcPadName $ \cSrcPadName ->
            liftM toBool $ {# call element_link_pads_filtered #} (toElement src) cSrcPadName (toElement dest) cDestPadName filter

elementLinkFiltered :: (ElementClass elementT1, ElementClass elementT2) =>
                       elementT1
                    -> elementT2
                    -> Maybe Caps
                    -> IO Bool
elementLinkFiltered element1 element2 filter =
    liftM toBool $
        {# call element_link_filtered #} (toElement element1) (toElement element2) $
            fromMaybe (Caps nullForeignPtr) filter

elementSetBaseTime :: ElementClass elementT =>
                      elementT
                   -> ClockTimeDiff
                   -> IO ()
elementSetBaseTime element time =
    {# call element_set_base_time #} (toElement element) $ fromIntegral time

elementGetBaseTime :: ElementClass elementT =>
                      elementT
                   -> IO ClockTimeDiff
elementGetBaseTime element =
    liftM fromIntegral $ {# call element_get_base_time #} (toElement element)

elementSetBus :: (ElementClass elementT, BusClass busT) =>
                 elementT
              -> busT
              -> IO ()
elementSetBus element bus =
    {# call element_set_bus #} (toElement element) (toBus bus)

elementGetBus :: ElementClass elementT =>
                 elementT
              -> IO Bus
elementGetBus element =
    {# call element_get_bus #} (toElement element) >>= newBus

elementGetFactory :: ElementClass elementT =>
                     elementT
                  -> IO ElementFactory
elementGetFactory element =
    {# call element_get_factory #} (toElement element) >>= newElementFactory_

elementSetIndex :: (ElementClass elementT, IndexClass indexT) =>
                   elementT
                -> indexT
                -> IO ()
elementSetIndex element index =
    {# call element_set_index #} (toElement element) (toIndex index)

elementGetIndex :: ElementClass elementT =>
                   elementT
                -> IO (Maybe Index)
elementGetIndex element =
    {# call element_get_index #} (toElement element) >>= maybePeek newIndex

elementIsIndexable :: ElementClass elementT =>
                      elementT
                   -> IO Bool
elementIsIndexable element =
    liftM toBool $ {# call element_is_indexable #} (toElement element)

elementRequiresClock :: ElementClass elementT =>
                        elementT
                     -> IO Bool
elementRequiresClock element =
    liftM toBool $ {# call element_requires_clock #} (toElement element)

elementSetClock :: (ElementClass elementT, ClockClass clockT) =>
                   elementT
                -> clockT
                -> IO Bool
elementSetClock element clock =
    liftM toBool $ {# call element_set_clock #} (toElement element) (toClock clock)

elementGetClock :: ElementClass elementT =>
                   elementT
                -> IO (Maybe Clock)
elementGetClock element =
    {# call element_get_clock #} (toElement element) >>= maybePeek newClock

elementProvidesClock :: ElementClass elementT =>
                        elementT
                     -> IO Bool
elementProvidesClock element =
    liftM toBool $ {# call element_provides_clock #} $ toElement element

elementProvideClock :: ElementClass elementT =>
                       elementT
                    -> IO (Maybe Clock)
elementProvideClock element =
    {# call element_provide_clock #} (toElement element) >>= maybePeek newClock

elementSetState :: ElementClass elementT =>
                   elementT
                -> State
                -> IO StateChangeReturn
elementSetState element state =
    liftM (toEnum . fromIntegral) $ {# call element_set_state #} (toElement element) $
        fromIntegral $ fromEnum state

elementGetState :: ElementClass elementT =>
                   elementT
                -> ClockTime
                -> IO (StateChangeReturn, State, State)
elementGetState element timeout =
    alloca $ \statePtr ->
        alloca $ \pendingPtr ->
            do result <- {# call element_get_state #} (toElement element) statePtr pendingPtr $ fromIntegral timeout
               state <- peek statePtr
               pending <- peek pendingPtr
               return (toEnum (fromIntegral result),
                       toEnum (fromIntegral state),
                       toEnum (fromIntegral pending))

elementSetLockedState :: ElementClass elementT =>
                         elementT
                      -> Bool
                      -> IO Bool
elementSetLockedState element lockedState =
    liftM toBool $ {# call element_set_locked_state #} (toElement element) $ fromBool lockedState

elementIsLockedState :: ElementClass elementT =>
                        elementT
                     -> IO Bool
elementIsLockedState element =
    liftM toBool $ {# call element_is_locked_state #} $ toElement element

elementAbortState :: ElementClass elementT =>
                     elementT
                  -> IO ()
elementAbortState element =
    {# call element_abort_state #} $ toElement element

elementStateGetName :: State
                    -> String
elementStateGetName state =
    unsafePerformIO $ ({# call element_state_get_name #} $ fromIntegral $ fromEnum state) >>= peekUTFString

elementStateChangeReturnGetName :: StateChangeReturn
                                -> String
elementStateChangeReturnGetName stateRet =
    unsafePerformIO $ ({# call element_state_change_return_get_name #} $ fromIntegral $ fromEnum stateRet) >>= peekUTFString

elementSyncStateWithParent :: ElementClass elementT =>
                              elementT
                           -> IO Bool
elementSyncStateWithParent element =
    liftM toBool $ {# call element_sync_state_with_parent #} $ toElement element

elementGetQueryTypes :: ElementClass element
                     => element
                     -> IO [QueryType]
elementGetQueryTypes element =
    liftM (map (toEnum . fromIntegral)) $
        {# call element_get_query_types #} (toElement element) >>=
            peekArray0 0

elementQuery :: (ElementClass element, QueryClass query)
             => element
             -> query
             -> IO (Maybe query)
elementQuery element query =
    do query' <- {# call mini_object_copy #} (toMiniObject query) >>=
                    newForeignPtr_ . castPtr
       success <- {# call element_query #} (toElement element) $ Query query'
       if toBool success
           then liftM (Just . unsafeCoerce#) $ withForeignPtr query' $ newQuery . castPtr
           else return Nothing

elementQueryConvert :: ElementClass element
                    => element
                    -> Format
                    -> Int64
                    -> IO (Maybe (Format, Int64))
elementQueryConvert element srcFormat srcVal =
    alloca $ \destFormatPtr ->
        alloca $ \destValPtr ->
            do success <- {# call element_query_convert #} (toElement element)
                                                       (fromIntegral $ fromEnum srcFormat)
                                                       (fromIntegral srcVal)
                                                       destFormatPtr
                                                       destValPtr
               if toBool success
                   then do destFormat <- peek destFormatPtr
                           destVal    <- peek destValPtr
                           return $ Just (toEnum $ fromIntegral destFormat,
                                          fromIntegral destVal)
                   else return Nothing

elementQueryPosition :: ElementClass element
                     => element
                     -> IO (Maybe (Format, Int64))
elementQueryPosition element =
    alloca $ \formatPtr ->
        alloca $ \curPtr ->
            do success <- {# call element_query_position #} (toElement element) formatPtr curPtr
               if toBool success
                   then do format <- peek formatPtr
                           cur    <- peek curPtr
                           return $ Just (toEnum $ fromIntegral format,
                                          fromIntegral cur)
                   else return Nothing

elementQueryDuration :: ElementClass element
                     => element
                     -> IO (Maybe (Format, Int64))
elementQueryDuration element =
    alloca $ \formatPtr ->
        alloca $ \durationPtr ->
            do success <- {# call element_query_duration #} (toElement element) formatPtr durationPtr
               if toBool success
                   then do format   <- peek formatPtr
                           duration <- peek durationPtr
                           return $ Just (toEnum $ fromIntegral format,
                                          fromIntegral duration)
                   else return Nothing

elementSendEvent :: (ElementClass element, EventClass event)
                 => element
                 -> event
                 -> IO Bool
elementSendEvent element event =
    liftM toBool $
        giveMiniObject (toEvent event) $ {# call element_send_event #} (toElement element)

elementSeekSimple :: ElementClass element
                  => element
                  -> Format
                  -> [SeekFlags]
                  -> Int64
                  -> IO Bool
elementSeekSimple element format seekFlags seekPos =
    liftM toBool $
        {# call element_seek_simple #} (toElement element)
                                       (fromIntegral $ fromEnum format)
                                       (fromIntegral $ fromFlags seekFlags)
                                       (fromIntegral seekPos)

elementSeek :: ElementClass element
            => element
            -> Double
            -> Format
            -> [SeekFlags]
            -> SeekType
            -> Int64
            -> SeekType
            -> Int64
            -> IO Bool
elementSeek element rate format flags curType cur stopType stop =
    liftM toBool $
        {# call element_seek #} (toElement element)
                                (realToFrac rate)
                                (fromIntegral $ fromEnum format)
                                (fromIntegral $ fromFlags flags)
                                (fromIntegral $ fromEnum curType)
                                (fromIntegral cur)
                                (fromIntegral $ fromEnum stopType)
                                (fromIntegral stop)

onElementNoMorePads, afterElementNoMorePads :: (ElementClass element)
                                            => element
                                            -> IO ()
                                            -> IO (ConnectId element)
onElementNoMorePads =
    connect_NONE__NONE "no-more-pads" False
afterElementNoMorePads =
    connect_NONE__NONE "no-more-pads" True

onElementPadAdded, afterElementPadAdded :: (ElementClass element)
                                        => element
                                        -> (Pad -> IO ())
                                        -> IO (ConnectId element)
onElementPadAdded =
    connect_OBJECT__NONE "pad-added" False
afterElementPadAdded =
    connect_OBJECT__NONE "pad-added" True

onElementPadRemoved, afterElementPadRemoved :: (ElementClass element)
                                            => element
                                            -> (Pad -> IO ())
                                            -> IO (ConnectId element)
onElementPadRemoved =
    connect_OBJECT__NONE "pad-removed" False
afterElementPadRemoved =
    connect_OBJECT__NONE "pad-removed" True

-- GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer   -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Version $Revision$ from $Date$
--
--  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.Element (

  Element,
  ElementClass,
  castToElement,
  toElement,
  fromElement,
  ElementFlags(..),
  State(..),
  StateChange(..),
  StateChangeReturn(..),
  elementAddPad,
  elementGetPad,
  elementGetCompatiblePad,
  elementGetCompatiblePadTemplate,
  elementGetRequestPad,
  elementGetStaticPad,
  elementNoMorePads,
  elementReleaseRequestPad,
  elementRemovePad,
  elementIteratePads,
  elementIterateSinkPads,
  elementIterateSrcPads,
  elementLink,
  elementUnlink,
  elementLinkPads,
  elementUnlinkPads,
  elementLinkPadsFiltered,
  elementLinkFiltered,
  elementSetBaseTime,
  elementGetBaseTime,
  elementSetBus,
  elementGetBus,
  elementGetFactory,
  elementSetIndex,
  elementIsIndexable,
  elementRequiresClock,
  elementSetClock,
  elementGetClock,
  elementProvidesClock,
  elementProvideClock,
  elementSetState,
  elementGetState,
  elementSetLockedState,
  elementIsLockedState,
  elementAbortState,
  elementStateGetName,
  elementStateChangeReturnGetName,
  elementSyncStateWithParent,
  elementGetQueryTypes,
  elementQuery,
  elementQueryConvert,
  elementQueryPosition,
  elementQueryDuration,
  elementSendEvent,
  elementSeekSimple,
  elementSeek,
  onElementNoMorePads,
  afterElementNoMorePads,
  onElementPadAdded,
  afterElementPadAdded,
  onElementPadRemoved,
  afterElementPadRemoved

  ) where

import Control.Monad         ( liftM )
import Data.Maybe            ( fromMaybe )
import System.Glib.FFI
import System.Glib.Flags
import System.Glib.UTFString ( withUTFString
                             , peekUTFString )
{#import System.Glib.Signals#}
{#import System.Glib.GObject#}
{#import Media.Streaming.GStreamer.Types#}
{#import Media.Streaming.GStreamer.Signals#}
import GHC.Base              ( unsafeCoerce# )

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

elementAddPad :: (ElementClass elementT, PadClass padT) =>
                 elementT
              -> padT
              -> IO Bool
elementAddPad element pad =
    liftM toBool $ {# call element_add_pad #} (toElement element) (toPad pad)

elementGetPad :: ElementClass elementT =>
                 elementT
              -> String
              -> IO (Maybe Pad)
elementGetPad element name =
    (withUTFString name $ {# call element_get_pad #} (toElement element)) >>=
        maybePeek newPad

elementGetCompatiblePad :: (ElementClass elementT, PadClass padT) =>
                           elementT
                        -> padT
                        -> Caps
                        -> IO (Maybe Pad)
elementGetCompatiblePad element pad caps =
    {# call element_get_compatible_pad #} (toElement element) (toPad pad) caps >>=
        maybePeek newPad

elementGetCompatiblePadTemplate :: (ElementClass elementT, PadTemplateClass padTemplateT) =>
                                   elementT
                                -> padTemplateT
                                -> IO (Maybe PadTemplate)
elementGetCompatiblePadTemplate element padTemplate =
    {# call element_get_compatible_pad_template #} (toElement element) (toPadTemplate padTemplate) >>=
        maybePeek newPadTemplate

elementGetRequestPad :: ElementClass elementT =>
                        elementT
                     -> String
                     -> IO (Maybe Pad)
elementGetRequestPad element name =
    (withUTFString name $ {# call element_get_request_pad #} (toElement element)) >>=
        maybePeek newPad_ -- no finalizer; use elementReleaseRequestPad

elementGetStaticPad :: ElementClass elementT =>
                       elementT
                    -> String
                    -> IO (Maybe Pad)
elementGetStaticPad element name =
    (withUTFString name $ {# call element_get_static_pad #} (toElement element)) >>=
        maybePeek newPad

elementNoMorePads :: ElementClass elementT =>
                     elementT
                  -> IO ()
elementNoMorePads element =
    {# call element_no_more_pads #} (toElement element)

elementReleaseRequestPad :: (ElementClass elementT, PadClass padT) =>
                            elementT
                         -> padT
                         -> IO ()
elementReleaseRequestPad element pad =
    {# call element_release_request_pad #} (toElement element) (toPad pad)

elementRemovePad :: (ElementClass elementT, PadClass padT) =>
                    elementT
                 -> padT
                 -> IO Bool
elementRemovePad element pad =
    liftM toBool $ {# call element_remove_pad #} (toElement element) (toPad pad)

elementIteratePads :: (ElementClass elementT) =>
                      elementT
                   -> IO (Iterator Pad)
elementIteratePads element =
    {# call element_iterate_pads #} (toElement element) >>= newIterator

elementIterateSinkPads :: (ElementClass elementT) =>
                          elementT
                       -> IO (Iterator Pad)
elementIterateSinkPads element =
    {# call element_iterate_sink_pads #} (toElement element) >>= newIterator

elementIterateSrcPads :: (ElementClass elementT) =>
                          elementT
                       -> IO (Iterator Pad)
elementIterateSrcPads element =
    {# call element_iterate_sink_pads #} (toElement element) >>= newIterator

elementLink :: (ElementClass elementT1, ElementClass elementT2) =>
               elementT1
            -> elementT2
            -> IO Bool
elementLink element1 element2 =
    liftM toBool $ {# call element_link #} (toElement element1) (toElement element2)

elementUnlink :: (ElementClass elementT1, ElementClass elementT2) =>
                 elementT1
              -> elementT2
              -> IO ()
elementUnlink element1 element2 =
    {# call element_unlink #} (toElement element1) (toElement element2)

elementLinkPads :: (ElementClass elementT1, ElementClass elementT2) =>
                   elementT1
                -> String
                -> elementT2
                -> String
                -> IO Bool
elementLinkPads src srcPadName dest destPadName =
    withUTFString destPadName $ \cDestPadName ->
        withUTFString srcPadName $ \cSrcPadName ->
            liftM toBool $ {# call element_link_pads #} (toElement src) cSrcPadName (toElement dest) cDestPadName

elementUnlinkPads :: (ElementClass elementT1, ElementClass elementT2) =>
                     elementT1
                  -> String
                  -> elementT2
                  -> String
                  -> IO ()
elementUnlinkPads src srcPadName dest destPadName =
    withUTFString destPadName $ \cDestPadName ->
        withUTFString srcPadName $ \cSrcPadName ->
            {# call element_unlink_pads #} (toElement src) cSrcPadName (toElement dest) cDestPadName

elementLinkPadsFiltered :: (ElementClass elementT1, ElementClass elementT2) =>
                           elementT1
                        -> String
                        -> elementT2
                        -> String
                        -> Caps
                        -> IO Bool
elementLinkPadsFiltered src srcPadName dest destPadName filter =
    withUTFString destPadName $ \cDestPadName ->
        withUTFString srcPadName $ \cSrcPadName ->
            liftM toBool $ {# call element_link_pads_filtered #} (toElement src) cSrcPadName (toElement dest) cDestPadName filter

elementLinkFiltered :: (ElementClass elementT1, ElementClass elementT2) =>
                       elementT1
                    -> elementT2
                    -> Maybe Caps
                    -> IO Bool
elementLinkFiltered element1 element2 filter =
    liftM toBool $
        {# call element_link_filtered #} (toElement element1) (toElement element2) $
            fromMaybe (Caps nullForeignPtr) filter

elementSetBaseTime :: ElementClass elementT =>
                      elementT
                   -> ClockTimeDiff
                   -> IO ()
elementSetBaseTime element time =
    {# call element_set_base_time #} (toElement element) $ fromIntegral time

elementGetBaseTime :: ElementClass elementT =>
                      elementT
                   -> IO ClockTimeDiff
elementGetBaseTime element =
    liftM fromIntegral $ {# call element_get_base_time #} (toElement element)

elementSetBus :: (ElementClass elementT, BusClass busT) =>
                 elementT
              -> busT
              -> IO ()
elementSetBus element bus =
    {# call element_set_bus #} (toElement element) (toBus bus)

elementGetBus :: ElementClass elementT =>
                 elementT
              -> IO Bus
elementGetBus element =
    {# call element_get_bus #} (toElement element) >>= newBus

elementGetFactory :: ElementClass elementT =>
                     elementT
                  -> IO ElementFactory
elementGetFactory element =
    {# call element_get_factory #} (toElement element) >>= newElementFactory_

elementSetIndex :: (ElementClass elementT, IndexClass indexT) =>
                   elementT
                -> indexT
                -> IO ()
elementSetIndex element index =
    {# call element_set_index #} (toElement element) (toIndex index)

elementGetIndex :: ElementClass elementT =>
                   elementT
                -> IO (Maybe Index)
elementGetIndex element =
    {# call element_get_index #} (toElement element) >>= maybePeek newIndex

elementIsIndexable :: ElementClass elementT =>
                      elementT
                   -> IO Bool
elementIsIndexable element =
    liftM toBool $ {# call element_is_indexable #} (toElement element)

elementRequiresClock :: ElementClass elementT =>
                        elementT
                     -> IO Bool
elementRequiresClock element =
    liftM toBool $ {# call element_requires_clock #} (toElement element)

elementSetClock :: (ElementClass elementT, ClockClass clockT) =>
                   elementT
                -> clockT
                -> IO Bool
elementSetClock element clock =
    liftM toBool $ {# call element_set_clock #} (toElement element) (toClock clock)

elementGetClock :: ElementClass elementT =>
                   elementT
                -> IO (Maybe Clock)
elementGetClock element =
    {# call element_get_clock #} (toElement element) >>= maybePeek newClock

elementProvidesClock :: ElementClass elementT =>
                        elementT
                     -> IO Bool
elementProvidesClock element =
    liftM toBool $ {# call element_provides_clock #} $ toElement element

elementProvideClock :: ElementClass elementT =>
                       elementT
                    -> IO (Maybe Clock)
elementProvideClock element =
    {# call element_provide_clock #} (toElement element) >>= maybePeek newClock

elementSetState :: ElementClass elementT =>
                   elementT
                -> State
                -> IO StateChangeReturn
elementSetState element state =
    liftM (toEnum . fromIntegral) $ {# call element_set_state #} (toElement element) $
        fromIntegral $ fromEnum state

elementGetState :: ElementClass elementT =>
                   elementT
                -> ClockTime
                -> IO (StateChangeReturn, State, State)
elementGetState element timeout =
    alloca $ \statePtr ->
        alloca $ \pendingPtr ->
            do result <- {# call element_get_state #} (toElement element) statePtr pendingPtr $ fromIntegral timeout
               state <- peek statePtr
               pending <- peek pendingPtr
               return (toEnum (fromIntegral result),
                       toEnum (fromIntegral state),
                       toEnum (fromIntegral pending))

elementSetLockedState :: ElementClass elementT =>
                         elementT
                      -> Bool
                      -> IO Bool
elementSetLockedState element lockedState =
    liftM toBool $ {# call element_set_locked_state #} (toElement element) $ fromBool lockedState

elementIsLockedState :: ElementClass elementT =>
                        elementT
                     -> IO Bool
elementIsLockedState element =
    liftM toBool $ {# call element_is_locked_state #} $ toElement element

elementAbortState :: ElementClass elementT =>
                     elementT
                  -> IO ()
elementAbortState element =
    {# call element_abort_state #} $ toElement element

elementStateGetName :: State
                    -> String
elementStateGetName state =
    unsafePerformIO $ ({# call element_state_get_name #} $ fromIntegral $ fromEnum state) >>= peekUTFString

elementStateChangeReturnGetName :: StateChangeReturn
                                -> String
elementStateChangeReturnGetName stateRet =
    unsafePerformIO $ ({# call element_state_change_return_get_name #} $ fromIntegral $ fromEnum stateRet) >>= peekUTFString

elementSyncStateWithParent :: ElementClass elementT =>
                              elementT
                           -> IO Bool
elementSyncStateWithParent element =
    liftM toBool $ {# call element_sync_state_with_parent #} $ toElement element

elementGetQueryTypes :: ElementClass element
                     => element
                     -> IO [QueryType]
elementGetQueryTypes element =
    liftM (map (toEnum . fromIntegral)) $
        {# call element_get_query_types #} (toElement element) >>=
            peekArray0 0

elementQuery :: (ElementClass element, QueryClass query)
             => element
             -> query
             -> IO (Maybe query)
elementQuery element query =
    do query' <- {# call mini_object_copy #} (toMiniObject query) >>=
                    newForeignPtr_ . castPtr
       success <- {# call element_query #} (toElement element) $ Query query'
       if toBool success
           then liftM (Just . unsafeCoerce#) $ withForeignPtr query' $ newQuery . castPtr
           else return Nothing

elementQueryConvert :: ElementClass element
                    => element
                    -> Format
                    -> Int64
                    -> IO (Maybe (Format, Int64))
elementQueryConvert element srcFormat srcVal =
    alloca $ \destFormatPtr ->
        alloca $ \destValPtr ->
            do success <- {# call element_query_convert #} (toElement element)
                                                       (fromIntegral $ fromEnum srcFormat)
                                                       (fromIntegral srcVal)
                                                       destFormatPtr
                                                       destValPtr
               if toBool success
                   then do destFormat <- peek destFormatPtr
                           destVal    <- peek destValPtr
                           return $ Just (toEnum $ fromIntegral destFormat,
                                          fromIntegral destVal)
                   else return Nothing

elementQueryPosition :: ElementClass element
                     => element
                     -> IO (Maybe (Format, Int64))
elementQueryPosition element =
    alloca $ \formatPtr ->
        alloca $ \curPtr ->
            do success <- {# call element_query_position #} (toElement element) formatPtr curPtr
               if toBool success
                   then do format <- peek formatPtr
                           cur    <- peek curPtr
                           return $ Just (toEnum $ fromIntegral format,
                                          fromIntegral cur)
                   else return Nothing

elementQueryDuration :: ElementClass element
                     => element
                     -> IO (Maybe (Format, Int64))
elementQueryDuration element =
    alloca $ \formatPtr ->
        alloca $ \durationPtr ->
            do success <- {# call element_query_duration #} (toElement element) formatPtr durationPtr
               if toBool success
                   then do format   <- peek formatPtr
                           duration <- peek durationPtr
                           return $ Just (toEnum $ fromIntegral format,
                                          fromIntegral duration)
                   else return Nothing

elementSendEvent :: (ElementClass element, EventClass event)
                 => element
                 -> event
                 -> IO Bool
elementSendEvent element event =
    liftM toBool $
        giveMiniObject (toEvent event) $ {# call element_send_event #} (toElement element)

elementSeekSimple :: ElementClass element
                  => element
                  -> Format
                  -> [SeekFlags]
                  -> Int64
                  -> IO Bool
elementSeekSimple element format seekFlags seekPos =
    liftM toBool $
        {# call element_seek_simple #} (toElement element)
                                       (fromIntegral $ fromEnum format)
                                       (fromIntegral $ fromFlags seekFlags)
                                       (fromIntegral seekPos)

elementSeek :: ElementClass element
            => element
            -> Double
            -> Format
            -> [SeekFlags]
            -> SeekType
            -> Int64
            -> SeekType
            -> Int64
            -> IO Bool
elementSeek element rate format flags curType cur stopType stop =
    liftM toBool $
        {# call element_seek #} (toElement element)
                                (realToFrac rate)
                                (fromIntegral $ fromEnum format)
                                (fromIntegral $ fromFlags flags)
                                (fromIntegral $ fromEnum curType)
                                (fromIntegral cur)
                                (fromIntegral $ fromEnum stopType)
                                (fromIntegral stop)

onElementNoMorePads, afterElementNoMorePads :: (ElementClass element)
                                            => element
                                            -> IO ()
                                            -> IO (ConnectId element)
onElementNoMorePads =
    connect_NONE__NONE "no-more-pads" False
afterElementNoMorePads =
    connect_NONE__NONE "no-more-pads" True

onElementPadAdded, afterElementPadAdded :: (ElementClass element)
                                        => element
                                        -> (GObject -> IO ())
                                        -> IO (ConnectId element)
onElementPadAdded =
    connect_OBJECT__NONE "pad-added" False
afterElementPadAdded =
    connect_OBJECT__NONE "pad-added" True

onElementPadRemoved, afterElementPadRemoved :: (ElementClass element)
                                            => element
                                            -> (GObject -> IO ())
                                            -> IO (ConnectId element)
onElementPadRemoved =
    connect_OBJECT__NONE "pad-removed" False
afterElementPadRemoved =
    connect_OBJECT__NONE "pad-removed" True


Initial stubs for blob

Initial stubs for blob

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}

#include "git2.h"

module Git2 where

import Foreign
import Foreign.C.String
import Foreign.C.Types

type OffT    = {#type git_off_t#}
type TimeT   = {#type git_time_t#}
type CPtr    = Ptr ()
type Ptr2Int = CPtr -> IO CInt

newtype ObjDB      = ObjDB CPtr
newtype Repository = Repository CPtr
newtype Index      = Index CPtr

defaultPort :: String
defaultPort = "9418" -- TODO: Import from net.h?

{#enum define Direction { GIT_DIR_FETCH as Fetch
                        , GIT_DIR_PUSH as Push}#}

{-
#define GIT_STATUS_CURRENT        0
/** Flags for index status */
#define GIT_STATUS_INDEX_NEW      (1 << 0)
#define GIT_STATUS_INDEX_MODIFIED (1 << 1)
#define GIT_STATUS_INDEX_DELETED  (1 << 2)

/** Flags for worktree status */
#define GIT_STATUS_WT_NEW         (1 << 3)
#define GIT_STATUS_WT_MODIFIED    (1 << 4)
#define GIT_STATUS_WT_DELETED     (1 << 5)

// TODO Ignored files not handled yet
#define GIT_STATUS_IGNORED        (1 << 6)
-}

{-
{#enum define Status { GIT_STATUS_CURRENT as Current
                     , GIT_STATUS_INDEX_NEW as NewIndex
                     , GIT_STATUS_INDEX_MODIFIED as ModifiedIndex
                     , GIT_STATUS_INDEX_DELETED as DeletedIndex
                     , GIT_STATUS_WT_NEW as NewWorkTree
                     , GIT_STATUS_WT_MODIFIED as ModifiedWorkTree
                     , GIT_STATUS_WT_DELETED as DeletedWorkTree
                     , GIT_STATUS_IGNORED as Ignored}#}
-}

{#enum git_otype as OType {underscoreToCase}#}
{#enum git_rtype as RType {underscoreToCase}#}
{#enum git_oid as OID {underscoreToCase}#}
{#enum git_blob as Blob {underscoreToCase}#}
{#enum git_repository_pathid as RepositoryPathID {underscoreToCase}#}
{#enum git_error as GitError {underscoreToCase}#}
{#enum git_odb_streammode as ODBStreamMode {underscoreToCase}#}

deriving instance Show GitError

-------------------------------------------------------------------------------
-- BEGIN: blob.h
-------------------------------------------------------------------------------

{-
/**
 * Lookup a blob object from a repository.
 *
 * @param blob pointer to the looked up blob
 * @param repo the repo to use when locating the blob.
 * @param id identity of the blob to locate.
 * @return 0 on success; error code otherwise
 */
GIT_INLINE(int) git_blob_lookup(git_blob **blob, git_repository *repo, const git_oid *id)
-}
blobLookup :: Repository -> OID -> IO (Either GitError Blob)
blobLookup = undefined

{-

/**
 * Lookup a blob object from a repository,
 * given a prefix of its identifier (short id).
 *
 * @see git_object_lookup_prefix
 *
 * @param blob pointer to the looked up blob
 * @param repo the repo to use when locating the blob.
 * @param id identity of the blob to locate.
 * @param len the length of the short identifier
 * @return 0 on success; error code otherwise
 */
GIT_INLINE(int) git_blob_lookup_prefix(git_blob **blob, git_repository *repo, const git_oid *id, unsigned int len)
{
	return git_object_lookup_prefix((git_object **)blob, repo, id, len, GIT_OBJ_BLOB);
}
-}
blobLookupPrefix :: Repository -> OID -> Int -> IO (Either GitError Blob)
blobLookupPrefix = undefined

{-
/**
 * Close an open blob
 *
 * This is a wrapper around git_object_close()
 *
 * IMPORTANT:
 * It *is* necessary to call this method when you stop
 * using a blob. Failure to do so will cause a memory leak.
 *
 * @param blob the blob to close
 */

GIT_INLINE(void) git_blob_close(git_blob *blob)
{
	git_object_close((git_object *) blob);
}
-}
closeBlob :: Blob -> IO ()
closeBlob = undefined

{-
/**
 * Get a read-only buffer with the raw content of a blob.
 *
 * A pointer to the raw content of a blob is returned;
 * this pointer is owned internally by the object and shall
 * not be free'd. The pointer may be invalidated at a later
 * time.
 *
 * @param blob pointer to the blob
 * @return the pointer; NULL if the blob has no contents
 */
GIT_EXTERN(const void *) git_blob_rawcontent(git_blob *blob);
-}
-- Return raw bytestring ? :x
rawBlobContent = undefined

{-
/**
 * Get the size in bytes of the contents of a blob
 *
 * @param blob pointer to the blob
 * @return size on bytes
 */
GIT_EXTERN(int) git_blob_rawsize(git_blob *blob);
-}
rawBlobSize :: Blob -> Int
rawBlobSize = undefined

{-
/**
 * Read a file from the working folder of a repository
 * and write it to the Object Database as a loose blob
 *
 * @param oid return the id of the written blob
 * @param repo repository where the blob will be written.
 *	this repository cannot be bare
 * @param path file from which the blob will be created,
 *	relative to the repository's working dir
 * @return 0 on success; error code otherwise
 */
GIT_EXTERN(int) git_blob_create_fromfile(git_oid *oid, git_repository *repo, const char *path);
-}
createBlobFromFile :: OID -> Repository -> String -> IO (Maybe GitError)
createBlobFromFile (OID o) (Repository r) path = do
  pathStr  <- newCString path
  res      <- {#call git_blob_create_fromfile #} o r pathStr
  if res == 0
    then return Nothing
    else return $ Just . toEnum . fromIntegral $ res

{-
/**
 * Write an in-memory buffer to the ODB as a blob
 *
 * @param oid return the oid of the written blob
 * @param repo repository where to blob will be written
 * @param buffer data to be written into the blob
 * @param len length of the data
 * @return 0 on success; error code otherwise
 */
GIT_EXTERN(int) git_blob_create_frombuffer(git_oid *oid, git_repository *repo, const void *buffer, size_t len);
-}
-- createBlobFromBuffer :: OID -> Repository -> ... -> Int -> IO (Maybe GitError)
createBlobFromBuffer = undefined

-------------------------------------------------------------------------------
-- END: blob.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: repositoy.h
-------------------------------------------------------------------------------

repoIs :: Ptr2Int -> Repository -> IO Bool
repoIs ffi (Repository ptr) = return . toBool =<< ffi ptr

openRepo :: String -> IO (Either GitError Repository)
openRepo path = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_open#} pprepo pstr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDir :: String -> String -> String -> String -> IO (Either GitError Repository)
openRepoObjDir dir objDir idxFile workTree = alloca $ \pprepo -> do
  dirStr     <- newCString dir
  objDirStr  <- newCString objDir
  idxFileStr <- newCString idxFile
  wtreeStr   <- newCString workTree
  res        <- {#call git_repository_open2#} pprepo dirStr objDirStr idxFileStr wtreeStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDb :: String -> ObjDB -> String -> String -> IO (Either GitError Repository)
openRepoObjDb dir (ObjDB db) idxFile workTree = alloca $ \pprepo -> do
  dirStr     <- newCString dir
  idxFileStr <- newCString idxFile
  wtreeStr   <- newCString workTree
  res        <- {#call git_repository_open3#} pprepo dirStr db idxFileStr wtreeStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

discover :: String -> Bool -> String -> IO (Either GitError String)
discover startPath acrossFs ceilingDirs = alloca $ \path -> do
  spStr  <- newCString startPath
  cdsStr <- newCString ceilingDirs
  res    <- {#call git_repository_discover#} path (fromIntegral $ sizeOf path) spStr (fromBool acrossFs) cdsStr
  retEither res $ fmap Right $ peekCString path

database :: Repository -> IO ObjDB
database (Repository r) = return . ObjDB =<< {#call git_repository_database#} r

index :: Repository -> IO (Either GitError Index)
index (Repository r) = alloca $ \idx -> do
  res  <- {#call git_repository_index#} idx r
  retEither res $ fmap (Right . Index) $ peek idx

free :: Repository -> IO ()
free (Repository r) = {#call git_repository_free#} r

init :: String -> Bool -> IO (Either GitError Repository)
init path isBare = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_init#} pprepo pstr (fromBool isBare)
  retEither res $ fmap (Right . Repository) $ peek pprepo

retEither :: CInt -> IO (Either GitError a) -> IO (Either GitError a)
retEither res f | res == 0  = f
                | otherwise = return . Left . toEnum . fromIntegral $ res

isHeadDetached :: Repository -> IO Bool
isHeadDetached = repoIs {#call git_repository_head_detached#}

isHeadOrphan :: Repository -> IO Bool
isHeadOrphan = repoIs {#call git_repository_head_orphan#}

isEmpty :: Repository -> IO Bool
isEmpty = repoIs {#call git_repository_is_empty#}

path :: Repository -> RepositoryPathID -> IO String
path (Repository r) pathID = peekCString =<< {#call git_repository_path#} r p
  where p = fromIntegral $ fromEnum pathID

isBare :: Repository -> IO Bool
isBare = repoIs {#call git_repository_is_bare#}

-------------------------------------------------------------------------------
-- END: repository.h
-------------------------------------------------------------------------------

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}

#include "git2.h"

module Git2 where

import Foreign
import Foreign.C.String
import Foreign.C.Types

type OffT    = {#type git_off_t#}
type TimeT   = {#type git_time_t#}
type CPtr    = Ptr ()
type Ptr2Int = CPtr -> IO CInt

newtype ObjDB      = ObjDB CPtr
newtype Repository = Repository CPtr
newtype Index      = Index CPtr

{#enum git_otype as OType {underscoreToCase}#}
{#enum git_rtype as RType {underscoreToCase}#}
{#enum git_repository_pathid as RepositoryPathID {underscoreToCase}#}
{#enum git_error as GitError {underscoreToCase}#}
{#enum git_odb_streammode as ODBStreamMode {underscoreToCase}#}

deriving instance Show GitError

repoIs :: Ptr2Int -> Repository -> IO Bool
repoIs ffi (Repository ptr) = return . toBool =<< ffi ptr

openRepo :: String -> IO (Either GitError Repository)
openRepo path = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_open#} pprepo pstr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDir :: String -> String -> String -> String -> IO (Either GitError Repository)
openRepoObjDir dir objDir idxFile workTree = alloca $ \pprepo -> do
  dirStr     <- newCString dir
  objDirStr  <- newCString objDir
  idxFileStr <- newCString idxFile
  wtreeStr   <- newCString workTree
  res        <- {#call git_repository_open2#} pprepo dirStr objDirStr idxFileStr wtreeStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDb :: String -> ObjDB -> String -> String -> IO (Either GitError Repository)
openRepoObjDb dir (ObjDB db) idxFile workTree = alloca $ \pprepo -> do
  dirStr     <- newCString dir
  idxFileStr <- newCString idxFile
  wtreeStr   <- newCString workTree
  res        <- {#call git_repository_open3#} pprepo dirStr db idxFileStr wtreeStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

discover :: String -> Bool -> String -> IO (Either GitError String)
discover startPath acrossFs ceilingDirs = alloca $ \path -> do
  spStr  <- newCString startPath
  cdsStr <- newCString ceilingDirs
  res    <- {#call git_repository_discover#} path (fromIntegral $ sizeOf path) spStr (fromBool acrossFs) cdsStr
  retEither res $ fmap Right $ peekCString path

database :: Repository -> IO ObjDB
database (Repository r) = return . ObjDB =<< {#call git_repository_database#} r

index :: Repository -> IO (Either GitError Index)
index (Repository r) = alloca $ \idx -> do
  res  <- {#call git_repository_index#} idx r
  retEither res $ fmap (Right . Index) $ peek idx

free :: Repository -> IO ()
free (Repository r) = {#call git_repository_free#} r

init :: String -> Bool -> IO (Either GitError Repository)
init path isBare = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_init#} pprepo pstr (fromBool isBare)
  retEither res $ fmap (Right . Repository) $ peek pprepo

retEither :: CInt -> IO (Either GitError a) -> IO (Either GitError a)
retEither res f | res == 0  = f
                | otherwise = return . Left . toEnum . fromIntegral $ res

isHeadDetached :: Repository -> IO Bool
isHeadDetached = repoIs {#call git_repository_head_detached#}

isHeadOrphan :: Repository -> IO Bool
isHeadOrphan = repoIs {#call git_repository_head_orphan#}

isEmpty :: Repository -> IO Bool
isEmpty = repoIs {#call git_repository_is_empty#}

path :: Repository -> RepositoryPathID -> IO String
path (Repository r) pathID = peekCString =<< {#call git_repository_path#} r p
  where p = fromIntegral $ fromEnum pathID

isBare :: Repository -> IO Bool
isBare = repoIs {#call git_repository_is_bare#}


gstreamer: M.S.G.Core.Caps: document everything; code cleanups, remove capsMerge and capsAppend; add capsCopyNth

darcs-hash:20080116040349-21862-98636cf9213c7319fc94891691cbbad7424f2bed.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 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/>.
--
--  GStreamer, 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 GStreamer documentation.
--
--  |
--  Maintainer  : gtk2hs-devel@lists.sourceforge.net
--  Stability   : alpha
--  Portability : portable (depends on GHC)
--
--  A structure describing sets of media formats.
module Media.Streaming.GStreamer.Core.Caps (

-- * Detail
  -- | 'Caps' (short for /capabilities/) are lightweight objects
  --   describing media types. They are composed of arrays of
  --   'Structure's.
  --
  --   'Caps' are exposed on 'PadTemplate's to describe all the
  --   possible types a given 'Pad' can handle. They are also stored
  --   in the 'Registry' along with the description of an 'Element'.
  --
  --   'Caps' can be retrieved from an 'Element'\'s 'Pad's using the
  --   'padGetCaps' function. The returned 'Caps' describes the possible
  --   types that the pad can handle or produce at runtime.
  --
  --   'Caps' are also attached to 'Buffers' to describe the type of
  --   the contained data using the function 'bufferSetCaps'. 'Caps'
  --   attached to a buffer allow for format negotiation upstream and
  --   downstream.
  --
  --   'Caps' are /fixed/ when they have no properties with ranges or
  --   lists. Use 'capsIsFixed' to test for fixed caps. Only fixed
  --   caps may be set on a 'Pad' or 'Buffer'.

-- * Types
  Caps,
  capsNone,
  capsAny,

-- * Caps Operations
  capsSize,
  capsGetStructure,
  capsIsEmpty,
  capsIsFixed,
  capsIsEqual,
  capsIsEqualFixed,
  capsIsAlwaysCompatible,
  capsIsSubset,
  capsIntersect,
  capsUnion,
  capsSubtract,
  capsNormalize,
  capsFromString,
  capsToString,

-- * Caps Mutation
  CapsM,
  capsCreate,
  capsModify,
  capsAppendStructure,
  capsMergeStructure,
  capsRemoveStructure,
  capsTruncate

  ) where

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

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

-- | A 'Caps' that represents an undefined media type.
capsNone :: Caps
capsNone =
    unsafePerformIO $ {# call caps_new_empty #} >>= takeCaps

-- | A 'Caps' that represents all possible media types.
capsAny :: Caps
capsAny =
    unsafePerformIO $ {# call caps_new_any #} >>= takeCaps

-- | Returns the number of structures contained in the 'Caps'.
capsSize :: Caps
         -> Word
capsSize caps =
    fromIntegral $ unsafePerformIO $ {# call caps_get_size #} caps

-- | Returns the 'Structure' at the given index.
capsGetStructure :: Caps
                 -> Word
                 -> Maybe Structure
capsGetStructure caps index =
    unsafePerformIO $
        {# call caps_get_structure #} caps (fromIntegral index) >>=
            maybePeek peekStructure

-- | Returns a new 'Caps' containing only the 'Structure' at the given
--   index of the caps.
capsCopyNth :: Caps
            -> Word
            -> Maybe Caps
capsCopyNth caps index =
    unsafePerformIO $
        {# call caps_copy_nth #} caps (fromIntegral index) >>=
            maybePeek takeCaps

-- | Returns 'True' if the caps represents no media formats.
capsIsEmpty :: Caps
            -> Bool
capsIsEmpty caps =
    toBool $ unsafePerformIO $
        {# call caps_is_empty #} caps

-- | Returns 'True' if the caps is fixed.
capsIsFixed :: Caps
            -> Bool
capsIsFixed caps =
    toBool $ unsafePerformIO $
        {# call caps_is_fixed #} caps

-- | Returns 'True' if the caps represent the same set of capabilities.
capsIsEqual :: Caps
            -> Caps
            -> Bool
capsIsEqual caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_equal #} caps1 caps2

instance Eq Caps where
    (==) = capsIsEqual

-- | Returns 'True' if the caps are equal.  The caps must both be
--   fixed.
capsIsEqualFixed :: Caps
                 -> Caps
                 -> Bool
capsIsEqualFixed caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_equal_fixed #} caps1 caps2

-- | Returns 'True' if every media format in the first caps is also
--   contained by the second. That is, the first is a subset of the
--   second.
capsIsAlwaysCompatible :: Caps
                       -> Caps
                       -> Bool
capsIsAlwaysCompatible caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_always_compatible #} caps1 caps2

-- | Returns 'True' if all caps represented by the first argument are
--   also represented by the second.
--
--   This function does not work reliably if optional properties for
--   caps are included on one caps and omitted on the other.
capsIsSubset :: Caps
             -> Caps
             -> Bool
capsIsSubset caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_subset #} caps1 caps2

-- | Creates a new caps containing all the formats that are common to
--   both of the caps.
capsIntersect :: Caps
              -> Caps
              -> Caps
capsIntersect caps1 caps2 =
    unsafePerformIO $
        {# call caps_intersect #} caps1 caps2 >>=
            takeCaps

-- | Creates a new caps containing all the formats that are common to
--   either of the caps. If either of the structures are equivalient
--   to 'capsAny', the result will be 'capsAny'.
capsUnion :: Caps
          -> Caps
          -> Caps
capsUnion caps1 caps2 =
    unsafePerformIO $
        {# call caps_union #} caps1 caps2 >>=
            takeCaps

-- | Creates a new caps containing all the formats that are in the
--   first but not the second.
capsSubtract :: Caps
             -> Caps
             -> Caps
capsSubtract caps1 caps2 =
    unsafePerformIO $
        {# call caps_subtract #} caps1 caps2 >>=
            takeCaps

-- | Creates a new caps that represents the same set of formats as the
--   argument, but that contains no lists.
capsNormalize :: Caps
              -> Caps
capsNormalize caps =
    unsafePerformIO $
        {# call caps_normalize #} caps >>= takeCaps

-- | Converts the argument to a string representation. The string can
--   be converted back to a caps using 'capsFromString'.
capsToString :: Caps
             -> String
capsToString caps =
    unsafePerformIO $
        {# call caps_to_string #} caps >>= readUTFString

-- | Read a caps from a string.
capsFromString :: String
               -> Maybe Caps
capsFromString string =
    unsafePerformIO $
        withUTFString string {# call caps_from_string #} >>=
            maybePeek takeCaps

-- | A 'Monad' for sequencing modifications to a 'Caps'.
newtype CapsM a =
    CapsM (ReaderT (Ptr Caps) IO a)
    deriving (Functor, Monad)

askCapsPtr :: CapsM (Ptr Caps)
askCapsPtr = CapsM $ ask

marshalCapsModify :: IO (Ptr Caps)
                  -> CapsM a
                  -> (Caps, a)
marshalCapsModify mkCaps (CapsM action) =
    unsafePerformIO $
        do ptr <- mkCaps
           result <- runReaderT action ptr
           caps <- takeCaps ptr
           return (caps, result)

-- | Create a caps and mutate it according to the given action.
capsCreate :: CapsM a
           -> (Caps, a)
capsCreate action =
    marshalCapsModify
        {# call caps_new_empty #}
        action

-- | Copy a caps and mutate it according to the given action.
capsModify :: Caps
           -> CapsM a
           -> (Caps, a)
capsModify caps action =
    marshalCapsModify ({# call caps_copy #} caps) action

-- | Append the given structure to the current caps.
capsAppendStructure :: Structure
                    -> CapsM ()
capsAppendStructure structure = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ withStructure structure $ \structurePtr ->
      do structurePtr' <- gst_structure_copy structurePtr
         gst_caps_append_structure capsPtr structurePtr
  where _ = {# call caps_append_structure #}
        _ = {# call structure_copy #}

-- | Append the structure to the current caps, if it is not already
--   expressed by the caps.
capsMergeStructure :: Structure
                   -> CapsM ()
capsMergeStructure structure = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ withStructure structure $ \structurePtr ->
      do structurePtr' <- gst_structure_copy structurePtr
         gst_caps_merge_structure capsPtr structurePtr
  where _ = {# call caps_merge_structure #}
        _ = {# call structure_copy #}

-- | Removes the structure at the given index from the current caps.
capsRemoveStructure :: Word
                    -> CapsM ()
capsRemoveStructure idx = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ gst_caps_remove_structure capsPtr $ fromIntegral idx
  where _ = {# call caps_remove_structure #}

-- | Discard all but the first structure from the current caps.
capsTruncate :: CapsM ()
capsTruncate = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ gst_caps_truncate capsPtr
  where _ = {# call caps_truncate #}

--  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 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/>.
--
--  GStreamer, 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 GStreamer documentation.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module Media.Streaming.GStreamer.Core.Caps (

  Caps,
  capsNone,
  capsAny,
  capsSize,
  capsGetStructure,
  capsIsEmpty,
  capsIsFixed,
  capsIsEqual,
  capsIsEqualFixed,
  capsIsAlwaysCompatible,
  capsIsSubset,
  capsIntersect,
  capsUnion,
  capsSubtract,
  capsNormalize,
  capsFromString,
  capsToString,

  CapsM,
  capsCreate,
  capsModify,
  capsAppend,
  capsMerge,
  capsAppendStructure,
  capsMergeStructure,
  capsRemoveStructure,
  capsTruncate

  ) where

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

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

capsNone :: Caps
capsNone =
    unsafePerformIO $ {# call caps_new_empty #} >>= takeCaps

capsAny :: Caps
capsAny =
    unsafePerformIO $ {# call caps_new_any #} >>= takeCaps

capsSize :: Caps
         -> Word
capsSize caps =
    fromIntegral $ unsafePerformIO $ {# call caps_get_size #} caps

capsGetStructure :: Caps
                 -> Word
                 -> Maybe Structure
capsGetStructure caps index =
    unsafePerformIO $
        {# call caps_get_structure #} caps (fromIntegral index) >>=
            maybePeek peekStructure

capsIsEmpty :: Caps
            -> Bool
capsIsEmpty caps =
    toBool $ unsafePerformIO $
        {# call caps_is_empty #} caps

capsIsFixed :: Caps
            -> Bool
capsIsFixed caps =
    toBool $ unsafePerformIO $
        {# call caps_is_fixed #} caps

capsIsEqual :: Caps
            -> Caps
            -> Bool
capsIsEqual caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_equal #} caps1 caps2

instance Eq Caps where
    (==) = capsIsEqual

capsIsEqualFixed :: Caps
                 -> Caps
                 -> Bool
capsIsEqualFixed caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_equal_fixed #} caps1 caps2

capsIsAlwaysCompatible :: Caps
                       -> Caps
                       -> Bool
capsIsAlwaysCompatible caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_always_compatible #} caps1 caps2

capsIsSubset :: Caps
             -> Caps
             -> Bool
capsIsSubset caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_subset #} caps1 caps2

capsIntersect :: Caps
             -> Caps
             -> Caps
capsIntersect caps1 caps2 =
    unsafePerformIO $
        {# call caps_intersect #} caps1 caps2 >>=
            takeCaps

capsUnion :: Caps
          -> Caps
          -> Caps
capsUnion caps1 caps2 =
    unsafePerformIO $
        {# call caps_union #} caps1 caps2 >>=
            takeCaps

capsSubtract :: Caps
             -> Caps
             -> Caps
capsSubtract caps1 caps2 =
    unsafePerformIO $
        {# call caps_subtract #} caps1 caps2 >>=
            takeCaps

capsNormalize :: Caps
              -> Caps
capsNormalize caps =
    unsafePerformIO $
        {# call caps_normalize #} caps >>= takeCaps

capsToString :: Caps
             -> String
capsToString caps =
    unsafePerformIO $
        {# call caps_to_string #} caps >>= readUTFString

capsFromString :: String
               -> Caps
capsFromString string =
    unsafePerformIO $
        withUTFString string {# call caps_from_string #} >>=
            takeCaps

newtype CapsM a = CapsM (CapsMRep a)
type CapsMRep a = (Caps -> IO a)

instance Monad CapsM where
    (CapsM aM) >>= fbM =
        CapsM $ \caps ->
            do a <- aM caps
               let CapsM bM = fbM a
               bM caps
    return a = CapsM $ const $ return a

marshalCapsModify :: IO (Ptr Caps)
                  -> CapsM a
                  -> (Caps, a)
marshalCapsModify mkCaps (CapsM action) =
    unsafePerformIO $
        do ptr <- mkCaps
           caps <- liftM Caps $ newForeignPtr_ ptr
           result <- action caps
           caps' <- takeCaps ptr
           return (caps', result)

capsCreate :: CapsM a
           -> (Caps, a)
capsCreate action =
    marshalCapsModify
        {# call caps_new_empty #}
        action

capsModify :: Caps
           -> CapsM a
           -> (Caps, a)
capsModify caps action =
    marshalCapsModify
        ({# call caps_copy #} caps)
        action

capsAppend :: Caps
           -> CapsM ()
capsAppend caps2 =
    CapsM $ \caps1 ->
        {# call caps_copy #} caps2 >>= takeCaps >>=
            {# call caps_append #} caps1

capsMerge :: Caps
          -> CapsM ()
capsMerge caps2 =
    CapsM $ \caps1 ->
        {# call caps_copy #} caps2 >>= takeCaps >>=
            {# call caps_merge #} caps1

capsAppendStructure :: Structure
                    -> CapsM ()
capsAppendStructure structure =
    CapsM $ \caps ->
        giveStructure structure $
            {# call caps_append_structure #} caps

capsMergeStructure :: Structure
                   -> CapsM ()
capsMergeStructure structure =
    CapsM $ \caps ->
        giveStructure structure $
            {# call caps_merge_structure #} caps

capsRemoveStructure :: Word
                    -> CapsM ()
capsRemoveStructure idx =
    CapsM $ \caps ->
        {# call caps_remove_structure #} caps $ fromIntegral idx

capsTruncate :: CapsM ()
capsTruncate =
    CapsM {# call caps_truncate #}