that shouldn't have been commited

that shouldn't have been commited

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GADTs #-}

module Bindings.GDAL.Internal (
    Datatype (..)
  , Access (..)
  , ColorInterpretation (..)
  , PaletteInterpretation (..)
  , GDALException
  , isGDALException
  , Geotransform (..)
  , MaybeIOVector
  , DriverOptions
  , MajorObject
  , Dataset
  , Band
  , Driver
  , ColorTable
  , RasterAttributeTable

  , setQuietErrorHandler

  , registerAllDrivers
  , driverByName
  , create
  , create'
  , createMem
  , flushCache
  , open
  , openShared
  , createCopy

  , datatypeSize
  , datatypeByName
  , datatypeUnion
  , datatypeIsComplex

  , datasetProjection
  , setDatasetProjection
  , datasetGeotransform
  , setDatasetGeotransform

  , withBand
  , bandDatatype
  , bandBlockSize
  , bandBlockLen
  , bandSize
  , bandNodataValue
  , setBandNodataValue
  , readBand
  , readBandBlock
  , writeBand
  , writeBandBlock
  , fillBand

) where

import Control.Applicative (liftA2, (<$>), (<*>))
import Control.Concurrent (newMVar, takeMVar, putMVar, MVar)
import Control.Exception (finally, bracket, throw, Exception(..), SomeException)
import Control.Monad (liftM, foldM)

import Data.Int (Int16, Int32)
import Data.Complex (Complex(..), realPart, imagPart)
import Data.Maybe (isJust)
import Data.Typeable (Typeable, cast, typeOf)
import Data.Word (Word8, Word16, Word32)
import Data.Vector.Storable (Vector, unsafeFromForeignPtr0, unsafeToForeignPtr0)
import Foreign.C.String (withCString, CString, peekCString)
import Foreign.C.Types (CDouble(..), CInt(..), CChar(..))
import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr, freeHaskellFunPtr)
import Foreign.Storable (Storable(..))
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, newForeignPtr
                          ,mallocForeignPtrArray)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Array (allocaArray)
import Foreign.Marshal.Utils (toBool, fromBool)

import System.IO.Unsafe (unsafePerformIO)

#include "gdal.h"
#include "cpl_string.h"
#include "cpl_error.h"

data GDALException = GDALException Error String
     deriving (Show, Typeable)

instance Exception GDALException

isGDALException :: SomeException -> Bool
isGDALException e = isJust (fromException e :: Maybe GDALException)

