fixes for 7.8.4

fixes for 7.8.4

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE BangPatterns #-}

module GDAL.Internal.Algorithms (
    GenImgProjTransformer (..)
  , GenImgProjTransformer2 (..)
  , GenImgProjTransformer3 (..)
  , SomeTransformer (..)

  , Contour (..)

  , GridPoint (..)
  , GridAlgorithm (..)
  , GridInverseDistanceToAPower (..)
  , GridMovingAverage (..)
  , GridNearestNeighbor (..)
  , GridDataMetrics (..)
  , MetricType (..)

  , GridAlgorithmEnum (..)

  , rasterizeLayersBuf
  , createGrid
  , createGridIO
  , computeProximity
  , contourGenerateVector
  , contourGenerateVectorIO

  , withTransformerAndArg
) where

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

import Control.Applicative ((<$>), (<*>), pure)
import Control.DeepSeq (NFData(rnf))
import Control.Monad.Catch (
    Exception(..)
  , bracket
  , mask
  , onException
  , try
  , bracketOnError
  )
import Control.Monad (liftM, mapM_, when)
import Control.Monad.IO.Class (liftIO)
import Data.Default (Default(..))
import Data.Maybe (isJust)
import Data.Proxy (Proxy(Proxy))
import Data.Text (Text)
import Data.Typeable (Typeable)
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Storable as St
import qualified Data.Vector.Storable.Mutable as Stm

import Foreign.C.Types (CDouble(..), CInt(..), CUInt(..), CChar(..))
import Foreign.Marshal.Utils (fromBool)
import Foreign.ForeignPtr (newForeignPtr)
import Foreign.Ptr (
    Ptr
  , FunPtr
  , nullPtr
  , castPtr
  , nullFunPtr
  , plusPtr
  )
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Array (withArrayLen)
import Foreign.Marshal.Utils (with)
import Foreign.Storable (Storable(..))

import System.IO.Unsafe (unsafePerformIO)

