Remove usage of addCleanup

Remove usage of addCleanup

{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveDataTypeable #-}

#include "bindings.h"
#include "gdal.h"
#include "ogr_api.h"

module GDAL.Internal.Layer (
    HasLayerTransaction
  , SQLDialect (..)
  , Layer (..)
  , LayerH (..)
  , ROLayer
  , RWLayer
  , OGR
  , OGRConduit
  , OGRSource
  , OGRSink
  , runOGR

  , canCreateMultipleGeometryFields

  , sourceLayer
  , sourceLayer_
  , conduitInsertLayer
  , conduitInsertLayer_
  , sinkInsertLayer
  , sinkInsertLayer_
  , sinkUpdateLayer

  , syncLayerToDisk

  , layerSpatialFilter
  , layerSpatialReference
  , setLayerSpatialFilter
  , setLayerSpatialFilterRect
  , clearLayerSpatialFilter

  , layerName
  , layerExtent
  , layerFeatureCount
  , layerFeatureDef

  , createFeature
  , createFeatureWithFid
  , createFeature_
  , getFeature
  , updateFeature
  , deleteFeature

  , unsafeToReadOnlyLayer

  , liftOGR
  , closeLayer
  , unLayer
  , layerHasCapability
  , nullLayerH
  , withSQLDialect
) where

{#context lib = "gdal" prefix = "OGR"#}

import Data.ByteString.Unsafe (unsafeUseAsCString)
import Data.Coerce (coerce)
import Data.Conduit ( Conduit, Sink, Source
                    , awaitForever, yield
                    , bracketP, catchC
                    , (=$=))
import qualified Data.Conduit.List as CL
import Data.Text (Text)

import Control.Applicative (Applicative, (<$>), (<*>), pure)
import Control.Exception (SomeException)
import Control.Monad (liftM, when, void, (>=>), (<=<))
import Control.Monad.Base (MonadBase)
import Control.Monad.Catch (
    MonadThrow(..)
  , MonadCatch
  , MonadMask
  )
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Control (MonadBaseControl(..))
import Control.Monad.Trans.Resource (MonadResource)
import Control.Monad.IO.Class (MonadIO(liftIO))

import Foreign.C.String (CString, withCString)
import Foreign.C.Types (CInt(..), CDouble(..))
import Foreign.Ptr (nullPtr)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Utils (toBool, fromBool)

import Foreign.Storable (Storable, peek)

import System.IO.Unsafe (unsafePerformIO)

{#import GDAL.Internal.OSR#}
{#import GDAL.Internal.OGRGeometry#}
{#import GDAL.Internal.OGRFeature#}
{#import GDAL.Internal.OGRError#}
{#import GDAL.Internal.CPLString#}
import GDAL.Internal.CPLError
import GDAL.Internal.Util
import GDAL.Internal.Types

-- A phantom-typed ST-like monad to make sure the layer does not escape its
-- scope
newtype OGR s l a = OGR { unOGR :: GDAL s a}

deriving instance Functor (OGR s l)
deriving instance Applicative (OGR s l)
deriving instance Monad (OGR s l)
deriving instance MonadIO (OGR s l)
deriving instance MonadThrow (OGR s l)
deriving instance MonadCatch (OGR s l)
deriving instance MonadMask (OGR s l)
deriving instance MonadBase IO (OGR s l)
deriving instance MonadResource (OGR s l)

instance MonadBaseControl IO (OGR s l) where
  type StM (OGR s l) a = a
  liftBaseWith runInBase = OGR $ do
    state <- getInternalState
    liftIO $ runInBase ((`runWithInternalState` state) . unOGR)
  restoreM = return

runOGR :: (forall l. OGR s l a ) -> GDAL s a
runOGR (OGR a) = a

liftOGR :: GDAL s a -> OGR s l a
liftOGR = OGR

type OGRConduit s l i o = Conduit i (OGR s l) o
type OGRSource s l o = Source (OGR s l) o
type OGRSink s l i = Sink i (OGR s l)

{#pointer LayerH newtype#}

deriving instance Storable LayerH
deriving instance Eq LayerH

nullLayerH :: LayerH
nullLayerH = LayerH nullPtr

newtype (Layer s l (t::AccessMode) a) = Layer (ReleaseKey, LayerH)

unLayer :: Layer s l t a -> LayerH
unLayer (Layer (_,l)) = l

closeLayer :: MonadIO m => Layer s l t a -> m ()
closeLayer (Layer (rk,_)) = release rk

type ROLayer s l = Layer s l ReadOnly
type RWLayer s l = Layer s l ReadWrite

unsafeToReadOnlyLayer :: RWLayer s l a -> ROLayer s l a
unsafeToReadOnlyLayer = coerce

data SQLDialect
  = DefaultDialect
  | SqliteDialect
  | OGRDialect
  deriving (Eq, Show, Enum)

withSQLDialect :: SQLDialect -> (CString -> IO a) -> IO a
withSQLDialect DefaultDialect = ($ nullPtr)
withSQLDialect SqliteDialect  = unsafeUseAsCString "SQLITE\0"
withSQLDialect OGRDialect     = unsafeUseAsCString "OGRSQL\0"

-- | GDAL < 1.11 only supports 1 geometry field and associates it to the layer
layerGeomFieldDef :: LayerH -> IO GeomFieldDef
layerGeomFieldDef p =
  GeomFieldDef
    <$> liftM toEnumC ({#call unsafe OGR_L_GetGeomType	as ^#} p)
    <*> maybeNewSpatialRefBorrowedHandle
          ({#call unsafe OGR_L_GetSpatialRef as ^#} p)
    <*> pure True

layerSpatialReference :: Layer s l a t -> GDAL s (Maybe SpatialReference)
layerSpatialReference
  = liftIO
  . maybeNewSpatialRefBorrowedHandle
  . {#call unsafe OGR_L_GetSpatialRef as ^#}
  . unLayer

syncLayerToDiskIO :: RWLayer s l a -> IO ()
syncLayerToDiskIO =
  checkOGRError "syncLayerToDisk" . {#call OGR_L_SyncToDisk as ^#} . unLayer

syncLayerToDisk :: RWLayer s l a -> GDAL s ()
syncLayerToDisk = liftIO . syncLayerToDiskIO

getLayerSchema :: LayerH -> IO FeatureDefnH
getLayerSchema = {#call OGR_L_GetLayerDefn as ^#}

createFeatureWithFidIO
  :: OGRFeature a => LayerH -> Maybe Fid -> a -> IO (Maybe Fid)
createFeatureWithFidIO pL fid feat = do
  pFd <- getLayerSchema pL
  featureToHandle pFd fid feat $ \pF -> do
    checkOGRError "CreateFeature" ({#call OGR_L_CreateFeature as ^#} pL pF)
    getFid pF

createFeatureWithFid
  :: OGRFeature a => RWLayer s l a -> Maybe Fid -> a -> GDAL s (Maybe Fid)
createFeatureWithFid layer fid =
  liftIO . createFeatureWithFidIO (unLayer layer) fid

createFeature :: OGRFeature a => RWLayer s l a -> a -> GDAL s Fid
createFeature layer =
  createFeatureWithFid layer Nothing >=>
    maybe (throwBindingException UnexpectedNullFid) return

createFeature_ :: OGRFeature a => RWLayer s l a -> a -> GDAL s ()
createFeature_ layer = void . createFeatureWithFid layer Nothing

updateFeature :: OGRFeature a => RWLayer s l a -> Fid -> a -> GDAL s ()
updateFeature layer fid feat = liftIO $ do
  pFd <- getLayerSchema pL
  featureToHandle pFd (Just fid) feat $
    checkOGRError "SetFeature" . {#call OGR_L_SetFeature as ^#} pL
  where pL = unLayer layer

getFeature :: OGRFeature a => Layer s l t a -> Fid -> GDAL s (Maybe a)
getFeature layer (Fid fid) = liftIO $ do
  when (not (pL `layerHasCapability` RandomRead)) $
    throwBindingException (UnsupportedLayerCapability RandomRead)
  fDef <- layerFeatureDefIO pL
  liftM (fmap snd) $ featureFromHandle fDef $
    checkGDALCall checkIt ({#call OGR_L_GetFeature as ^#} pL (fromIntegral fid))
  where
    checkIt (Just GDALException{gdalErrNum=AppDefined}) _ = Nothing
    checkIt   e _                                         = e
    pL = unLayer layer

deleteFeature :: Layer s l t a -> Fid -> GDAL s ()
deleteFeature layer (Fid fid) = liftIO $
  checkOGRError "DeleteFeature" $
    {#call OGR_L_DeleteFeature as ^#} (unLayer layer) (fromIntegral fid)

layerHasCapability :: LayerH -> LayerCapability -> Bool
layerHasCapability l c = unsafePerformIO $ do
  withCString (show c)
    (liftM toBool . {#call unsafe OGR_L_TestCapability as ^#} l)

layerName :: Layer s l t a -> GDAL s Text
layerName =
  liftIO . (peekEncodedCString <=< {#call unsafe OGR_L_GetName as ^#} . unLayer)

layerExtent :: Layer s l t a -> GDAL s EnvelopeReal
layerExtent l = liftIO $ alloca $ \pE -> do
  checkOGRError "GetExtent" ({#call OGR_L_GetExtent as ^#} (unLayer l) pE 1)
  peek pE

layerFeatureDef :: Layer s l t a -> GDAL s FeatureDef
layerFeatureDef = liftIO . layerFeatureDefIO . unLayer

layerFeatureDefIO :: LayerH -> IO FeatureDef
layerFeatureDefIO pL = do
  gfd <- layerGeomFieldDef pL
  getLayerSchema pL >>= featureDefFromHandle gfd

layerFeatureCount :: Layer s l t a -> Bool -> GDAL s (Maybe Int)
layerFeatureCount layer force = liftIO $ do
  c <- liftM fromIntegral $
        {#call OGR_L_GetFeatureCount as ^#} (unLayer layer) (fromBool force)
  if c<0 then return Nothing else return (Just c)

layerSpatialFilter :: Layer s l t a -> GDAL s (Maybe Geometry)
layerSpatialFilter l = liftIO $
  {#call unsafe OGR_L_GetSpatialFilter as ^#} (unLayer l) >>= maybeCloneGeometry

setLayerSpatialFilter :: Layer s l t a -> Geometry -> GDAL s ()
setLayerSpatialFilter l g = liftIO $
  withGeometry g $ {#call unsafe OGR_L_SetSpatialFilter as ^#} (unLayer l)

clearLayerSpatialFilter :: Layer s l t a -> GDAL s ()
clearLayerSpatialFilter l = liftIO $
  {#call unsafe OGR_L_SetSpatialFilter as ^#} (unLayer l) (nullPtr)

setLayerSpatialFilterRect :: Layer s l t a -> EnvelopeReal -> GDAL s ()
setLayerSpatialFilterRect l (Envelope (x0 :+: y0) (x1 :+: y1)) = liftIO $
  {#call unsafe OGR_L_SetSpatialFilterRect as ^#} (unLayer l)
    (realToFrac x0)
    (realToFrac y0)
    (realToFrac x1)
    (realToFrac y1)

sourceLayer
  :: (HasLayerTransaction t, OGRFeature a)
  => GDAL s (Layer s l t a)
  -> OGRSource s l (Maybe Fid, a)
sourceLayer alloc = layerTransaction alloc' loop
  where
    alloc' = do
      l <- alloc
      liftIO $ {#call OGR_L_ResetReading as ^#} (unLayer l)
      fDef <- layerFeatureDef l
      return (l, fDef)

    loop seed = do
      next <- liftIO $
              featureFromHandle (snd seed) $
              {#call OGR_L_GetNextFeature as ^#} (unLayer (fst seed))
      case next of
        Just v  -> yield v >> loop seed
        Nothing -> return ()

sourceLayer_
  :: (HasLayerTransaction t, OGRFeature a)
  => GDAL s (Layer s l t a) -> OGRSource s l a
sourceLayer_ = (=$= (CL.map snd)) . sourceLayer

conduitInsertLayer
  :: OGRFeature a
  => GDAL s (RWLayer s l a) -> OGRConduit s l (Maybe Fid, a) (Maybe Fid)
conduitInsertLayer = flip conduitFromLayer createIt
  where
    createIt (l, pFd) = awaitForever $ \(fid, feat) -> do
      fid' <- liftIO $ featureToHandle pFd fid feat $ \pF -> do
                checkOGRError "CreateFeature" $
                  {#call OGR_L_CreateFeature as ^#} (unLayer l) pF
                getFid pF
      yield fid'

conduitInsertLayer_
  :: OGRFeature a
  => GDAL s (RWLayer s l a) -> OGRConduit s l a (Maybe Fid)
conduitInsertLayer_ = (CL.map (\i->(Nothing,i)) =$=) . conduitInsertLayer

sinkInsertLayer
  :: OGRFeature a => GDAL s (RWLayer s l a) -> OGRSink s l (Maybe Fid, a) ()
sinkInsertLayer = (=$= CL.sinkNull) . conduitInsertLayer

sinkInsertLayer_
  :: OGRFeature a => GDAL s (RWLayer s l a) -> OGRSink s l a ()
sinkInsertLayer_ =
  ((=$= CL.sinkNull) . ((CL.map (\i->(Nothing,i))) =$=)) . conduitInsertLayer

sinkUpdateLayer
  :: OGRFeature a => GDAL s (RWLayer s l a) -> OGRSink s l (Fid, a) ()
sinkUpdateLayer = flip conduitFromLayer updateIt
  where
    updateIt (l, pFd) = awaitForever $ \(fid, feat) ->
      liftIO $ featureToHandle pFd (Just fid) feat $
        checkOGRError "SetFeature" . {#call OGR_L_SetFeature as ^#} (unLayer l)

class HasLayerTransaction (t :: AccessMode) where
  layerTransaction
    :: GDAL s (Layer s l t a, e)
    -> ((Layer s l t a, e) -> OGRConduit s l i o)
    -> OGRConduit s l i o

instance HasLayerTransaction ReadWrite where
  layerTransaction alloc inside = do
    state <- lift (liftOGR getInternalState)
    bracketP (alloc' state) free $ \ seed@(layer,_) -> do
      liftIO $ checkOGRError "StartTransaction" $
        {#call OGR_L_StartTransaction as ^#} (unLayer layer)

      res <-
        inside seed `catchC`
          \(e :: SomeException) -> rollback layer >> throwM e
      commit layer
      pure res
    where
      alloc' = runWithInternalState alloc
      free = closeLayer . fst
      commit layer = liftIO $ do
        checkOGRError "CommitTransaction" $
          {#call OGR_L_CommitTransaction as ^#} (unLayer layer)
        syncLayerToDiskIO layer

      rollback layer = liftIO $
        checkOGRError "RollbackTransaction" $
          {#call OGR_L_RollbackTransaction as ^#} (unLayer layer)

instance HasLayerTransaction ReadOnly where
  layerTransaction alloc inside = do
    state <- lift (liftOGR getInternalState)
    bracketP (alloc' state) free $ \ seed -> do
      liftIO $ checkOGRError "StartTransaction" $
        {#call OGR_L_StartTransaction as ^#} (unLayer (fst seed))
      inside seed
    where
      free = closeLayer . fst
      alloc' = runWithInternalState alloc

conduitFromLayer
  :: GDAL s (RWLayer s l a)
  -> ((RWLayer s l a, FeatureDefnH) -> OGRConduit s l i o)
  -> OGRConduit s l i o
conduitFromLayer alloc = layerTransaction alloc'
  where
    alloc' = do
      l <- alloc
      schema <- liftIO $ getLayerSchema (unLayer l)
      return (l, schema)

canCreateMultipleGeometryFields :: Bool
canCreateMultipleGeometryFields =
#if SUPPORTS_MULTI_GEOM_FIELDS
  True
#else
  False
#endif

{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveDataTypeable #-}

#include "bindings.h"
#include "gdal.h"
#include "ogr_api.h"

module GDAL.Internal.Layer (
    HasLayerTransaction
  , SQLDialect (..)
  , Layer (..)
  , LayerH (..)
  , ROLayer
  , RWLayer
  , OGR
  , OGRConduit
  , OGRSource
  , OGRSink
  , runOGR

  , canCreateMultipleGeometryFields

  , sourceLayer
  , sourceLayer_
  , conduitInsertLayer
  , conduitInsertLayer_
  , sinkInsertLayer
  , sinkInsertLayer_
  , sinkUpdateLayer

  , syncLayerToDisk

  , layerSpatialFilter
  , layerSpatialReference
  , setLayerSpatialFilter
  , setLayerSpatialFilterRect
  , clearLayerSpatialFilter

  , layerName
  , layerExtent
  , layerFeatureCount
  , layerFeatureDef

  , createFeature
  , createFeatureWithFid
  , createFeature_
  , getFeature
  , updateFeature
  , deleteFeature

  , unsafeToReadOnlyLayer

  , liftOGR
  , closeLayer
  , unLayer
  , layerHasCapability
  , nullLayerH
  , withSQLDialect
) where

{#context lib = "gdal" prefix = "OGR"#}

import Data.ByteString.Unsafe (unsafeUseAsCString)
import Data.Coerce (coerce)
import Data.Conduit ( Conduit, Sink, Source
                    , addCleanup, awaitForever, yield
                    , bracketP, catchC
                    , (=$=))
import qualified Data.Conduit.List as CL
import Data.Text (Text)

import Control.Applicative (Applicative, (<$>), (<*>), pure)
import Control.Exception (SomeException)
import Control.Monad (liftM, when, void, (>=>), (<=<))
import Control.Monad.Base (MonadBase)
import Control.Monad.Catch (
    MonadThrow(..)
  , MonadCatch
  , MonadMask
  )
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Control (MonadBaseControl(..))
import Control.Monad.Trans.Resource (MonadResource)
import Control.Monad.IO.Class (MonadIO(liftIO))

import Foreign.C.String (CString, withCString)
import Foreign.C.Types (CInt(..), CDouble(..))
import Foreign.Ptr (nullPtr)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Utils (toBool, fromBool)

import Foreign.Storable (Storable, peek)

import System.IO.Unsafe (unsafePerformIO)

{#import GDAL.Internal.OSR#}
{#import GDAL.Internal.OGRGeometry#}
{#import GDAL.Internal.OGRFeature#}
{#import GDAL.Internal.OGRError#}
{#import GDAL.Internal.CPLString#}
import GDAL.Internal.CPLError
import GDAL.Internal.Util
import GDAL.Internal.Types

-- A phantom-typed ST-like monad to make sure the layer does not escape its
-- scope
newtype OGR s l a = OGR { unOGR :: GDAL s a}

deriving instance Functor (OGR s l)
deriving instance Applicative (OGR s l)
deriving instance Monad (OGR s l)
deriving instance MonadIO (OGR s l)
deriving instance MonadThrow (OGR s l)
deriving instance MonadCatch (OGR s l)
deriving instance MonadMask (OGR s l)
deriving instance MonadBase IO (OGR s l)
deriving instance MonadResource (OGR s l)

instance MonadBaseControl IO (OGR s l) where
  type StM (OGR s l) a = a
  liftBaseWith runInBase = OGR $ do
    state <- getInternalState
    liftIO $ runInBase ((`runWithInternalState` state) . unOGR)
  restoreM = return

runOGR :: (forall l. OGR s l a ) -> GDAL s a
runOGR (OGR a) = a

liftOGR :: GDAL s a -> OGR s l a
liftOGR = OGR

type OGRConduit s l i o = Conduit i (OGR s l) o
type OGRSource s l o = Source (OGR s l) o
type OGRSink s l i = Sink i (OGR s l)

{#pointer LayerH newtype#}

deriving instance Storable LayerH
deriving instance Eq LayerH

nullLayerH :: LayerH
nullLayerH = LayerH nullPtr

newtype (Layer s l (t::AccessMode) a) = Layer (ReleaseKey, LayerH)

unLayer :: Layer s l t a -> LayerH
unLayer (Layer (_,l)) = l

closeLayer :: MonadIO m => Layer s l t a -> m ()
closeLayer (Layer (rk,_)) = release rk

type ROLayer s l = Layer s l ReadOnly
type RWLayer s l = Layer s l ReadWrite

unsafeToReadOnlyLayer :: RWLayer s l a -> ROLayer s l a
unsafeToReadOnlyLayer = coerce

data SQLDialect
  = DefaultDialect
  | SqliteDialect
  | OGRDialect
  deriving (Eq, Show, Enum)

withSQLDialect :: SQLDialect -> (CString -> IO a) -> IO a
withSQLDialect DefaultDialect = ($ nullPtr)
withSQLDialect SqliteDialect  = unsafeUseAsCString "SQLITE\0"
withSQLDialect OGRDialect     = unsafeUseAsCString "OGRSQL\0"

-- | GDAL < 1.11 only supports 1 geometry field and associates it to the layer
layerGeomFieldDef :: LayerH -> IO GeomFieldDef
layerGeomFieldDef p =
  GeomFieldDef
    <$> liftM toEnumC ({#call unsafe OGR_L_GetGeomType	as ^#} p)
    <*> maybeNewSpatialRefBorrowedHandle
          ({#call unsafe OGR_L_GetSpatialRef as ^#} p)
    <*> pure True

layerSpatialReference :: Layer s l a t -> GDAL s (Maybe SpatialReference)
layerSpatialReference
  = liftIO
  . maybeNewSpatialRefBorrowedHandle
  . {#call unsafe OGR_L_GetSpatialRef as ^#}
  . unLayer

syncLayerToDiskIO :: RWLayer s l a -> IO ()
syncLayerToDiskIO =
  checkOGRError "syncLayerToDisk" . {#call OGR_L_SyncToDisk as ^#} . unLayer

syncLayerToDisk :: RWLayer s l a -> GDAL s ()
syncLayerToDisk = liftIO . syncLayerToDiskIO

getLayerSchema :: LayerH -> IO FeatureDefnH
getLayerSchema = {#call OGR_L_GetLayerDefn as ^#}

createFeatureWithFidIO
  :: OGRFeature a => LayerH -> Maybe Fid -> a -> IO (Maybe Fid)
createFeatureWithFidIO pL fid feat = do
  pFd <- getLayerSchema pL
  featureToHandle pFd fid feat $ \pF -> do
    checkOGRError "CreateFeature" ({#call OGR_L_CreateFeature as ^#} pL pF)
    getFid pF

createFeatureWithFid
  :: OGRFeature a => RWLayer s l a -> Maybe Fid -> a -> GDAL s (Maybe Fid)
createFeatureWithFid layer fid =
  liftIO . createFeatureWithFidIO (unLayer layer) fid

createFeature :: OGRFeature a => RWLayer s l a -> a -> GDAL s Fid
createFeature layer =
  createFeatureWithFid layer Nothing >=>
    maybe (throwBindingException UnexpectedNullFid) return

createFeature_ :: OGRFeature a => RWLayer s l a -> a -> GDAL s ()
createFeature_ layer = void . createFeatureWithFid layer Nothing

updateFeature :: OGRFeature a => RWLayer s l a -> Fid -> a -> GDAL s ()
updateFeature layer fid feat = liftIO $ do
  pFd <- getLayerSchema pL
  featureToHandle pFd (Just fid) feat $
    checkOGRError "SetFeature" . {#call OGR_L_SetFeature as ^#} pL
  where pL = unLayer layer

getFeature :: OGRFeature a => Layer s l t a -> Fid -> GDAL s (Maybe a)
getFeature layer (Fid fid) = liftIO $ do
  when (not (pL `layerHasCapability` RandomRead)) $
    throwBindingException (UnsupportedLayerCapability RandomRead)
  fDef <- layerFeatureDefIO pL
  liftM (fmap snd) $ featureFromHandle fDef $
    checkGDALCall checkIt ({#call OGR_L_GetFeature as ^#} pL (fromIntegral fid))
  where
    checkIt (Just GDALException{gdalErrNum=AppDefined}) _ = Nothing
    checkIt   e _                                         = e
    pL = unLayer layer

deleteFeature :: Layer s l t a -> Fid -> GDAL s ()
deleteFeature layer (Fid fid) = liftIO $
  checkOGRError "DeleteFeature" $
    {#call OGR_L_DeleteFeature as ^#} (unLayer layer) (fromIntegral fid)

layerHasCapability :: LayerH -> LayerCapability -> Bool
layerHasCapability l c = unsafePerformIO $ do
  withCString (show c)
    (liftM toBool . {#call unsafe OGR_L_TestCapability as ^#} l)

layerName :: Layer s l t a -> GDAL s Text
layerName =
  liftIO . (peekEncodedCString <=< {#call unsafe OGR_L_GetName as ^#} . unLayer)

layerExtent :: Layer s l t a -> GDAL s EnvelopeReal
layerExtent l = liftIO $ alloca $ \pE -> do
  checkOGRError "GetExtent" ({#call OGR_L_GetExtent as ^#} (unLayer l) pE 1)
  peek pE

layerFeatureDef :: Layer s l t a -> GDAL s FeatureDef
layerFeatureDef = liftIO . layerFeatureDefIO . unLayer

layerFeatureDefIO :: LayerH -> IO FeatureDef
layerFeatureDefIO pL = do
  gfd <- layerGeomFieldDef pL
  getLayerSchema pL >>= featureDefFromHandle gfd

layerFeatureCount :: Layer s l t a -> Bool -> GDAL s (Maybe Int)
layerFeatureCount layer force = liftIO $ do
  c <- liftM fromIntegral $
        {#call OGR_L_GetFeatureCount as ^#} (unLayer layer) (fromBool force)
  if c<0 then return Nothing else return (Just c)

layerSpatialFilter :: Layer s l t a -> GDAL s (Maybe Geometry)
layerSpatialFilter l = liftIO $
  {#call unsafe OGR_L_GetSpatialFilter as ^#} (unLayer l) >>= maybeCloneGeometry

setLayerSpatialFilter :: Layer s l t a -> Geometry -> GDAL s ()
setLayerSpatialFilter l g = liftIO $
  withGeometry g $ {#call unsafe OGR_L_SetSpatialFilter as ^#} (unLayer l)

clearLayerSpatialFilter :: Layer s l t a -> GDAL s ()
clearLayerSpatialFilter l = liftIO $
  {#call unsafe OGR_L_SetSpatialFilter as ^#} (unLayer l) (nullPtr)

setLayerSpatialFilterRect :: Layer s l t a -> EnvelopeReal -> GDAL s ()
setLayerSpatialFilterRect l (Envelope (x0 :+: y0) (x1 :+: y1)) = liftIO $
  {#call unsafe OGR_L_SetSpatialFilterRect as ^#} (unLayer l)
    (realToFrac x0)
    (realToFrac y0)
    (realToFrac x1)
    (realToFrac y1)

sourceLayer
  :: (HasLayerTransaction t, OGRFeature a)
  => GDAL s (Layer s l t a)
  -> OGRSource s l (Maybe Fid, a)
sourceLayer alloc = layerTransaction alloc' loop
  where
    alloc' = do
      l <- alloc
      liftIO $ {#call OGR_L_ResetReading as ^#} (unLayer l)
      fDef <- layerFeatureDef l
      return (l, fDef)

    loop seed = do
      next <- liftIO $
              featureFromHandle (snd seed) $
              {#call OGR_L_GetNextFeature as ^#} (unLayer (fst seed))
      case next of
        Just v  -> yield v >> loop seed
        Nothing -> return ()

sourceLayer_
  :: (HasLayerTransaction t, OGRFeature a)
  => GDAL s (Layer s l t a) -> OGRSource s l a
sourceLayer_ = (=$= (CL.map snd)) . sourceLayer

conduitInsertLayer
  :: OGRFeature a
  => GDAL s (RWLayer s l a) -> OGRConduit s l (Maybe Fid, a) (Maybe Fid)
conduitInsertLayer = flip conduitFromLayer createIt
  where
    createIt (l, pFd) = awaitForever $ \(fid, feat) -> do
      fid' <- liftIO $ featureToHandle pFd fid feat $ \pF -> do
                checkOGRError "CreateFeature" $
                  {#call OGR_L_CreateFeature as ^#} (unLayer l) pF
                getFid pF
      yield fid'

conduitInsertLayer_
  :: OGRFeature a
  => GDAL s (RWLayer s l a) -> OGRConduit s l a (Maybe Fid)
conduitInsertLayer_ = (CL.map (\i->(Nothing,i)) =$=) . conduitInsertLayer

sinkInsertLayer
  :: OGRFeature a => GDAL s (RWLayer s l a) -> OGRSink s l (Maybe Fid, a) ()
sinkInsertLayer = (=$= CL.sinkNull) . conduitInsertLayer

sinkInsertLayer_
  :: OGRFeature a => GDAL s (RWLayer s l a) -> OGRSink s l a ()
sinkInsertLayer_ =
  ((=$= CL.sinkNull) . ((CL.map (\i->(Nothing,i))) =$=)) . conduitInsertLayer

sinkUpdateLayer
  :: OGRFeature a => GDAL s (RWLayer s l a) -> OGRSink s l (Fid, a) ()
sinkUpdateLayer = flip conduitFromLayer updateIt
  where
    updateIt (l, pFd) = awaitForever $ \(fid, feat) ->
      liftIO $ featureToHandle pFd (Just fid) feat $
        checkOGRError "SetFeature" . {#call OGR_L_SetFeature as ^#} (unLayer l)

class HasLayerTransaction (t :: AccessMode) where
  layerTransaction
    :: GDAL s (Layer s l t a, e)
    -> ((Layer s l t a, e) -> OGRConduit s l i o)
    -> OGRConduit s l i o

instance HasLayerTransaction ReadWrite where
  layerTransaction alloc inside = do
    state <- lift (liftOGR getInternalState)
    bracketP (alloc' state) free $ \ seed@(layer,_) -> do
      liftIO $ checkOGRError "StartTransaction" $
        {#call OGR_L_StartTransaction as ^#} (unLayer layer)
      addCleanup (\terminated -> when terminated (commit layer)) $
        inside seed `catchC`
          \(e :: SomeException) -> rollback layer >> throwM e
    where
      alloc' = runWithInternalState alloc
      free = closeLayer . fst
      commit layer = liftIO $ do
        checkOGRError "CommitTransaction" $
          {#call OGR_L_CommitTransaction as ^#} (unLayer layer)
        syncLayerToDiskIO layer

      rollback layer = liftIO $
        checkOGRError "RollbackTransaction" $
          {#call OGR_L_RollbackTransaction as ^#} (unLayer layer)

instance HasLayerTransaction ReadOnly where
  layerTransaction alloc inside = do
    state <- lift (liftOGR getInternalState)
    bracketP (alloc' state) free $ \ seed -> do
      liftIO $ checkOGRError "StartTransaction" $
        {#call OGR_L_StartTransaction as ^#} (unLayer (fst seed))
      inside seed
    where
      free = closeLayer . fst
      alloc' = runWithInternalState alloc

conduitFromLayer
  :: GDAL s (RWLayer s l a)
  -> ((RWLayer s l a, FeatureDefnH) -> OGRConduit s l i o)
  -> OGRConduit s l i o
conduitFromLayer alloc = layerTransaction alloc'
  where
    alloc' = do
      l <- alloc
      schema <- liftIO $ getLayerSchema (unLayer l)
      return (l, schema)

canCreateMultipleGeometryFields :: Bool
canCreateMultipleGeometryFields =
#if SUPPORTS_MULTI_GEOM_FIELDS
  True
#else
  False
#endif


fix fixed types instead of c2hs ones

fix fixed types instead of c2hs ones

-- -----------------------------------------------------------------------------
-- This file is part of Haskell-Opencl.

-- Haskell-Opencl is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.

-- Haskell-Opencl 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 General Public License for more details.

-- You should have received a copy of the GNU General Public License
-- along with Haskell-Opencl.  If not, see <http://www.gnu.org/licenses/>.
-- -----------------------------------------------------------------------------
module System.GPU.OpenCL.Types(
  ErrorCode(..), CLbool, CLint, CLuint, CLulong, CLPlatformInfo_, CLMem,
  CLProgram, CLEvent,
  CLDeviceType_, CLDeviceInfo_, CLContextInfo_, CLDeviceFPConfig(..),
  CLDeviceMemCacheType(..), CLDeviceExecCapability(..), CLDeviceLocalMemType(..),
  CLPlatformID, CLDeviceID, CLContext, CLCommandQueue, CLContextProperty_,
  CLDeviceType(..), CLCommandQueueProperty(..), CLCommandQueueInfo_,
  CLCommandQueueProperty_, getDeviceTypeValue, getDeviceLocalMemType,
  getDeviceMemCacheType, bitmaskToDeviceTypes, bitmaskFromDeviceTypes,
  bitmaskToCommandQueueProperties, bitmaskFromCommandQueueProperties,
  bitmaskToFPConfig, bitmaskToExecCapability )
       where

-- -----------------------------------------------------------------------------
import Foreign( Ptr )
import Foreign.C.Types
import Data.Maybe( fromMaybe, mapMaybe )
import Data.List( foldl' )
import Data.Bits( shiftL, complement, (.|.) )
import System.GPU.OpenCL.Util( testMask )

#include <CL/cl.h>

-- -----------------------------------------------------------------------------

type CLPlatformID = {#type cl_platform_id#}
type CLDeviceID = {#type cl_device_id#}
type CLContext = {#type cl_context#}
type CLCommandQueue = {#type cl_command_queue#}
type CLMem = {#type cl_mem#}
type CLEvent = {#type cl_event#}
type CLProgram = {#type cl_program#}

type CLint = {#type cl_int#}
type CLuint = {#type cl_uint#}
type CLulong = {#type cl_ulong#}
type CLbool = {#type cl_bool#}

type CLPlatformInfo_ = {#type cl_platform_info#}
type CLDeviceType_ = {#type cl_device_type#}
type CLDeviceInfo_ = {#type cl_device_info#}
type CLDeviceFPConfig_ = {#type cl_device_fp_config#}
type CLDeviceMemCacheType_ = {#type cl_device_mem_cache_type#}
type CLDeviceLocalMemType_ = {#type cl_device_local_mem_type#}
type CLDeviceExecCapability_ = {#type cl_device_exec_capabilities#}
type CLContextInfo_ = {#type cl_context_info#}
type CLContextProperty_ = {#type cl_context_properties#}
type CLCommandQueueInfo_ = {#type cl_command_queue_info#}
type CLCommandQueueProperty_ ={#type cl_command_queue_properties#}

newtype ErrorCode = ErrorCode CInt deriving( Eq )

-- -----------------------------------------------------------------------------
data CLDeviceType = CL_DEVICE_TYPE_CPU
                    -- ^ An OpenCL device that is the host processor. The host
                    -- processor runs the OpenCL implementations and is a single
                    -- or multi-core CPU.
                  | CL_DEVICE_TYPE_GPU
                    -- ^ An OpenCL device that is a GPU. By this we mean that
                    -- the device can also be used to accelerate a 3D API such
                    -- as OpenGL or DirectX.
                  | CL_DEVICE_TYPE_ACCELERATOR
                    -- ^ Dedicated OpenCL accelerators (for example the IBM CELL
                    -- Blade). These devices communicate with the host processor
                    -- using a peripheral interconnect such as PCIe.
                  | CL_DEVICE_TYPE_DEFAULT
                    -- ^ The default OpenCL device in the system.
                  | CL_DEVICE_TYPE_ALL
                    -- ^ All OpenCL devices available in the system.
                  deriving( Eq, Show )

deviceTypeValues :: [(CLDeviceType,CLDeviceType_)]
deviceTypeValues = [
  (CL_DEVICE_TYPE_CPU, 1 `shiftL` 1), (CL_DEVICE_TYPE_GPU, 1 `shiftL` 2),
  (CL_DEVICE_TYPE_ACCELERATOR, 1 `shiftL` 3), (CL_DEVICE_TYPE_DEFAULT, 1 `shiftL` 0),
  (CL_DEVICE_TYPE_ALL, complement 0) ]
getDeviceTypeValue :: CLDeviceType -> CLDeviceType_
getDeviceTypeValue info = fromMaybe 0 (lookup info deviceTypeValues)

data CLCommandQueueProperty = CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE
                              -- ^ Determines whether the commands queued in the
                              -- command-queue are executed in-order or
                              -- out-of-order. If set, the commands in the
                              -- command-queue are executed out-of-order.
                              -- Otherwise, commands are executed in-order.
                            | CL_QUEUE_PROFILING_ENABLE
                              -- ^ Enable or disable profiling of commands in
                              -- the command-queue. If set, the profiling of
                              -- commands is enabled. Otherwise profiling of
                              -- commands is disabled. See
                              -- 'clGetEventProfilingInfo' for more information.
                              deriving( Eq, Show )

commandQueueProperties :: [(CLCommandQueueProperty,CLCommandQueueProperty_)]
commandQueueProperties = [
  (CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE, 1 `shiftL` 0),
  (CL_QUEUE_PROFILING_ENABLE, 1 `shiftL` 1)]

data CLDeviceFPConfig = CL_FP_DENORM -- ^ denorms are supported.
                      | CL_FP_INF_NAN -- ^ INF and NaNs are supported.
                      | CL_FP_ROUND_TO_NEAREST
                        -- ^ round to nearest even rounding mode supported.
                      | CL_FP_ROUND_TO_ZERO
                        -- ^ round to zero rounding mode supported.
                      | CL_FP_ROUND_TO_INF
                        -- ^ round to +ve and -ve infinity rounding modes
                        -- supported.
                      | CL_FP_FMA
                        -- ^ IEEE754-2008 fused multiply-add is supported.
                        deriving( Show )

deviceFPValues :: [(CLDeviceFPConfig,CLDeviceFPConfig_)]
deviceFPValues = [
  (CL_FP_DENORM, 1 `shiftL` 0), (CL_FP_INF_NAN, 1 `shiftL` 1),
  (CL_FP_ROUND_TO_NEAREST, 1 `shiftL` 2), (CL_FP_ROUND_TO_ZERO, 1 `shiftL` 3),
  (CL_FP_ROUND_TO_INF, 1 `shiftL` 4), (CL_FP_FMA, 1 `shiftL` 5)]

data CLDeviceExecCapability = CL_EXEC_KERNEL
                              -- ^ The OpenCL device can execute OpenCL kernels.
                            | CL_EXEC_NATIVE_KERNEL
                              -- ^ The OpenCL device can execute native kernels.
                              deriving( Show )

deviceExecValues :: [(CLDeviceExecCapability,CLDeviceExecCapability_)]
deviceExecValues = [
  (CL_EXEC_KERNEL, 1 `shiftL` 0), (CL_EXEC_NATIVE_KERNEL, 1 `shiftL` 1)]

data CLDeviceMemCacheType = CL_NONE | CL_READ_ONLY_CACHE | CL_READ_WRITE_CACHE
                          deriving( Show )
deviceMemCacheTypes :: [(CLDeviceMemCacheType_,CLDeviceMemCacheType)]
deviceMemCacheTypes = [
  (0x0,CL_NONE), (0x1,CL_READ_ONLY_CACHE),(0x2,CL_READ_WRITE_CACHE)]
getDeviceMemCacheType :: CLDeviceMemCacheType_ -> Maybe CLDeviceMemCacheType
getDeviceMemCacheType val = lookup val deviceMemCacheTypes

data CLDeviceLocalMemType = CL_LOCAL | CL_GLOBAL deriving( Show )

deviceLocalMemTypes :: [(CLDeviceLocalMemType_,CLDeviceLocalMemType)]
deviceLocalMemTypes = [(0x1,CL_LOCAL), (0x2,CL_GLOBAL)]
getDeviceLocalMemType :: CLDeviceLocalMemType_ -> Maybe CLDeviceLocalMemType
getDeviceLocalMemType val = lookup val deviceLocalMemTypes

-- -----------------------------------------------------------------------------
bitmaskToDeviceTypes :: CLDeviceType_ -> [CLDeviceType]
bitmaskToDeviceTypes mask = map fst . filter (testMask mask) $ deviceTypeValues

bitmaskFromDeviceTypes :: [CLDeviceType] -> CLDeviceType_
bitmaskFromDeviceTypes = foldl' (.|.) 0 . mapMaybe (`lookup` deviceTypeValues)

bitmaskToCommandQueueProperties :: CLCommandQueueProperty_ -> [CLCommandQueueProperty]
bitmaskToCommandQueueProperties mask = map fst . filter (testMask mask) $ commandQueueProperties

bitmaskFromCommandQueueProperties :: [CLCommandQueueProperty] -> CLCommandQueueProperty_
bitmaskFromCommandQueueProperties = foldl' (.|.) 0 . mapMaybe (`lookup` commandQueueProperties)

bitmaskToFPConfig :: CLDeviceFPConfig_ -> [CLDeviceFPConfig]
bitmaskToFPConfig mask = map fst . filter (testMask mask) $ deviceFPValues

bitmaskToExecCapability :: CLDeviceExecCapability_ -> [CLDeviceExecCapability]
bitmaskToExecCapability mask = map fst . filter (testMask mask) $ deviceExecValues

-- -----------------------------------------------------------------------------

-- -----------------------------------------------------------------------------
-- This file is part of Haskell-Opencl.

-- Haskell-Opencl is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.

-- Haskell-Opencl 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 General Public License for more details.

-- You should have received a copy of the GNU General Public License
-- along with Haskell-Opencl.  If not, see <http://www.gnu.org/licenses/>.
-- -----------------------------------------------------------------------------
module System.GPU.OpenCL.Types(
  ErrorCode(..), CLbool, CLint, CLuint, CLulong, CLPlatformInfo_, CLMem,
  CLProgram, CLEvent,
  CLDeviceType_, CLDeviceInfo_, CLContextInfo_, CLDeviceFPConfig(..),
  CLDeviceMemCacheType(..), CLDeviceExecCapability(..), CLDeviceLocalMemType(..),
  CLPlatformID, CLDeviceID, CLContext, CLCommandQueue, CLContextProperty_,
  CLDeviceType(..), CLCommandQueueProperty(..), CLCommandQueueInfo_,
  CLCommandQueueProperty_, getDeviceTypeValue, getDeviceLocalMemType,
  getDeviceMemCacheType, bitmaskToDeviceTypes, bitmaskFromDeviceTypes,
  bitmaskToCommandQueueProperties, bitmaskFromCommandQueueProperties,
  bitmaskToFPConfig, bitmaskToExecCapability )
       where

-- -----------------------------------------------------------------------------
import Foreign( Ptr )
import Foreign.C.Types( CUInt, CInt, CULong, CLong )
import Data.Maybe( fromMaybe, mapMaybe )
import Data.List( foldl' )
import Data.Bits( shiftL, complement, (.|.) )
import System.GPU.OpenCL.Util( testMask )

#include <CL/cl.h>

-- -----------------------------------------------------------------------------

type CLPlatformID = {#type cl_platform_id#}
type CLDeviceID = {#type cl_device_id#}
type CLContext = {#type cl_context#}
type CLCommandQueue = {#type cl_command_queue#}
type CLMem = {#type cl_mem#}
type CLEvent = {#type cl_event#}
type CLProgram = {#type cl_program#}

type CLint = {#type cl_int#}
type CLuint = {#type cl_uint#}
type CLulong = {#type cl_ulong#}
type CLbool = {#type cl_bool#}

type CLPlatformInfo_ = {#type cl_platform_info#}
type CLDeviceType_ = {#type cl_device_type#}
type CLDeviceInfo_ = {#type cl_device_info#}
type CLDeviceFPConfig_ = {#type cl_device_fp_config#}
type CLDeviceMemCacheType_ = {#type cl_device_mem_cache_type#}
type CLDeviceLocalMemType_ = {#type cl_device_local_mem_type#}
type CLDeviceExecCapability_ = {#type cl_device_exec_capabilities#}
type CLContextInfo_ = {#type cl_context_info#}
type CLContextProperty_ = {#type cl_context_properties#}
type CLCommandQueueInfo_ = {#type cl_command_queue_info#}
type CLCommandQueueProperty_ ={#type cl_command_queue_properties#}

newtype ErrorCode = ErrorCode CInt deriving( Eq )

-- -----------------------------------------------------------------------------
data CLDeviceType = CL_DEVICE_TYPE_CPU
                    -- ^ An OpenCL device that is the host processor. The host
                    -- processor runs the OpenCL implementations and is a single
                    -- or multi-core CPU.
                  | CL_DEVICE_TYPE_GPU
                    -- ^ An OpenCL device that is a GPU. By this we mean that
                    -- the device can also be used to accelerate a 3D API such
                    -- as OpenGL or DirectX.
                  | CL_DEVICE_TYPE_ACCELERATOR
                    -- ^ Dedicated OpenCL accelerators (for example the IBM CELL
                    -- Blade). These devices communicate with the host processor
                    -- using a peripheral interconnect such as PCIe.
                  | CL_DEVICE_TYPE_DEFAULT
                    -- ^ The default OpenCL device in the system.
                  | CL_DEVICE_TYPE_ALL
                    -- ^ All OpenCL devices available in the system.
                  deriving( Eq, Show )

deviceTypeValues :: [(CLDeviceType,CULong)]
deviceTypeValues = [
  (CL_DEVICE_TYPE_CPU, 1 `shiftL` 1), (CL_DEVICE_TYPE_GPU, 1 `shiftL` 2),
  (CL_DEVICE_TYPE_ACCELERATOR, 1 `shiftL` 3), (CL_DEVICE_TYPE_DEFAULT, 1 `shiftL` 0),
  (CL_DEVICE_TYPE_ALL, complement 0) ]
getDeviceTypeValue :: CLDeviceType -> CULong
getDeviceTypeValue info = fromMaybe 0 (lookup info deviceTypeValues)

data CLCommandQueueProperty = CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE
                              -- ^ Determines whether the commands queued in the
                              -- command-queue are executed in-order or
                              -- out-of-order. If set, the commands in the
                              -- command-queue are executed out-of-order.
                              -- Otherwise, commands are executed in-order.
                            | CL_QUEUE_PROFILING_ENABLE
                              -- ^ Enable or disable profiling of commands in
                              -- the command-queue. If set, the profiling of
                              -- commands is enabled. Otherwise profiling of
                              -- commands is disabled. See
                              -- 'clGetEventProfilingInfo' for more information.
                              deriving( Eq, Show )

commandQueueProperties :: [(CLCommandQueueProperty,CULong)]
commandQueueProperties = [
  (CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE, 1 `shiftL` 0),
  (CL_QUEUE_PROFILING_ENABLE, 1 `shiftL` 1)]

data CLDeviceFPConfig = CL_FP_DENORM -- ^ denorms are supported.
                      | CL_FP_INF_NAN -- ^ INF and NaNs are supported.
                      | CL_FP_ROUND_TO_NEAREST
                        -- ^ round to nearest even rounding mode supported.
                      | CL_FP_ROUND_TO_ZERO
                        -- ^ round to zero rounding mode supported.
                      | CL_FP_ROUND_TO_INF
                        -- ^ round to +ve and -ve infinity rounding modes
                        -- supported.
                      | CL_FP_FMA
                        -- ^ IEEE754-2008 fused multiply-add is supported.
                        deriving( Show )

deviceFPValues :: [(CLDeviceFPConfig,CLDeviceFPConfig_)]
deviceFPValues = [
  (CL_FP_DENORM, 1 `shiftL` 0), (CL_FP_INF_NAN, 1 `shiftL` 1),
  (CL_FP_ROUND_TO_NEAREST, 1 `shiftL` 2), (CL_FP_ROUND_TO_ZERO, 1 `shiftL` 3),
  (CL_FP_ROUND_TO_INF, 1 `shiftL` 4), (CL_FP_FMA, 1 `shiftL` 5)]

data CLDeviceExecCapability = CL_EXEC_KERNEL
                              -- ^ The OpenCL device can execute OpenCL kernels.
                            | CL_EXEC_NATIVE_KERNEL
                              -- ^ The OpenCL device can execute native kernels.
                              deriving( Show )

deviceExecValues :: [(CLDeviceExecCapability,CLDeviceExecCapability_)]
deviceExecValues = [
  (CL_EXEC_KERNEL, 1 `shiftL` 0), (CL_EXEC_NATIVE_KERNEL, 1 `shiftL` 1)]

data CLDeviceMemCacheType = CL_NONE | CL_READ_ONLY_CACHE | CL_READ_WRITE_CACHE
                          deriving( Show )
deviceMemCacheTypes :: [(CLDeviceMemCacheType_,CLDeviceMemCacheType)]
deviceMemCacheTypes = [
  (0x0,CL_NONE), (0x1,CL_READ_ONLY_CACHE),(0x2,CL_READ_WRITE_CACHE)]
getDeviceMemCacheType :: CLDeviceMemCacheType_ -> Maybe CLDeviceMemCacheType
getDeviceMemCacheType val = lookup val deviceMemCacheTypes

data CLDeviceLocalMemType = CL_LOCAL | CL_GLOBAL deriving( Show )

deviceLocalMemTypes :: [(CLDeviceLocalMemType_,CLDeviceLocalMemType)]
deviceLocalMemTypes = [(0x1,CL_LOCAL), (0x2,CL_GLOBAL)]
getDeviceLocalMemType :: CLDeviceLocalMemType_ -> Maybe CLDeviceLocalMemType
getDeviceLocalMemType val = lookup val deviceLocalMemTypes

-- -----------------------------------------------------------------------------
bitmaskToDeviceTypes :: CULong -> [CLDeviceType]
bitmaskToDeviceTypes mask = map fst . filter (testMask mask) $ deviceTypeValues

bitmaskFromDeviceTypes :: [CLDeviceType] -> CULong
bitmaskFromDeviceTypes = foldl' (.|.) 0 . mapMaybe (`lookup` deviceTypeValues)

bitmaskToCommandQueueProperties :: CULong -> [CLCommandQueueProperty]
bitmaskToCommandQueueProperties mask = map fst . filter (testMask mask) $ commandQueueProperties

bitmaskFromCommandQueueProperties :: [CLCommandQueueProperty] -> CULong
bitmaskFromCommandQueueProperties = foldl' (.|.) 0 . mapMaybe (`lookup` commandQueueProperties)

bitmaskToFPConfig :: CLDeviceFPConfig_ -> [CLDeviceFPConfig]
bitmaskToFPConfig mask = map fst . filter (testMask mask) $ deviceFPValues

bitmaskToExecCapability :: CLDeviceExecCapability_ -> [CLDeviceExecCapability]
bitmaskToExecCapability mask = map fst . filter (testMask mask) $ deviceExecValues

-- -----------------------------------------------------------------------------


gstreamer: M.S.G.Core.Bus documentation cleanup

--  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)
--
--  An asynchronous message bus subsystem.
module Media.Streaming.GStreamer.Core.Bus (
-- * Detail
  -- | The 'Bus' is resposible for delivering 'Message's in a
  --   first-in, first-out order, from the streaming threads to the
  --   application.
  --
  --   Since the application typically only wants to deal with
  --   delivery of these messages from one thread, the 'Bus' will
  --   marshal the messages between different threads. This is
  --   important since the actual streaming of media is done in
  --   a thread separate from the application.
  --
  --   The 'Bus' provides support for 'System.Glib.MainLoop.Source'
  --   based notifications. This makes it possible to handle the
  --   delivery in the GLib 'System.Glib.MainLoop.Source'.
  --
  --   A message is posted on the bus with the 'busPost' method. With
  --   the 'busPeek' and 'busPop' methods one can look at or retrieve
  --   a previously posted message.
  --
  --   The bus can be polled with the 'busPoll' method. This methods
  --   blocks up to the specified timeout value until one of the
  --   specified messages types is posted on the bus. The application
  --   can then pop the messages from the bus to handle
  --   them. Alternatively the application can register an
  --   asynchronous bus function using 'busAddWatch'. This function
  --   will install a 'System.Glib.MainLoop.Source' in the default
  --   GLib main loop and will deliver messages a short while after
  --   they have been posted. Note that the main loop should be
  --   running for the asynchronous callbacks.
  --
  --   It is also possible to get messages from the bus without any
  --   thread marshalling with the 'busSetSyncHandler' method. This
  --   makes it possible to react to a message in the same thread that
  --   posted the message on the bus. This should only be used if the
  --   application is able to deal with messages from different
  --   threads.
  --
  --   Every 'Pipeline' has one bus.
  --
  --   Note that a 'Pipeline' will set its bus into flushing state
  --   when changing from 'StateReady' to 'StateNull'.

-- * Types
  Bus,
  -- | The result of a 'BusSyncHandler'.
  BusSyncReply,
  -- | A handler that will be invoked synchronously when a new message
  --   is injected into the bus. This function is mostly used internally.
  --   Only one sync handler may be attached to a given bus.
  BusSyncHandler,
  BusClass,
  castToBus,
  toBus,
-- * Bus Operations
  busGetFlags,
  busSetFlags,
  busUnsetFlags,
  busNew,
  busPost,
  busHavePending,
  busPeek,
  busPop,
  busTimedPop,
  busSetFlushing,
  busSetSyncHandler,
  busUseSyncSignalHandler,
  busCreateWatch,
  busAddWatch,
  busDisableSyncMessageEmission,
  busEnableSyncMessageEmission,
  busAddSignalWatch,
  busRemoveSignalWatch,
  busPoll,

-- * Bus Signals
  onBusMessage,
  afterBusMessage,
  onBusSyncMessage,
  afterBusSyncMessage

  ) where

import Control.Monad ( liftM
                     , when )
{#import Media.Streaming.GStreamer.Core.Object#}
{#import Media.Streaming.GStreamer.Core.Types#}
{#import Media.Streaming.GStreamer.Core.Signals#}
{#import System.Glib.MainLoop#}
import System.Glib.Flags
import System.Glib.FFI
{#import System.Glib.GObject#}
{#import System.Glib.MainLoop#}

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

-- | Get the flags set on this bus.
busGetFlags :: BusClass busT
            => busT
            -> IO [BusFlags]
busGetFlags = mkObjectGetFlags

-- | Set flags on this bus.
busSetFlags :: BusClass busT
            => busT
            -> [BusFlags]
            -> IO ()
busSetFlags = mkObjectSetFlags

-- | Unset flags on this bus.
busUnsetFlags :: BusClass busT
              => busT
              -> [BusFlags]
              -> IO ()
busUnsetFlags = mkObjectUnsetFlags

-- | Create a new bus.
busNew :: IO Bus
busNew =
    {# call bus_new #} >>= takeObject

-- | Post a message to the bus.
busPost :: BusClass busT
        => busT
        -> Message
        -> IO Bool
busPost bus message =
    do {# call gst_mini_object_ref #} (toMiniObject message)
       liftM toBool $ {# call bus_post #} (toBus bus) message

-- | Check if there are pending messages on the bus.
busHavePending :: BusClass busT
               => busT
               -> IO Bool
busHavePending bus =
    liftM toBool $ {# call bus_have_pending #} $ toBus bus

-- | Get the message at the front of the queue.  It will remain on the
--   queue.
busPeek :: BusClass busT
        => busT
        -> IO (Maybe Message)
busPeek bus =
    {# call bus_peek #} (toBus bus) >>= maybePeek takeMiniObject

-- | Get the message at the front of the queue.  It will be removed
--   from the queue.
busPop :: BusClass busT
       => busT
       -> IO (Maybe Message)
busPop bus =
    {# call bus_pop #} (toBus bus) >>= maybePeek takeMiniObject

-- | Get a message from the bus, waiting up to the specified timeout.
--   If the time given is 'Nothing', the function will wait forever.
--   If the time given is @0@, the function will behave like 'busPop'.
busTimedPop :: BusClass busT
            => busT
            -> Maybe ClockTime
            -> IO (Maybe Message)
busTimedPop bus timeoutM =
    let timeout = case timeoutM of
                    Just timeout' -> timeout'
                    Nothing       -> clockTimeNone
    in {# call bus_timed_pop #} (toBus bus) (fromIntegral timeout) >>=
           maybePeek takeMiniObject

-- | If @flushing@ is 'True', the bus will flush out any queued
--   messages, as well as any future messages, until the function is
--   called with @flushing@ set to 'False'.
busSetFlushing :: BusClass busT
               => busT
               -> Bool
               -> IO ()
busSetFlushing bus flushing =
    {# call bus_set_flushing #} (toBus bus) $ fromBool flushing

-- these will leak memory, maybe one day we can set a destroy notifier...

type CBusSyncHandler =  Ptr Bus
                     -> Ptr Message
                     -> {# type gpointer #}
                     -> IO {# type GstBusSyncReply #}
marshalBusSyncHandler :: BusSyncHandler
                      -> IO {# type GstBusSyncHandler #}
marshalBusSyncHandler busSyncHandler =
    makeBusSyncHandler cBusSyncHandler
    where cBusSyncHandler :: CBusSyncHandler
          cBusSyncHandler busPtr messagePtr _ =
              do bus <- peekObject busPtr
                 message <- peekMiniObject messagePtr
                 reply <- busSyncHandler bus message
                 when (reply == BusDrop) $
                     {# call gst_mini_object_unref #} (toMiniObject message)
                 return $ fromIntegral $ fromEnum reply
foreign import ccall "wrapper"
    makeBusSyncHandler :: CBusSyncHandler
                       -> IO {# type GstBusSyncHandler #}

-- the following mess is necessary to clean up safely after busSetSyncHandler.
-- gstreamer doesn't give us a nice way to do this (such as a DestroyNotify)
weakNotifyQuark, funPtrQuark :: Quark
weakNotifyQuark = unsafePerformIO $ quarkFromString "Gtk2HS::SyncHandlerWeakNotify"
funPtrQuark = unsafePerformIO $ quarkFromString "Gtk2HS::SyncHandlerFunPtr"

getWeakNotify :: BusClass busT
              => busT
              -> IO (Maybe GWeakNotify)
getWeakNotify = objectGetAttributeUnsafe weakNotifyQuark

setWeakNotify :: BusClass busT
              => busT
              -> Maybe GWeakNotify
              -> IO ()
setWeakNotify = objectSetAttribute weakNotifyQuark

getFunPtr :: BusClass busT
          => busT
          -> IO (Maybe {# type GstBusSyncHandler #})
getFunPtr = objectGetAttributeUnsafe funPtrQuark

setFunPtr :: BusClass busT
          => busT
          -> Maybe {# type GstBusSyncHandler #}
          -> IO ()
setFunPtr = objectSetAttribute funPtrQuark

unsetSyncHandler :: BusClass busT
                 => busT
                 -> IO ()
unsetSyncHandler bus = do
  {# call bus_set_sync_handler #} (toBus bus) nullFunPtr nullPtr
  oldWeakNotifyM <- getWeakNotify bus
  case oldWeakNotifyM of
    Just oldWeakNotify -> objectWeakunref bus oldWeakNotify
    Nothing            -> return ()
  setWeakNotify bus Nothing
  oldFunPtrM <- getFunPtr bus
  case oldFunPtrM of
    Just oldFunPtr -> freeHaskellFunPtr oldFunPtr
    Nothing        -> return ()
  setFunPtr bus Nothing

-- | Set the synchronous message handler on the bus. The function will
--   be called every time a new message is posted to the bus. Note
--   that the function will be called from the thread context of the
--   poster.
--
--   Calling this function will replace any previously set sync
--   handler. If 'Nothing' is passed to this function, it will unset
--   the handler.
busSetSyncHandler :: BusClass busT
                  => busT
                  -> Maybe BusSyncHandler
                  -> IO ()
busSetSyncHandler bus busSyncHandlerM = do
  objectWithLock bus $ do
    unsetSyncHandler bus
    case busSyncHandlerM of
      Just busSyncHandler ->
          do funPtr <- marshalBusSyncHandler busSyncHandler
             setFunPtr bus $ Just funPtr
             weakNotify <- objectWeakref bus $ freeHaskellFunPtr funPtr
             setWeakNotify bus $ Just weakNotify
             {# call bus_set_sync_handler #} (toBus bus) funPtr nullPtr
      Nothing ->
          return ()

-- | Use a synchronous message handler that converts all messages to signals.
busUseSyncSignalHandler :: BusClass busT
                        => busT
                        -> IO ()
busUseSyncSignalHandler bus = do
  objectWithLock bus $ do
    unsetSyncHandler bus
    {# call bus_set_sync_handler #} (toBus bus) cBusSyncSignalHandlerPtr nullPtr
foreign import ccall unsafe "&gst_bus_sync_signal_handler"
    cBusSyncSignalHandlerPtr :: {# type GstBusSyncHandler #}

-- | Create a watch for the bus. The 'Source' will dispatch a signal
--   whenever a message is on the bus. After the signal is dispatched,
--   the message is popped off the bus.
busCreateWatch :: BusClass busT
               => busT
               -> IO Source
busCreateWatch bus =
    liftM Source $ {# call bus_create_watch #} (toBus bus) >>=
        flip newForeignPtr sourceFinalizer
foreign import ccall unsafe "&g_source_unref"
    sourceFinalizer :: FunPtr (Ptr Source -> IO ())

type CBusFunc =  Ptr Bus
              -> Ptr Message
              -> {# type gpointer #}
              -> IO {# type gboolean #}
marshalBusFunc :: BusFunc
               -> IO {# type GstBusFunc #}
marshalBusFunc busFunc =
    makeBusFunc cBusFunc
    where cBusFunc :: CBusFunc
          cBusFunc busPtr messagePtr userData =
              do bus <- peekObject busPtr
                 message <- peekMiniObject messagePtr
                 liftM fromBool $ busFunc bus message
foreign import ccall "wrapper"
    makeBusFunc :: CBusFunc
                -> IO {# type GstBusFunc #}

-- | Adds a bus watch to the default main context with the given
--   priority. This function is used to receive asynchronous messages
--   in the main loop.
--
--   The watch can be removed by calling 'System.Glib.MainLoop.sourceRemove'.
busAddWatch :: BusClass busT
            => busT
            -> Priority
            -> BusFunc
            -> IO HandlerId
busAddWatch bus priority func =
    do busFuncPtr <- marshalBusFunc func
       destroyNotify <- mkFunPtrDestroyNotify busFuncPtr
       liftM fromIntegral $
           {# call bus_add_watch_full #}
               (toBus bus)
               (fromIntegral priority)
               busFuncPtr
               nullPtr
               destroyNotify

-- | Instructs GStreamer to stop emitting the @"sync-message"@ signal
--   for this bus. See 'busEnableSyncMessageEmission' for more
--   information.
--
--   In the event that multiple pieces of code have called
--   'busEnableSyncMessageEmission', the sync-message
--   emissions will only be stopped after all calls to
--   'busEnableSyncMessageEmission' were "cancelled" by
--   calling this function.
busDisableSyncMessageEmission :: BusClass busT
                              => busT
                              -> IO ()
busDisableSyncMessageEmission =
    {# call bus_disable_sync_message_emission #} . toBus

-- | Instructs GStreamer to emit the @"sync-message"@ signal after
--   running the bus's sync handler. This function is here so that
--   programmers can ensure that they can synchronously receive
--   messages without having to affect what the bin's sync handler is.
--
--   This function may be called multiple times. To clean up, the
--   caller is responsible for calling 'busDisableSyncMessageEmission'
--   as many times as this function is called.
--
--   While this function looks similar to 'busAddSignalWatch', it is
--   not exactly the same -- this function enables synchronous
--   emission of signals when messages arrive; 'busAddSignalWatch'
--   adds an idle callback to pop messages off the bus
--   asynchronously. The @"sync-message"@ signal comes from the thread
--   of whatever object posted the message; the @"message"@ signal is
--   marshalled to the main thread via the main loop.
busEnableSyncMessageEmission :: BusClass busT
                             => busT
                             -> IO ()
busEnableSyncMessageEmission =
    {# call bus_enable_sync_message_emission #} . toBus

-- | Adds a bus signal watch to the default main context with the
--   given priority. After calling this method, the bus will emit the
--   @"message"@ signal for each message posted on the bus.
--
--   This function may be called multiple times. To clean up, the
--   caller is responsible for calling 'busRemoveSignalWatch' as many
--   times.
busAddSignalWatch :: BusClass busT
                  => busT
                  -> Priority
                  -> IO ()
busAddSignalWatch bus priority =
    {# call bus_add_signal_watch_full #} (toBus bus) $ fromIntegral priority

-- | Remove the signal watch that was added with 'busAddSignalWatch'.
busRemoveSignalWatch :: BusClass busT
                     => busT
                     -> IO ()
busRemoveSignalWatch =
    {# call bus_remove_signal_watch #} . toBus

-- | Poll the bus for a message. Will block while waiting for messages
--   to come. You can specify the maximum amount of time to wait with
--   the @timeout@ parameter. If @timeout@ is negative, the function
--   will wait indefinitely.
--
--   Messages not in @events@ will be popped off the bus and ignored.
--
--   Because 'busPoll' is implemented using the @"message"@ signal
--   enabled by 'busAddSignalWatch', calling 'busPoll' will cause the
--   @"message"@ signal to be emitted for every message that the
--   function sees. Thus, a @"message"@ signal handler will see every
--   message that 'busPoll' sees -- neither will steal messages from
--   the other.
--
--   This function will run a main loop in the default main context
--   while polling.
busPoll :: Bus
        -> [MessageType]
        -> ClockTimeDiff
        -> IO Message
busPoll bus events timeout =
    {# call bus_poll #} bus
                        (fromIntegral $ fromFlags events)
                        (fromIntegral timeout) >>=
        takeMiniObject

-- | Connect to the @"message"@ signal. Emitted from a 'Source' added
--   to the mainloop. This signal will only be emitted when there is a
--   'MainLoop' running.
onBusMessage, afterBusMessage :: BusClass bus
                              => bus
                              -> (Message -> IO ())
                              -> IO (ConnectId bus)
onBusMessage =
    connect_BOXED__NONE "message" peekMiniObject False
afterBusMessage =
    connect_BOXED__NONE "message" peekMiniObject True

-- | A message has been posted on the bus. This signal is emitted from
--   the thread that posted the message so one has to be careful with
--   locking.
--
--   This signal will not be emitted by default, you must first call
--   'busUseSyncSignalHandler' if you want this signal to be emitted
--   when a message is posted on the bus.
onBusSyncMessage, afterBusSyncMessage :: BusClass bus
                                      => bus
                                      -> (Message -> IO ())
                                      -> IO (ConnectId bus)
onBusSyncMessage =
    connect_BOXED__NONE "sync-message" peekMiniObject False
afterBusSyncMessage =
    connect_BOXED__NONE "sync-message" peekMiniObject True

--  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)
--
--   An asynchronous message bus subsystem.
--
module Media.Streaming.GStreamer.Core.Bus (
-- * Types
  -- | The 'Bus' is resposible for delivering 'Message's in a
  --   first-in, first-out order, from the streaming threads to the
  --   application.
  --
  --   Since the application typically only wants to deal with
  --   delivery of these messages from one thread, the 'Bus' will
  --   marshal the messages between different threads. This is
  --   important since the actual streaming of media is done in
  --   a thread separate from the application.
  --
  --   The 'Bus' provides support for 'System.Glib.MainLoop.Source'
  --   based notifications. This makes it possible to handle the
  --   delivery in the GLib 'System.Glib.MainLoop.Source'.
  --
  --   A message is posted on the bus with the 'busPost' method. With
  --   the 'busPeek' and 'busPop' methods one can look at or retrieve
  --   a previously posted message.
  --
  --   The bus can be polled with the 'busPoll' method. This methods
  --   blocks up to the specified timeout value until one of the
  --   specified messages types is posted on the bus. The application
  --   can then pop the messages from the bus to handle
  --   them. Alternatively the application can register an
  --   asynchronous bus function using 'busAddWatch'. This function
  --   will install a 'System.Glib.MainLoop.Source' in the default
  --   GLib main loop and will deliver messages a short while after
  --   they have been posted. Note that the main loop should be
  --   running for the asynchronous callbacks.
  --
  --   It is also possible to get messages from the bus without any
  --   thread marshalling with the 'busSetSyncHandler' method. This
  --   makes it possible to react to a message in the same thread that
  --   posted the message on the bus. This should only be used if the
  --   application is able to deal with messages from different
  --   threads.
  --
  --   Every 'Pipeline' has one bus.
  --
  --   Note that a 'Pipeline' will set its bus into flushing state
  --   when changing from 'StateReady' to 'StateNull'.
  Bus,
  -- | The result of a 'BusSyncHandler'.
  BusSyncReply,
  -- | A handler that will be invoked synchronously when a new message
  --   is injected into the bus. This function is mostly used internally.
  --   Only one sync handler may be attached to a given bus.
  BusSyncHandler,
  BusClass,
  castToBus,
  toBus,
-- * Bus Operations
  busGetFlags,
  busSetFlags,
  busUnsetFlags,
  busNew,
  busPost,
  busHavePending,
  busPeek,
  busPop,
  busTimedPop,
  busSetFlushing,
  busSetSyncHandler,
  busUseSyncSignalHandler,
  busCreateWatch,
  busAddWatch,
  busDisableSyncMessageEmission,
  busEnableSyncMessageEmission,
  busAddSignalWatch,
  busRemoveSignalWatch,
  busPoll,

-- * Bus Signals
  onBusMessage,
  afterBusMessage,
  onBusSyncMessage,
  afterBusSyncMessage

  ) where

import Control.Monad ( liftM
                     , when )
{#import Media.Streaming.GStreamer.Core.Object#}
{#import Media.Streaming.GStreamer.Core.Types#}
{#import Media.Streaming.GStreamer.Core.Signals#}
{#import System.Glib.MainLoop#}
import System.Glib.Flags
import System.Glib.FFI
{#import System.Glib.GObject#}
{#import System.Glib.MainLoop#}

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

-- | Get the flags set on this bus.
busGetFlags :: BusClass busT
            => busT
            -> IO [BusFlags]
busGetFlags = mkObjectGetFlags

-- | Set flags on this bus.
busSetFlags :: BusClass busT
            => busT
            -> [BusFlags]
            -> IO ()
busSetFlags = mkObjectSetFlags

-- | Unset flags on this bus.
busUnsetFlags :: BusClass busT
              => busT
              -> [BusFlags]
              -> IO ()
busUnsetFlags = mkObjectUnsetFlags

-- | Create a new bus.
busNew :: IO Bus
busNew =
    {# call bus_new #} >>= takeObject

-- | Post a message to the bus.
busPost :: BusClass busT
        => busT
        -> Message
        -> IO Bool
busPost bus message =
    do {# call gst_mini_object_ref #} (toMiniObject message)
       liftM toBool $ {# call bus_post #} (toBus bus) message

-- | Check if there are pending messages on the bus.
busHavePending :: BusClass busT
               => busT
               -> IO Bool
busHavePending bus =
    liftM toBool $ {# call bus_have_pending #} $ toBus bus

-- | Get the message at the front of the queue.  It will remain on the
--   queue.
busPeek :: BusClass busT
        => busT
        -> IO (Maybe Message)
busPeek bus =
    {# call bus_peek #} (toBus bus) >>= maybePeek takeMiniObject

-- | Get the message at the front of the queue.  It will be removed
--   from the queue.
busPop :: BusClass busT
       => busT
       -> IO (Maybe Message)
busPop bus =
    {# call bus_pop #} (toBus bus) >>= maybePeek takeMiniObject

-- | Get a message from the bus, waiting up to the specified timeout.
--   If the time given is 'Nothing', the function will wait forever.
--   If the time given is @0@, the function will behave like 'busPop'.
busTimedPop :: BusClass busT
            => busT
            -> Maybe ClockTime
            -> IO (Maybe Message)
busTimedPop bus timeoutM =
    let timeout = case timeoutM of
                    Just timeout' -> timeout'
                    Nothing       -> clockTimeNone
    in {# call bus_timed_pop #} (toBus bus) (fromIntegral timeout) >>=
           maybePeek takeMiniObject

-- | If @flushing@ is 'True', the bus will flush out any queued
--   messages, as well as any future messages, until the function is
--   called with @flushing@ set to 'False'.
busSetFlushing :: BusClass busT
               => busT
               -> Bool
               -> IO ()
busSetFlushing bus flushing =
    {# call bus_set_flushing #} (toBus bus) $ fromBool flushing

-- these will leak memory, maybe one day we can set a destroy notifier...

type CBusSyncHandler =  Ptr Bus
                     -> Ptr Message
                     -> {# type gpointer #}
                     -> IO {# type GstBusSyncReply #}
marshalBusSyncHandler :: BusSyncHandler
                      -> IO {# type GstBusSyncHandler #}
marshalBusSyncHandler busSyncHandler =
    makeBusSyncHandler cBusSyncHandler
    where cBusSyncHandler :: CBusSyncHandler
          cBusSyncHandler busPtr messagePtr _ =
              do bus <- peekObject busPtr
                 message <- peekMiniObject messagePtr
                 reply <- busSyncHandler bus message
                 when (reply == BusDrop) $
                     {# call gst_mini_object_unref #} (toMiniObject message)
                 return $ fromIntegral $ fromEnum reply
foreign import ccall "wrapper"
    makeBusSyncHandler :: CBusSyncHandler
                       -> IO {# type GstBusSyncHandler #}

-- the following mess is necessary to clean up safely after busSetSyncHandler.
-- gstreamer doesn't give us a nice way to do this (such as a DestroyNotify)
weakNotifyQuark, funPtrQuark :: Quark
weakNotifyQuark = unsafePerformIO $ quarkFromString "Gtk2HS::SyncHandlerWeakNotify"
funPtrQuark = unsafePerformIO $ quarkFromString "Gtk2HS::SyncHandlerFunPtr"

getWeakNotify :: BusClass busT
              => busT
              -> IO (Maybe GWeakNotify)
getWeakNotify = objectGetAttributeUnsafe weakNotifyQuark

setWeakNotify :: BusClass busT
              => busT
              -> Maybe GWeakNotify
              -> IO ()
setWeakNotify = objectSetAttribute weakNotifyQuark

getFunPtr :: BusClass busT
          => busT
          -> IO (Maybe {# type GstBusSyncHandler #})
getFunPtr = objectGetAttributeUnsafe funPtrQuark

setFunPtr :: BusClass busT
          => busT
          -> Maybe {# type GstBusSyncHandler #}
          -> IO ()
setFunPtr = objectSetAttribute funPtrQuark

unsetSyncHandler :: BusClass busT
                 => busT
                 -> IO ()
unsetSyncHandler bus = do
  {# call bus_set_sync_handler #} (toBus bus) nullFunPtr nullPtr
  oldWeakNotifyM <- getWeakNotify bus
  case oldWeakNotifyM of
    Just oldWeakNotify -> objectWeakunref bus oldWeakNotify
    Nothing            -> return ()
  setWeakNotify bus Nothing
  oldFunPtrM <- getFunPtr bus
  case oldFunPtrM of
    Just oldFunPtr -> freeHaskellFunPtr oldFunPtr
    Nothing        -> return ()
  setFunPtr bus Nothing

-- | Set the synchronous message handler on the bus. The function will
--   be called every time a new message is posted to the bus. Note
--   that the function will be called from the thread context of the
--   poster.
--
--   Calling this function will replace any previously set sync
--   handler. If 'Nothing' is passed to this function, it will unset
--   the handler.
busSetSyncHandler :: BusClass busT
                  => busT
                  -> Maybe BusSyncHandler
                  -> IO ()
busSetSyncHandler bus busSyncHandlerM = do
  objectWithLock bus $ do
    unsetSyncHandler bus
    case busSyncHandlerM of
      Just busSyncHandler ->
          do funPtr <- marshalBusSyncHandler busSyncHandler
             setFunPtr bus $ Just funPtr
             weakNotify <- objectWeakref bus $ freeHaskellFunPtr funPtr
             setWeakNotify bus $ Just weakNotify
             {# call bus_set_sync_handler #} (toBus bus) funPtr nullPtr
      Nothing ->
          return ()

-- | Use a synchronous message handler that converts all messages to signals.
busUseSyncSignalHandler :: BusClass busT
                        => busT
                        -> IO ()
busUseSyncSignalHandler bus = do
  objectWithLock bus $ do
    unsetSyncHandler bus
    {# call bus_set_sync_handler #} (toBus bus) cBusSyncSignalHandlerPtr nullPtr
foreign import ccall unsafe "&gst_bus_sync_signal_handler"
    cBusSyncSignalHandlerPtr :: {# type GstBusSyncHandler #}

-- | Create a watch for the bus. The 'Source' will dispatch a signal
--   whenever a message is on the bus. After the signal is dispatched,
--   the message is popped off the bus.
busCreateWatch :: BusClass busT
               => busT
               -> IO Source
busCreateWatch bus =
    liftM Source $ {# call bus_create_watch #} (toBus bus) >>=
        flip newForeignPtr sourceFinalizer
foreign import ccall unsafe "&g_source_unref"
    sourceFinalizer :: FunPtr (Ptr Source -> IO ())

type CBusFunc =  Ptr Bus
              -> Ptr Message
              -> {# type gpointer #}
              -> IO {# type gboolean #}
marshalBusFunc :: BusFunc
               -> IO {# type GstBusFunc #}
marshalBusFunc busFunc =
    makeBusFunc cBusFunc
    where cBusFunc :: CBusFunc
          cBusFunc busPtr messagePtr userData =
              do bus <- peekObject busPtr
                 message <- peekMiniObject messagePtr
                 liftM fromBool $ busFunc bus message
foreign import ccall "wrapper"
    makeBusFunc :: CBusFunc
                -> IO {# type GstBusFunc #}

-- | Adds a bus watch to the default main context with the given
--   priority. This function is used to receive asynchronous messages
--   in the main loop.
--
--   The watch can be removed by calling 'System.Glib.MainLoop.sourceRemove'.
busAddWatch :: BusClass busT
            => busT
            -> Priority
            -> BusFunc
            -> IO HandlerId
busAddWatch bus priority func =
    do busFuncPtr <- marshalBusFunc func
       destroyNotify <- mkFunPtrDestroyNotify busFuncPtr
       liftM fromIntegral $
           {# call bus_add_watch_full #}
               (toBus bus)
               (fromIntegral priority)
               busFuncPtr
               nullPtr
               destroyNotify

-- | Instructs GStreamer to stop emitting the @"sync-message"@ signal
--   for this bus. See 'busEnableSyncMessageEmission' for more
--   information.
--
--   In the event that multiple pieces of code have called
--   'busEnableSyncMessageEmission', the sync-message
--   emissions will only be stopped after all calls to
--   'busEnableSyncMessageEmission' were "cancelled" by
--   calling this function.
busDisableSyncMessageEmission :: BusClass busT
                              => busT
                              -> IO ()
busDisableSyncMessageEmission =
    {# call bus_disable_sync_message_emission #} . toBus

-- | Instructs GStreamer to emit the @"sync-message"@ signal after
--   running the bus's sync handler. This function is here so that
--   programmers can ensure that they can synchronously receive
--   messages without having to affect what the bin's sync handler is.
--
--   This function may be called multiple times. To clean up, the
--   caller is responsible for calling 'busDisableSyncMessageEmission'
--   as many times as this function is called.
--
--   While this function looks similar to 'busAddSignalWatch', it is
--   not exactly the same -- this function enables synchronous
--   emission of signals when messages arrive; 'busAddSignalWatch'
--   adds an idle callback to pop messages off the bus
--   asynchronously. The @"sync-message"@ signal comes from the thread
--   of whatever object posted the message; the @"message"@ signal is
--   marshalled to the main thread via the main loop.
busEnableSyncMessageEmission :: BusClass busT
                             => busT
                             -> IO ()
busEnableSyncMessageEmission =
    {# call bus_enable_sync_message_emission #} . toBus

-- | Adds a bus signal watch to the default main context with the
--   given priority. After calling this method, the bus will emit the
--   @"message"@ signal for each message posted on the bus.
--
--   This function may be called multiple times. To clean up, the
--   caller is responsible for calling 'busRemoveSignalWatch' as many
--   times.
busAddSignalWatch :: BusClass busT
                  => busT
                  -> Priority
                  -> IO ()
busAddSignalWatch bus priority =
    {# call bus_add_signal_watch_full #} (toBus bus) $ fromIntegral priority

-- | Remove the signal watch that was added with 'busAddSignalWatch'.
busRemoveSignalWatch :: BusClass busT
                     => busT
                     -> IO ()
busRemoveSignalWatch =
    {# call bus_remove_signal_watch #} . toBus

-- | Poll the bus for a message. Will block while waiting for messages
--   to come. You can specify the maximum amount of time to wait with
--   the @timeout@ parameter. If @timeout@ is negative, the function
--   will wait indefinitely.
--
--   Messages not in @events@ will be popped off the bus and ignored.
--
--   Because 'busPoll' is implemented using the @"message"@ signal
--   enabled by 'busAddSignalWatch', calling 'busPoll' will cause the
--   @"message"@ signal to be emitted for every message that the
--   function sees. Thus, a @"message"@ signal handler will see every
--   message that 'busPoll' sees -- neither will steal messages from
--   the other.
--
--   This function will run a main loop in the default main context
--   while polling.
busPoll :: Bus
        -> [MessageType]
        -> ClockTimeDiff
        -> IO Message
busPoll bus events timeout =
    {# call bus_poll #} bus
                        (fromIntegral $ fromFlags events)
                        (fromIntegral timeout) >>=
        takeMiniObject

-- | Connect to the @"message"@ signal. Emitted from a 'Source' added
--   to the mainloop. This signal will only be emitted when there is a
--   'MainLoop' running.
onBusMessage, afterBusMessage :: BusClass bus
                              => bus
                              -> (Message -> IO ())
                              -> IO (ConnectId bus)
onBusMessage =
    connect_BOXED__NONE "message" peekMiniObject False
afterBusMessage =
    connect_BOXED__NONE "message" peekMiniObject True

-- | A message has been posted on the bus. This signal is emitted from
--   the thread that posted the message so one has to be careful with
--   locking.
--
--   This signal will not be emitted by default, you must first call
--   'busUseSyncSignalHandler' if you want this signal to be emitted
--   when a message is posted on the bus.
onBusSyncMessage, afterBusSyncMessage :: BusClass bus
                                      => bus
                                      -> (Message -> IO ())
                                      -> IO (ConnectId bus)
onBusSyncMessage =
    connect_BOXED__NONE "sync-message" peekMiniObject False
afterBusSyncMessage =
    connect_BOXED__NONE "sync-message" peekMiniObject True