{# enum CPLErr as Error {upcaseFirstLetter} deriving (Eq,Show) #}

type ErrorHandler = CInt -> CInt -> CString -> IO ()

foreign import ccall "cpl_error.h &CPLQuietErrorHandler"
  c_quietErrorHandler :: FunPtr ErrorHandler

foreign import ccall "cpl_error.h CPLSetErrorHandler"
  c_setErrorHandler :: FunPtr ErrorHandler -> IO (FunPtr ErrorHandler)

foreign import ccall "wrapper"
  wrapErrorHandler :: ErrorHandler -> IO (FunPtr ErrorHandler)

setQuietErrorHandler :: IO ()
setQuietErrorHandler = setErrorHandler c_quietErrorHandler

setErrorHandler :: FunPtr ErrorHandler -> IO ()
setErrorHandler h = c_setErrorHandler h >>= (\_->return ())

throwIfError :: String -> IO CInt -> IO ()
throwIfError msg act = do
    e <- liftM toEnumC act
    case e of
      CE_None -> return ()
      e       -> throw $ GDALException e msg

{# enum GDALDataType as Datatype {upcaseFirstLetter} deriving (Eq) #}
instance Show Datatype where
   show = getDatatypeName

{# fun pure unsafe GDALGetDataTypeSize as datatypeSize
    { fromEnumC `Datatype' } -> `Int' #}

{# fun pure unsafe GDALDataTypeIsComplex as datatypeIsComplex
    { fromEnumC `Datatype' } -> `Bool' #}

{# fun pure unsafe GDALGetDataTypeName as getDatatypeName
    { fromEnumC `Datatype' } -> `String' #}

{# fun pure unsafe GDALGetDataTypeByName as datatypeByName
    { `String' } -> `Datatype' toEnumC #}

{# fun pure unsafe GDALDataTypeUnion as datatypeUnion
    { fromEnumC `Datatype', fromEnumC `Datatype' } -> `Datatype' toEnumC #}

{# enum GDALAccess as Access {upcaseFirstLetter} deriving (Eq, Show) #}

{# enum GDALRWFlag as RwFlag {upcaseFirstLetter} deriving (Eq, Show) #}

{# enum GDALColorInterp as ColorInterpretation {upcaseFirstLetter}
   deriving (Eq) #}

instance Show ColorInterpretation where
    show = getColorInterpretationName

{# fun pure unsafe GDALGetColorInterpretationName as getColorInterpretationName
    { fromEnumC `ColorInterpretation' } -> `String' #}

{# fun pure unsafe GDALGetColorInterpretationByName as getColorInterpretationByName
    { `String' } -> `ColorInterpretation' toEnumC #}

{# enum GDALPaletteInterp as PaletteInterpretation {upcaseFirstLetter}
   deriving (Eq) #}

instance Show PaletteInterpretation where
    show = getPaletteInterpretationName

{# fun pure unsafe GDALGetPaletteInterpretationName as getPaletteInterpretationName
    { fromEnumC `PaletteInterpretation' } -> `String' #}

{#pointer GDALMajorObjectH as MajorObject newtype#}
{#pointer GDALDatasetH as Dataset foreign newtype nocode#}

newtype Dataset = Dataset (ForeignPtr Dataset, Mutex)

withDataset, withDataset' :: Dataset -> (Ptr Dataset -> IO b) -> IO b
withDataset ds@(Dataset (_, m)) fun = withMutex m $ withDataset' ds fun

withDataset' (Dataset (fptr,_)) = withForeignPtr fptr

{#pointer GDALRasterBandH as Band newtype#}
{#pointer GDALDriverH as Driver newtype#}
{#pointer GDALColorTableH as ColorTable newtype#}
{#pointer GDALRasterAttributeTableH as RasterAttributeTable newtype#}

{# fun GDALAllRegister as registerAllDrivers {} -> `()'  #}

{# fun unsafe GDALGetDriverByName as c_driverByName
    { `String' } -> `Driver' id #}

driverByName :: String -> IO Driver
driverByName s = do
    driver@(Driver ptr) <- c_driverByName s
    if ptr==nullPtr
        then throw $ GDALException CE_Failure "failed to load driver"
        else return driver

type DriverOptions = [(String,String)]

create :: String -> String -> Int -> Int -> Int -> Datatype -> DriverOptions
       -> IO Dataset
create drv path nx ny bands dtype options = do
    d <- driverByName  drv
    create' d path nx ny bands dtype options

create' :: Driver -> String -> Int -> Int -> Int -> Datatype -> DriverOptions
       -> IO Dataset
create' drv path nx ny bands dtype options = withCString path $ \path' -> do
    opts <- toOptionList options
    ptr <- {#call GDALCreate as ^#}
             drv
             path'
             (fromIntegral nx)
             (fromIntegral ny)
             (fromIntegral bands)
             (fromEnumC dtype)
             opts
    newDatasetHandle ptr

{# fun GDALOpen as open
    { `String', fromEnumC `Access'} -> `Dataset' newDatasetHandle* #}

{# fun GDALOpen as openShared
    { `String', fromEnumC `Access'} -> `Dataset' newDatasetHandle* #}

createCopy' :: Driver -> String -> Dataset -> Bool -> DriverOptions
            -> ProgressFun -> IO Dataset
createCopy' driver path dataset strict options progressFun
  = withCString path $ \p ->
    withDataset dataset $ \ds ->
    withProgressFun progressFun $ \pFunc -> do
        let s = fromBool strict
        o <- toOptionList options
        {#call GDALCreateCopy as ^#} driver p ds s o pFunc (castPtr nullPtr) >>=
            newDatasetHandle

withProgressFun = withCCallback wrapProgressFun

withCCallback w f = bracket (w f) freeHaskellFunPtr

createCopy :: String -> String -> Dataset -> Bool -> DriverOptions
           -> IO Dataset
createCopy driver path dataset strict options = do
  d <- driverByName driver
  createCopy' d path dataset strict options (\_ _ _ -> return 1)

type ProgressFun = CDouble -> Ptr CChar -> Ptr () -> IO CInt

foreign import ccall "wrapper"
  wrapProgressFun :: ProgressFun -> IO (FunPtr ProgressFun)

newDatasetHandle :: Ptr Dataset -> IO Dataset
newDatasetHandle p =
    if p==nullPtr
        then throw $ GDALException CE_Failure "Could not create dataset"
        else do fp <- newForeignPtr closeDataset p
                mutex <- newMutex
                return $ Dataset (fp, mutex)

foreign import ccall "gdal.h &GDALClose"
  closeDataset :: FunPtr (Ptr (Dataset) -> IO ())

createMem:: Int -> Int -> Int -> Datatype -> DriverOptions -> IO Dataset
createMem = create "MEM" ""

{# fun GDALFlushCache as flushCache
    {  withDataset*  `Dataset'} -> `()' #}

{# fun unsafe GDALGetProjectionRef as datasetProjection
    {  withDataset*  `Dataset'} -> `String' #}

{# fun unsafe GDALSetProjection as setDatasetProjection
    {  withDataset*  `Dataset', `String'} -> `Error' toEnumC #}

data Geotransform = Geotransform !Double !Double !Double !Double !Double !Double
    deriving (Eq, Show)

datasetGeotransform :: Dataset -> IO Geotransform
datasetGeotransform ds = withDataset' ds $ \dPtr -> do
    allocaArray 6 $ \a -> do
      throwIfError "could not get geotransform" $
         {#call unsafe GDALGetGeoTransform as ^#} dPtr a
      Geotransform <$> liftM realToFrac (peekElemOff a 0)
                   <*> liftM realToFrac (peekElemOff a 1)
                   <*> liftM realToFrac (peekElemOff a 2)
                   <*> liftM realToFrac (peekElemOff a 3)
                   <*> liftM realToFrac (peekElemOff a 4)
                   <*> liftM realToFrac (peekElemOff a 5)

setDatasetGeotransform :: Dataset -> Geotransform -> IO ()
setDatasetGeotransform ds gt = withDataset ds $ \dPtr -> do
    allocaArray 6 $ \a -> do
        let (Geotransform g0 g1 g2 g3 g4 g5) = gt
        pokeElemOff a 0 (realToFrac g0)
        pokeElemOff a 1 (realToFrac g1)
        pokeElemOff a 2 (realToFrac g2)
        pokeElemOff a 3 (realToFrac g3)
        pokeElemOff a 4 (realToFrac g4)
        pokeElemOff a 5 (realToFrac g5)
        throwIfError "could not set geotransform" $
            {#call unsafe GDALSetGeoTransform as ^#} dPtr a

withBand :: Dataset -> Int -> (Band -> IO a) -> IO a
withBand ds band f = withDataset ds $ \dPtr -> do
    rBand@(Band p) <- {# call unsafe GDALGetRasterBand as ^ #}
                         dPtr (fromIntegral band)
    if p == nullPtr
        then throw $
            GDALException CE_Failure ("could not get band #" ++ show band)
        else f rBand

{# fun pure unsafe GDALGetRasterDataType as bandDatatype
   { id `Band'} -> `Datatype' toEnumC #}

bandBlockSize :: Band -> (Int,Int)
bandBlockSize band = unsafePerformIO $ alloca $ \xPtr -> alloca $ \yPtr ->
   -- unsafePerformIO is safe here since the block size cant change once
   -- a dataset is created
   {#call unsafe GDALGetBlockSize as ^#} band xPtr yPtr >>
   liftA2 (,) (liftM fromIntegral $ peek xPtr) (liftM fromIntegral $ peek yPtr)

bandBlockLen :: Band -> Int
bandBlockLen = uncurry (*) . bandBlockSize

bandSize :: Band -> (Int, Int)
bandSize band
  = ( fromIntegral . {# call pure unsafe GDALGetRasterBandXSize as ^#} $ band
    , fromIntegral . {# call pure unsafe GDALGetRasterBandYSize as ^#} $ band
    )

bandNodataValue :: Band -> IO (Maybe Double)
bandNodataValue b = alloca $ \p -> do
   value <- liftM realToFrac $ {#call unsafe GDALGetRasterNoDataValue as ^#} b p
   hasNodata <- liftM toBool $ peek p
   return (if hasNodata then Just value else Nothing)

{# fun GDALSetRasterNoDataValue as setBandNodataValue
   { id `Band', `Double'} -> `Error' toEnumC #}

{# fun GDALFillRaster as fillBand
    { id `Band', `Double', `Double'} -> `Error' toEnumC #}

class HasDatatype a where
    datatype :: a -> Datatype

instance HasDatatype (Ptr Word8)  where datatype _ = GDT_Byte
instance HasDatatype (Ptr Word16) where datatype _ = GDT_UInt16
instance HasDatatype (Ptr Word32) where datatype _ = GDT_UInt32
instance HasDatatype (Ptr Int16)  where datatype _ = GDT_Int16
instance HasDatatype (Ptr Int32)  where datatype _ = GDT_Int32
instance HasDatatype (Ptr Float)  where datatype _ = GDT_Float32
instance HasDatatype (Ptr Double) where datatype _ = GDT_Float64
-- GDT_CInt16 or GDT_CInt32 can be written as Complex (Float|Double) but
-- will be truncated by GDAL. Both can be read as Complex (Float|Double).
-- This is a limitation imposed by Complex a which constrains a to be a
-- RealFloat.
instance HasDatatype (Ptr (Complex Float)) where datatype _ = GDT_CFloat32
instance HasDatatype (Ptr (Complex Double)) where datatype _ = GDT_CFloat64

instance (RealFloat a, Storable a) => Storable (Complex a) where
  sizeOf _ = sizeOf (undefined :: a) * 2
  alignment _ = alignment (undefined :: a)

  {-# SPECIALIZE INLINE peek :: Ptr (Complex Float) -> IO (Complex Float) #-}
  {-# SPECIALIZE INLINE peek :: Ptr (Complex Double) -> IO (Complex Double) #-}
  peek p = (:+) <$> peekElemOff (castPtr p) 0 <*> peekElemOff (castPtr p) 1

  {-# SPECIALIZE INLINE
      poke :: Ptr (Complex Float) -> Complex Float -> IO () #-}
  {-# SPECIALIZE INLINE
      poke :: Ptr (Complex Double) -> Complex Double -> IO () #-}
  poke p v = pokeElemOff (castPtr p) 0 (realPart v) >>
             pokeElemOff (castPtr p) 1 (imagPart v)

readBand :: (Storable a, HasDatatype (Ptr a))
  => Band
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> IO (Vector a)
readBand band xoff yoff sx sy bx by pxs lns = do
    fp <- mallocForeignPtrArray (bx * by)
    withForeignPtr fp $ \ptr -> do
      throwIfError "could not advise read" $
        {#call GDALRasterAdviseRead as ^#}
          band
          (fromIntegral xoff)
          (fromIntegral yoff)
          (fromIntegral sx)
          (fromIntegral sy)
          (fromIntegral bx)
          (fromIntegral by)
          (fromEnumC (datatype ptr))
          (castPtr nullPtr)
      throwIfError "could not read band" $
        {#call GDALRasterIO as ^#}
          band
          (fromEnumC GF_Read)
          (fromIntegral xoff)
          (fromIntegral yoff)
          (fromIntegral sx)
          (fromIntegral sy)
          (castPtr ptr)
          (fromIntegral bx)
          (fromIntegral by)
          (fromEnumC (datatype ptr))
          (fromIntegral pxs)
          (fromIntegral lns)
    return $ unsafeFromForeignPtr0 fp (bx * by)

writeBand :: (Storable a, HasDatatype (Ptr a))
  => Band
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Vector a
  -> IO ()
writeBand band xoff yoff sx sy bx by pxs lns vec = do
    let nElems    = bx * by
        (fp, len) = unsafeToForeignPtr0 vec
    if nElems /= len
      then throw $ GDALException CE_Failure "vector of wrong size"
      else withForeignPtr fp $ \ptr -> do
        throwIfError "could not write band" $
          {#call GDALRasterIO as ^#}
            band
            (fromEnumC GF_Write)
            (fromIntegral xoff)
            (fromIntegral yoff)
            (fromIntegral sx)
            (fromIntegral sy)
            (castPtr ptr)
            (fromIntegral bx)
            (fromIntegral by)
            (fromEnumC (datatype ptr))
            (fromIntegral pxs)
            (fromIntegral lns)

data Block where
    Block :: (Typeable a, Storable a) => Vector a -> Block

type MaybeIOVector a = IO (Maybe (Vector a))

readBandBlock :: (Storable a, Typeable a)
  => Band -> Int -> Int -> MaybeIOVector a
readBandBlock b x y = do
  block <- readBandBlock' b x y
  liftM (maybe Nothing (\(Block a) -> cast a)) $ readBandBlock' b x y

readBandBlock' :: Band -> Int -> Int -> IO (Maybe Block)
readBandBlock' b x y =
  case bandDatatype b of
    GDT_Byte     -> Just . Block <$> (readIt b x y :: IOVector Word8)
    GDT_Int16    -> Just . Block <$> (readIt b x y :: IOVector Int16)
    GDT_Int32    -> Just . Block <$> (readIt b x y :: IOVector Int32)
    GDT_Float32  -> Just . Block <$> (readIt b x y :: IOVector Float)
    GDT_Float64  -> Just . Block <$> (readIt b x y :: IOVector Double)
    GDT_CInt16   -> Just . Block <$> (readIt b x y :: IOVector (Complex Float))
    GDT_CInt32   -> Just . Block <$> (readIt b x y :: IOVector (Complex Double))
    GDT_CFloat32 -> Just . Block <$> (readIt b x y :: IOVector (Complex Float))
    GDT_CFloat64 -> Just . Block <$> (readIt b x y :: IOVector (Complex Double))
    _            -> return Nothing
  where
    readIt :: Storable a => Band -> Int -> Int -> IOVector a
    readIt b x y = do
      f <- mallocForeignPtrArray (bandBlockLen b)
      withForeignPtr f $ \ptr ->
        throwIfError "could not read block" $
          {#call GDALReadBlock as ^#}
            b (fromIntegral x) (fromIntegral y) (castPtr ptr)
      return $ unsafeFromForeignPtr0 f (bandBlockLen b)

type IOVector a = IO (Vector a)

writeBandBlock :: (Storable a, Typeable a)
  => Band
  -> Int -> Int
  -> Vector a
  -> IO ()
writeBandBlock b x y vec = do
    let nElems    = bandBlockLen b
        (fp, len) = unsafeToForeignPtr0 vec
    if nElems /= len
      then throw $ GDALException CE_Failure "wrongly sized vector"
      else if typeOf vec /= typeOfBand b
           then throw $ GDALException CE_Failure "wrongly typed vector"
           else withForeignPtr fp $ \ptr ->
                throwIfError "could not write block" $
                   {#call GDALWriteBlock as ^#}
                      b (fromIntegral x) (fromIntegral y) (castPtr ptr)

typeOfBand = typeOfdatatype . bandDatatype

typeOfdatatype dt =
  case dt of
    GDT_Byte     -> typeOf (undefined :: Vector Word8)
    GDT_Int16    -> typeOf (undefined :: Vector Int16)
    GDT_Int32    -> typeOf (undefined :: Vector Int32)
    GDT_Float32  -> typeOf (undefined :: Vector Float)
    GDT_Float64  -> typeOf (undefined :: Vector Double)
    GDT_CInt16   -> typeOf (undefined :: Vector (Complex Float))
    GDT_CInt32   -> typeOf (undefined :: Vector (Complex Double))
    GDT_CFloat32 -> typeOf (undefined :: Vector (Complex Float))
    GDT_CFloat64 -> typeOf (undefined :: Vector (Complex Double))
    _            -> typeOf (undefined :: Bool) -- will never match a vector

fromEnumC :: Enum a => a -> CInt
fromEnumC = fromIntegral . fromEnum

toEnumC :: Enum a => CInt -> a
toEnumC = toEnum . fromIntegral

toOptionList :: [(String,String)] -> IO (Ptr CString)
toOptionList opts =  foldM folder nullPtr opts
  where folder acc (k,v) = withCString k $ \k' -> withCString v $ \v' ->
                           {#call unsafe CSLSetNameValue as ^#} acc k' v'

type Mutex = MVar ()

newMutex :: IO Mutex
newMutex = newMVar ()

acquireMutex :: Mutex -> IO ()
acquireMutex = takeMVar

releaseMutex :: Mutex -> IO ()
releaseMutex m = putMVar m ()

withMutex m action = finally (acquireMutex m >> action) (releaseMutex m)

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GADTs #-}

module Bindings.GDAL.Internal (
    Datatype (..)
  , Access (..)
  , ColorInterpretation (..)
  , PaletteInterpretation (..)
  , GDALException
  , isGDALException
  , Geotransform (..)
  , MaybeIOVector
  , DriverOptions
  , MajorObject
  , Dataset
  , Band
  , Driver
  , ColorTable
  , RasterAttributeTable

  , setQuietErrorHandler

  , registerAllDrivers
  , driverByName
  , create
  , create'
  , createMem
  , flushCache
  , open
  , openShared
  , createCopy

  , datatypeSize
  , datatypeByName
  , datatypeUnion
  , datatypeIsComplex

  , datasetProjection
  , setDatasetProjection
  , datasetGeotransform
  , setDatasetGeotransform

  , withBand
  , bandDatatype
  , bandBlockSize
  , bandBlockLen
  , bandSize
  , bandNodataValue
  , setBandNodataValue
  , readBand
  , readBandBlock
  , writeBand
  , writeBandBlock
  , fillBand

) where

import Control.Applicative (liftA2, (<$>), (<*>))
import Control.Concurrent (newMVar, takeMVar, putMVar, MVar, runInBoundThread,
                           rtsSupportsBoundThreads)
import Control.Exception (finally, bracket, throw, Exception(..), SomeException)
import Control.Monad (liftM, foldM)

import Data.Int (Int16, Int32)
import Data.Complex (Complex(..), realPart, imagPart)
import Data.Maybe (isJust)
import Data.Typeable (Typeable, cast, typeOf)
import Data.Word (Word8, Word16, Word32)
import Data.Vector.Storable (Vector, unsafeFromForeignPtr0, unsafeToForeignPtr0)
import Foreign.C.String (withCString, CString, peekCString)
import Foreign.C.Types (CDouble(..), CInt(..), CChar(..))
import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr, freeHaskellFunPtr)
import Foreign.Storable (Storable(..))
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, newForeignPtr
                          ,mallocForeignPtrArray)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Array (allocaArray)
import Foreign.Marshal.Utils (toBool, fromBool)

import System.IO.Unsafe (unsafePerformIO)

#include "gdal.h"
#include "cpl_string.h"
#include "cpl_error.h"

data GDALException = GDALException Error String
     deriving (Show, Typeable)

instance Exception GDALException

isGDALException :: SomeException -> Bool
isGDALException e = isJust (fromException e :: Maybe GDALException)

{# enum CPLErr as Error {upcaseFirstLetter} deriving (Eq,Show) #}

type ErrorHandler = CInt -> CInt -> CString -> IO ()

foreign import ccall "cpl_error.h &CPLQuietErrorHandler"
  c_quietErrorHandler :: FunPtr ErrorHandler

foreign import ccall "cpl_error.h CPLSetErrorHandler"
  c_setErrorHandler :: FunPtr ErrorHandler -> IO (FunPtr ErrorHandler)

foreign import ccall "wrapper"
  wrapErrorHandler :: ErrorHandler -> IO (FunPtr ErrorHandler)

setQuietErrorHandler :: IO ()
setQuietErrorHandler = setErrorHandler c_quietErrorHandler

setErrorHandler :: FunPtr ErrorHandler -> IO ()
setErrorHandler h = c_setErrorHandler h >>= (\_->return ())

throwIfError :: String -> IO CInt -> IO ()
throwIfError msg act = do
    e <- liftM toEnumC act
    case e of
      CE_None -> return ()
      e       -> throw $ GDALException e msg

{# enum GDALDataType as Datatype {upcaseFirstLetter} deriving (Eq) #}
instance Show Datatype where
   show = getDatatypeName

{# fun pure unsafe GDALGetDataTypeSize as datatypeSize
    { fromEnumC `Datatype' } -> `Int' #}

{# fun pure unsafe GDALDataTypeIsComplex as datatypeIsComplex
    { fromEnumC `Datatype' } -> `Bool' #}

{# fun pure unsafe GDALGetDataTypeName as getDatatypeName
    { fromEnumC `Datatype' } -> `String' #}

{# fun pure unsafe GDALGetDataTypeByName as datatypeByName
    { `String' } -> `Datatype' toEnumC #}

{# fun pure unsafe GDALDataTypeUnion as datatypeUnion
    { fromEnumC `Datatype', fromEnumC `Datatype' } -> `Datatype' toEnumC #}

{# enum GDALAccess as Access {upcaseFirstLetter} deriving (Eq, Show) #}

{# enum GDALRWFlag as RwFlag {upcaseFirstLetter} deriving (Eq, Show) #}

{# enum GDALColorInterp as ColorInterpretation {upcaseFirstLetter}
   deriving (Eq) #}

instance Show ColorInterpretation where
    show = getColorInterpretationName

{# fun pure unsafe GDALGetColorInterpretationName as getColorInterpretationName
    { fromEnumC `ColorInterpretation' } -> `String' #}

{# fun pure unsafe GDALGetColorInterpretationByName as getColorInterpretationByName
    { `String' } -> `ColorInterpretation' toEnumC #}

{# enum GDALPaletteInterp as PaletteInterpretation {upcaseFirstLetter}
   deriving (Eq) #}

instance Show PaletteInterpretation where
    show = getPaletteInterpretationName

{# fun pure unsafe GDALGetPaletteInterpretationName as getPaletteInterpretationName
    { fromEnumC `PaletteInterpretation' } -> `String' #}

{#pointer GDALMajorObjectH as MajorObject newtype#}
{#pointer GDALDatasetH as Dataset foreign newtype nocode#}

newtype Dataset = Dataset (ForeignPtr Dataset, Mutex)

withDataset, withDataset' :: Dataset -> (Ptr Dataset -> IO b) -> IO b
withDataset ds@(Dataset (_, m)) fun
  = runInBoundThread' $ withMutex m $ withDataset' ds fun

runInBoundThread' a
    = if rtsSupportsBoundThreads then runInBoundThread a else a

withDataset' (Dataset (fptr,_)) = withForeignPtr fptr

{#pointer GDALRasterBandH as Band newtype#}
{#pointer GDALDriverH as Driver newtype#}
{#pointer GDALColorTableH as ColorTable newtype#}
{#pointer GDALRasterAttributeTableH as RasterAttributeTable newtype#}

{# fun GDALAllRegister as registerAllDrivers {} -> `()'  #}

{# fun unsafe GDALGetDriverByName as c_driverByName
    { `String' } -> `Driver' id #}

driverByName :: String -> IO Driver
driverByName s = do
    driver@(Driver ptr) <- c_driverByName s
    if ptr==nullPtr
        then throw $ GDALException CE_Failure "failed to load driver"
        else return driver

type DriverOptions = [(String,String)]

create :: String -> String -> Int -> Int -> Int -> Datatype -> DriverOptions
       -> IO Dataset
create drv path nx ny bands dtype options = do
    d <- driverByName  drv
    create' d path nx ny bands dtype options

create' :: Driver -> String -> Int -> Int -> Int -> Datatype -> DriverOptions
       -> IO Dataset
create' drv path nx ny bands dtype options = withCString path $ \path' -> do
    opts <- toOptionList options
    ptr <- {#call GDALCreate as ^#}
             drv
             path'
             (fromIntegral nx)
             (fromIntegral ny)
             (fromIntegral bands)
             (fromEnumC dtype)
             opts
    newDatasetHandle ptr

{# fun GDALOpen as open
    { `String', fromEnumC `Access'} -> `Dataset' newDatasetHandle* #}

{# fun GDALOpen as openShared
    { `String', fromEnumC `Access'} -> `Dataset' newDatasetHandle* #}

createCopy' :: Driver -> String -> Dataset -> Bool -> DriverOptions
            -> ProgressFun -> IO Dataset
createCopy' driver path dataset strict options progressFun
  = withCString path $ \p ->
    withDataset dataset $ \ds ->
    withProgressFun progressFun $ \pFunc -> do
        let s = fromBool strict
        o <- toOptionList options
        {#call GDALCreateCopy as ^#} driver p ds s o pFunc (castPtr nullPtr) >>=
            newDatasetHandle

withProgressFun = withCCallback wrapProgressFun

withCCallback w f = bracket (w f) freeHaskellFunPtr

createCopy :: String -> String -> Dataset -> Bool -> DriverOptions
           -> IO Dataset
createCopy driver path dataset strict options = do
  d <- driverByName driver
  createCopy' d path dataset strict options (\_ _ _ -> return 1)

type ProgressFun = CDouble -> Ptr CChar -> Ptr () -> IO CInt

foreign import ccall "wrapper"
  wrapProgressFun :: ProgressFun -> IO (FunPtr ProgressFun)

newDatasetHandle :: Ptr Dataset -> IO Dataset
newDatasetHandle p =
    if p==nullPtr
        then throw $ GDALException CE_Failure "Could not create dataset"
        else do fp <- newForeignPtr closeDataset p
                mutex <- newMutex
                return $ Dataset (fp, mutex)

foreign import ccall "gdal.h &GDALClose"
  closeDataset :: FunPtr (Ptr (Dataset) -> IO ())

createMem:: Int -> Int -> Int -> Datatype -> DriverOptions -> IO Dataset
createMem = create "MEM" ""

{# fun GDALFlushCache as flushCache
    {  withDataset*  `Dataset'} -> `()' #}

{# fun unsafe GDALGetProjectionRef as datasetProjection
    {  withDataset*  `Dataset'} -> `String' #}

{# fun unsafe GDALSetProjection as setDatasetProjection
    {  withDataset*  `Dataset', `String'} -> `Error' toEnumC #}

data Geotransform = Geotransform !Double !Double !Double !Double !Double !Double
    deriving (Eq, Show)

datasetGeotransform :: Dataset -> IO Geotransform
datasetGeotransform ds = withDataset' ds $ \dPtr -> do
    allocaArray 6 $ \a -> do
      throwIfError "could not get geotransform" $
         {#call unsafe GDALGetGeoTransform as ^#} dPtr a
      Geotransform <$> liftM realToFrac (peekElemOff a 0)
                   <*> liftM realToFrac (peekElemOff a 1)
                   <*> liftM realToFrac (peekElemOff a 2)
                   <*> liftM realToFrac (peekElemOff a 3)
                   <*> liftM realToFrac (peekElemOff a 4)
                   <*> liftM realToFrac (peekElemOff a 5)

setDatasetGeotransform :: Dataset -> Geotransform -> IO ()
setDatasetGeotransform ds gt = withDataset ds $ \dPtr -> do
    allocaArray 6 $ \a -> do
        let (Geotransform g0 g1 g2 g3 g4 g5) = gt
        pokeElemOff a 0 (realToFrac g0)
        pokeElemOff a 1 (realToFrac g1)
        pokeElemOff a 2 (realToFrac g2)
        pokeElemOff a 3 (realToFrac g3)
        pokeElemOff a 4 (realToFrac g4)
        pokeElemOff a 5 (realToFrac g5)
        throwIfError "could not set geotransform" $
            {#call unsafe GDALSetGeoTransform as ^#} dPtr a

withBand :: Dataset -> Int -> (Band -> IO a) -> IO a
withBand ds band f = withDataset ds $ \dPtr -> do
    rBand@(Band p) <- {# call unsafe GDALGetRasterBand as ^ #}
                         dPtr (fromIntegral band)
    if p == nullPtr
        then throw $
            GDALException CE_Failure ("could not get band #" ++ show band)
        else f rBand

{# fun pure unsafe GDALGetRasterDataType as bandDatatype
   { id `Band'} -> `Datatype' toEnumC #}

bandBlockSize :: Band -> (Int,Int)
bandBlockSize band = unsafePerformIO $ alloca $ \xPtr -> alloca $ \yPtr ->
   -- unsafePerformIO is safe here since the block size cant change once
   -- a dataset is created
   {#call unsafe GDALGetBlockSize as ^#} band xPtr yPtr >>
   liftA2 (,) (liftM fromIntegral $ peek xPtr) (liftM fromIntegral $ peek yPtr)

bandBlockLen :: Band -> Int
bandBlockLen = uncurry (*) . bandBlockSize

bandSize :: Band -> (Int, Int)
bandSize band
  = ( fromIntegral . {# call pure unsafe GDALGetRasterBandXSize as ^#} $ band
    , fromIntegral . {# call pure unsafe GDALGetRasterBandYSize as ^#} $ band
    )

bandNodataValue :: Band -> IO (Maybe Double)
bandNodataValue b = alloca $ \p -> do
   value <- liftM realToFrac $ {#call unsafe GDALGetRasterNoDataValue as ^#} b p
   hasNodata <- liftM toBool $ peek p
   return (if hasNodata then Just value else Nothing)

{# fun GDALSetRasterNoDataValue as setBandNodataValue
   { id `Band', `Double'} -> `Error' toEnumC #}

{# fun GDALFillRaster as fillBand
    { id `Band', `Double', `Double'} -> `Error' toEnumC #}

class HasDatatype a where
    datatype :: a -> Datatype

instance HasDatatype (Ptr Word8)  where datatype _ = GDT_Byte
instance HasDatatype (Ptr Word16) where datatype _ = GDT_UInt16
instance HasDatatype (Ptr Word32) where datatype _ = GDT_UInt32
instance HasDatatype (Ptr Int16)  where datatype _ = GDT_Int16
instance HasDatatype (Ptr Int32)  where datatype _ = GDT_Int32
instance HasDatatype (Ptr Float)  where datatype _ = GDT_Float32
instance HasDatatype (Ptr Double) where datatype _ = GDT_Float64
-- GDT_CInt16 or GDT_CInt32 can be written as Complex (Float|Double) but
-- will be truncated by GDAL. Both can be read as Complex (Float|Double).
-- This is a limitation imposed by Complex a which constrains a to be a
-- RealFloat.
instance HasDatatype (Ptr (Complex Float)) where datatype _ = GDT_CFloat32
instance HasDatatype (Ptr (Complex Double)) where datatype _ = GDT_CFloat64

instance (RealFloat a, Storable a) => Storable (Complex a) where
  sizeOf _ = sizeOf (undefined :: a) * 2
  alignment _ = alignment (undefined :: a)

  {-# SPECIALIZE INLINE peek :: Ptr (Complex Float) -> IO (Complex Float) #-}
  {-# SPECIALIZE INLINE peek :: Ptr (Complex Double) -> IO (Complex Double) #-}
  peek p = (:+) <$> peekElemOff (castPtr p) 0 <*> peekElemOff (castPtr p) 1

  {-# SPECIALIZE INLINE
      poke :: Ptr (Complex Float) -> Complex Float -> IO () #-}
  {-# SPECIALIZE INLINE
      poke :: Ptr (Complex Double) -> Complex Double -> IO () #-}
  poke p v = pokeElemOff (castPtr p) 0 (realPart v) >>
             pokeElemOff (castPtr p) 1 (imagPart v)

readBand :: (Storable a, HasDatatype (Ptr a))
  => Band
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> IO (Vector a)
readBand band xoff yoff sx sy bx by pxs lns = do
    fp <- mallocForeignPtrArray (bx * by)
    withForeignPtr fp $ \ptr -> do
      throwIfError "could not advise read" $
        {#call GDALRasterAdviseRead as ^#}
          band
          (fromIntegral xoff)
          (fromIntegral yoff)
          (fromIntegral sx)
          (fromIntegral sy)
          (fromIntegral bx)
          (fromIntegral by)
          (fromEnumC (datatype ptr))
          (castPtr nullPtr)
      throwIfError "could not read band" $
        {#call GDALRasterIO as ^#}
          band
          (fromEnumC GF_Read)
          (fromIntegral xoff)
          (fromIntegral yoff)
          (fromIntegral sx)
          (fromIntegral sy)
          (castPtr ptr)
          (fromIntegral bx)
          (fromIntegral by)
          (fromEnumC (datatype ptr))
          (fromIntegral pxs)
          (fromIntegral lns)
    return $ unsafeFromForeignPtr0 fp (bx * by)

writeBand :: (Storable a, HasDatatype (Ptr a))
  => Band
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Vector a
  -> IO ()
writeBand band xoff yoff sx sy bx by pxs lns vec = do
    let nElems    = bx * by
        (fp, len) = unsafeToForeignPtr0 vec
    if nElems /= len
      then throw $ GDALException CE_Failure "vector of wrong size"
      else withForeignPtr fp $ \ptr -> do
        throwIfError "could not write band" $
          {#call GDALRasterIO as ^#}
            band
            (fromEnumC GF_Write)
            (fromIntegral xoff)
            (fromIntegral yoff)
            (fromIntegral sx)
            (fromIntegral sy)
            (castPtr ptr)
            (fromIntegral bx)
            (fromIntegral by)
            (fromEnumC (datatype ptr))
            (fromIntegral pxs)
            (fromIntegral lns)

data Block where
    Block :: (Typeable a, Storable a) => Vector a -> Block

type MaybeIOVector a = IO (Maybe (Vector a))

readBandBlock :: (Storable a, Typeable a)
  => Band -> Int -> Int -> MaybeIOVector a
readBandBlock b x y = do
  block <- readBandBlock' b x y
  liftM (maybe Nothing (\(Block a) -> cast a)) $ readBandBlock' b x y

readBandBlock' :: Band -> Int -> Int -> IO (Maybe Block)
readBandBlock' b x y =
  case bandDatatype b of
    GDT_Byte     -> Just . Block <$> (readIt b x y :: IOVector Word8)
    GDT_Int16    -> Just . Block <$> (readIt b x y :: IOVector Int16)
    GDT_Int32    -> Just . Block <$> (readIt b x y :: IOVector Int32)
    GDT_Float32  -> Just . Block <$> (readIt b x y :: IOVector Float)
    GDT_Float64  -> Just . Block <$> (readIt b x y :: IOVector Double)
    GDT_CInt16   -> Just . Block <$> (readIt b x y :: IOVector (Complex Float))
    GDT_CInt32   -> Just . Block <$> (readIt b x y :: IOVector (Complex Double))
    GDT_CFloat32 -> Just . Block <$> (readIt b x y :: IOVector (Complex Float))
    GDT_CFloat64 -> Just . Block <$> (readIt b x y :: IOVector (Complex Double))
    _            -> return Nothing
  where
    readIt :: Storable a => Band -> Int -> Int -> IOVector a
    readIt b x y = do
      f <- mallocForeignPtrArray (bandBlockLen b)
      withForeignPtr f $ \ptr ->
        throwIfError "could not read block" $
          {#call GDALReadBlock as ^#}
            b (fromIntegral x) (fromIntegral y) (castPtr ptr)
      return $ unsafeFromForeignPtr0 f (bandBlockLen b)

type IOVector a = IO (Vector a)

writeBandBlock :: (Storable a, Typeable a)
  => Band
  -> Int -> Int
  -> Vector a
  -> IO ()
writeBandBlock b x y vec = do
    let nElems    = bandBlockLen b
        (fp, len) = unsafeToForeignPtr0 vec
    if nElems /= len
      then throw $ GDALException CE_Failure "wrongly sized vector"
      else if typeOf vec /= typeOfBand b
           then throw $ GDALException CE_Failure "wrongly typed vector"
           else withForeignPtr fp $ \ptr ->
                throwIfError "could not write block" $
                   {#call GDALWriteBlock as ^#}
                      b (fromIntegral x) (fromIntegral y) (castPtr ptr)

typeOfBand = typeOfdatatype . bandDatatype

typeOfdatatype dt =
  case dt of
    GDT_Byte     -> typeOf (undefined :: Vector Word8)
    GDT_Int16    -> typeOf (undefined :: Vector Int16)
    GDT_Int32    -> typeOf (undefined :: Vector Int32)
    GDT_Float32  -> typeOf (undefined :: Vector Float)
    GDT_Float64  -> typeOf (undefined :: Vector Double)
    GDT_CInt16   -> typeOf (undefined :: Vector (Complex Float))
    GDT_CInt32   -> typeOf (undefined :: Vector (Complex Double))
    GDT_CFloat32 -> typeOf (undefined :: Vector (Complex Float))
    GDT_CFloat64 -> typeOf (undefined :: Vector (Complex Double))
    _            -> typeOf (undefined :: Bool) -- will never match a vector

fromEnumC :: Enum a => a -> CInt
fromEnumC = fromIntegral . fromEnum

toEnumC :: Enum a => CInt -> a
toEnumC = toEnum . fromIntegral

toOptionList :: [(String,String)] -> IO (Ptr CString)
toOptionList opts =  foldM folder nullPtr opts
  where folder acc (k,v) = withCString k $ \k' -> withCString v $ \v' ->
                           {#call unsafe CSLSetNameValue as ^#} acc k' v'

type Mutex = MVar ()

newMutex :: IO Mutex
newMutex = newMVar ()

acquireMutex :: Mutex -> IO ()
acquireMutex = takeMVar

releaseMutex :: Mutex -> IO ()
releaseMutex m = putMVar m ()

withMutex m action = finally (acquireMutex m >> action) (releaseMutex m)


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


ghc-7.6/7.8 import fix

ghc-7.6/7.8 import fix

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE DeriveDataTypeable       #-}
{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Runtime.Error
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Error handling functions
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Runtime.Error (

  Status(..), CUDAException(..),

  cudaError, describe, requireSDK,
  resultIfOk, nothingIfOk

) where

-- Friends
import Foreign.CUDA.Internal.C2HS

-- System
import Foreign.C
import Foreign.Ptr
import Data.Typeable
import Control.Exception
import System.IO.Unsafe

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

--------------------------------------------------------------------------------
-- Return Status
--------------------------------------------------------------------------------

-- |
-- Return codes from API functions
--
{# enum cudaError as Status
    { cudaSuccess as Success }
    with prefix="cudaError" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Exceptions
--------------------------------------------------------------------------------

data CUDAException
  = ExitCode  Status
  | UserError String
  deriving Typeable

instance Exception CUDAException

instance Show CUDAException where
  showsPrec _ (ExitCode  s) = showString ("CUDA Exception: " ++ describe s)
  showsPrec _ (UserError s) = showString ("CUDA Exception: " ++ s)

-- |
-- Raise a 'CUDAException' in the IO Monad
--
cudaError :: String -> IO a
cudaError s = throwIO (UserError s)

-- |
-- A specially formatted error message
--
requireSDK :: Double -> String -> IO a
requireSDK v s = cudaError ("'" ++ s ++ "' requires at least cuda-" ++ show v)

--------------------------------------------------------------------------------
-- Helper Functions
--------------------------------------------------------------------------------

-- |
-- Return the descriptive string associated with a particular error code
--
{# fun pure unsafe cudaGetErrorStringWrapper as describe
    { cFromEnum `Status' } -> `String' #}
--
-- Logically, this must be a pure function, returning a pointer to a statically
-- defined string constant.
--

-- |
-- Return the results of a function on successful execution, otherwise return
-- the error string associated with the return code
--
{-# INLINE resultIfOk #-}
resultIfOk :: (Status, a) -> IO a
resultIfOk (status, !result) =
    case status of
        Success -> return  result
        _       -> throwIO (ExitCode status)

-- |
-- Return the error string associated with an unsuccessful return code,
-- otherwise Nothing
--
{-# INLINE nothingIfOk #-}
nothingIfOk :: Status -> IO ()
nothingIfOk status =
    case status of
        Success -> return  ()
        _       -> throwIO (ExitCode status)

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE DeriveDataTypeable       #-}
{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Runtime.Error
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Error handling functions
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Runtime.Error (

  Status(..), CUDAException(..),

  cudaError, describe, requireSDK,
  resultIfOk, nothingIfOk

) where

-- Friends
import Foreign.CUDA.Internal.C2HS

-- System
import Foreign
import Foreign.C
import Data.Typeable
import Control.Exception
import System.IO.Unsafe

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

--------------------------------------------------------------------------------
-- Return Status
--------------------------------------------------------------------------------

-- |
-- Return codes from API functions
--
{# enum cudaError as Status
    { cudaSuccess as Success }
    with prefix="cudaError" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Exceptions
--------------------------------------------------------------------------------

data CUDAException
  = ExitCode  Status
  | UserError String
  deriving Typeable

instance Exception CUDAException

instance Show CUDAException where
  showsPrec _ (ExitCode  s) = showString ("CUDA Exception: " ++ describe s)
  showsPrec _ (UserError s) = showString ("CUDA Exception: " ++ s)

-- |
-- Raise a 'CUDAException' in the IO Monad
--
cudaError :: String -> IO a
cudaError s = throwIO (UserError s)

-- |
-- A specially formatted error message
--
requireSDK :: Double -> String -> IO a
requireSDK v s = cudaError ("'" ++ s ++ "' requires at least cuda-" ++ show v)

--------------------------------------------------------------------------------
-- Helper Functions
--------------------------------------------------------------------------------

-- |
-- Return the descriptive string associated with a particular error code
--
{# fun pure unsafe cudaGetErrorStringWrapper as describe
    { cFromEnum `Status' } -> `String' #}
--
-- Logically, this must be a pure function, returning a pointer to a statically
-- defined string constant.
--

-- |
-- Return the results of a function on successful execution, otherwise return
-- the error string associated with the return code
--
{-# INLINE resultIfOk #-}
resultIfOk :: (Status, a) -> IO a
resultIfOk (status, !result) =
    case status of
        Success -> return  result
        _       -> throwIO (ExitCode status)

-- |
-- Return the error string associated with an unsuccessful return code,
-- otherwise Nothing
--
{-# INLINE nothingIfOk #-}
nothingIfOk :: Status -> IO ()
nothingIfOk status =
    case status of
        Success -> return  ()
        _       -> throwIO (ExitCode status)