import GDAL.Internal.Util (fromEnumC)
import GDAL.Internal.Types
{#import GDAL.Internal.CPLString#}
{#import GDAL.Internal.OSR #}
{#import GDAL.Internal.CPLProgress#}
{#import GDAL.Internal.OGR#}
{#import GDAL.Internal.OGRGeometry#}
{#import GDAL.Internal.CPLError#}
{#import GDAL.Internal.GDAL#}

#include "gdal_alg.h"
#include "contourwriter.h"

data GDALAlgorithmException
  = RasterizeStopped
  | CreateGridStopped
  | ComputeProximityStopped
  | NullTransformer !Text
  deriving (Typeable, Show, Eq)

instance NFData GDALAlgorithmException where
  rnf a = a `seq` ()

instance Exception GDALAlgorithmException where
  toException   = bindingExceptionToException
  fromException = bindingExceptionFromException

class Transformer t where
  transformerFun         :: t s -> TransformerFun t s
  createTransformerArg   :: t s -> IO (Ptr (t s))
  destroyTransformerArg  :: Ptr (t s) -> IO ()
  setGeotransform        :: Geotransform -> Ptr (t s) -> IO ()

  destroyTransformerArg p =
    when (p/=nullPtr) ({# call unsafe GDALDestroyTransformer as ^#} (castPtr p))

data SomeTransformer s
  = forall t. Transformer t => SomeTransformer (t s)
  | DefaultTransformer

instance Default (SomeTransformer s) where
  def = DefaultTransformer

withTransformerAndArg
  :: SomeTransformer s
  -> Maybe Geotransform
  -> (TransformerFunPtr -> Ptr () -> IO c)
  -> IO c
withTransformerAndArg DefaultTransformer _ act  = act nullFunPtr nullPtr
withTransformerAndArg (SomeTransformer t) mGt act =
  mask $ \restore -> do
    arg <- createTransformerArg t
    case mGt of
      Just gt -> setGeotransform gt arg
      Nothing -> return ()
    -- Assumes arg will be destroyed by whoever takes it if not errors occur
    restore (act (getTransformerFunPtr (transformerFun t)) (castPtr arg))
              `onException` destroyTransformerArg arg

newtype TransformerFun (t :: * -> *) s
  = TransformerFun {getTransformerFunPtr :: TransformerFunPtr}

{#pointer GDALTransformerFunc as TransformerFunPtr #}

-- ############################################################################
-- GenImgProjTransformer
-- ############################################################################

data GenImgProjTransformer s =
     GenImgProjTransformer {
      giptSrcDs    :: Maybe (RODataset s)
    , giptDstDs    :: Maybe (RWDataset s)
    , giptSrcSrs   :: Maybe SpatialReference
    , giptDstSrs   :: Maybe SpatialReference
    , giptUseGCP   :: Bool
    , giptMaxError :: Double
    , giptOrder    :: Int
  }

instance Default (GenImgProjTransformer s) where
  def = GenImgProjTransformer {
          giptSrcDs    = Nothing
        , giptDstDs    = Nothing
        , giptSrcSrs   = Nothing
        , giptDstSrs   = Nothing
        , giptUseGCP   = True
        , giptMaxError = 1
        , giptOrder    = 0
        }

checkCreateTransformer :: Text -> IO (Ptr ()) -> IO (Ptr ())
checkCreateTransformer msg = checkGDALCall checkit
  where
    checkit e p
      | p==nullPtr = Just (NullTransformer (maybe msg gdalErrMsg e))
      | otherwise  = Nothing

instance Transformer GenImgProjTransformer where
  transformerFun _ = c_GDALGenImgProjTransform
  setGeotransform = setGenImgProjTransfomerGeotransform
  createTransformerArg GenImgProjTransformer{..} =
    liftM castPtr $
    checkCreateTransformer "GenImgProjTransformer" $
    withMaybeSRAsCString giptSrcSrs $ \sSr ->
    withMaybeSRAsCString giptDstSrs $ \dSr ->
      {#call unsafe CreateGenImgProjTransformer as ^#}
        (maybe nullDatasetH unDataset giptSrcDs)
        sSr
        (maybe nullDatasetH unDataset giptDstDs)
        dSr
        (fromBool giptUseGCP)
        (realToFrac giptMaxError)
        (fromIntegral giptOrder)

foreign import ccall "gdal_alg.h &GDALGenImgProjTransform"
  c_GDALGenImgProjTransform :: TransformerFun GenImgProjTransformer s

-- ############################################################################
-- GenImgProjTransformer2
-- ############################################################################

data GenImgProjTransformer2 s =
     GenImgProjTransformer2 {
      gipt2SrcDs    :: Maybe (RODataset s)
    , gipt2DstDs    :: Maybe (RWDataset s)
    , gipt2Options  :: OptionList
  }

instance Default (GenImgProjTransformer2 s) where
  def = GenImgProjTransformer2 {
          gipt2SrcDs   = Nothing
        , gipt2DstDs   = Nothing
        , gipt2Options = []
        }

instance Transformer GenImgProjTransformer2 where
  transformerFun _ = c_GDALGenImgProjTransform2
  setGeotransform = setGenImgProjTransfomerGeotransform
  createTransformerArg GenImgProjTransformer2{..} =
    liftM castPtr $
    checkCreateTransformer "GenImgProjTransformer2" $
    withOptionList gipt2Options $ \opts ->
      {#call unsafe CreateGenImgProjTransformer2 as ^#}
        (maybe nullDatasetH unDataset gipt2SrcDs)
        (maybe nullDatasetH unDataset gipt2DstDs)
        opts

foreign import ccall "gdal_alg.h &GDALGenImgProjTransform"
  c_GDALGenImgProjTransform2 :: TransformerFun GenImgProjTransformer2 s

-- ############################################################################
-- GenImgProjTransformer3
-- ############################################################################

data GenImgProjTransformer3 s =
     GenImgProjTransformer3 {
      gipt3SrcSrs :: Maybe SpatialReference
    , gipt3DstSrs :: Maybe SpatialReference
    , gipt3SrcGt  :: Maybe Geotransform
    , gipt3DstGt  :: Maybe Geotransform
  }

instance Default (GenImgProjTransformer3 s) where
  def = GenImgProjTransformer3 {
          gipt3SrcSrs = Nothing
        , gipt3DstSrs = Nothing
        , gipt3SrcGt  = Nothing
        , gipt3DstGt  = Nothing
        }

instance Transformer GenImgProjTransformer3 where
  transformerFun _ = c_GDALGenImgProjTransform3
  setGeotransform = setGenImgProjTransfomerGeotransform
  createTransformerArg GenImgProjTransformer3{..} =
    liftM castPtr $
    checkCreateTransformer "GenImgProjTransformer3" $
    withMaybeSRAsCString gipt3SrcSrs $ \sSr ->
    withMaybeSRAsCString gipt3DstSrs $ \dSr ->
    withMaybeGeotransformPtr gipt3SrcGt $ \sGt ->
    withMaybeGeotransformPtr gipt3DstGt $ \dGt ->
      {#call unsafe CreateGenImgProjTransformer3 as ^#}
        sSr (castPtr sGt) dSr (castPtr dGt)

setGenImgProjTransfomerGeotransform :: Geotransform -> Ptr a -> IO ()
setGenImgProjTransfomerGeotransform geotransform pArg =
  with geotransform $ \gt ->
    {#call unsafe GDALSetGenImgProjTransformerDstGeoTransform as ^#}
    (castPtr pArg) (castPtr gt)

withMaybeGeotransformPtr
  :: Maybe Geotransform -> (Ptr Geotransform -> IO a) -> IO a
withMaybeGeotransformPtr Nothing   f = f nullPtr
withMaybeGeotransformPtr (Just g) f = alloca $ \gp -> poke gp g >> f gp

foreign import ccall "gdal_alg.h &GDALGenImgProjTransform"
  c_GDALGenImgProjTransform3 :: TransformerFun GenImgProjTransformer3 s

-- ############################################################################
-- GDALRasterizeLayersBuf
-- ############################################################################

rasterizeLayersBuf
  :: forall s l a b. GDALType a
  => GDAL s [ROLayer s l b]
  -> SomeTransformer s
  -> a
  -> a
  -> OptionList
  -> Maybe ProgressFun
  -> SpatialReference
  -> Size
  -> Geotransform
  -> OGR s l (U.Vector (Value a))
rasterizeLayersBuf getLayers mTransformer nodataValue
                   burnValue options progressFun
                   srs size geotransform =
  bracket (liftOGR getLayers) (mapM_ closeLayer) $ \layers ->
  liftIO $
  withProgressFun RasterizeStopped progressFun $ \pFun ->
  withArrayLen (map unLayer layers) $ \len lPtrPtr ->
  withMaybeSRAsCString (Just srs) $ \srsPtr ->
  withOptionList options $ \opts ->
  withTransformerAndArg mTransformer (Just geotransform) $ \trans tArg ->
  with geotransform $ \gt -> do
    vec <- Stm.replicate (sizeLen size) nodataValue
    Stm.unsafeWith vec $ \vecPtr ->
      checkCPLError "RasterizeLayersBuf" $
      {#call GDALRasterizeLayersBuf as ^#}
        (castPtr vecPtr) nx ny dt 0 0 (fromIntegral len)
        lPtrPtr srsPtr (castPtr gt) trans
        tArg bValue opts pFun nullPtr
    liftM (stToUValue . St.map toValue) (St.unsafeFreeze vec)
  where
    toValue v = if toCDouble v == ndValue then NoData else Value v
    dt        = fromEnumC (dataType (Proxy :: Proxy a))
    bValue    = toCDouble burnValue
    ndValue   = toCDouble nodataValue
    XY nx ny  = fmap fromIntegral size

-- ############################################################################
-- GDALCreateGrid
-- ############################################################################

{# enum GDALGridAlgorithm as GridAlgorithmEnum {}
    deriving (Eq,Read,Show,Bounded) #}

class (Storable a, Typeable a, Default a, Show a) => GridAlgorithm a where
  gridAlgorithm :: a -> GridAlgorithmEnum
  setNodata     :: Ptr a -> CDouble -> IO ()

createGridIO
  :: forall a opts. (GDALType a, GridAlgorithm opts)
  => opts
  -> a
  -> Maybe ProgressFun
  -> St.Vector (GridPoint a)
  -> EnvelopeReal
  -> Size
  -> IO (U.Vector (Value a))
createGridIO options noDataVal progressFun points envelope size =
  withProgressFun CreateGridStopped progressFun $ \pFun ->
  withErrorHandler $
  with options $ \opts -> do
    setNodata opts ndValue
    xs <- St.unsafeThaw (St.unsafeCast (St.map (px . gpXY) points))
    ys <- St.unsafeThaw (St.unsafeCast (St.map (py . gpXY) points))
    zs <- St.unsafeThaw (St.map (toCDouble . gpZ) points)
    out <- Stm.unsafeNew (sizeLen size)
    checkCPLError "GDALGridCreate" $
      Stm.unsafeWith xs $ \pXs ->
      Stm.unsafeWith ys $ \pYs ->
      Stm.unsafeWith zs $ \pZs ->
      Stm.unsafeWith out $ \pOut ->
      {#call GDALGridCreate as ^#}
        (fromEnumC (gridAlgorithm options))
        (castPtr opts)
        (fromIntegral (St.length points))
        pXs
        pYs
        pZs
        x0
        x1
        y0
        y1
        nx
        ny
        gtype
        (castPtr pOut)
        pFun
        nullPtr
    liftM (stToUValue . St.map toValue) (St.unsafeFreeze out)
  where
    toValue v
      | toCDouble v == ndValue     = NoData
      | otherwise                  = Value v
    ndValue                        = toCDouble noDataVal
    XY nx ny                       = fmap fromIntegral size
    Envelope (XY x0 y0) (XY x1 y1) = fmap realToFrac envelope
    gtype                          = fromEnumC (dataType (Proxy :: Proxy a))

createGrid
  :: forall a opts. (GDALType a, GridAlgorithm opts)
  => opts
  -> a
  -> St.Vector (GridPoint a)
  -> EnvelopeReal
  -> Size
  -> Either GDALException (U.Vector (Value a))
createGrid options noDataVal points envelope =
  unsafePerformIO .
  try .
  createGridIO options noDataVal Nothing points envelope

data GridPoint a =
  GP {
    gpXY :: {-# UNPACK #-} !(XY Double)
  , gpZ  :: {-# UNPACK #-} !a
  } deriving (Eq, Show, Read)

instance Storable a => Storable (GridPoint a) where
  sizeOf _ = sizeOf (undefined::XY Double) + sizeOf (undefined::Double)
  {-# INLINE sizeOf #-}
  alignment _ = alignment (undefined::Double)
  {-# INLINE alignment #-}
  poke ptr (GP xy z) = poke ptr' xy >> poke (castPtr (ptr' `plusPtr` 1)) z
    where ptr' = castPtr ptr
  {-# INLINE poke #-}
  peek ptr = GP <$> peek ptr'
                <*> peek (castPtr (ptr' `plusPtr` 1))
    where ptr' = castPtr ptr
  {-# INLINE peek #-}

-- ############################################################################
-- GridInverseDistanceToAPower
-- ############################################################################

data GridInverseDistanceToAPower =
  GridInverseDistanceToAPower {
    idpPower           :: !Double
  , idpSmoothing       :: !Double
  , idpAnisotropyRatio :: !Double
  , idpAnisotropyAngle :: !Double
  , idpRadius1         :: !Double
  , idpRadius2         :: !Double
  , idpAngle           :: !Double
  , idpMinPoints       :: !Int
  , idpMaxPoints       :: !Int
  } deriving (Eq, Show, Typeable)

instance GridAlgorithm GridInverseDistanceToAPower where
  gridAlgorithm = const GGA_InverseDistanceToAPower
  setNodata     = {#set GridInverseDistanceToAPowerOptions->dfNoDataValue#}

instance Default GridInverseDistanceToAPower where
  def = GridInverseDistanceToAPower {
          idpPower           = 2
        , idpSmoothing       = 0
        , idpAnisotropyRatio = 0
        , idpAnisotropyAngle = 0
        , idpRadius1         = 0
        , idpRadius2         = 0
        , idpAngle           = 0
        , idpMinPoints       = 0
        , idpMaxPoints       = 0
        }

instance Storable GridInverseDistanceToAPower where
  sizeOf _    = {#sizeof GridInverseDistanceToAPowerOptions#}
  alignment _ = {#alignof GridInverseDistanceToAPowerOptions#}
  peek _      = error "GridInverseDistanceToAPower: peek not implemented"
  poke p GridInverseDistanceToAPower{..}= do
    {#set GridInverseDistanceToAPowerOptions->dfPower#} p
      (realToFrac idpPower)
    {#set GridInverseDistanceToAPowerOptions->dfSmoothing#} p
      (realToFrac idpSmoothing)
    {#set GridInverseDistanceToAPowerOptions->dfAnisotropyRatio#} p
      (realToFrac idpAnisotropyRatio)
    {#set GridInverseDistanceToAPowerOptions->dfAnisotropyAngle#} p
      (realToFrac idpAnisotropyAngle)
    {#set GridInverseDistanceToAPowerOptions->dfRadius1#} p
      (realToFrac idpRadius1)
    {#set GridInverseDistanceToAPowerOptions->dfRadius2#} p
      (realToFrac idpRadius2)
    {#set GridInverseDistanceToAPowerOptions->dfAngle#} p
      (realToFrac idpAngle)
    {#set GridInverseDistanceToAPowerOptions->nMinPoints#} p
      (fromIntegral idpMinPoints)
    {#set GridInverseDistanceToAPowerOptions->nMaxPoints#} p
      (fromIntegral idpMaxPoints)

-- ############################################################################
-- GridMovingAverage
-- ############################################################################

data GridMovingAverage =
  GridMovingAverage {
    maRadius1   :: !Double
  , maRadius2   :: !Double
  , maAngle     :: !Double
  , maMinPoints :: !Int
  } deriving (Eq, Show, Typeable)

instance GridAlgorithm GridMovingAverage where
  gridAlgorithm = const GGA_MovingAverage
  setNodata     = {#set GridMovingAverageOptions->dfNoDataValue#}

instance Default GridMovingAverage where
  def = GridMovingAverage {
          maRadius1   = 0
        , maRadius2   = 0
        , maAngle     = 0
        , maMinPoints = 0
        }

instance Storable GridMovingAverage where
  sizeOf _    = {#sizeof GridMovingAverageOptions#}
  alignment _ = {#alignof GridMovingAverageOptions#}
  peek _      = error "GridMovingAverage: peek not implemented"
  poke p GridMovingAverage{..}= do
    {#set GridMovingAverageOptions->dfRadius1#} p
      (realToFrac maRadius1)
    {#set GridMovingAverageOptions->dfRadius2#} p
      (realToFrac maRadius2)
    {#set GridMovingAverageOptions->dfAngle#} p
      (realToFrac maAngle)
    {#set GridMovingAverageOptions->nMinPoints#} p
      (fromIntegral maMinPoints)

-- ############################################################################
-- GridNearestNeighbor
-- ############################################################################

data GridNearestNeighbor =
  GridNearestNeighbor {
    nnRadius1   :: !Double
  , nnRadius2   :: !Double
  , nnAngle     :: !Double
  } deriving (Eq, Show, Typeable)

instance GridAlgorithm GridNearestNeighbor where
  gridAlgorithm = const GGA_NearestNeighbor
  setNodata     = {#set GridNearestNeighborOptions->dfNoDataValue#}

instance Default GridNearestNeighbor where
  def = GridNearestNeighbor {
          nnRadius1   = 0
        , nnRadius2   = 0
        , nnAngle     = 0
        }

instance Storable GridNearestNeighbor where
  sizeOf _    = {#sizeof GridNearestNeighborOptions#}
  alignment _ = {#alignof GridNearestNeighborOptions#}
  peek _      = error "GridNearestNeighbor: peek not implemented"
  poke p GridNearestNeighbor{..}= do
    {#set GridNearestNeighborOptions->dfRadius1#} p
      (realToFrac nnRadius1)
    {#set GridNearestNeighborOptions->dfRadius2#} p
      (realToFrac nnRadius2)
    {#set GridNearestNeighborOptions->dfAngle#} p
      (realToFrac nnAngle)

-- ############################################################################
-- GridDataMetrics
-- ############################################################################

data MetricType
  = MetricMinimum
  | MetricMaximum
  | MetricRange
  | MetricCount
  | MetricAverageDistance
  | MetricAverageDistancePts
  deriving (Eq, Read, Show, Bounded)

instance Default MetricType where
  def = MetricCount

data GridDataMetrics =
  GridDataMetrics {
    dmRadius1   :: !Double
  , dmRadius2   :: !Double
  , dmAngle     :: !Double
  , dmMinPoints :: !Int
  , dmType      :: !MetricType
  } deriving (Eq, Show, Typeable)

instance GridAlgorithm GridDataMetrics where
  gridAlgorithm = mtToGGA . dmType
    where
      mtToGGA MetricMinimum            = GGA_MetricMinimum
      mtToGGA MetricMaximum            = GGA_MetricMaximum
      mtToGGA MetricRange              = GGA_MetricRange
      mtToGGA MetricCount              = GGA_MetricCount
      mtToGGA MetricAverageDistance    = GGA_MetricAverageDistance
      mtToGGA MetricAverageDistancePts = GGA_MetricAverageDistancePts
  setNodata     = {#set GridDataMetricsOptions->dfNoDataValue#}

instance Default GridDataMetrics where
  def = GridDataMetrics {
          dmRadius1   = 0
        , dmRadius2   = 0
        , dmAngle     = 0
        , dmMinPoints = 0
        , dmType      = def
        }

instance Storable GridDataMetrics where
  sizeOf _    = {#sizeof GridDataMetricsOptions#}
  alignment _ = {#alignof GridDataMetricsOptions#}
  peek _      = error "GridDataMetrics: peek not implemented"
  poke p GridDataMetrics{..}= do
    {#set GridDataMetricsOptions->dfRadius1#} p
      (realToFrac dmRadius1)
    {#set GridDataMetricsOptions->dfRadius2#} p
      (realToFrac dmRadius2)
    {#set GridDataMetricsOptions->dfAngle#} p
      (realToFrac dmAngle)
    {#set GridDataMetricsOptions->nMinPoints#} p
      (fromIntegral dmMinPoints)

-- ############################################################################
-- ComputeProximity
-- ############################################################################

computeProximity
  :: Band s t
  -> RWBand s
  -> OptionList
  -> Maybe ProgressFun
  -> GDAL s ()
computeProximity srcBand prxBand options progressFun =
  liftIO $
  withOptionList options $ \opts ->
  withProgressFun ComputeProximityStopped progressFun $ \pFun ->
  checkCPLError "computeProximity" $
  {#call GDALComputeProximity as ^#}
    (unBand srcBand)
    (unBand prxBand)
    opts
    pFun
    nullPtr

-- ############################################################################
-- contourVector
-- ############################################################################

data Contour =
  Contour {
    cLevel  :: {-# UNPACK #-} !Double
  , cPoints :: {-# UNPACK #-} !(St.Vector (XY Double))
  } deriving (Eq, Show)

{#pointer contour_list as ContourList #}
{#pointer *Contour as CContour #}
{#pointer *Point->XYDouble #}

type XYDouble = XY Double

contourGenerateVectorIO
  :: Double
  -> Double
  -> Maybe Double
  -> Size
  -> (St.Vector Double)
  -> IO [Contour]
contourGenerateVectorIO _ _ _ size vector
  | St.length vector /= sizeLen size =
      throwBindingException (InvalidRasterSize size)
contourGenerateVectorIO interval base nodataVal (XY nx ny) vector =
  withErrorHandler $
  with nullPtr $ \pList ->
  bracket (alloc pList) (free pList) $ \generator -> do
    St.forM_ (St.enumFromStepN 0 nx (ny-1)) $ \offset ->
      St.unsafeWith (St.slice offset nx (St.unsafeCast vector)) $
      checkCPLError "FeedLine" . {#call unsafe GDAL_CG_FeedLine as ^#} generator
    getContours pList
  where
    alloc pList =
      {#call unsafe GDAL_CG_Create as ^#}
        (fromIntegral nx)
        (fromIntegral ny)
        (fromBool (isJust nodataVal))
        (maybe 0 realToFrac nodataVal)
        (realToFrac interval)
        (realToFrac base)
        c_contourWriter
        (castPtr pList)

    free pList gen = do
      freeContourList pList
      {#call unsafe GDAL_CG_Destroy as ^#} gen

    getContours pList =
      bracket
      ({#call unsafe pop_contour#} pList)
      {#call unsafe destroy_contour#} $ \c ->
      if c==nullPtr
        then return []
        else do
          fp <- bracketOnError
                  ({#get Contour->points#} c)
                  {#call unsafe destroy_points#}
                  (newForeignPtr c_destroyPoints)
          nPoints <- liftM fromIntegral ({#get Contour->nPoints#} c)
          contour <- Contour <$> liftM realToFrac ({#get Contour->level#} c)
                             <*> pure (St.unsafeFromForeignPtr0 fp nPoints)
          liftM (contour:) (getContours pList)

    freeContourList pList = do
      p <- {#call unsafe pop_contour#} pList
      if p==nullPtr
        then return ()
        else do {#get Contour->points#} p >>= {#call unsafe destroy_points#}
                {#call unsafe destroy_contour #} p
                freeContourList pList

contourGenerateVector
  :: Double
  -> Double
  -> Maybe Double
  -> Size
  -> (St.Vector Double)
  -> Either GDALException [Contour]
contourGenerateVector interval base nodataVal size =
  unsafePerformIO . try . contourGenerateVectorIO interval base nodataVal size

type CContourWriter =
  CDouble -> CInt -> Ptr CDouble -> Ptr CDouble -> Ptr () -> IO CInt

foreign import ccall "contourwriter.h &hs_contour_writer"
  c_contourWriter :: FunPtr CContourWriter

foreign import ccall "contourwriter.h &destroy_points"
  c_destroyPoints :: FunPtr (Ptr XYDouble -> IO ())

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE BangPatterns #-}

module GDAL.Internal.Algorithms (
    GenImgProjTransformer (..)
  , GenImgProjTransformer2 (..)
  , GenImgProjTransformer3 (..)
  , SomeTransformer (..)

  , Contour (..)

  , GridPoint (..)
  , GridAlgorithm (..)
  , GridInverseDistanceToAPower (..)
  , GridMovingAverage (..)
  , GridNearestNeighbor (..)
  , GridDataMetrics (..)
  , MetricType (..)

  , GridAlgorithmEnum (..)

  , rasterizeLayersBuf
  , createGrid
  , createGridIO
  , computeProximity
  , contourGenerateVector
  , contourGenerateVectorIO

  , withTransformerAndArg
) where

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

import Control.Applicative ((<$>), (<*>))
import Control.DeepSeq (NFData(rnf))
import Control.Monad.Catch (
    Exception(..)
  , bracket
  , mask
  , onException
  , try
  , bracketOnError
  )
import Control.Monad (liftM, mapM_, when)
import Control.Monad.IO.Class (liftIO)
import Data.Default (Default(..))
import Data.Maybe (isJust)
import Data.Proxy (Proxy(Proxy))
import Data.Text (Text)
import Data.Typeable (Typeable)
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Storable as St
import qualified Data.Vector.Storable.Mutable as Stm

import Foreign.C.Types (CDouble(..), CInt(..), CUInt(..), CChar(..))
import Foreign.Marshal.Utils (fromBool)
import Foreign.ForeignPtr (newForeignPtr)
import Foreign.Ptr (
    Ptr
  , FunPtr
  , nullPtr
  , castPtr
  , nullFunPtr
  , plusPtr
  )
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Array (withArrayLen)
import Foreign.Marshal.Utils (with)
import Foreign.Storable (Storable(..))

import System.IO.Unsafe (unsafePerformIO)

import GDAL.Internal.Util (fromEnumC)
import GDAL.Internal.Types
{#import GDAL.Internal.CPLString#}
{#import GDAL.Internal.OSR #}
{#import GDAL.Internal.CPLProgress#}
{#import GDAL.Internal.OGR#}
{#import GDAL.Internal.OGRGeometry#}
{#import GDAL.Internal.CPLError#}
{#import GDAL.Internal.GDAL#}

#include "gdal_alg.h"
#include "contourwriter.h"

data GDALAlgorithmException
  = RasterizeStopped
  | CreateGridStopped
  | ComputeProximityStopped
  | NullTransformer !Text
  deriving (Typeable, Show, Eq)

instance NFData GDALAlgorithmException where
  rnf a = a `seq` ()

instance Exception GDALAlgorithmException where
  toException   = bindingExceptionToException
  fromException = bindingExceptionFromException

class Transformer t where
  transformerFun         :: t s -> TransformerFun t s
  createTransformerArg   :: t s -> IO (Ptr (t s))
  destroyTransformerArg  :: Ptr (t s) -> IO ()
  setGeotransform        :: Geotransform -> Ptr (t s) -> IO ()

  destroyTransformerArg p =
    when (p/=nullPtr) ({# call unsafe GDALDestroyTransformer as ^#} (castPtr p))

data SomeTransformer s
  = forall t. Transformer t => SomeTransformer (t s)
  | DefaultTransformer

instance Default (SomeTransformer s) where
  def = DefaultTransformer

withTransformerAndArg
  :: SomeTransformer s
  -> Maybe Geotransform
  -> (TransformerFunPtr -> Ptr () -> IO c)
  -> IO c
withTransformerAndArg DefaultTransformer _ act  = act nullFunPtr nullPtr
withTransformerAndArg (SomeTransformer t) mGt act =
  mask $ \restore -> do
    arg <- createTransformerArg t
    case mGt of
      Just gt -> setGeotransform gt arg
      Nothing -> return ()
    -- Assumes arg will be destroyed by whoever takes it if not errors occur
    restore (act (getTransformerFunPtr (transformerFun t)) (castPtr arg))
              `onException` destroyTransformerArg arg

newtype TransformerFun (t :: * -> *) s
  = TransformerFun {getTransformerFunPtr :: TransformerFunPtr}

{#pointer GDALTransformerFunc as TransformerFunPtr #}

-- ############################################################################
-- GenImgProjTransformer
-- ############################################################################

data GenImgProjTransformer s =
     GenImgProjTransformer {
      giptSrcDs    :: Maybe (RODataset s)
    , giptDstDs    :: Maybe (RWDataset s)
    , giptSrcSrs   :: Maybe SpatialReference
    , giptDstSrs   :: Maybe SpatialReference
    , giptUseGCP   :: Bool
    , giptMaxError :: Double
    , giptOrder    :: Int
  }

instance Default (GenImgProjTransformer s) where
  def = GenImgProjTransformer {
          giptSrcDs    = Nothing
        , giptDstDs    = Nothing
        , giptSrcSrs   = Nothing
        , giptDstSrs   = Nothing
        , giptUseGCP   = True
        , giptMaxError = 1
        , giptOrder    = 0
        }

checkCreateTransformer :: Text -> IO (Ptr ()) -> IO (Ptr ())
checkCreateTransformer msg = checkGDALCall checkit
  where
    checkit e p
      | p==nullPtr = Just (NullTransformer (maybe msg gdalErrMsg e))
      | otherwise  = Nothing

instance Transformer GenImgProjTransformer where
  transformerFun _ = c_GDALGenImgProjTransform
  setGeotransform = setGenImgProjTransfomerGeotransform
  createTransformerArg GenImgProjTransformer{..} =
    liftM castPtr $
    checkCreateTransformer "GenImgProjTransformer" $
    withMaybeSRAsCString giptSrcSrs $ \sSr ->
    withMaybeSRAsCString giptDstSrs $ \dSr ->
      {#call unsafe CreateGenImgProjTransformer as ^#}
        (maybe nullDatasetH unDataset giptSrcDs)
        sSr
        (maybe nullDatasetH unDataset giptDstDs)
        dSr
        (fromBool giptUseGCP)
        (realToFrac giptMaxError)
        (fromIntegral giptOrder)

foreign import ccall "gdal_alg.h &GDALGenImgProjTransform"
  c_GDALGenImgProjTransform :: TransformerFun GenImgProjTransformer s

-- ############################################################################
-- GenImgProjTransformer2
-- ############################################################################

data GenImgProjTransformer2 s =
     GenImgProjTransformer2 {
      gipt2SrcDs    :: Maybe (RODataset s)
    , gipt2DstDs    :: Maybe (RWDataset s)
    , gipt2Options  :: OptionList
  }

instance Default (GenImgProjTransformer2 s) where
  def = GenImgProjTransformer2 {
          gipt2SrcDs   = Nothing
        , gipt2DstDs   = Nothing
        , gipt2Options = []
        }

instance Transformer GenImgProjTransformer2 where
  transformerFun _ = c_GDALGenImgProjTransform2
  setGeotransform = setGenImgProjTransfomerGeotransform
  createTransformerArg GenImgProjTransformer2{..} =
    liftM castPtr $
    checkCreateTransformer "GenImgProjTransformer2" $
    withOptionList gipt2Options $ \opts ->
      {#call unsafe CreateGenImgProjTransformer2 as ^#}
        (maybe nullDatasetH unDataset gipt2SrcDs)
        (maybe nullDatasetH unDataset gipt2DstDs)
        opts

foreign import ccall "gdal_alg.h &GDALGenImgProjTransform"
  c_GDALGenImgProjTransform2 :: TransformerFun GenImgProjTransformer2 s

-- ############################################################################
-- GenImgProjTransformer3
-- ############################################################################

data GenImgProjTransformer3 s =
     GenImgProjTransformer3 {
      gipt3SrcSrs :: Maybe SpatialReference
    , gipt3DstSrs :: Maybe SpatialReference
    , gipt3SrcGt  :: Maybe Geotransform
    , gipt3DstGt  :: Maybe Geotransform
  }

instance Default (GenImgProjTransformer3 s) where
  def = GenImgProjTransformer3 {
          gipt3SrcSrs = Nothing
        , gipt3DstSrs = Nothing
        , gipt3SrcGt  = Nothing
        , gipt3DstGt  = Nothing
        }

instance Transformer GenImgProjTransformer3 where
  transformerFun _ = c_GDALGenImgProjTransform3
  setGeotransform = setGenImgProjTransfomerGeotransform
  createTransformerArg GenImgProjTransformer3{..} =
    liftM castPtr $
    checkCreateTransformer "GenImgProjTransformer3" $
    withMaybeSRAsCString gipt3SrcSrs $ \sSr ->
    withMaybeSRAsCString gipt3DstSrs $ \dSr ->
    withMaybeGeotransformPtr gipt3SrcGt $ \sGt ->
    withMaybeGeotransformPtr gipt3DstGt $ \dGt ->
      {#call unsafe CreateGenImgProjTransformer3 as ^#}
        sSr (castPtr sGt) dSr (castPtr dGt)

setGenImgProjTransfomerGeotransform :: Geotransform -> Ptr a -> IO ()
setGenImgProjTransfomerGeotransform geotransform pArg =
  with geotransform $ \gt ->
    {#call unsafe GDALSetGenImgProjTransformerDstGeoTransform as ^#}
    (castPtr pArg) (castPtr gt)

withMaybeGeotransformPtr
  :: Maybe Geotransform -> (Ptr Geotransform -> IO a) -> IO a
withMaybeGeotransformPtr Nothing   f = f nullPtr
withMaybeGeotransformPtr (Just g) f = alloca $ \gp -> poke gp g >> f gp

foreign import ccall "gdal_alg.h &GDALGenImgProjTransform"
  c_GDALGenImgProjTransform3 :: TransformerFun GenImgProjTransformer3 s

-- ############################################################################
-- GDALRasterizeLayersBuf
-- ############################################################################

rasterizeLayersBuf
  :: forall s l a b. GDALType a
  => GDAL s [ROLayer s l b]
  -> SomeTransformer s
  -> a
  -> a
  -> OptionList
  -> Maybe ProgressFun
  -> SpatialReference
  -> Size
  -> Geotransform
  -> OGR s l (U.Vector (Value a))
rasterizeLayersBuf getLayers mTransformer nodataValue
                   burnValue options progressFun
                   srs size geotransform =
  bracket (liftOGR getLayers) (mapM_ closeLayer) $ \layers ->
  liftIO $
  withProgressFun RasterizeStopped progressFun $ \pFun ->
  withArrayLen (map unLayer layers) $ \len lPtrPtr ->
  withMaybeSRAsCString (Just srs) $ \srsPtr ->
  withOptionList options $ \opts ->
  withTransformerAndArg mTransformer (Just geotransform) $ \trans tArg ->
  with geotransform $ \gt -> do
    vec <- Stm.replicate (sizeLen size) nodataValue
    Stm.unsafeWith vec $ \vecPtr ->
      checkCPLError "RasterizeLayersBuf" $
      {#call GDALRasterizeLayersBuf as ^#}
        (castPtr vecPtr) nx ny dt 0 0 (fromIntegral len)
        lPtrPtr srsPtr (castPtr gt) trans
        tArg bValue opts pFun nullPtr
    liftM (stToUValue . St.map toValue) (St.unsafeFreeze vec)
  where
    toValue v = if toCDouble v == ndValue then NoData else Value v
    dt        = fromEnumC (dataType (Proxy :: Proxy a))
    bValue    = toCDouble burnValue
    ndValue   = toCDouble nodataValue
    XY nx ny  = fmap fromIntegral size

-- ############################################################################
-- GDALCreateGrid
-- ############################################################################

{# enum GDALGridAlgorithm as GridAlgorithmEnum {}
    deriving (Eq,Read,Show,Bounded) #}

class (Storable a, Typeable a, Default a, Show a) => GridAlgorithm a where
  gridAlgorithm :: a -> GridAlgorithmEnum
  setNodata     :: Ptr a -> CDouble -> IO ()

createGridIO
  :: forall a opts. (GDALType a, GridAlgorithm opts)
  => opts
  -> a
  -> Maybe ProgressFun
  -> St.Vector (GridPoint a)
  -> EnvelopeReal
  -> Size
  -> IO (U.Vector (Value a))
createGridIO options noDataVal progressFun points envelope size =
  withProgressFun CreateGridStopped progressFun $ \pFun ->
  withErrorHandler $
  with options $ \opts -> do
    setNodata opts ndValue
    xs <- St.unsafeThaw (St.unsafeCast (St.map (px . gpXY) points))
    ys <- St.unsafeThaw (St.unsafeCast (St.map (py . gpXY) points))
    zs <- St.unsafeThaw (St.map (toCDouble . gpZ) points)
    out <- Stm.unsafeNew (sizeLen size)
    checkCPLError "GDALGridCreate" $
      Stm.unsafeWith xs $ \pXs ->
      Stm.unsafeWith ys $ \pYs ->
      Stm.unsafeWith zs $ \pZs ->
      Stm.unsafeWith out $ \pOut ->
      {#call GDALGridCreate as ^#}
        (fromEnumC (gridAlgorithm options))
        (castPtr opts)
        (fromIntegral (St.length points))
        pXs
        pYs
        pZs
        x0
        x1
        y0
        y1
        nx
        ny
        gtype
        (castPtr pOut)
        pFun
        nullPtr
    liftM (stToUValue . St.map toValue) (St.unsafeFreeze out)
  where
    toValue v
      | toCDouble v == ndValue     = NoData
      | otherwise                  = Value v
    ndValue                        = toCDouble noDataVal
    XY nx ny                       = fmap fromIntegral size
    Envelope (XY x0 y0) (XY x1 y1) = fmap realToFrac envelope
    gtype                          = fromEnumC (dataType (Proxy :: Proxy a))

createGrid
  :: forall a opts. (GDALType a, GridAlgorithm opts)
  => opts
  -> a
  -> St.Vector (GridPoint a)
  -> EnvelopeReal
  -> Size
  -> Either GDALException (U.Vector (Value a))
createGrid options noDataVal points envelope =
  unsafePerformIO .
  try .
  createGridIO options noDataVal Nothing points envelope

data GridPoint a =
  GP {
    gpXY :: {-# UNPACK #-} !(XY Double)
  , gpZ  :: {-# UNPACK #-} !a
  } deriving (Eq, Show, Read)

instance Storable a => Storable (GridPoint a) where
  sizeOf _ = sizeOf (undefined::XY Double) + sizeOf (undefined::Double)
  {-# INLINE sizeOf #-}
  alignment _ = alignment (undefined::Double)
  {-# INLINE alignment #-}
  poke ptr (GP xy z) = poke ptr' xy >> poke (castPtr (ptr' `plusPtr` 1)) z
    where ptr' = castPtr ptr
  {-# INLINE poke #-}
  peek ptr = GP <$> peek ptr'
                <*> peek (castPtr (ptr' `plusPtr` 1))
    where ptr' = castPtr ptr
  {-# INLINE peek #-}

-- ############################################################################
-- GridInverseDistanceToAPower
-- ############################################################################

data GridInverseDistanceToAPower =
  GridInverseDistanceToAPower {
    idpPower           :: !Double
  , idpSmoothing       :: !Double
  , idpAnisotropyRatio :: !Double
  , idpAnisotropyAngle :: !Double
  , idpRadius1         :: !Double
  , idpRadius2         :: !Double
  , idpAngle           :: !Double
  , idpMinPoints       :: !Int
  , idpMaxPoints       :: !Int
  } deriving (Eq, Show, Typeable)

instance GridAlgorithm GridInverseDistanceToAPower where
  gridAlgorithm = const GGA_InverseDistanceToAPower
  setNodata     = {#set GridInverseDistanceToAPowerOptions->dfNoDataValue#}

instance Default GridInverseDistanceToAPower where
  def = GridInverseDistanceToAPower {
          idpPower           = 2
        , idpSmoothing       = 0
        , idpAnisotropyRatio = 0
        , idpAnisotropyAngle = 0
        , idpRadius1         = 0
        , idpRadius2         = 0
        , idpAngle           = 0
        , idpMinPoints       = 0
        , idpMaxPoints       = 0
        }

instance Storable GridInverseDistanceToAPower where
  sizeOf _    = {#sizeof GridInverseDistanceToAPowerOptions#}
  alignment _ = {#alignof GridInverseDistanceToAPowerOptions#}
  peek _      = error "GridInverseDistanceToAPower: peek not implemented"
  poke p GridInverseDistanceToAPower{..}= do
    {#set GridInverseDistanceToAPowerOptions->dfPower#} p
      (realToFrac idpPower)
    {#set GridInverseDistanceToAPowerOptions->dfSmoothing#} p
      (realToFrac idpSmoothing)
    {#set GridInverseDistanceToAPowerOptions->dfAnisotropyRatio#} p
      (realToFrac idpAnisotropyRatio)
    {#set GridInverseDistanceToAPowerOptions->dfAnisotropyAngle#} p
      (realToFrac idpAnisotropyAngle)
    {#set GridInverseDistanceToAPowerOptions->dfRadius1#} p
      (realToFrac idpRadius1)
    {#set GridInverseDistanceToAPowerOptions->dfRadius2#} p
      (realToFrac idpRadius2)
    {#set GridInverseDistanceToAPowerOptions->dfAngle#} p
      (realToFrac idpAngle)
    {#set GridInverseDistanceToAPowerOptions->nMinPoints#} p
      (fromIntegral idpMinPoints)
    {#set GridInverseDistanceToAPowerOptions->nMaxPoints#} p
      (fromIntegral idpMaxPoints)

-- ############################################################################
-- GridMovingAverage
-- ############################################################################

data GridMovingAverage =
  GridMovingAverage {
    maRadius1   :: !Double
  , maRadius2   :: !Double
  , maAngle     :: !Double
  , maMinPoints :: !Int
  } deriving (Eq, Show, Typeable)

instance GridAlgorithm GridMovingAverage where
  gridAlgorithm = const GGA_MovingAverage
  setNodata     = {#set GridMovingAverageOptions->dfNoDataValue#}

instance Default GridMovingAverage where
  def = GridMovingAverage {
          maRadius1   = 0
        , maRadius2   = 0
        , maAngle     = 0
        , maMinPoints = 0
        }

instance Storable GridMovingAverage where
  sizeOf _    = {#sizeof GridMovingAverageOptions#}
  alignment _ = {#alignof GridMovingAverageOptions#}
  peek _      = error "GridMovingAverage: peek not implemented"
  poke p GridMovingAverage{..}= do
    {#set GridMovingAverageOptions->dfRadius1#} p
      (realToFrac maRadius1)
    {#set GridMovingAverageOptions->dfRadius2#} p
      (realToFrac maRadius2)
    {#set GridMovingAverageOptions->dfAngle#} p
      (realToFrac maAngle)
    {#set GridMovingAverageOptions->nMinPoints#} p
      (fromIntegral maMinPoints)

-- ############################################################################
-- GridNearestNeighbor
-- ############################################################################

data GridNearestNeighbor =
  GridNearestNeighbor {
    nnRadius1   :: !Double
  , nnRadius2   :: !Double
  , nnAngle     :: !Double
  } deriving (Eq, Show, Typeable)

instance GridAlgorithm GridNearestNeighbor where
  gridAlgorithm = const GGA_NearestNeighbor
  setNodata     = {#set GridNearestNeighborOptions->dfNoDataValue#}

instance Default GridNearestNeighbor where
  def = GridNearestNeighbor {
          nnRadius1   = 0
        , nnRadius2   = 0
        , nnAngle     = 0
        }

instance Storable GridNearestNeighbor where
  sizeOf _    = {#sizeof GridNearestNeighborOptions#}
  alignment _ = {#alignof GridNearestNeighborOptions#}
  peek _      = error "GridNearestNeighbor: peek not implemented"
  poke p GridNearestNeighbor{..}= do
    {#set GridNearestNeighborOptions->dfRadius1#} p
      (realToFrac nnRadius1)
    {#set GridNearestNeighborOptions->dfRadius2#} p
      (realToFrac nnRadius2)
    {#set GridNearestNeighborOptions->dfAngle#} p
      (realToFrac nnAngle)

-- ############################################################################
-- GridDataMetrics
-- ############################################################################

data MetricType
  = MetricMinimum
  | MetricMaximum
  | MetricRange
  | MetricCount
  | MetricAverageDistance
  | MetricAverageDistancePts
  deriving (Eq, Read, Show, Bounded)

instance Default MetricType where
  def = MetricCount

data GridDataMetrics =
  GridDataMetrics {
    dmRadius1   :: !Double
  , dmRadius2   :: !Double
  , dmAngle     :: !Double
  , dmMinPoints :: !Int
  , dmType      :: !MetricType
  } deriving (Eq, Show, Typeable)

instance GridAlgorithm GridDataMetrics where
  gridAlgorithm = mtToGGA . dmType
    where
      mtToGGA MetricMinimum            = GGA_MetricMinimum
      mtToGGA MetricMaximum            = GGA_MetricMaximum
      mtToGGA MetricRange              = GGA_MetricRange
      mtToGGA MetricCount              = GGA_MetricCount
      mtToGGA MetricAverageDistance    = GGA_MetricAverageDistance
      mtToGGA MetricAverageDistancePts = GGA_MetricAverageDistancePts
  setNodata     = {#set GridDataMetricsOptions->dfNoDataValue#}

instance Default GridDataMetrics where
  def = GridDataMetrics {
          dmRadius1   = 0
        , dmRadius2   = 0
        , dmAngle     = 0
        , dmMinPoints = 0
        , dmType      = def
        }

instance Storable GridDataMetrics where
  sizeOf _    = {#sizeof GridDataMetricsOptions#}
  alignment _ = {#alignof GridDataMetricsOptions#}
  peek _      = error "GridDataMetrics: peek not implemented"
  poke p GridDataMetrics{..}= do
    {#set GridDataMetricsOptions->dfRadius1#} p
      (realToFrac dmRadius1)
    {#set GridDataMetricsOptions->dfRadius2#} p
      (realToFrac dmRadius2)
    {#set GridDataMetricsOptions->dfAngle#} p
      (realToFrac dmAngle)
    {#set GridDataMetricsOptions->nMinPoints#} p
      (fromIntegral dmMinPoints)

-- ############################################################################
-- ComputeProximity
-- ############################################################################

computeProximity
  :: Band s t
  -> RWBand s
  -> OptionList
  -> Maybe ProgressFun
  -> GDAL s ()
computeProximity srcBand prxBand options progressFun =
  liftIO $
  withOptionList options $ \opts ->
  withProgressFun ComputeProximityStopped progressFun $ \pFun ->
  checkCPLError "computeProximity" $
  {#call GDALComputeProximity as ^#}
    (unBand srcBand)
    (unBand prxBand)
    opts
    pFun
    nullPtr

-- ############################################################################
-- contourVector
-- ############################################################################

data Contour =
  Contour {
    cLevel  :: {-# UNPACK #-} !Double
  , cPoints :: {-# UNPACK #-} !(St.Vector (XY Double))
  } deriving (Eq, Show)

{#pointer contour_list as ContourList #}
{#pointer *Contour as CContour #}
{#pointer *Point->XYDouble #}

type XYDouble = XY Double

contourGenerateVectorIO
  :: Double
  -> Double
  -> Maybe Double
  -> Size
  -> (St.Vector Double)
  -> IO [Contour]
contourGenerateVectorIO _ _ _ size vector
  | St.length vector /= sizeLen size =
      throwBindingException (InvalidRasterSize size)
contourGenerateVectorIO interval base nodataVal (XY nx ny) vector =
  withErrorHandler $
  with nullPtr $ \pList ->
  bracket (alloc pList) (free pList) $ \generator -> do
    St.forM_ (St.enumFromStepN 0 nx (ny-1)) $ \offset ->
      St.unsafeWith (St.slice offset nx (St.unsafeCast vector)) $
      checkCPLError "FeedLine" . {#call unsafe GDAL_CG_FeedLine as ^#} generator
    getContours pList
  where
    alloc pList =
      {#call unsafe GDAL_CG_Create as ^#}
        (fromIntegral nx)
        (fromIntegral ny)
        (fromBool (isJust nodataVal))
        (maybe 0 realToFrac nodataVal)
        (realToFrac interval)
        (realToFrac base)
        c_contourWriter
        (castPtr pList)

    free pList gen = do
      freeContourList pList
      {#call unsafe GDAL_CG_Destroy as ^#} gen

    getContours pList =
      bracket
      ({#call unsafe pop_contour#} pList)
      {#call unsafe destroy_contour#} $ \c ->
      if c==nullPtr
        then return []
        else do
          fp <- bracketOnError
                  ({#get Contour->points#} c)
                  {#call unsafe destroy_points#}
                  (newForeignPtr c_destroyPoints)
          nPoints <- liftM fromIntegral ({#get Contour->nPoints#} c)
          contour <- Contour <$> liftM realToFrac ({#get Contour->level#} c)
                             <*> pure (St.unsafeFromForeignPtr0 fp nPoints)
          liftM (contour:) (getContours pList)

    freeContourList pList = do
      p <- {#call unsafe pop_contour#} pList
      if p==nullPtr
        then return ()
        else do {#get Contour->points#} p >>= {#call unsafe destroy_points#}
                {#call unsafe destroy_contour #} p
                freeContourList pList

contourGenerateVector
  :: Double
  -> Double
  -> Maybe Double
  -> Size
  -> (St.Vector Double)
  -> Either GDALException [Contour]
contourGenerateVector interval base nodataVal size =
  unsafePerformIO . try . contourGenerateVectorIO interval base nodataVal size

type CContourWriter =
  CDouble -> CInt -> Ptr CDouble -> Ptr CDouble -> Ptr () -> IO CInt

foreign import ccall "contourwriter.h &hs_contour_writer"
  c_contourWriter :: FunPtr CContourWriter

foreign import ccall "contourwriter.h &destroy_points"
  c_destroyPoints :: FunPtr (Ptr XYDouble -> IO ())


Make safe calls to g_object_get_property

This is too complex a function for use to be confident that it's ok to make an
unsafe foreign call to it.
This probably does not fix Axel's current segfault bug.

darcs-hash:20060130080710-b4c10-ed5bb73618e2d87b2c0fd77aed19cd3f8081e849.gz

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GObject Properties
--
--  Author : Duncan Coutts
--
--  Created: 16 April 2005
--
--  Version $Revision: 1.8 $ from $Date: 2005/08/29 11:15:58 $
--
--  Copyright (C) 2005 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Functions for getting and setting GObject properties
--
module System.Glib.Properties (
  -- * per-type functions for getting and setting GObject properties
  objectSetPropertyInt,
  objectGetPropertyInt,
  objectSetPropertyUInt,
  objectGetPropertyUInt,
  objectSetPropertyBool,
  objectGetPropertyBool,
  objectSetPropertyEnum,
  objectGetPropertyEnum,
  objectSetPropertyFlags,
  objectGetPropertyFlags,
  objectSetPropertyFloat,
  objectGetPropertyFloat,
  objectSetPropertyDouble,
  objectGetPropertyDouble,
  objectSetPropertyString,
  objectGetPropertyString,
  objectSetPropertyMaybeString,
  objectGetPropertyMaybeString,
  objectSetPropertyGObject,
  objectGetPropertyGObject,

  objectSetPropertyInternal,
  objectGetPropertyInternal,

  -- * constructors for attributes backed by GObject properties
  newAttrFromIntProperty,
  readAttrFromIntProperty,
  newAttrFromUIntProperty,
  writeAttrFromUIntProperty,
  newAttrFromBoolProperty,
  newAttrFromFloatProperty,
  newAttrFromDoubleProperty,
  newAttrFromEnumProperty,
  readAttrFromEnumProperty,
  newAttrFromFlagsProperty,
  newAttrFromStringProperty,
  readAttrFromStringProperty,
  writeAttrFromStringProperty,
  newAttrFromMaybeStringProperty,
  newAttrFromObjectProperty,
  writeAttrFromObjectProperty,
  ) where

import Monad (liftM)

import System.Glib.FFI
import System.Glib.Flags	(Flags, fromFlags, toFlags)
import System.Glib.UTFString
{#import System.Glib.Types#}
{#import System.Glib.GValue#}	(GValue(GValue), valueInit, allocaGValue)
import System.Glib.GObject	(makeNewGObject)
import qualified System.Glib.GTypeConstants as GType
import System.Glib.GType
import System.Glib.GValueTypes
import System.Glib.Attributes	(Attr, ReadAttr, WriteAttr, ReadWriteAttr,
				newAttr, readAttr, writeAttr)

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

objectSetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> a -> IO ()) -> String -> gobj -> a -> IO ()
objectSetPropertyInternal gtype valueSet prop obj val =
  withCString prop $ \propPtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  valueSet gvalue val
  {# call g_object_set_property #}
    (toGObject obj)
    propPtr
    gvalue

objectGetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> IO a) -> String -> gobj -> IO a
objectGetPropertyInternal gtype valueGet prop obj =
  withCString prop $ \propPtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  {# call g_object_get_property #}
    (toGObject obj)
    propPtr
    gvalue
  valueGet gvalue

objectSetPropertyInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()
objectSetPropertyInt = objectSetPropertyInternal GType.int valueSetInt

objectGetPropertyInt :: GObjectClass gobj => String -> gobj -> IO Int
objectGetPropertyInt = objectGetPropertyInternal GType.int valueGetInt

objectSetPropertyUInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()
objectSetPropertyUInt = objectSetPropertyInternal GType.uint (\gv v -> valueSetUInt gv (fromIntegral v))

objectGetPropertyUInt :: GObjectClass gobj => String -> gobj -> IO Int
objectGetPropertyUInt = objectGetPropertyInternal GType.uint (\gv -> liftM fromIntegral $ valueGetUInt gv)

objectSetPropertyBool :: GObjectClass gobj => String -> gobj -> Bool -> IO ()
objectSetPropertyBool = objectSetPropertyInternal GType.bool valueSetBool

objectGetPropertyBool :: GObjectClass gobj => String -> gobj -> IO Bool
objectGetPropertyBool = objectGetPropertyInternal GType.bool valueGetBool

objectSetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> enum -> IO ()
objectSetPropertyEnum gtype = objectSetPropertyInternal gtype valueSetEnum

objectGetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> IO enum
objectGetPropertyEnum gtype = objectGetPropertyInternal gtype valueGetEnum

objectSetPropertyFlags :: (GObjectClass gobj, Flags flag) => String -> gobj -> [flag] -> IO ()
objectSetPropertyFlags = objectSetPropertyInternal GType.flags valueSetFlags

objectGetPropertyFlags :: (GObjectClass gobj, Flags flag) => String -> gobj -> IO [flag]
objectGetPropertyFlags = objectGetPropertyInternal GType.flags valueGetFlags

objectSetPropertyFloat :: GObjectClass gobj => String -> gobj -> Float -> IO ()
objectSetPropertyFloat = objectSetPropertyInternal GType.float valueSetFloat

objectGetPropertyFloat :: GObjectClass gobj => String -> gobj -> IO Float
objectGetPropertyFloat = objectGetPropertyInternal GType.float valueGetFloat

objectSetPropertyDouble :: GObjectClass gobj => String -> gobj -> Double -> IO ()
objectSetPropertyDouble = objectSetPropertyInternal GType.double valueSetDouble

objectGetPropertyDouble :: GObjectClass gobj => String -> gobj -> IO Double
objectGetPropertyDouble = objectGetPropertyInternal GType.double valueGetDouble

objectSetPropertyString :: GObjectClass gobj => String -> gobj -> String -> IO ()
objectSetPropertyString = objectSetPropertyInternal GType.string valueSetString

objectGetPropertyString :: GObjectClass gobj => String -> gobj -> IO String
objectGetPropertyString = objectGetPropertyInternal GType.string valueGetString

objectSetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> Maybe String -> IO ()
objectSetPropertyMaybeString = objectSetPropertyInternal GType.string valueSetMaybeString

objectGetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> IO (Maybe String)
objectGetPropertyMaybeString = objectGetPropertyInternal GType.string valueGetMaybeString

objectSetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> gobj' -> IO ()
objectSetPropertyGObject gtype = objectSetPropertyInternal gtype valueSetGObject

objectGetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> IO gobj'
objectGetPropertyGObject gtype = objectGetPropertyInternal gtype valueGetGObject

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

newAttrFromIntProperty :: GObjectClass gobj => String -> Attr gobj Int
newAttrFromIntProperty propName =
  newAttr (objectGetPropertyInt propName) (objectSetPropertyInt propName)

readAttrFromIntProperty :: GObjectClass gobj => String -> ReadAttr gobj Int
readAttrFromIntProperty propName =
  readAttr (objectGetPropertyInt propName)

newAttrFromUIntProperty :: GObjectClass gobj => String -> Attr gobj Int
newAttrFromUIntProperty propName =
  newAttr (objectGetPropertyUInt propName) (objectSetPropertyUInt propName)

writeAttrFromUIntProperty :: GObjectClass gobj => String -> WriteAttr gobj Int
writeAttrFromUIntProperty propName =
  writeAttr (objectSetPropertyUInt propName)

newAttrFromBoolProperty :: GObjectClass gobj => String -> Attr gobj Bool
newAttrFromBoolProperty propName =
  newAttr (objectGetPropertyBool propName) (objectSetPropertyBool propName)

newAttrFromFloatProperty :: GObjectClass gobj => String -> Attr gobj Float
newAttrFromFloatProperty propName =
  newAttr (objectGetPropertyFloat propName) (objectSetPropertyFloat propName)

newAttrFromDoubleProperty :: GObjectClass gobj => String -> Attr gobj Double
newAttrFromDoubleProperty propName =
  newAttr (objectGetPropertyDouble propName) (objectSetPropertyDouble propName)

newAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> Attr gobj enum
newAttrFromEnumProperty propName gtype =
  newAttr (objectGetPropertyEnum gtype propName) (objectSetPropertyEnum gtype propName)

readAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> ReadAttr gobj enum
readAttrFromEnumProperty propName gtype =
  readAttr (objectGetPropertyEnum gtype propName)

newAttrFromFlagsProperty :: (GObjectClass gobj, Flags flag) => String -> Attr gobj [flag]
newAttrFromFlagsProperty propName =
  newAttr (objectGetPropertyFlags propName) (objectSetPropertyFlags propName)

newAttrFromStringProperty :: GObjectClass gobj => String -> Attr gobj String
newAttrFromStringProperty propName =
  newAttr (objectGetPropertyString propName) (objectSetPropertyString propName)

readAttrFromStringProperty :: GObjectClass gobj => String -> ReadAttr gobj String
readAttrFromStringProperty propName =
  readAttr (objectGetPropertyString propName)

writeAttrFromStringProperty :: GObjectClass gobj => String -> WriteAttr gobj String
writeAttrFromStringProperty propName =
  writeAttr (objectSetPropertyString propName)

newAttrFromMaybeStringProperty :: GObjectClass gobj => String -> Attr gobj (Maybe String)
newAttrFromMaybeStringProperty propName =
  newAttr (objectGetPropertyMaybeString propName) (objectSetPropertyMaybeString propName)

newAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj', GObjectClass gobj'') => String -> GType -> ReadWriteAttr gobj gobj' gobj''
newAttrFromObjectProperty propName gtype =
  newAttr (objectGetPropertyGObject gtype propName) (objectSetPropertyGObject gtype propName)

writeAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj') => String -> GType -> WriteAttr gobj gobj'
writeAttrFromObjectProperty propName gtype =
  writeAttr (objectSetPropertyGObject gtype propName)

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GObject Properties
--
--  Author : Duncan Coutts
--
--  Created: 16 April 2005
--
--  Version $Revision: 1.8 $ from $Date: 2005/08/29 11:15:58 $
--
--  Copyright (C) 2005 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Functions for getting and setting GObject properties
--
module System.Glib.Properties (
  -- * per-type functions for getting and setting GObject properties
  objectSetPropertyInt,
  objectGetPropertyInt,
  objectSetPropertyUInt,
  objectGetPropertyUInt,
  objectSetPropertyBool,
  objectGetPropertyBool,
  objectSetPropertyEnum,
  objectGetPropertyEnum,
  objectSetPropertyFlags,
  objectGetPropertyFlags,
  objectSetPropertyFloat,
  objectGetPropertyFloat,
  objectSetPropertyDouble,
  objectGetPropertyDouble,
  objectSetPropertyString,
  objectGetPropertyString,
  objectSetPropertyMaybeString,
  objectGetPropertyMaybeString,
  objectSetPropertyGObject,
  objectGetPropertyGObject,

  objectSetPropertyInternal,
  objectGetPropertyInternal,

  -- * constructors for attributes backed by GObject properties
  newAttrFromIntProperty,
  readAttrFromIntProperty,
  newAttrFromUIntProperty,
  writeAttrFromUIntProperty,
  newAttrFromBoolProperty,
  newAttrFromFloatProperty,
  newAttrFromDoubleProperty,
  newAttrFromEnumProperty,
  readAttrFromEnumProperty,
  newAttrFromFlagsProperty,
  newAttrFromStringProperty,
  readAttrFromStringProperty,
  writeAttrFromStringProperty,
  newAttrFromMaybeStringProperty,
  newAttrFromObjectProperty,
  writeAttrFromObjectProperty,
  ) where

import Monad (liftM)

import System.Glib.FFI
import System.Glib.Flags	(Flags, fromFlags, toFlags)
import System.Glib.UTFString
{#import System.Glib.Types#}
{#import System.Glib.GValue#}	(GValue(GValue), valueInit, allocaGValue)
import System.Glib.GObject	(makeNewGObject)
import qualified System.Glib.GTypeConstants as GType
import System.Glib.GType
import System.Glib.GValueTypes
import System.Glib.Attributes	(Attr, ReadAttr, WriteAttr, ReadWriteAttr,
				newAttr, readAttr, writeAttr)

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

objectSetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> a -> IO ()) -> String -> gobj -> a -> IO ()
objectSetPropertyInternal gtype valueSet prop obj val =
  withCString prop $ \propPtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  valueSet gvalue val
  {# call g_object_set_property #}
    (toGObject obj)
    propPtr
    gvalue

objectGetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> IO a) -> String -> gobj -> IO a
objectGetPropertyInternal gtype valueGet prop obj =
  withCString prop $ \propPtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  {# call unsafe g_object_get_property #}
    (toGObject obj)
    propPtr
    gvalue
  valueGet gvalue

objectSetPropertyInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()
objectSetPropertyInt = objectSetPropertyInternal GType.int valueSetInt

objectGetPropertyInt :: GObjectClass gobj => String -> gobj -> IO Int
objectGetPropertyInt = objectGetPropertyInternal GType.int valueGetInt

objectSetPropertyUInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()
objectSetPropertyUInt = objectSetPropertyInternal GType.uint (\gv v -> valueSetUInt gv (fromIntegral v))

objectGetPropertyUInt :: GObjectClass gobj => String -> gobj -> IO Int
objectGetPropertyUInt = objectGetPropertyInternal GType.uint (\gv -> liftM fromIntegral $ valueGetUInt gv)

objectSetPropertyBool :: GObjectClass gobj => String -> gobj -> Bool -> IO ()
objectSetPropertyBool = objectSetPropertyInternal GType.bool valueSetBool

objectGetPropertyBool :: GObjectClass gobj => String -> gobj -> IO Bool
objectGetPropertyBool = objectGetPropertyInternal GType.bool valueGetBool

objectSetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> enum -> IO ()
objectSetPropertyEnum gtype = objectSetPropertyInternal gtype valueSetEnum

objectGetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> IO enum
objectGetPropertyEnum gtype = objectGetPropertyInternal gtype valueGetEnum

objectSetPropertyFlags :: (GObjectClass gobj, Flags flag) => String -> gobj -> [flag] -> IO ()
objectSetPropertyFlags = objectSetPropertyInternal GType.flags valueSetFlags

objectGetPropertyFlags :: (GObjectClass gobj, Flags flag) => String -> gobj -> IO [flag]
objectGetPropertyFlags = objectGetPropertyInternal GType.flags valueGetFlags

objectSetPropertyFloat :: GObjectClass gobj => String -> gobj -> Float -> IO ()
objectSetPropertyFloat = objectSetPropertyInternal GType.float valueSetFloat

objectGetPropertyFloat :: GObjectClass gobj => String -> gobj -> IO Float
objectGetPropertyFloat = objectGetPropertyInternal GType.float valueGetFloat

objectSetPropertyDouble :: GObjectClass gobj => String -> gobj -> Double -> IO ()
objectSetPropertyDouble = objectSetPropertyInternal GType.double valueSetDouble

objectGetPropertyDouble :: GObjectClass gobj => String -> gobj -> IO Double
objectGetPropertyDouble = objectGetPropertyInternal GType.double valueGetDouble

objectSetPropertyString :: GObjectClass gobj => String -> gobj -> String -> IO ()
objectSetPropertyString = objectSetPropertyInternal GType.string valueSetString

objectGetPropertyString :: GObjectClass gobj => String -> gobj -> IO String
objectGetPropertyString = objectGetPropertyInternal GType.string valueGetString

objectSetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> Maybe String -> IO ()
objectSetPropertyMaybeString = objectSetPropertyInternal GType.string valueSetMaybeString

objectGetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> IO (Maybe String)
objectGetPropertyMaybeString = objectGetPropertyInternal GType.string valueGetMaybeString

objectSetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> gobj' -> IO ()
objectSetPropertyGObject gtype = objectSetPropertyInternal gtype valueSetGObject

objectGetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> IO gobj'
objectGetPropertyGObject gtype = objectGetPropertyInternal gtype valueGetGObject

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

newAttrFromIntProperty :: GObjectClass gobj => String -> Attr gobj Int
newAttrFromIntProperty propName =
  newAttr (objectGetPropertyInt propName) (objectSetPropertyInt propName)

readAttrFromIntProperty :: GObjectClass gobj => String -> ReadAttr gobj Int
readAttrFromIntProperty propName =
  readAttr (objectGetPropertyInt propName)

newAttrFromUIntProperty :: GObjectClass gobj => String -> Attr gobj Int
newAttrFromUIntProperty propName =
  newAttr (objectGetPropertyUInt propName) (objectSetPropertyUInt propName)

writeAttrFromUIntProperty :: GObjectClass gobj => String -> WriteAttr gobj Int
writeAttrFromUIntProperty propName =
  writeAttr (objectSetPropertyUInt propName)

newAttrFromBoolProperty :: GObjectClass gobj => String -> Attr gobj Bool
newAttrFromBoolProperty propName =
  newAttr (objectGetPropertyBool propName) (objectSetPropertyBool propName)

newAttrFromFloatProperty :: GObjectClass gobj => String -> Attr gobj Float
newAttrFromFloatProperty propName =
  newAttr (objectGetPropertyFloat propName) (objectSetPropertyFloat propName)

newAttrFromDoubleProperty :: GObjectClass gobj => String -> Attr gobj Double
newAttrFromDoubleProperty propName =
  newAttr (objectGetPropertyDouble propName) (objectSetPropertyDouble propName)

newAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> Attr gobj enum
newAttrFromEnumProperty propName gtype =
  newAttr (objectGetPropertyEnum gtype propName) (objectSetPropertyEnum gtype propName)

readAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> ReadAttr gobj enum
readAttrFromEnumProperty propName gtype =
  readAttr (objectGetPropertyEnum gtype propName)

newAttrFromFlagsProperty :: (GObjectClass gobj, Flags flag) => String -> Attr gobj [flag]
newAttrFromFlagsProperty propName =
  newAttr (objectGetPropertyFlags propName) (objectSetPropertyFlags propName)

newAttrFromStringProperty :: GObjectClass gobj => String -> Attr gobj String
newAttrFromStringProperty propName =
  newAttr (objectGetPropertyString propName) (objectSetPropertyString propName)

readAttrFromStringProperty :: GObjectClass gobj => String -> ReadAttr gobj String
readAttrFromStringProperty propName =
  readAttr (objectGetPropertyString propName)

writeAttrFromStringProperty :: GObjectClass gobj => String -> WriteAttr gobj String
writeAttrFromStringProperty propName =
  writeAttr (objectSetPropertyString propName)

newAttrFromMaybeStringProperty :: GObjectClass gobj => String -> Attr gobj (Maybe String)
newAttrFromMaybeStringProperty propName =
  newAttr (objectGetPropertyMaybeString propName) (objectSetPropertyMaybeString propName)

newAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj', GObjectClass gobj'') => String -> GType -> ReadWriteAttr gobj gobj' gobj''
newAttrFromObjectProperty propName gtype =
  newAttr (objectGetPropertyGObject gtype propName) (objectSetPropertyGObject gtype propName)

writeAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj') => String -> GType -> WriteAttr gobj gobj'
writeAttrFromObjectProperty propName gtype =
  writeAttr (objectSetPropertyGObject gtype propName)