getMaskBand and bandNodataPredicate

getMaskBand and bandNodataPredicate

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module OSGeo.GDAL.Internal (
    GDAL
  , runGDAL
  , GDALType
  , Datatype (..)
  , GDALException (..)
  , isGDALException
  , Geotransform (..)
  , DriverOptions
  , Driver (..)
  , Dataset
  , SomeDataset (..)
  , ReadWrite
  , ReadOnly
  , RWDataset
  , RODataset
  , RWBand
  , ROBand
  , Band

  , setQuietErrorHandler

  , registerAllDrivers
  , destroyDriverManager
  , create
  , createMem
  , flushCache
  , openReadOnly
  , openReadWrite
  , openAnyReadOnly
  , openAnyReadWrite
  , createCopy

  , datatypeSize
  , datatypeByName
  , datatypeUnion
  , datatypeIsComplex

  , datasetSize
  , datasetProjection
  , setDatasetProjection
  , datasetGeotransform
  , setDatasetGeotransform
  , datasetBandCount

  , bandDatatype
  , bandBlockSize
  , bandBlockLen
  , bandSize
  , bandNodataValue
  , bandNodataPredicate
  , setBandNodataValue
  , getBand
  , getMaskBand
  , readBand
  , unsafeLazyReadBand
  , readBandBlock
  , writeBand
  , writeBandBlock
  , fillBand

  -- Internal Util
  , throwIfError
  , unsafeWithDataset
  , unsafeWithBand
) where

import Control.Applicative (liftA2, (<$>), (<*>))
import Control.Exception ( bracket, throw, Exception(..), SomeException
                         , evaluate)
import Control.DeepSeq (NFData, force)
import Control.Monad (liftM, foldM)
import Control.Monad.Trans.Resource (ResourceT, runResourceT, register)
import Control.Monad.IO.Class (MonadIO(..))

import Data.Int (Int16, Int32)
import Data.Complex (Complex(..), realPart)
import Data.Maybe (isJust)
import Data.Proxy (Proxy(..))
import Data.Typeable (Typeable)
import Data.Word (Word8, Word16, Word32)
import Data.Vector.Storable (Vector, unsafeFromForeignPtr0, unsafeToForeignPtr0)
import Data.Coerce (coerce)
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 (withForeignPtr, mallocForeignPtrArray)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Array (allocaArray)
import Foreign.Marshal.Utils (toBool, fromBool)

import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO)
import System.Process (readProcess)
import Data.Char (toUpper)

import OSGeo.Util

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

$(let names = fmap (words . map toUpper) $
                readProcess "gdal-config" ["--formats"] ""
  in createEnum "Driver" names)

newtype GDAL s a = GDAL (ResourceT IO a)

deriving instance Functor (GDAL s)
deriving instance Applicative (GDAL s)
deriving instance Monad (GDAL s)
deriving instance MonadIO (GDAL s)

runGDAL :: NFData a => (forall s. GDAL s a) -> IO a
runGDAL (GDAL a) = do
  registerAllDrivers
  runResourceT (a >>= liftIO . evaluate . force)

data GDALException = Unknown !Error !String
                   | InvalidType
                   | InvalidRasterSize !Int !Int
                   | InvalidBlockSize
                   | DriverLoadError
                   | NullDatasetHandle
                   | InvalidBand !Int
     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)

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 $ Unknown 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) #}

{#pointer GDALDatasetH as Dataset foreign newtype nocode#}

data DatasetMode = ReadOnly | ReadWrite

type ReadOnly  = 'ReadOnly
type ReadWrite = 'ReadWrite

newtype Dataset s (t::DatasetMode) a = Dataset (Ptr (Dataset s t a))

unsafeWithDataset
  :: Dataset s t a -> (Ptr (Dataset s t a) -> GDAL s b) -> GDAL s b
unsafeWithDataset (Dataset p) f = f p

unsafeWithDatasetIO
  :: Dataset s t a -> (Ptr (Dataset s t a) -> IO b) -> GDAL s b
unsafeWithDatasetIO ds f = unsafeWithDataset ds (liftIO . f)

type RODataset s = Dataset s ReadOnly
type RWDataset s = Dataset s ReadWrite

{#pointer GDALRasterBandH as Band newtype nocode#}
newtype (Band s (t::DatasetMode) a) = Band (Ptr (Band s t a))

unsafeWithBand
  :: Band s t a -> (Ptr (Band s t a) -> GDAL s b) -> GDAL s b
unsafeWithBand (Band p) f = f p

type ROBand s = Band s ReadOnly
type RWBand s = Band s ReadWrite

{#pointer GDALDriverH as DriverH newtype#}

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

{#fun GDALDestroyDriverManager as destroyDriverManager {} -> `()'#}

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

driverByName :: Driver -> GDAL s DriverH
driverByName s = GDAL $ liftIO $ do
    driver@(DriverH ptr) <- c_driverByName (show s)
    if ptr==nullPtr
        then throw DriverLoadError
        else return driver

type DriverOptions = [(String,String)]

create
  :: forall s a. GDALType a
  => Driver -> String -> Int -> Int -> Int -> DriverOptions
  -> GDAL s (Dataset s ReadWrite a)
create drv path nx ny bands options = do
  d <- driverByName drv
  ptr <- liftIO $ withCString path $ \path' -> do
    let nx'    = fromIntegral nx
        ny'    = fromIntegral ny
        bands' = fromIntegral bands
        dtype' = fromEnumC $ datatype (Proxy :: Proxy a)
    withOptionList options $ \opts ->
        c_create d path' nx' ny' bands' dtype' opts
  newDatasetHandle ptr

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

foreign import ccall safe "gdal.h GDALCreate" c_create
  :: DriverH
  -> CString
  -> CInt
  -> CInt
  -> CInt
  -> CInt
  -> Ptr CString
  -> IO (Ptr (RWDataset s a))

openReadOnly :: GDALType a => FilePath -> GDAL s (RODataset s a)
openReadOnly p = openWithMode GA_ReadOnly p >>= checkType

openReadWrite :: GDALType a => FilePath -> GDAL s (RWDataset s a)
openReadWrite p = openWithMode GA_Update p >>= checkType

openWithMode :: Access -> String -> GDAL s (Dataset s t a)
openWithMode m p =
  liftIO (withCString p $ \p' -> open_ p' (fromEnumC m)) >>= newDatasetHandle

openAnyWithMode :: forall s t. Access -> String -> GDAL s (SomeDataset s t)
openAnyWithMode m p = do
  ds <- openWithMode m p
  dt <- getBand ds 1 >>= bandDatatype
  case dt of
    GDT_Byte     -> return $ SomeDataset ((coerce ds) :: Dataset s t Word8)
    GDT_UInt16   -> return $ SomeDataset ((coerce ds) :: Dataset s t Word16)
    GDT_UInt32   -> return $ SomeDataset ((coerce ds) :: Dataset s t Word32)
    GDT_Int16    -> return $ SomeDataset ((coerce ds) :: Dataset s t Int16)
    GDT_Int32    -> return $ SomeDataset ((coerce ds) :: Dataset s t Int32)
    GDT_Float32  -> return $ SomeDataset ((coerce ds) :: Dataset s t Float)
    GDT_Float64  -> return $ SomeDataset ((coerce ds) :: Dataset s t Double)
    GDT_CInt16   -> return $ SomeDataset ((coerce ds) :: Dataset s t (Complex Int16))
    GDT_CInt32   -> return $ SomeDataset ((coerce ds) :: Dataset s t (Complex Int32))
    GDT_CFloat32 -> return $ SomeDataset ((coerce ds) :: Dataset s t (Complex Float))
    GDT_CFloat64 -> return $ SomeDataset ((coerce ds) :: Dataset s t (Complex Double))
    _            -> liftIO (throw InvalidType)

checkType
  :: forall s t a. GDALType a
  => Dataset s t a -> GDAL s (Dataset s t a)
checkType ds = do
  c <- datasetBandCount ds
  if c > 0
    then do
      b <- getBand ds 1
      dt <- bandDatatype b
      if datatype (Proxy :: Proxy a) == dt
        then return ds
        else liftIO (throw InvalidType)
    else return ds

data SomeDataset s (t :: DatasetMode)
  = forall a. GDALType a => SomeDataset (Dataset s t a)

openAnyReadOnly :: forall s. FilePath -> GDAL s (SomeDataset s ReadOnly)
openAnyReadOnly = openAnyWithMode GA_ReadOnly

openAnyReadWrite :: forall s. FilePath -> GDAL s (SomeDataset s ReadWrite)
openAnyReadWrite = openAnyWithMode GA_Update

foreign import ccall safe "gdal.h GDALOpen" open_
   :: CString -> CInt -> IO (Ptr (Dataset s t a))

createCopy' :: GDALType a
  => Driver -> String -> (Dataset s t a) -> Bool -> DriverOptions
  -> ProgressFun -> GDAL s (RWDataset s a)
createCopy' driver path dataset strict options progressFun = do
  d <- driverByName driver
  ptr <- unsafeWithDatasetIO dataset $ \ds -> do
    withCString path $ \p ->
      withProgressFun progressFun $ \pFunc -> do
          let s = fromBool strict
          withOptionList options $ \o ->
              c_createCopy d p ds s o pFunc (castPtr nullPtr)
  newDatasetHandle ptr

createCopy :: GDALType a
  => Driver -> FilePath -> (Dataset s t a) -> Bool -> DriverOptions
  -> GDAL s (RWDataset s a)
createCopy driver path dataset strict options = do
  createCopy' driver path dataset strict options (\_ _ _ -> return 1)

foreign import ccall safe "gdal.h GDALCreateCopy" c_createCopy
  :: DriverH
  -> Ptr CChar
  -> Ptr (Dataset s t a)
  -> CInt
  -> Ptr CString
  -> FunPtr ProgressFun
  -> Ptr ()
  -> IO (Ptr (RWDataset s a))

withProgressFun :: forall c.
  ProgressFun -> (FunPtr ProgressFun -> IO c) -> IO c
withProgressFun = withCCallback wrapProgressFun

withCCallback :: forall c t a.
  (t -> IO (FunPtr a)) -> t -> (FunPtr a -> IO c) -> IO c
withCCallback w f = bracket (w f) freeHaskellFunPtr

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

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

newDatasetHandle :: Ptr (Dataset s t a) -> GDAL s (Dataset s t a)
newDatasetHandle p = GDAL $
    if p==nullPtr
        then liftIO $ throw NullDatasetHandle
        else do _ <- register (c_closeDataset p)
                return $ Dataset p

foreign import ccall "gdal.h GDALClose"
  c_closeDataset :: Ptr (Dataset s t a) -> IO ()

createMem
  :: GDALType a
  => Int -> Int -> Int -> DriverOptions -> GDAL s (Dataset s ReadWrite a)
createMem = create MEM ""

flushCache :: forall s a. RWDataset s a -> GDAL s ()
flushCache = flip unsafeWithDatasetIO flushCache'

foreign import ccall safe "gdal.h GDALFlushCache" flushCache'
  :: Ptr (Dataset s t a) -> IO ()

datasetSize :: Dataset s t a -> GDAL s (Int, Int)
datasetSize ds = unsafeWithDatasetIO ds $ \dPtr -> do
  x <- getDatasetXSize_ dPtr
  y <- getDatasetYSize_ dPtr
  return (fromIntegral x, fromIntegral y)

foreign import ccall unsafe "gdal.h GDALGetRasterXSize" getDatasetXSize_
  :: Ptr (Dataset s t a) -> IO CInt

foreign import ccall unsafe "gdal.h GDALGetRasterYSize" getDatasetYSize_
  :: Ptr (Dataset s t a) -> IO CInt

datasetProjection :: Dataset s t a -> GDAL s String
datasetProjection = flip unsafeWithDatasetIO (\d -> getProjection_ d >>= peekCString)

foreign import ccall unsafe "gdal.h GDALGetProjectionRef" getProjection_
  :: Ptr (Dataset s t a) -> IO (Ptr CChar)

setDatasetProjection :: (RWDataset s a) -> String -> GDAL s ()
setDatasetProjection d p = unsafeWithDatasetIO d $ \d' ->
  throwIfError "setDatasetProjection: could not set projection" $
    withCString p $ \p' -> setProjection' d' p'

foreign import ccall unsafe "gdal.h GDALSetProjection" setProjection'
  :: Ptr (Dataset s t a) -> Ptr CChar -> IO CInt

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

datasetGeotransform :: Dataset s t a -> GDAL s Geotransform
datasetGeotransform d = unsafeWithDatasetIO d $ \dPtr ->
  allocaArray 6 $ \a -> do
    throwIfError "could not get geotransform" $ getGeoTransform 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)

foreign import ccall unsafe "gdal.h GDALGetGeoTransform" getGeoTransform
  :: Ptr (Dataset s t a) -> Ptr CDouble -> IO CInt

setDatasetGeotransform :: (RWDataset s a) -> Geotransform -> GDAL s ()
setDatasetGeotransform ds gt = unsafeWithDatasetIO ds $ \dPtr ->
  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" $ setGeoTransform dPtr a

foreign import ccall unsafe "gdal.h GDALSetGeoTransform" setGeoTransform
  :: Ptr (Dataset s t a) -> Ptr CDouble -> IO CInt

datasetBandCount :: Dataset s t a -> GDAL s Int
datasetBandCount = flip unsafeWithDatasetIO (fmap fromIntegral . bandCount_)

foreign import ccall unsafe "gdal.h GDALGetRasterCount" bandCount_
  :: Ptr (Dataset s t a) -> IO CInt

getBand :: Dataset s t a -> Int -> GDAL s (Band s t a)
getBand ds band = unsafeWithDatasetIO ds $ \dPtr -> do
    rBand@(Band p) <- getRasterBand dPtr (fromIntegral band)
    if p == nullPtr
        then throw (InvalidBand band)
        else return rBand

foreign import ccall unsafe "gdal.h GDALGetRasterBand" getRasterBand
  :: Ptr (Dataset s t a) -> CInt -> IO ((Band s t a))

bandDatatype :: (Band s t a) -> GDAL s Datatype
bandDatatype = fmap toEnumC . liftIO . getDatatype_

foreign import ccall unsafe "gdal.h GDALGetRasterDataType" getDatatype_
  :: (Band s a t) -> IO CInt

bandBlockSize :: (Band s t a) -> GDAL s (Int,Int)
bandBlockSize band = liftIO $ alloca $ \xPtr -> alloca $ \yPtr -> do
   getBlockSize_ band xPtr yPtr
   liftA2 (,) (liftM fromIntegral $ peek xPtr) (liftM fromIntegral $ peek yPtr)

foreign import ccall unsafe "gdal.h GDALGetBlockSize" getBlockSize_
    :: (Band s a t) -> Ptr CInt -> Ptr CInt -> IO ()

bandBlockLen :: (Band s t a) -> GDAL s Int
bandBlockLen = fmap (uncurry (*)) . bandBlockSize

bandSize :: (Band s a t) -> GDAL s (Int, Int)
bandSize band = liftIO $ do
  x <- getBandXSize_ band
  y <- getBandYSize_ band
  return (fromIntegral x, fromIntegral y)

foreign import ccall unsafe "gdal.h GDALGetRasterBandXSize" getBandXSize_
  :: (Band s t a) -> IO CInt

foreign import ccall unsafe "gdal.h GDALGetRasterBandYSize" getBandYSize_
  :: (Band s t a) -> IO CInt

bandNodataValue :: GDALType a => (Band s t a) -> GDAL s (Maybe a)
bandNodataValue b = liftIO $ alloca $ \p -> do
   value <- liftM fromNodata $ getNodata_ b p
   hasNodata <- liftM toBool $ peek p
   return (if hasNodata then Just value else Nothing)

bandNodataPredicate :: GDALType a => (Band s t a) -> GDAL s (a -> Bool)
bandNodataPredicate b = liftIO $ alloca $ \p -> do
  nd <- getNodata_ b p
  hasNodata <- liftM toBool $ peek p
  return (if hasNodata then (==nd) . toNodata else const False)
{-# INLINE bandNodataPredicate #-}

foreign import ccall unsafe "gdal.h GDALGetRasterNoDataValue" getNodata_
   :: (Band s t a) -> Ptr CInt -> IO CDouble

setBandNodataValue :: GDALType a => (RWBand s a) -> a -> GDAL s ()
setBandNodataValue b v = liftIO $ throwIfError "could not set nodata" $
                            setNodata_ b (toNodata v)

foreign import ccall safe "gdal.h GDALSetRasterNoDataValue" setNodata_
    :: (RWBand s t) -> CDouble -> IO CInt

fillBand :: (RWBand s a) -> Double -> Double -> GDAL s ()
fillBand b r i = liftIO $ throwIfError "could not fill band" $
    fillRaster_ b (realToFrac r) (realToFrac i)

foreign import ccall safe "gdal.h GDALFillRaster" fillRaster_
    :: (RWBand s t) -> CDouble -> CDouble -> IO CInt

readBand :: forall s t a. GDALType a
  => (Band s t a)
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> GDAL s (Vector a)
readBand band xoff yoff sx sy bx by = liftIO $
  readBandIO band xoff yoff sx sy bx by

-- | Unsafe lazy IO version of readBand.
--   *must* make sure vectors are evaluated inside the GDAL monad and in the
--   same thread that called 'runGDAL0
unsafeLazyReadBand :: forall s a. GDALType a
  => (ROBand s a)
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> GDAL s (Vector a)
unsafeLazyReadBand band xoff yoff sx sy bx by = liftIO $
  unsafeInterleaveIO $ readBandIO band xoff yoff sx sy bx by

readBandIO :: forall s t a. GDALType a
  => (Band s t a)
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> IO (Vector a)
readBandIO band xoff yoff sx sy bx by = do
    fp <- mallocForeignPtrArray (bx * by)
    let dtype = fromEnumC (datatype (Proxy :: Proxy a))
    withForeignPtr fp $ \ptr -> do
      throwIfError "could not advise read" $
        adviseRead_
          band
          (fromIntegral xoff)
          (fromIntegral yoff)
          (fromIntegral sx)
          (fromIntegral sy)
          (fromIntegral bx)
          (fromIntegral by)
          dtype
          (castPtr nullPtr)
      throwIfError "could not read band" $
        rasterIO_
          band
          (fromEnumC GF_Read)
          (fromIntegral xoff)
          (fromIntegral yoff)
          (fromIntegral sx)
          (fromIntegral sy)
          (castPtr ptr)
          (fromIntegral bx)
          (fromIntegral by)
          dtype
          0
          0
    return $ unsafeFromForeignPtr0 fp (bx * by)

foreign import ccall safe "gdal.h GDALRasterAdviseRead" adviseRead_
    :: (Band s a t) -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt
    -> Ptr (Ptr CChar) -> IO CInt

writeBand :: forall s a. GDALType a
  => (RWBand s a)
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Vector a
  -> GDAL s ()
writeBand band xoff yoff sx sy bx by vec = liftIO $ do
    let nElems    = bx * by
        (fp, len) = unsafeToForeignPtr0 vec
    if nElems /= len
      then throw $ InvalidRasterSize bx by
      else withForeignPtr fp $ \ptr -> do
        throwIfError "could not write band" $
          rasterIO_
            band
            (fromEnumC GF_Write)
            (fromIntegral xoff)
            (fromIntegral yoff)
            (fromIntegral sx)
            (fromIntegral sy)
            (castPtr ptr)
            (fromIntegral bx)
            (fromIntegral by)
            (fromEnumC (datatype (Proxy :: Proxy a)))
            0
            0

foreign import ccall safe "gdal.h GDALRasterIO" rasterIO_
  :: (Band s a t) -> CInt -> CInt -> CInt -> CInt -> CInt -> Ptr () -> CInt -> CInt
  -> CInt -> CInt -> CInt -> IO CInt

readBandBlock
  :: forall s t a. GDALType a
  => Band s t a -> Int -> Int -> GDAL s (Vector a)
readBandBlock b x y = do
  len <- bandBlockLen b
  liftIO $ do
    f <- mallocForeignPtrArray len
    withForeignPtr f $ \ptr ->
      throwIfError "could not read block" $
        readBlock_ b (fromIntegral x) (fromIntegral y) (castPtr ptr)
    return $ unsafeFromForeignPtr0 f len

foreign import ccall safe "gdal.h GDALReadBlock" readBlock_
    :: (Band s a t) -> CInt -> CInt -> Ptr () -> IO CInt

writeBandBlock
  :: forall s a. GDALType a
  => RWBand s a -> Int -> Int -> Vector a -> GDAL s ()
writeBandBlock b x y vec = do
  nElems <- bandBlockLen b
  liftIO $ do
    let (fp, len) = unsafeToForeignPtr0 vec
    if nElems /= len
      then throw InvalidBlockSize
      else withForeignPtr fp $ \ptr ->
           throwIfError "could not write block" $
              writeBlock_ b (fromIntegral x) (fromIntegral y)
                            (castPtr ptr)

foreign import ccall safe "gdal.h GDALWriteBlock" writeBlock_
   :: (RWBand s a) -> CInt -> CInt -> Ptr () -> IO CInt

foreign import ccall safe "gdal.h GDALGetMaskBand" c_getMaskBand
   :: (Band s t a) -> IO (Band s t Word8)

getMaskBand :: Band s t a -> GDAL s (Band s t Word8)
getMaskBand = liftIO . c_getMaskBand

class Storable a => GDALType a where
  datatype   :: Proxy a -> Datatype
  toNodata   :: a -> CDouble
  fromNodata :: CDouble -> a

instance GDALType Word8 where
  datatype _ = GDT_Byte
  toNodata = fromIntegral
  fromNodata = round
  {-# INLINE datatype #-}
  {-# INLINE toNodata #-}
  {-# INLINE fromNodata #-}

instance GDALType Word16 where
  datatype _ = GDT_UInt16
  toNodata = fromIntegral
  fromNodata = round
  {-# INLINE datatype #-}
  {-# INLINE toNodata #-}
  {-# INLINE fromNodata #-}

instance GDALType Word32 where
  datatype _ = GDT_UInt32
  toNodata = fromIntegral
  fromNodata = round
  {-# INLINE datatype #-}
  {-# INLINE toNodata #-}
  {-# INLINE fromNodata #-}

instance GDALType Int16 where
  datatype _ = GDT_Int16
  toNodata = fromIntegral
  fromNodata = round
  {-# INLINE datatype #-}
  {-# INLINE toNodata #-}
  {-# INLINE fromNodata #-}

instance GDALType Int32 where
  datatype _ = GDT_Int32
  toNodata = fromIntegral
  fromNodata = round
  {-# INLINE datatype #-}
  {-# INLINE toNodata #-}
  {-# INLINE fromNodata #-}

instance GDALType Float where
  datatype _ = GDT_Float32
  toNodata = realToFrac
  fromNodata = realToFrac
  {-# INLINE datatype #-}
  {-# INLINE toNodata #-}
  {-# INLINE fromNodata #-}

instance GDALType Double where
  datatype _ = GDT_Float64
  toNodata = realToFrac
  fromNodata = realToFrac
  {-# INLINE datatype #-}
  {-# INLINE toNodata #-}
  {-# INLINE fromNodata #-}

instance GDALType (Complex Int16) where
  datatype _ = GDT_CInt16
  toNodata = fromIntegral . realPart
  fromNodata d = fromNodata d :+ fromNodata d
  {-# INLINE datatype #-}
  {-# INLINE toNodata #-}
  {-# INLINE fromNodata #-}

instance GDALType (Complex Int32) where
  datatype _ = GDT_CInt32
  toNodata = fromIntegral . realPart
  fromNodata d = fromNodata d :+ fromNodata d
  {-# INLINE datatype #-}
  {-# INLINE toNodata #-}
  {-# INLINE fromNodata #-}

instance GDALType (Complex Float) where
  datatype _ = GDT_CFloat32
  toNodata = realToFrac . realPart
  fromNodata d = fromNodata d :+ fromNodata d
  {-# INLINE datatype #-}
  {-# INLINE toNodata #-}
  {-# INLINE fromNodata #-}

instance GDALType (Complex Double) where
  datatype _ = GDT_CFloat64
  toNodata = realToFrac . realPart
  fromNodata d = fromNodata d :+ fromNodata d
  {-# INLINE datatype #-}
  {-# INLINE toNodata #-}
  {-# INLINE fromNodata #-}

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module OSGeo.GDAL.Internal (
    GDAL
  , runGDAL
  , GDALType
  , Datatype (..)
  , GDALException (..)
  , isGDALException
  , Geotransform (..)
  , DriverOptions
  , Driver (..)
  , Dataset
  , SomeDataset (..)
  , ReadWrite
  , ReadOnly
  , RWDataset
  , RODataset
  , RWBand
  , ROBand
  , Band

  , setQuietErrorHandler

  , registerAllDrivers
  , destroyDriverManager
  , create
  , createMem
  , flushCache
  , openReadOnly
  , openReadWrite
  , openAnyReadOnly
  , openAnyReadWrite
  , createCopy

  , datatypeSize
  , datatypeByName
  , datatypeUnion
  , datatypeIsComplex

  , datasetSize
  , datasetProjection
  , setDatasetProjection
  , datasetGeotransform
  , setDatasetGeotransform
  , datasetBandCount

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

  -- Internal Util
  , throwIfError
  , unsafeWithDataset
  , unsafeWithBand
) where

import Control.Applicative (liftA2, (<$>), (<*>))
import Control.Exception ( bracket, throw, Exception(..), SomeException
                         , evaluate)
import Control.DeepSeq (NFData, force)
import Control.Monad (liftM, foldM)
import Control.Monad.Trans.Resource (ResourceT, runResourceT, register)
import Control.Monad.IO.Class (MonadIO(..))

import Data.Int (Int16, Int32)
import Data.Complex (Complex(..))
import Data.Maybe (isJust)
import Data.Proxy (Proxy(..))
import Data.Typeable (Typeable)
import Data.Word (Word8, Word16, Word32)
import Data.Vector.Storable (Vector, unsafeFromForeignPtr0, unsafeToForeignPtr0)
import Data.Coerce (coerce)
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 (withForeignPtr, mallocForeignPtrArray)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Array (allocaArray)
import Foreign.Marshal.Utils (toBool, fromBool)

import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO)
import System.Process (readProcess)
import Data.Char (toUpper)

import OSGeo.Util

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

$(let names = fmap (words . map toUpper) $
                readProcess "gdal-config" ["--formats"] ""
  in createEnum "Driver" names)

newtype GDAL s a = GDAL (ResourceT IO a)

deriving instance Functor (GDAL s)
deriving instance Applicative (GDAL s)
deriving instance Monad (GDAL s)
deriving instance MonadIO (GDAL s)

runGDAL :: NFData a => (forall s. GDAL s a) -> IO a
runGDAL (GDAL a) = do
  registerAllDrivers
  runResourceT (a >>= liftIO . evaluate . force)

data GDALException = Unknown !Error !String
                   | InvalidType
                   | InvalidRasterSize !Int !Int
                   | InvalidBlockSize
                   | DriverLoadError
                   | NullDatasetHandle
                   | InvalidBand !Int
     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)

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 $ Unknown 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) #}

{#pointer GDALDatasetH as Dataset foreign newtype nocode#}

data DatasetMode = ReadOnly | ReadWrite

type ReadOnly  = 'ReadOnly
type ReadWrite = 'ReadWrite

newtype Dataset s (t::DatasetMode) a = Dataset (Ptr (Dataset s t a))

unsafeWithDataset
  :: Dataset s t a -> (Ptr (Dataset s t a) -> GDAL s b) -> GDAL s b
unsafeWithDataset (Dataset p) f = f p

unsafeWithDatasetIO
  :: Dataset s t a -> (Ptr (Dataset s t a) -> IO b) -> GDAL s b
unsafeWithDatasetIO ds f = unsafeWithDataset ds (liftIO . f)

type RODataset s = Dataset s ReadOnly
type RWDataset s = Dataset s ReadWrite

{#pointer GDALRasterBandH as Band newtype nocode#}
newtype (Band s (t::DatasetMode) a) = Band (Ptr (Band s t a))

unsafeWithBand
  :: Band s t a -> (Ptr (Band s t a) -> GDAL s b) -> GDAL s b
unsafeWithBand (Band p) f = f p

type ROBand s = Band s ReadOnly
type RWBand s = Band s ReadWrite

{#pointer GDALDriverH as DriverH newtype#}

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

{#fun GDALDestroyDriverManager as destroyDriverManager {} -> `()'#}

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

driverByName :: Driver -> GDAL s DriverH
driverByName s = GDAL $ liftIO $ do
    driver@(DriverH ptr) <- c_driverByName (show s)
    if ptr==nullPtr
        then throw DriverLoadError
        else return driver

type DriverOptions = [(String,String)]

create
  :: forall s a. GDALType a
  => Driver -> String -> Int -> Int -> Int -> DriverOptions
  -> GDAL s (Dataset s ReadWrite a)
create drv path nx ny bands options = do
  d <- driverByName drv
  ptr <- liftIO $ withCString path $ \path' -> do
    let nx'    = fromIntegral nx
        ny'    = fromIntegral ny
        bands' = fromIntegral bands
        dtype' = fromEnumC $ datatype (Proxy :: Proxy a)
    withOptionList options $ \opts ->
        c_create d path' nx' ny' bands' dtype' opts
  newDatasetHandle ptr

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

foreign import ccall safe "gdal.h GDALCreate" c_create
  :: DriverH
  -> CString
  -> CInt
  -> CInt
  -> CInt
  -> CInt
  -> Ptr CString
  -> IO (Ptr (RWDataset s a))

openReadOnly :: GDALType a => FilePath -> GDAL s (RODataset s a)
openReadOnly p = openWithMode GA_ReadOnly p >>= checkType

openReadWrite :: GDALType a => FilePath -> GDAL s (RWDataset s a)
openReadWrite p = openWithMode GA_Update p >>= checkType

openWithMode :: Access -> String -> GDAL s (Dataset s t a)
openWithMode m p =
  liftIO (withCString p $ \p' -> open_ p' (fromEnumC m)) >>= newDatasetHandle

openAnyWithMode :: forall s t. Access -> String -> GDAL s (SomeDataset s t)
openAnyWithMode m p = do
  ds <- openWithMode m p
  dt <- getBand ds 1 >>= bandDatatype
  case dt of
    GDT_Byte     -> return $ SomeDataset ((coerce ds) :: Dataset s t Word8)
    GDT_UInt16   -> return $ SomeDataset ((coerce ds) :: Dataset s t Word16)
    GDT_UInt32   -> return $ SomeDataset ((coerce ds) :: Dataset s t Word32)
    GDT_Int16    -> return $ SomeDataset ((coerce ds) :: Dataset s t Int16)
    GDT_Int32    -> return $ SomeDataset ((coerce ds) :: Dataset s t Int32)
    GDT_Float32  -> return $ SomeDataset ((coerce ds) :: Dataset s t Float)
    GDT_Float64  -> return $ SomeDataset ((coerce ds) :: Dataset s t Double)
    GDT_CInt16   -> return $ SomeDataset ((coerce ds) :: Dataset s t (Complex Int16))
    GDT_CInt32   -> return $ SomeDataset ((coerce ds) :: Dataset s t (Complex Int32))
    GDT_CFloat32 -> return $ SomeDataset ((coerce ds) :: Dataset s t (Complex Float))
    GDT_CFloat64 -> return $ SomeDataset ((coerce ds) :: Dataset s t (Complex Double))
    _            -> liftIO (throw InvalidType)

checkType
  :: forall s t a. GDALType a
  => Dataset s t a -> GDAL s (Dataset s t a)
checkType ds = do
  c <- datasetBandCount ds
  if c > 0
    then do
      b <- getBand ds 1
      dt <- bandDatatype b
      if datatype (Proxy :: Proxy a) == dt
        then return ds
        else liftIO (throw InvalidType)
    else return ds

data SomeDataset s (t :: DatasetMode)
  = forall a. GDALType a => SomeDataset (Dataset s t a)

openAnyReadOnly :: forall s. FilePath -> GDAL s (SomeDataset s ReadOnly)
openAnyReadOnly = openAnyWithMode GA_ReadOnly

openAnyReadWrite :: forall s. FilePath -> GDAL s (SomeDataset s ReadWrite)
openAnyReadWrite = openAnyWithMode GA_Update

foreign import ccall safe "gdal.h GDALOpen" open_
   :: CString -> CInt -> IO (Ptr (Dataset s t a))

createCopy' :: GDALType a
  => Driver -> String -> (Dataset s t a) -> Bool -> DriverOptions
  -> ProgressFun -> GDAL s (RWDataset s a)
createCopy' driver path dataset strict options progressFun = do
  d <- driverByName driver
  ptr <- unsafeWithDatasetIO dataset $ \ds -> do
    withCString path $ \p ->
      withProgressFun progressFun $ \pFunc -> do
          let s = fromBool strict
          withOptionList options $ \o ->
              c_createCopy d p ds s o pFunc (castPtr nullPtr)
  newDatasetHandle ptr

createCopy :: GDALType a
  => Driver -> FilePath -> (Dataset s t a) -> Bool -> DriverOptions
  -> GDAL s (RWDataset s a)
createCopy driver path dataset strict options = do
  createCopy' driver path dataset strict options (\_ _ _ -> return 1)

foreign import ccall safe "gdal.h GDALCreateCopy" c_createCopy
  :: DriverH
  -> Ptr CChar
  -> Ptr (Dataset s t a)
  -> CInt
  -> Ptr CString
  -> FunPtr ProgressFun
  -> Ptr ()
  -> IO (Ptr (RWDataset s a))

withProgressFun :: forall c.
  ProgressFun -> (FunPtr ProgressFun -> IO c) -> IO c
withProgressFun = withCCallback wrapProgressFun

withCCallback :: forall c t a.
  (t -> IO (FunPtr a)) -> t -> (FunPtr a -> IO c) -> IO c
withCCallback w f = bracket (w f) freeHaskellFunPtr

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

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

newDatasetHandle :: Ptr (Dataset s t a) -> GDAL s (Dataset s t a)
newDatasetHandle p = GDAL $
    if p==nullPtr
        then liftIO $ throw NullDatasetHandle
        else do _ <- register (c_closeDataset p)
                return $ Dataset p

foreign import ccall "gdal.h GDALClose"
  c_closeDataset :: Ptr (Dataset s t a) -> IO ()

createMem
  :: GDALType a
  => Int -> Int -> Int -> DriverOptions -> GDAL s (Dataset s ReadWrite a)
createMem = create MEM ""

flushCache :: forall s a. RWDataset s a -> GDAL s ()
flushCache = flip unsafeWithDatasetIO flushCache'

foreign import ccall safe "gdal.h GDALFlushCache" flushCache'
  :: Ptr (Dataset s t a) -> IO ()

datasetSize :: Dataset s t a -> GDAL s (Int, Int)
datasetSize ds = unsafeWithDatasetIO ds $ \dPtr -> do
  x <- getDatasetXSize_ dPtr
  y <- getDatasetYSize_ dPtr
  return (fromIntegral x, fromIntegral y)

foreign import ccall unsafe "gdal.h GDALGetRasterXSize" getDatasetXSize_
  :: Ptr (Dataset s t a) -> IO CInt

foreign import ccall unsafe "gdal.h GDALGetRasterYSize" getDatasetYSize_
  :: Ptr (Dataset s t a) -> IO CInt

datasetProjection :: Dataset s t a -> GDAL s String
datasetProjection = flip unsafeWithDatasetIO (\d -> getProjection_ d >>= peekCString)

foreign import ccall unsafe "gdal.h GDALGetProjectionRef" getProjection_
  :: Ptr (Dataset s t a) -> IO (Ptr CChar)

setDatasetProjection :: (RWDataset s a) -> String -> GDAL s ()
setDatasetProjection d p = unsafeWithDatasetIO d $ \d' ->
  throwIfError "setDatasetProjection: could not set projection" $
    withCString p $ \p' -> setProjection' d' p'

foreign import ccall unsafe "gdal.h GDALSetProjection" setProjection'
  :: Ptr (Dataset s t a) -> Ptr CChar -> IO CInt

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

datasetGeotransform :: Dataset s t a -> GDAL s Geotransform
datasetGeotransform d = unsafeWithDatasetIO d $ \dPtr ->
  allocaArray 6 $ \a -> do
    throwIfError "could not get geotransform" $ getGeoTransform 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)

foreign import ccall unsafe "gdal.h GDALGetGeoTransform" getGeoTransform
  :: Ptr (Dataset s t a) -> Ptr CDouble -> IO CInt

setDatasetGeotransform :: (RWDataset s a) -> Geotransform -> GDAL s ()
setDatasetGeotransform ds gt = unsafeWithDatasetIO ds $ \dPtr ->
  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" $ setGeoTransform dPtr a

foreign import ccall unsafe "gdal.h GDALSetGeoTransform" setGeoTransform
  :: Ptr (Dataset s t a) -> Ptr CDouble -> IO CInt

datasetBandCount :: Dataset s t a -> GDAL s Int
datasetBandCount = flip unsafeWithDatasetIO (fmap fromIntegral . bandCount_)

foreign import ccall unsafe "gdal.h GDALGetRasterCount" bandCount_
  :: Ptr (Dataset s t a) -> IO CInt

getBand :: Dataset s t a -> Int -> GDAL s (Band s t a)
getBand ds band = unsafeWithDatasetIO ds $ \dPtr -> do
    rBand@(Band p) <- getRasterBand dPtr (fromIntegral band)
    if p == nullPtr
        then throw (InvalidBand band)
        else return rBand

foreign import ccall unsafe "gdal.h GDALGetRasterBand" getRasterBand
  :: Ptr (Dataset s t a) -> CInt -> IO ((Band s t a))

bandDatatype :: (Band s t a) -> GDAL s Datatype
bandDatatype = fmap toEnumC . liftIO . getDatatype_

foreign import ccall unsafe "gdal.h GDALGetRasterDataType" getDatatype_
  :: (Band s a t) -> IO CInt

bandBlockSize :: (Band s t a) -> GDAL s (Int,Int)
bandBlockSize band = liftIO $ alloca $ \xPtr -> alloca $ \yPtr -> do
   getBlockSize_ band xPtr yPtr
   liftA2 (,) (liftM fromIntegral $ peek xPtr) (liftM fromIntegral $ peek yPtr)

foreign import ccall unsafe "gdal.h GDALGetBlockSize" getBlockSize_
    :: (Band s a t) -> Ptr CInt -> Ptr CInt -> IO ()

bandBlockLen :: (Band s t a) -> GDAL s Int
bandBlockLen = fmap (uncurry (*)) . bandBlockSize

bandSize :: (Band s a t) -> GDAL s (Int, Int)
bandSize band = liftIO $ do
  x <- getBandXSize_ band
  y <- getBandYSize_ band
  return (fromIntegral x, fromIntegral y)

foreign import ccall unsafe "gdal.h GDALGetRasterBandXSize" getBandXSize_
  :: (Band s t a) -> IO CInt

foreign import ccall unsafe "gdal.h GDALGetRasterBandYSize" getBandYSize_
  :: (Band s t a) -> IO CInt

bandNodataValue :: (Band s t a) -> GDAL s (Maybe Double)
bandNodataValue b = liftIO $ alloca $ \p -> do
   value <- liftM realToFrac $ getNodata_ b p
   hasNodata <- liftM toBool $ peek p
   return (if hasNodata then Just value else Nothing)

foreign import ccall unsafe "gdal.h GDALGetRasterNoDataValue" getNodata_
   :: (Band s t a) -> Ptr CInt -> IO CDouble

setBandNodataValue :: (RWBand s a) -> Double -> GDAL s ()
setBandNodataValue b v = liftIO $ throwIfError "could not set nodata" $
                            setNodata_ b (realToFrac v)

foreign import ccall safe "gdal.h GDALSetRasterNoDataValue" setNodata_
    :: (RWBand s t) -> CDouble -> IO CInt

fillBand :: (RWBand s a) -> Double -> Double -> GDAL s ()
fillBand b r i = liftIO $ throwIfError "could not fill band" $
    fillRaster_ b (realToFrac r) (realToFrac i)

foreign import ccall safe "gdal.h GDALFillRaster" fillRaster_
    :: (RWBand s t) -> CDouble -> CDouble -> IO CInt

readBand :: forall s t a. GDALType a
  => (Band s t a)
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> GDAL s (Vector a)
readBand band xoff yoff sx sy bx by = liftIO $
  readBandIO band xoff yoff sx sy bx by

-- | Unsafe lazy IO version of readBand.
--   *must* make sure vectors are evaluated inside the GDAL monad and in the
--   same thread that called 'runGDAL0
unsafeLazyReadBand :: forall s a. GDALType a
  => (ROBand s a)
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> GDAL s (Vector a)
unsafeLazyReadBand band xoff yoff sx sy bx by = liftIO $
  unsafeInterleaveIO $ readBandIO band xoff yoff sx sy bx by

readBandIO :: forall s t a. GDALType a
  => (Band s t a)
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> IO (Vector a)
readBandIO band xoff yoff sx sy bx by = do
    fp <- mallocForeignPtrArray (bx * by)
    let dtype = fromEnumC (datatype (Proxy :: Proxy a))
    withForeignPtr fp $ \ptr -> do
      throwIfError "could not advise read" $
        adviseRead_
          band
          (fromIntegral xoff)
          (fromIntegral yoff)
          (fromIntegral sx)
          (fromIntegral sy)
          (fromIntegral bx)
          (fromIntegral by)
          dtype
          (castPtr nullPtr)
      throwIfError "could not read band" $
        rasterIO_
          band
          (fromEnumC GF_Read)
          (fromIntegral xoff)
          (fromIntegral yoff)
          (fromIntegral sx)
          (fromIntegral sy)
          (castPtr ptr)
          (fromIntegral bx)
          (fromIntegral by)
          dtype
          0
          0
    return $ unsafeFromForeignPtr0 fp (bx * by)

foreign import ccall safe "gdal.h GDALRasterAdviseRead" adviseRead_
    :: (Band s a t) -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt
    -> Ptr (Ptr CChar) -> IO CInt

writeBand :: forall s a. GDALType a
  => (RWBand s a)
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Vector a
  -> GDAL s ()
writeBand band xoff yoff sx sy bx by vec = liftIO $ do
    let nElems    = bx * by
        (fp, len) = unsafeToForeignPtr0 vec
    if nElems /= len
      then throw $ InvalidRasterSize bx by
      else withForeignPtr fp $ \ptr -> do
        throwIfError "could not write band" $
          rasterIO_
            band
            (fromEnumC GF_Write)
            (fromIntegral xoff)
            (fromIntegral yoff)
            (fromIntegral sx)
            (fromIntegral sy)
            (castPtr ptr)
            (fromIntegral bx)
            (fromIntegral by)
            (fromEnumC (datatype (Proxy :: Proxy a)))
            0
            0

foreign import ccall safe "gdal.h GDALRasterIO" rasterIO_
  :: (Band s a t) -> CInt -> CInt -> CInt -> CInt -> CInt -> Ptr () -> CInt -> CInt
  -> CInt -> CInt -> CInt -> IO CInt

readBandBlock
  :: forall s t a. GDALType a
  => Band s t a -> Int -> Int -> GDAL s (Vector a)
readBandBlock b x y = do
  len <- bandBlockLen b
  liftIO $ do
    f <- mallocForeignPtrArray len
    withForeignPtr f $ \ptr ->
      throwIfError "could not read block" $
        readBlock_ b (fromIntegral x) (fromIntegral y) (castPtr ptr)
    return $ unsafeFromForeignPtr0 f len

foreign import ccall safe "gdal.h GDALReadBlock" readBlock_
    :: (Band s a t) -> CInt -> CInt -> Ptr () -> IO CInt

writeBandBlock
  :: forall s a. GDALType a
  => RWBand s a -> Int -> Int -> Vector a -> GDAL s ()
writeBandBlock b x y vec = do
  nElems <- bandBlockLen b
  liftIO $ do
    let (fp, len) = unsafeToForeignPtr0 vec
    if nElems /= len
      then throw InvalidBlockSize
      else withForeignPtr fp $ \ptr ->
           throwIfError "could not write block" $
              writeBlock_ b (fromIntegral x) (fromIntegral y)
                            (castPtr ptr)

foreign import ccall safe "gdal.h GDALWriteBlock" writeBlock_
   :: (RWBand s a) -> CInt -> CInt -> Ptr () -> IO CInt

class Storable a => GDALType a where
  datatype :: Proxy a -> Datatype

instance GDALType Word8  where datatype _ = GDT_Byte
instance GDALType Word16 where datatype _ = GDT_UInt16
instance GDALType Word32 where datatype _ = GDT_UInt32
instance GDALType Int16  where datatype _ = GDT_Int16
instance GDALType Int32  where datatype _ = GDT_Int32
instance GDALType Float  where datatype _ = GDT_Float32
instance GDALType Double where datatype _ = GDT_Float64
instance GDALType (Complex Int16) where datatype _ = GDT_CInt16
instance GDALType (Complex Int32) where datatype _ = GDT_CInt32
instance GDALType (Complex Float) where datatype _ = GDT_CFloat32
instance GDALType (Complex Double) where datatype _ = GDT_CFloat64


gstreamer: fix marshaling on Structure where GValues weren't initialized properly reported/fixed by Oleg Belozeorov <upwawet@gmail.com>

--  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.Structure (
  Structure,
  structureEmpty,
  structureToString,
  structureFromString,
  structureName,
  structureHasName,
  structureGetBool,
  structureGetInt,
  structureGetFourCC,
  structureGetDouble,
  structureGetString,
  structureGetDate,
  structureGetClockTime,
  structureGetFraction,

  StructureM,
  structureCreate,
  structureModify,
  structureSetNameM,
  structureRemoveFieldM,
  structureSetBoolM,
  structureSetIntM,
  structureSetFourCCM,
  structureSetDoubleM,
  structureSetStringM,
  structureSetDateM,
  structureSetClockTimeM,
  structureSetFractionM,
  structureFixateFieldNearestIntM,
  structureFixateFieldNearestDoubleM,
  structureFixateFieldNearestFractionM,
  structureFixateFieldBoolM
  ) where

import Data.Ratio ( (%)
                  , numerator
                  , denominator )
import Control.Monad (liftM)
{#import Media.Streaming.GStreamer.Core.Types#}
import System.Glib.UTFString
import System.Glib.FFI
import System.Glib.GTypeConstants
{#import System.Glib.GDateTime#}
{#import System.Glib.GType#}
{#import System.Glib.GValue#}
{#import System.Glib.GValueTypes#}

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

structureEmpty :: String
               -> Structure
structureEmpty name =
    unsafePerformIO $
        withUTFString name {# call structure_empty_new #} >>=
            takeStructure

structureToString :: Structure
                  -> String
structureToString structure =
    unsafePerformIO $
        {# call structure_to_string #} structure >>=
            readUTFString

structureFromString :: String
                    -> (Maybe Structure, Int)
structureFromString string =
    unsafePerformIO $
        withUTFString string $ \cString ->
            alloca $ \endPtr ->
                do structure <- {# call structure_from_string #} cString endPtr >>=
                                    maybePeek takeStructure
                   end <- peek endPtr
                   offset <- {# call g_utf8_pointer_to_offset #} cString end
                   return (structure, fromIntegral offset)

structureName :: Structure
              -> String
structureName structure =
    unsafePerformIO $
        {# call structure_get_name #} structure >>=
            peekUTFString

structureHasName :: Structure
                 -> String
                 -> Bool
structureHasName structure name =
    toBool $ unsafePerformIO $
        withUTFString name $
             {# call structure_has_name #} structure

marshalStructureGet :: Storable a
                    => (Structure -> CString -> Ptr a -> IO {# type gboolean #})
                    -> (a -> IO b)
                    -> Structure
                    -> String
                    -> Maybe b
marshalStructureGet getAction convert structure fieldname =
    unsafePerformIO $
        alloca $ \ptr ->
            withUTFString fieldname $ \cFieldname ->
                do result <- getAction structure cFieldname ptr
                   if toBool result
                       then liftM Just $ peek (castPtr ptr) >>= convert
                       else return Nothing

structureGetBool :: Structure
                 -> String
                 -> Maybe Bool
structureGetBool =
    marshalStructureGet {# call structure_get_boolean #} $
        return . toBool

structureGetInt :: Structure
                -> String
                -> Maybe Int
structureGetInt =
    marshalStructureGet {# call structure_get_int #} $
        return . fromIntegral

structureGetFourCC :: Structure
                   -> String
                   -> Maybe FourCC
structureGetFourCC =
    marshalStructureGet {# call structure_get_fourcc #} $
        return . fromIntegral

structureGetDouble :: Structure
                   -> String
                   -> Maybe Double
structureGetDouble =
    marshalStructureGet {# call structure_get_double #} $
        return . realToFrac

structureGetString :: Structure
                   -> String
                   -> Maybe String
structureGetString structure fieldname =
    unsafePerformIO $
        (withUTFString fieldname $ {# call structure_get_string #} structure) >>=
            maybePeek peekUTFString

structureGetDate :: Structure
                 -> String
                 -> Maybe GDate
structureGetDate =
    marshalStructureGet {# call structure_get_date #} $
        peek . castPtr

structureGetClockTime :: Structure
                      -> String
                      -> Maybe ClockTime
structureGetClockTime =
    marshalStructureGet {# call structure_get_clock_time #} $
        return . fromIntegral

structureGetFraction :: Structure
                     -> String
                     -> Maybe Fraction
structureGetFraction structure fieldname =
    unsafePerformIO $
        alloca $ \numPtr -> alloca $ \denPtr ->
            withUTFString fieldname $ \cFieldname ->
                do result <- {# call structure_get_fraction #} structure cFieldname numPtr denPtr
                   if toBool result
                       then do num <- peek numPtr
                               den <- peek denPtr
                               return $ Just $ (fromIntegral num) % (fromIntegral den)
                       else return Nothing

marshalStructureModify :: IO (Ptr Structure)
                       -> StructureM a
                       -> (Structure, a)
marshalStructureModify mkStructure (StructureM action) =
    unsafePerformIO $
        do ptr <- mkStructure
           structure <- liftM Structure $ newForeignPtr_ ptr
           result <- action structure
           structure' <- takeStructure ptr
           return (structure', result)

structureCreate :: String
                -> StructureM a
                -> (Structure, a)
structureCreate name action =
    marshalStructureModify
        (withUTFString name {# call structure_empty_new #})
        action

structureModify :: Structure
                -> StructureM a
                -> (Structure, a)
structureModify structure action =
    marshalStructureModify
        ({# call structure_copy #} structure)
        action

structureSetNameM :: String
                  -> StructureM ()
structureSetNameM name =
    StructureM $ \structure ->
        withUTFString name $ {# call structure_set_name #} structure

structureRemoveFieldM :: String
                      -> StructureM ()
structureRemoveFieldM name =
    StructureM $ \structure ->
        withUTFString name $ {# call structure_remove_field #} structure

marshalStructureSetM :: GType
                     -> (GValue -> a -> IO ())
                     -> String
                     -> a
                     -> StructureM ()
marshalStructureSetM valueType setGValue fieldname value =
    StructureM $ \structure ->
        withUTFString fieldname $ \cFieldname ->
        allocaGValue $ \gValue ->
            do valueInit gValue valueType
               setGValue gValue value
               {# call structure_set_value #} structure cFieldname gValue

structureSetBoolM :: String
                  -> Bool
                  -> StructureM ()
structureSetBoolM =
    marshalStructureSetM bool valueSetBool

structureSetIntM :: String
                 -> Int
                 -> StructureM ()
structureSetIntM =
    marshalStructureSetM int valueSetInt

structureSetFourCCM :: String
                    -> FourCC
                    -> StructureM ()
structureSetFourCCM =
    marshalStructureSetM fourcc $ \gValue fourcc ->
        {# call value_set_fourcc #} gValue $ fromIntegral fourcc

structureSetDoubleM :: String
                    -> Double
                    -> StructureM ()
structureSetDoubleM =
    marshalStructureSetM double valueSetDouble

structureSetStringM :: String
                    -> String
                    -> StructureM ()
structureSetStringM =
    marshalStructureSetM string valueSetString

structureSetDateM :: String
                  -> GDate
                  -> StructureM ()
structureSetDateM =
    marshalStructureSetM date $ \gValue date ->
        with date $ ({# call value_set_date #} gValue) . castPtr

structureSetClockTimeM :: String
                       -> ClockTime
                       -> StructureM ()
structureSetClockTimeM =
    marshalStructureSetM uint64 $ \gValue clockTime ->
        {# call g_value_set_uint64 #} gValue $ fromIntegral clockTime

structureSetFractionM :: String
                      -> Fraction
                      -> StructureM ()
structureSetFractionM =
    marshalStructureSetM fraction $ \gValue fraction ->
        {# call value_set_fraction #} gValue
                                      (fromIntegral $ numerator fraction)
                                      (fromIntegral $ denominator fraction)

marshalStructureFixateM :: (Structure -> CString -> a -> IO {# type gboolean #})
                        -> String
                        -> a
                        -> StructureM Bool
marshalStructureFixateM fixate fieldname target =
    StructureM $ \structure ->
        withUTFString fieldname $ \cFieldname ->
            liftM toBool $
                fixate structure cFieldname target

structureFixateFieldNearestIntM :: String
                                -> Int
                                -> StructureM Bool
structureFixateFieldNearestIntM =
    marshalStructureFixateM $ \structure cFieldname target ->
        {# call structure_fixate_field_nearest_int #}
            structure
            cFieldname
            (fromIntegral target)

structureFixateFieldNearestDoubleM :: String
                                   -> Double
                                   -> StructureM Bool
structureFixateFieldNearestDoubleM =
    marshalStructureFixateM $ \structure cFieldname target ->
        {# call structure_fixate_field_nearest_double #}
            structure
            cFieldname
            (realToFrac target)

structureFixateFieldNearestFractionM :: String
                                     -> Fraction
                                     -> StructureM Bool
structureFixateFieldNearestFractionM =
    marshalStructureFixateM $ \structure cFieldname target ->
                {# call structure_fixate_field_nearest_fraction #}
                    structure
                    cFieldname
                    (fromIntegral $ numerator target)
                    (fromIntegral $ denominator target)

structureFixateFieldBoolM :: String
                          -> Bool
                          -> StructureM Bool
structureFixateFieldBoolM =
    marshalStructureFixateM $ \structure cFieldname target ->
                {# call structure_fixate_field_boolean #}
                    structure
                    cFieldname
                    (fromBool target)

fourcc = {# call fun fourcc_get_type #}
date = {# call fun date_get_type #}
fraction = {# call fun fraction_get_type #}

--  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.Structure (
  Structure,
  structureEmpty,
  structureToString,
  structureFromString,
  structureName,
  structureHasName,
  structureGetBool,
  structureGetInt,
  structureGetFourCC,
  structureGetDouble,
  structureGetString,
  structureGetDate,
  structureGetClockTime,
  structureGetFraction,

  StructureM,
  structureCreate,
  structureModify,
  structureSetNameM,
  structureRemoveFieldM,
  structureSetBoolM,
  structureSetIntM,
  structureSetFourCCM,
  structureSetDoubleM,
  structureSetStringM,
  structureSetDateM,
  structureSetClockTimeM,
  structureSetFractionM,
  structureFixateFieldNearestIntM,
  structureFixateFieldNearestDoubleM,
  structureFixateFieldNearestFractionM,
  structureFixateFieldBoolM
  ) where

import Data.Ratio ( (%)
                  , numerator
                  , denominator )
import Control.Monad (liftM)
{#import Media.Streaming.GStreamer.Core.Types#}
import System.Glib.UTFString
import System.Glib.FFI
{#import System.Glib.GDateTime#}
{#import System.Glib.GValue#}
{#import System.Glib.GValueTypes#}

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

structureEmpty :: String
               -> Structure
structureEmpty name =
    unsafePerformIO $
        withUTFString name {# call structure_empty_new #} >>=
            takeStructure

structureToString :: Structure
                  -> String
structureToString structure =
    unsafePerformIO $
        {# call structure_to_string #} structure >>=
            readUTFString

structureFromString :: String
                    -> (Maybe Structure, Int)
structureFromString string =
    unsafePerformIO $
        withUTFString string $ \cString ->
            alloca $ \endPtr ->
                do structure <- {# call structure_from_string #} cString endPtr >>=
                                    maybePeek takeStructure
                   end <- peek endPtr
                   offset <- {# call g_utf8_pointer_to_offset #} cString end
                   return (structure, fromIntegral offset)

structureName :: Structure
              -> String
structureName structure =
    unsafePerformIO $
        {# call structure_get_name #} structure >>=
            peekUTFString

structureHasName :: Structure
                 -> String
                 -> Bool
structureHasName structure name =
    toBool $ unsafePerformIO $
        withUTFString name $
             {# call structure_has_name #} structure

marshalStructureGet :: Storable a
                    => (Structure -> CString -> Ptr a -> IO {# type gboolean #})
                    -> (a -> IO b)
                    -> Structure
                    -> String
                    -> Maybe b
marshalStructureGet getAction convert structure fieldname =
    unsafePerformIO $
        alloca $ \ptr ->
            withUTFString fieldname $ \cFieldname ->
                do result <- getAction structure cFieldname ptr
                   if toBool result
                       then liftM Just $ peek (castPtr ptr) >>= convert
                       else return Nothing

structureGetBool :: Structure
                 -> String
                 -> Maybe Bool
structureGetBool =
    marshalStructureGet {# call structure_get_boolean #} $
        return . toBool

structureGetInt :: Structure
                -> String
                -> Maybe Int
structureGetInt =
    marshalStructureGet {# call structure_get_int #} $
        return . fromIntegral

structureGetFourCC :: Structure
                   -> String
                   -> Maybe FourCC
structureGetFourCC =
    marshalStructureGet {# call structure_get_fourcc #} $
        return . fromIntegral

structureGetDouble :: Structure
                   -> String
                   -> Maybe Double
structureGetDouble =
    marshalStructureGet {# call structure_get_double #} $
        return . realToFrac

structureGetString :: Structure
                   -> String
                   -> Maybe String
structureGetString structure fieldname =
    unsafePerformIO $
        (withUTFString fieldname $ {# call structure_get_string #} structure) >>=
            maybePeek peekUTFString

structureGetDate :: Structure
                 -> String
                 -> Maybe GDate
structureGetDate =
    marshalStructureGet {# call structure_get_date #} $
        peek . castPtr

structureGetClockTime :: Structure
                      -> String
                      -> Maybe ClockTime
structureGetClockTime =
    marshalStructureGet {# call structure_get_clock_time #} $
        return . fromIntegral

structureGetFraction :: Structure
                     -> String
                     -> Maybe Fraction
structureGetFraction structure fieldname =
    unsafePerformIO $
        alloca $ \numPtr -> alloca $ \denPtr ->
            withUTFString fieldname $ \cFieldname ->
                do result <- {# call structure_get_fraction #} structure cFieldname numPtr denPtr
                   if toBool result
                       then do num <- peek numPtr
                               den <- peek denPtr
                               return $ Just $ (fromIntegral num) % (fromIntegral den)
                       else return Nothing

marshalStructureModify :: IO (Ptr Structure)
                       -> StructureM a
                       -> (Structure, a)
marshalStructureModify mkStructure (StructureM action) =
    unsafePerformIO $
        do ptr <- mkStructure
           structure <- liftM Structure $ newForeignPtr_ ptr
           result <- action structure
           structure' <- takeStructure ptr
           return (structure', result)

structureCreate :: String
                -> StructureM a
                -> (Structure, a)
structureCreate name action =
    marshalStructureModify
        (withUTFString name {# call structure_empty_new #})
        action

structureModify :: Structure
                -> StructureM a
                -> (Structure, a)
structureModify structure action =
    marshalStructureModify
        ({# call structure_copy #} structure)
        action

structureSetNameM :: String
                  -> StructureM ()
structureSetNameM name =
    StructureM $ \structure ->
        withUTFString name $ {# call structure_set_name #} structure

structureRemoveFieldM :: String
                      -> StructureM ()
structureRemoveFieldM name =
    StructureM $ \structure ->
        withUTFString name $ {# call structure_remove_field #} structure

marshalStructureSetM :: (GValue -> a -> IO ())
                     -> String
                     -> a
                     -> StructureM ()
marshalStructureSetM setGValue fieldname value =
    StructureM $ \structure ->
        withUTFString fieldname $ \cFieldname ->
        allocaGValue $ \gValue ->
            do setGValue gValue value
               {# call structure_set_value #} structure cFieldname gValue

structureSetBoolM :: String
                  -> Bool
                  -> StructureM ()
structureSetBoolM =
    marshalStructureSetM valueSetBool

structureSetIntM :: String
                 -> Int
                 -> StructureM ()
structureSetIntM =
    marshalStructureSetM valueSetInt

structureSetFourCCM :: String
                    -> FourCC
                    -> StructureM ()
structureSetFourCCM =
    marshalStructureSetM $ \gValue fourcc ->
        {# call value_set_fourcc #} gValue $ fromIntegral fourcc

structureSetDoubleM :: String
                    -> Double
                    -> StructureM ()
structureSetDoubleM =
    marshalStructureSetM valueSetDouble

structureSetStringM :: String
                    -> String
                    -> StructureM ()
structureSetStringM =
    marshalStructureSetM valueSetString

structureSetDateM :: String
                  -> GDate
                  -> StructureM ()
structureSetDateM =
    marshalStructureSetM $ \gValue date ->
        with date $ ({# call value_set_date #} gValue) . castPtr

structureSetClockTimeM :: String
                       -> ClockTime
                       -> StructureM ()
structureSetClockTimeM =
    marshalStructureSetM $ \gValue clockTime ->
        {# call g_value_set_uint64 #} gValue $ fromIntegral clockTime

structureSetFractionM :: String
                      -> Fraction
                      -> StructureM ()
structureSetFractionM =
    marshalStructureSetM $ \gValue fraction ->
        {# call value_set_fraction #} gValue
                                      (fromIntegral $ numerator fraction)
                                      (fromIntegral $ denominator fraction)

marshalStructureFixateM :: (Structure -> CString -> a -> IO {# type gboolean #})
                        -> String
                        -> a
                        -> StructureM Bool
marshalStructureFixateM fixate fieldname target =
    StructureM $ \structure ->
        withUTFString fieldname $ \cFieldname ->
            liftM toBool $
                fixate structure cFieldname target

structureFixateFieldNearestIntM :: String
                                -> Int
                                -> StructureM Bool
structureFixateFieldNearestIntM =
    marshalStructureFixateM $ \structure cFieldname target ->
        {# call structure_fixate_field_nearest_int #}
            structure
            cFieldname
            (fromIntegral target)

structureFixateFieldNearestDoubleM :: String
                                   -> Double
                                   -> StructureM Bool
structureFixateFieldNearestDoubleM =
    marshalStructureFixateM $ \structure cFieldname target ->
        {# call structure_fixate_field_nearest_double #}
            structure
            cFieldname
            (realToFrac target)

structureFixateFieldNearestFractionM :: String
                                     -> Fraction
                                     -> StructureM Bool
structureFixateFieldNearestFractionM =
    marshalStructureFixateM $ \structure cFieldname target ->
                {# call structure_fixate_field_nearest_fraction #}
                    structure
                    cFieldname
                    (fromIntegral $ numerator target)
                    (fromIntegral $ denominator target)

structureFixateFieldBoolM :: String
                          -> Bool
                          -> StructureM Bool
structureFixateFieldBoolM =
    marshalStructureFixateM $ \structure cFieldname target ->
                {# call structure_fixate_field_boolean #}
                    structure
                    cFieldname
                    (fromBool target)


gstreamer: document & implement missing API for M.S.G.Core.ElementFactory

--  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 factory for creating 'Element's.
module Media.Streaming.GStreamer.Core.ElementFactory (

-- * Detail

  -- | 'ElementFactory' is used to create instances of 'Element's.
  --
  --   Use 'elementFactoryFind' and 'elementFactoryCreate' to create
  --   element instances, or use 'elementFactoryMake' as a convenient
  --   shortcut.

-- * Types
  ElementFactory,
  ElementFactoryClass,
  castToElementFactory,
  toElementFactory,

-- * ElementFactory Operations
  elementFactoryFind,
  elementFactoryGetElementType,
  elementFactoryGetLongname,
  elementFactoryGetKlass,
  elementFactoryGetDescription,
  elementFactoryGetAuthor,
  elementFactoryGetNumPadTemplates,
  elementFactoryGetURIType,
  elementFactoryGetURIProtocols,
  elementFactoryHasInterface,
  elementFactoryCreate,
  elementFactoryMake,
  elementFactoryCanSinkCaps,
  elementFactoryCanSrcCaps,
  elementFactoryGetPadTemplates

  ) where

import Control.Monad         ( liftM
                             , (>=>) )
import Data.Maybe            ( fromMaybe )
import System.Glib.FFI
import System.Glib.UTFString ( withUTFString
                             , peekUTFString
                             , peekUTFStringArray0 )
import System.Glib.GType     ( GType )
import System.Glib.GList     ( readGList )
{# import Media.Streaming.GStreamer.Core.Types #}

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

-- | Search for an element factory with the given name.
elementFactoryFind :: String                    -- ^ @name@ - the name of the desired factory
                   -> IO (Maybe ElementFactory) -- ^ the factory if found, otherwise 'Nothing'
elementFactoryFind name =
    withUTFString name {# call element_factory_find #} >>= maybePeek takeObject

-- | Get the 'GType' for elements managed by the given factory. The type
--   can only be retrieved if the element factory is loaded, which can
--   be assured with
--   'Media.Streaming.GStreamer.Core.PluginFeature.pluginFeatureLoad'.
elementFactoryGetElementType :: (ElementFactoryClass elementFactory)
                             => elementFactory   -- ^ @factory@ - an element factory
                             -> IO (Maybe GType) -- ^ the type of elements managed
                                                 --   by the factory, or 'Nothing' if
                                                 --   the factory is not loaded
elementFactoryGetElementType factory =
    do gtype <- {# call element_factory_get_element_type #} (toElementFactory factory)
       if gtype == 0
          then return $ Just $ fromIntegral gtype
          else return Nothing

-- | Get the long name for the given factory.
elementFactoryGetLongname :: (ElementFactoryClass elementFactory)
                          => elementFactory -- ^ @factory@ - an element factory
                          -> IO String      -- ^ the factory's long name
elementFactoryGetLongname factory =
    {# call element_factory_get_longname #} (toElementFactory factory) >>=
        peekUTFString

-- | Get the class for the given factory.
elementFactoryGetKlass :: (ElementFactoryClass elementFactory)
                       => elementFactory -- ^ @factory@ - an element factory
                       -> IO String      -- ^ the factory's class
elementFactoryGetKlass factory =
    {# call element_factory_get_klass #} (toElementFactory factory) >>=
        peekUTFString

-- | Get the description for the given factory.
elementFactoryGetDescription :: (ElementFactoryClass elementFactory)
                             => elementFactory -- ^ @factory@ - an element factory
                             -> IO String      -- ^ the factory's description
elementFactoryGetDescription factory =
    {# call element_factory_get_description #} (toElementFactory factory) >>=
        peekUTFString

-- | Get the author of the given factory.
elementFactoryGetAuthor :: (ElementFactoryClass elementFactory)
                        => elementFactory -- ^ @factory@ - an element factory
                        -> IO String      -- ^ the factory's author
elementFactoryGetAuthor factory =
    {# call element_factory_get_author #} (toElementFactory factory) >>=
        peekUTFString

-- | Get the number of 'PadTemplate's provided by the given factory.
elementFactoryGetNumPadTemplates :: (ElementFactoryClass elementFactory)
                                 => elementFactory -- ^ @factory@ - an element factory
                                 -> IO Word        -- ^ the number of 'PadTemplate's
elementFactoryGetNumPadTemplates factory =
    liftM fromIntegral $
        {# call element_factory_get_num_pad_templates #} $ toElementFactory factory

-- | Get the type of URIs supported by the given factory.
elementFactoryGetURIType :: (ElementFactoryClass elementFactory)
                         => elementFactory -- ^ @factory@ - an element factory
                         -> IO Int         -- ^ the type of URIs supported by the factory
elementFactoryGetURIType factory =
    liftM fromIntegral $
        {# call element_factory_get_uri_type #} $ toElementFactory factory

-- | Get the list of protocols supported by the given factory.
elementFactoryGetURIProtocols :: (ElementFactoryClass elementFactory)
                              => elementFactory -- ^ @factory@ - an element factory
                              -> IO [String]    -- ^ the supported protocols
elementFactoryGetURIProtocols factory =
    {# call element_factory_get_uri_protocols #} (toElementFactory factory) >>=
        liftM (fromMaybe []) . maybePeek peekUTFStringArray0

-- | Check if the given factory implements the interface with the given name.
elementFactoryHasInterface :: (ElementFactoryClass elementFactory)
                           => elementFactory -- ^ @factory@ - an element factory
                           -> String         -- ^ @name@ - the interface name
                           -> IO Bool        -- ^ true if the interface is implemented
elementFactoryHasInterface factory name =
    liftM toBool .
        withUTFString name .
        {# call element_factory_has_interface #} .
        toElementFactory $
        factory

-- | Create a new element of the type supplied by the given
--   factory. It will be given the name supplied.
elementFactoryCreate :: (ElementFactoryClass elementFactory)
                     => elementFactory     -- ^ @factory@ - an element factory
                     -> String             -- ^ @name@ - the new element's name
                     -> IO (Maybe Element) -- ^ the new element if it could be created,
                                           --   otherwise 'Nothing'
elementFactoryCreate factory name =
    withUTFString name $ \cName ->
        {# call element_factory_create #} (toElementFactory factory) cName >>=
            maybePeek takeObject

-- | Create a new element of the type supplied by the named
--   factory.
elementFactoryMake :: String             -- ^ @factoryName@ - the name of an element factory
                   -> Maybe String       -- ^ @name@ - the new element's name, or
                                         --   'Nothing' generate a unique name
                   -> IO (Maybe Element) -- ^ the new element if it could be created,
                                         --   otherwise 'Nothing'
elementFactoryMake factoryName name =
    withUTFString factoryName $ \cFactoryName ->
        maybeWith withUTFString name $ \cName ->
            {# call element_factory_make #} cFactoryName cName >>=
                maybePeek takeObject

-- | Check if the given factory can sink the given capabilities.
elementFactoryCanSinkCaps :: (ElementFactoryClass elementFactory)
                          => elementFactory -- ^ @factory@ - an element factory
                          -> Caps           -- ^ @caps@ - the capabilities to check for
                          -> IO Bool        -- ^ 'True' if @factory@ can sink the given capabilities
elementFactoryCanSinkCaps factory caps =
    liftM toBool $ {# call element_factory_can_sink_caps #} (toElementFactory factory) caps

-- | Check if the given factory can source the given capabilities.
elementFactoryCanSrcCaps :: (ElementFactoryClass elementFactory)
                         => elementFactory -- ^ @factory@ - an element factory
                         -> Caps           -- ^ @caps@ - the capabilities to check for
                         -> IO Bool        -- ^ 'True' if @factory@ can source the given capabilities
elementFactoryCanSrcCaps factory caps =
    liftM toBool $ {# call element_factory_can_src_caps #} (toElementFactory factory) caps

-- | Get the pad templates provided by the given factory.
elementFactoryGetPadTemplates :: (ElementFactoryClass elementFactory)
                              => elementFactory   -- ^ @factory@ - an element factory
                              -> IO [PadTemplate] -- ^ the provided pad templates
elementFactoryGetPadTemplates =
    {# call element_factory_get_static_pad_templates #} . toElementFactory >=>
        readGList >=> mapM staticPadTemplateGet

--  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.ElementFactory (

  ElementFactory,
  ElementFactoryClass,
  castToElementFactory,
  toElementFactory,

  elementFactoryFind,
  elementFactoryGetElementType,
  elementFactoryGetLongname,
  elementFactoryGetKlass,
  elementFactoryGetDescription,
  elementFactoryGetAuthor,
  elementFactoryGetNumPadTemplates,
  elementFactoryGetURIType,
  elementFactoryGetURIProtocols,
  elementFactoryCreate,
  elementFactoryMake

  ) where

import Control.Monad         ( liftM )
import System.Glib.FFI
import System.Glib.UTFString ( withUTFString
                             , peekUTFString
                             , peekUTFStringArray0 )
import System.Glib.GType     ( GType )
{# import Media.Streaming.GStreamer.Core.Types #}

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

elementFactoryFind :: String
                   -> IO ElementFactory
elementFactoryFind name =
    withUTFString name {# call element_factory_find #} >>= takeObject

elementFactoryGetElementType :: (ElementFactoryClass elementFactory) =>
                                elementFactory
                             -> IO (Maybe GType)
elementFactoryGetElementType factory =
    do gtype <- {# call element_factory_get_element_type #} (toElementFactory factory)
       if gtype == 0
          then return $ Just $ fromIntegral gtype
          else return Nothing

elementFactoryGetLongname :: (ElementFactoryClass elementFactory) =>
                             elementFactory
                          -> IO String
elementFactoryGetLongname factory =
    {# call element_factory_get_longname #} (toElementFactory factory) >>=
        peekUTFString

elementFactoryGetKlass :: (ElementFactoryClass elementFactory) =>
                          elementFactory
                       -> IO String
elementFactoryGetKlass factory =
    {# call element_factory_get_klass #} (toElementFactory factory) >>=
        peekUTFString

elementFactoryGetDescription :: (ElementFactoryClass elementFactory) =>
                                elementFactory
                             -> IO String
elementFactoryGetDescription factory =
    {# call element_factory_get_description #} (toElementFactory factory) >>=
        peekUTFString

elementFactoryGetAuthor :: (ElementFactoryClass elementFactory) =>
                           elementFactory
                        -> IO String
elementFactoryGetAuthor factory =
    {# call element_factory_get_author #} (toElementFactory factory) >>=
        peekUTFString

elementFactoryGetNumPadTemplates :: (ElementFactoryClass elementFactory) =>
                                    elementFactory
                                 -> IO Word
elementFactoryGetNumPadTemplates factory =
    liftM fromIntegral $
        {# call element_factory_get_num_pad_templates #} $ toElementFactory factory

elementFactoryGetURIType :: (ElementFactoryClass elementFactory) =>
                            elementFactory
                         -> IO Word
elementFactoryGetURIType factory =
    liftM fromIntegral $
        {# call element_factory_get_uri_type #} $ toElementFactory factory

elementFactoryGetURIProtocols :: (ElementFactoryClass elementFactory) =>
                                 elementFactory
                              -> IO (Maybe [String])
elementFactoryGetURIProtocols factory =
    {# call element_factory_get_uri_protocols #} (toElementFactory factory) >>=
        maybePeek peekUTFStringArray0

elementFactoryCreate :: (ElementFactoryClass elementFactory) =>
                        elementFactory
                     -> String
                     -> IO (Maybe Element)
elementFactoryCreate factory name =
    withUTFString name $ \cName ->
        {# call element_factory_create #} (toElementFactory factory) cName >>=
            maybePeek takeObject

elementFactoryMake :: String
                   -> String
                   -> IO (Maybe Element)
elementFactoryMake factoryName name =
    withUTFString factoryName $ \cFactoryName ->
        withUTFString name $ \cName ->
            {# call element_factory_make #} cFactoryName cName >>=
                maybePeek takeObject