Fix the get side of all container child attributes. It was accidentally calling 'set' rather than 'get'. doh! :-)

-- -*-haskell-*-
--  GIMP Toolkit (GTK) Container child Properties
--
--  Author : Duncan Coutts
--
--  Created: 16 April 2005
--
--  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.
--
-- #hide

-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Functions for getting and setting container child properties
--
module Graphics.UI.Gtk.Abstract.ContainerChildProperties (
  containerChildGetPropertyBool,
  containerChildSetPropertyBool,

  newAttrFromContainerChildIntProperty,
  newAttrFromContainerChildUIntProperty,
  newAttrFromContainerChildBoolProperty,
  newAttrFromContainerChildEnumProperty,
  newAttrFromContainerChildFlagsProperty,
  newAttrFromContainerChildStringProperty,
  ) where

import Control.Monad (liftM)

import System.Glib.FFI
import System.Glib.Flags
{#import Graphics.UI.Gtk.Types#}
import System.Glib.GType
import qualified System.Glib.GTypeConstants as GType
import System.Glib.GValueTypes
{#import System.Glib.GValue#}		(GValue(GValue), allocaGValue, valueInit)
import System.Glib.Attributes		(Attr, newAttr)

{# context lib="gtk" prefix="gtk" #}

containerChildSetPropertyInternal ::
 (ContainerClass container, WidgetClass child)
 => GType
 -> (GValue -> a -> IO ())
 -> String
 -> child
 -> container
 -> a
 -> IO ()
containerChildSetPropertyInternal gtype valueSet prop child container val =
  withCString prop $ \propertyNamePtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  valueSet gvalue val
  {# call container_child_set_property #}
    (toContainer container)
    (toWidget child)
    propertyNamePtr
    gvalue

containerChildGetPropertyInternal ::
 (ContainerClass container, WidgetClass child)
 => GType
 -> (GValue -> IO a)
 -> String
 -> child
 -> container
 -> IO a
containerChildGetPropertyInternal gtype valueGet prop child container =
  withCString prop $ \propertyNamePtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  {# call container_child_get_property #}
    (toContainer container)
    (toWidget child)
    propertyNamePtr
    gvalue
  valueGet gvalue

-- Versions for specific types:
-- we actually don't use any others than bool at the moment
--

containerChildGetPropertyBool :: (ContainerClass container, WidgetClass child)
 => String -> child -> container -> IO Bool
containerChildGetPropertyBool =
          containerChildGetPropertyInternal GType.bool valueGetBool

containerChildSetPropertyBool :: (ContainerClass container, WidgetClass child)
 => String -> child -> container -> Bool -> IO ()
containerChildSetPropertyBool =
          containerChildSetPropertyInternal GType.bool valueSetBool

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

newAttrFromContainerChildIntProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Int
newAttrFromContainerChildIntProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.int valueGetInt propName child)
  (containerChildSetPropertyInternal GType.int valueSetInt propName child)

newAttrFromContainerChildUIntProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Int
newAttrFromContainerChildUIntProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.uint
    (\gv -> liftM fromIntegral $ valueGetUInt gv) propName child)
  (containerChildSetPropertyInternal GType.uint
    (\gv v -> valueSetUInt gv (fromIntegral v)) propName child)

newAttrFromContainerChildBoolProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Bool
newAttrFromContainerChildBoolProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.bool valueGetBool propName child)
  (containerChildSetPropertyInternal GType.bool valueSetBool propName child)

newAttrFromContainerChildEnumProperty ::
 (ContainerClass container, WidgetClass child, Enum enum)
 => String -> GType -> child -> Attr container enum
newAttrFromContainerChildEnumProperty propName gtype child = newAttr
  (containerChildGetPropertyInternal gtype valueGetEnum propName child)
  (containerChildSetPropertyInternal gtype valueSetEnum propName child)

newAttrFromContainerChildFlagsProperty ::
 (ContainerClass container, WidgetClass child, Flags flag)
 => String -> GType -> child -> Attr container [flag]
newAttrFromContainerChildFlagsProperty propName gtype child = newAttr
  (containerChildGetPropertyInternal gtype valueGetFlags propName child)
  (containerChildSetPropertyInternal gtype valueSetFlags propName child)

newAttrFromContainerChildStringProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container String
newAttrFromContainerChildStringProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.string valueGetString propName child)
  (containerChildSetPropertyInternal GType.string valueSetString propName child)

-- -*-haskell-*-
--  GIMP Toolkit (GTK) Container child Properties
--
--  Author : Duncan Coutts
--
--  Created: 16 April 2005
--
--  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.
--
-- #hide

-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Functions for getting and setting container child properties
--
module Graphics.UI.Gtk.Abstract.ContainerChildProperties (
  containerChildGetPropertyBool,
  containerChildSetPropertyBool,

  newAttrFromContainerChildIntProperty,
  newAttrFromContainerChildUIntProperty,
  newAttrFromContainerChildBoolProperty,
  newAttrFromContainerChildEnumProperty,
  newAttrFromContainerChildFlagsProperty,
  newAttrFromContainerChildStringProperty,
  ) where

import Control.Monad (liftM)

import System.Glib.FFI
import System.Glib.Flags
{#import Graphics.UI.Gtk.Types#}
import System.Glib.GType
import qualified System.Glib.GTypeConstants as GType
import System.Glib.GValueTypes
{#import System.Glib.GValue#}		(GValue(GValue), allocaGValue, valueInit)
import System.Glib.Attributes		(Attr, newAttr)

{# context lib="gtk" prefix="gtk" #}

containerChildSetPropertyInternal ::
 (ContainerClass container, WidgetClass child)
 => GType
 -> (GValue -> a -> IO ())
 -> String
 -> child
 -> container
 -> a
 -> IO ()
containerChildSetPropertyInternal gtype valueSet prop child container val =
  withCString prop $ \propertyNamePtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  valueSet gvalue val
  {# call container_child_set_property #}
    (toContainer container)
    (toWidget child)
    propertyNamePtr
    gvalue

containerChildGetPropertyInternal ::
 (ContainerClass container, WidgetClass child)
 => GType
 -> (GValue -> IO a)
 -> String
 -> child
 -> container
 -> IO a
containerChildGetPropertyInternal gtype valueGet prop child container =
  withCString prop $ \propertyNamePtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  {# call container_child_set_property #}
    (toContainer container)
    (toWidget child)
    propertyNamePtr
    gvalue
  valueGet gvalue

-- Versions for specific types:
-- we actually don't use any others than bool at the moment
--

containerChildGetPropertyBool :: (ContainerClass container, WidgetClass child)
 => String -> child -> container -> IO Bool
containerChildGetPropertyBool =
          containerChildGetPropertyInternal GType.bool valueGetBool

containerChildSetPropertyBool :: (ContainerClass container, WidgetClass child)
 => String -> child -> container -> Bool -> IO ()
containerChildSetPropertyBool =
          containerChildSetPropertyInternal GType.bool valueSetBool

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

newAttrFromContainerChildIntProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Int
newAttrFromContainerChildIntProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.int valueGetInt propName child)
  (containerChildSetPropertyInternal GType.int valueSetInt propName child)

newAttrFromContainerChildUIntProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Int
newAttrFromContainerChildUIntProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.uint
    (\gv -> liftM fromIntegral $ valueGetUInt gv) propName child)
  (containerChildSetPropertyInternal GType.uint
    (\gv v -> valueSetUInt gv (fromIntegral v)) propName child)

newAttrFromContainerChildBoolProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Bool
newAttrFromContainerChildBoolProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.bool valueGetBool propName child)
  (containerChildSetPropertyInternal GType.bool valueSetBool propName child)

newAttrFromContainerChildEnumProperty ::
 (ContainerClass container, WidgetClass child, Enum enum)
 => String -> GType -> child -> Attr container enum
newAttrFromContainerChildEnumProperty propName gtype child = newAttr
  (containerChildGetPropertyInternal gtype valueGetEnum propName child)
  (containerChildSetPropertyInternal gtype valueSetEnum propName child)

newAttrFromContainerChildFlagsProperty ::
 (ContainerClass container, WidgetClass child, Flags flag)
 => String -> GType -> child -> Attr container [flag]
newAttrFromContainerChildFlagsProperty propName gtype child = newAttr
  (containerChildGetPropertyInternal gtype valueGetFlags propName child)
  (containerChildSetPropertyInternal gtype valueSetFlags propName child)

newAttrFromContainerChildStringProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container String
newAttrFromContainerChildStringProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.string valueGetString propName child)
  (containerChildSetPropertyInternal GType.string valueSetString propName child)


added read mode phantom type to Band. Can now safely (as long as no other process is modifying a file) implement lazy IO

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

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

  , setQuietErrorHandler

  , registerAllDrivers
  , driverByName
  , create
  , create'
  , createMem
  , flushCache
  , openReadOnly
  , openReadWrite
  , createCopy

  , datatypeSize
  , datatypeByName
  , datatypeUnion
  , datatypeIsComplex

  , datasetProjection
  , setDatasetProjection
  , datasetGeotransform
  , setDatasetGeotransform

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

) where

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

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

import System.IO.Unsafe (unsafePerformIO)

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

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

instance Exception GDALException

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

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

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

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

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

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

setQuietErrorHandler :: IO ()
setQuietErrorHandler = setErrorHandler c_quietErrorHandler

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

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

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

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

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

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

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

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

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

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

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

instance Show ColorInterpretation where
    show = getColorInterpretationName

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

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

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

instance Show PaletteInterpretation where
    show = getPaletteInterpretationName

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

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

data ReadOnly
data ReadWrite
newtype Dataset a = Dataset (ForeignPtr (Dataset a), Mutex)

type RODataset = Dataset ReadOnly
type RWDataset = Dataset ReadWrite

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

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

{#pointer GDALRasterBandH as Band newtype nocode#}
newtype Band a = Band (Ptr (Band a))

type ROBand = Band ReadOnly
type RWBand = Band ReadWrite

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

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

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

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

type DriverOptions = [(String,String)]

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

create' :: Driver -> String -> Int -> Int -> Int -> Datatype -> DriverOptions
       -> IO RWDataset
create' drv path nx ny bands dtype options = withCString path $ \path' -> do
    opts <- toOptionList options
    let nx'    = fromIntegral nx
        ny'    = fromIntegral ny
        bands' = fromIntegral bands
        dtype' = fromEnumC dtype
    create_ drv path' nx' ny' bands' dtype' opts >>= newDatasetHandle

foreign import ccall safe "gdal.h GDALCreate" create_
  :: Driver
  -> CString
  -> CInt
  -> CInt
  -> CInt
  -> CInt
  -> Ptr CString
  -> IO (Ptr (Dataset a))

openReadOnly :: String -> IO RODataset
openReadOnly p = withCString p openIt
  where openIt p' = open_ p' (fromEnumC GA_ReadOnly) >>= newDatasetHandle

openReadWrite :: String -> IO RWDataset
openReadWrite p = withCString p openIt
  where openIt p' = open_ p' (fromEnumC GA_Update) >>= newDatasetHandle

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

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

foreign import ccall safe "gdal.h GDALCreateCopy" createCopy_
  :: Driver
  -> Ptr CChar
  -> Ptr (Dataset a)
  -> CInt
  -> Ptr CString
  -> FunPtr ProgressFun
  -> Ptr ()
  -> IO (Ptr (Dataset a))

withProgressFun = withCCallback wrapProgressFun

withCCallback w f = bracket (w f) freeHaskellFunPtr

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

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

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

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

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

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

flushCache d = withDataset d flushCache'

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

datasetProjection :: Dataset a -> IO String
datasetProjection d = withDataset d $ \d' -> do
    p <- getProjection_ d'
    peekCString p

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

setDatasetProjection :: RWDataset -> String -> IO ()
setDatasetProjection d p = throwIfError "could not set projection" f
  where f = withDataset d $ \d' -> withCString p $ \p' -> setProjection' d' p'

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

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

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

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

setDatasetGeotransform :: RWDataset -> Geotransform -> IO ()
setDatasetGeotransform ds gt = withDataset ds $ \dPtr -> do
    allocaArray 6 $ \a -> do
        let (Geotransform g0 g1 g2 g3 g4 g5) = gt
        pokeElemOff a 0 (realToFrac g0)
        pokeElemOff a 1 (realToFrac g1)
        pokeElemOff a 2 (realToFrac g2)
        pokeElemOff a 3 (realToFrac g3)
        pokeElemOff a 4 (realToFrac g4)
        pokeElemOff a 5 (realToFrac g5)
        throwIfError "could not set geotransform" $ setGeoTransform dPtr a

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

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

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

bandDatatype :: Band a -> Datatype
bandDatatype band = toEnumC . getDatatype_ $ band

foreign import ccall unsafe "gdal.h GDALGetRasterDataType" getDatatype_
   :: Band a -> CInt

bandBlockSize :: Band a -> (Int,Int)
bandBlockSize band = unsafePerformIO $ alloca $ \xPtr -> alloca $ \yPtr -> do
   -- unsafePerformIO is safe here since the block size cant change once
   -- a dataset is created
   getBlockSize_ band xPtr yPtr
   liftA2 (,) (liftM fromIntegral $ peek xPtr) (liftM fromIntegral $ peek yPtr)

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

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

bandSize :: Band a -> (Int, Int)
bandSize band
  = (fromIntegral . getXSize_ $ band, fromIntegral . getYSize_ $ band)

foreign import ccall unsafe "gdal.h GDALGetRasterBandXSize" getXSize_
  :: Band a -> CInt

foreign import ccall unsafe "gdal.h GDALGetRasterBandYSize" getYSize_
  :: Band a -> CInt

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

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

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

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

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

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

class HasDatatype a where
    datatype :: a -> Datatype

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

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

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

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

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

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

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

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

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

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

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

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

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

type IOVector a = IO (Vector a)

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

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

typeOfBand = typeOfdatatype . bandDatatype

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

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

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

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

type Mutex = MVar ()

newMutex :: IO Mutex
newMutex = newMVar ()

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

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

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

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

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

  , setQuietErrorHandler

  , registerAllDrivers
  , driverByName
  , create
  , create'
  , createMem
  , flushCache
  , openReadOnly
  , openReadWrite
  , createCopy

  , datatypeSize
  , datatypeByName
  , datatypeUnion
  , datatypeIsComplex

  , datasetProjection
  , setDatasetProjection
  , datasetGeotransform
  , setDatasetGeotransform

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

) where

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

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

import System.IO.Unsafe (unsafePerformIO)

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

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

instance Exception GDALException

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

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

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

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

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

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

setQuietErrorHandler :: IO ()
setQuietErrorHandler = setErrorHandler c_quietErrorHandler

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

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

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

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

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

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

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

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

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

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

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

instance Show ColorInterpretation where
    show = getColorInterpretationName

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

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

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

instance Show PaletteInterpretation where
    show = getPaletteInterpretationName

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

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

data ReadOnly
data ReadWrite
newtype (Dataset a) = Dataset (ForeignPtr (Dataset a), Mutex)

type RODataset = Dataset ReadOnly
type RWDataset = Dataset ReadWrite

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

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

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

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

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

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

type DriverOptions = [(String,String)]

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

create' :: Driver -> String -> Int -> Int -> Int -> Datatype -> DriverOptions
       -> IO RWDataset
create' drv path nx ny bands dtype options = withCString path $ \path' -> do
    opts <- toOptionList options
    let nx'    = fromIntegral nx
        ny'    = fromIntegral ny
        bands' = fromIntegral bands
        dtype' = fromEnumC dtype
    create_ drv path' nx' ny' bands' dtype' opts >>= newDatasetHandle

foreign import ccall safe "gdal.h GDALCreate" create_
  :: Driver
  -> CString
  -> CInt
  -> CInt
  -> CInt
  -> CInt
  -> Ptr CString
  -> IO (Ptr (Dataset a))

openReadOnly :: String -> IO RODataset
openReadOnly p = withCString p openIt
  where openIt p' = open_ p' (fromEnumC GA_ReadOnly) >>= newDatasetHandle

openReadWrite :: String -> IO RWDataset
openReadWrite p = withCString p openIt
  where openIt p' = open_ p' (fromEnumC GA_Update) >>= newDatasetHandle

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

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

foreign import ccall safe "gdal.h GDALCreateCopy" createCopy_
  :: Driver
  -> Ptr CChar
  -> Ptr (Dataset a)
  -> CInt
  -> Ptr CString
  -> FunPtr ProgressFun
  -> Ptr ()
  -> IO (Ptr (Dataset a))

withProgressFun = withCCallback wrapProgressFun

withCCallback w f = bracket (w f) freeHaskellFunPtr

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

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

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

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

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

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

flushCache d = withDataset d flushCache'

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

datasetProjection :: Dataset a -> IO String
datasetProjection d = withDataset d $ \d' -> do
    p <- getProjection_ d'
    peekCString p

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

setDatasetProjection :: RWDataset -> String -> IO ()
setDatasetProjection d p = throwIfError "could not set projection" f
  where f = withDataset d $ \d' -> withCString p $ \p' -> setProjection' d' p'

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

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

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

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

setDatasetGeotransform :: RWDataset -> Geotransform -> IO ()
setDatasetGeotransform ds gt = withDataset ds $ \dPtr -> do
    allocaArray 6 $ \a -> do
        let (Geotransform g0 g1 g2 g3 g4 g5) = gt
        pokeElemOff a 0 (realToFrac g0)
        pokeElemOff a 1 (realToFrac g1)
        pokeElemOff a 2 (realToFrac g2)
        pokeElemOff a 3 (realToFrac g3)
        pokeElemOff a 4 (realToFrac g4)
        pokeElemOff a 5 (realToFrac g5)
        throwIfError "could not set geotransform" $ setGeoTransform dPtr a

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

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

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

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

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

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

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

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

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

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

class HasDatatype a where
    datatype :: a -> Datatype

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

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

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

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

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

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

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

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

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

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

type IOVector a = IO (Vector a)

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

typeOfBand = typeOfdatatype . bandDatatype

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

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

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

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

type Mutex = MVar ()

newMutex :: IO Mutex
newMutex = newMVar ()

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

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

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


fix for 7.8.4

fix for 7.8.4

{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}

module GDAL.Internal.DataType (
    GDALType (..)
  , KnownDataType
  , DataType (..)
  , GType

  , dataType
  , dataTypeSize
  , dataTypeByName
  , dataTypeUnion
  , dataTypeIsComplex
) where

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

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

import Data.Int (Int8, Int16, Int32)
import Data.Complex (Complex(..), realPart)
import Data.Coerce (Coercible, coerce)
import Data.Proxy (Proxy(..))
import Data.Word (Word8, Word16, Word32)

import Foreign.C.Types
import Foreign.C.String (withCString)
import Foreign.Marshal.Utils (toBool)
import Foreign.Ptr (Ptr)
import Foreign.Storable (Storable(..))

import System.IO.Unsafe (unsafePerformIO)

import GDAL.Internal.Util (toEnumC, fromEnumC)

{#enum DataType {} omit (GDT_TypeCount) deriving (Eq, Show, Bounded) #}

{#fun pure unsafe GetDataTypeSize as dataTypeSize
    { fromEnumC `DataType' } -> `Int' #}

{#fun pure unsafe DataTypeIsComplex as ^
    { fromEnumC `DataType' } -> `Bool' #}

{#fun pure unsafe GetDataTypeByName as dataTypeByName
    { `String' } -> `DataType' toEnumC #}

{#fun pure unsafe DataTypeUnion as ^
    { fromEnumC `DataType', fromEnumC `DataType' } -> `DataType' toEnumC #}

------------------------------------------------------------------------------
-- GDALType
------------------------------------------------------------------------------

class (
    Eq a
  , Storable a
    -- Make sure we can safely castPtr in RasterIO, etc..
  , Coercible a (GType (DataTypeT a))
  , KnownDataType (DataTypeT a)
  ) => GDALType a where
  type DataTypeT a :: DataType
  toGType   :: a -> GType (DataTypeT a)
  fromGType :: GType (DataTypeT a) -> a

  toCDouble :: a -> CDouble
  fromCDouble :: CDouble -> a

type family GType (k :: DataType) where
  GType 'GDT_Byte     = CUChar
  GType 'GDT_UInt16   = CUShort
  GType 'GDT_UInt32   = CUInt
  GType 'GDT_Int16    = CShort
  GType 'GDT_Int32    = CInt
  GType 'GDT_Float32  = CFloat
  GType 'GDT_Float64  = CDouble
  GType 'GDT_CInt16   = CComplex CShort
  GType 'GDT_CInt32   = CComplex CInt
  GType 'GDT_CFloat32 = CComplex CFloat
  GType 'GDT_CFloat64 = CComplex CDouble

newtype CComplex a = CComplex (Complex a)
  deriving (Eq, Show)

class KnownDataType (k :: DataType) where
  dataTypeVal :: Proxy (k :: DataType) -> DataType

dataType :: forall a. GDALType a => Proxy a -> DataType
dataType _ = dataTypeVal (Proxy :: Proxy (DataTypeT a))
{-# INLINE dataType #-}

instance KnownDataType 'GDT_Byte      where dataTypeVal _ = GDT_Byte
instance KnownDataType 'GDT_UInt16    where dataTypeVal _ = GDT_UInt16
instance KnownDataType 'GDT_UInt32    where dataTypeVal _ = GDT_UInt32
instance KnownDataType 'GDT_Int16     where dataTypeVal _ = GDT_Int16
instance KnownDataType 'GDT_Int32     where dataTypeVal _ = GDT_Int32
instance KnownDataType 'GDT_Float32   where dataTypeVal _ = GDT_Float32
instance KnownDataType 'GDT_Float64   where dataTypeVal _ = GDT_Float64
instance KnownDataType 'GDT_CInt16    where dataTypeVal _ = GDT_CInt16
instance KnownDataType 'GDT_CInt32    where dataTypeVal _ = GDT_CInt32
instance KnownDataType 'GDT_CFloat32  where dataTypeVal _ = GDT_CFloat32
instance KnownDataType 'GDT_CFloat64  where dataTypeVal _ = GDT_CFloat64

instance GDALType Word8 where
  type DataTypeT Word8 = 'GDT_Byte
  toCDouble = fromIntegral
  fromCDouble = truncate
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType Word16 where
  type DataTypeT Word16 = 'GDT_UInt16
  toCDouble = fromIntegral
  fromCDouble = truncate
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType Word32 where
  type DataTypeT Word32 = 'GDT_UInt32
  toCDouble = fromIntegral
  fromCDouble = truncate
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType Int16 where
  type DataTypeT Int16 = 'GDT_Int16
  toCDouble = fromIntegral
  fromCDouble = truncate
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType Int32 where
  type DataTypeT Int32 = 'GDT_Int32
  toCDouble = fromIntegral
  fromCDouble = truncate
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType Float where
  type DataTypeT Float = 'GDT_Float32
  fromCDouble = realToFrac
  toCDouble = realToFrac
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType Double where
  type DataTypeT Double = 'GDT_Float64
  toCDouble = realToFrac
  fromCDouble = realToFrac
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

#ifdef STORABLE_COMPLEX

deriving instance Storable a => Storable (CComplex a)

instance GDALType (Complex Int16) where
  type DataTypeT (Complex Int16) = 'GDT_CInt16
  toCDouble = fromIntegral . realPart
  fromCDouble d = fromCDouble d :+ fromCDouble d
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType (Complex Int32) where
  type DataTypeT (Complex Int32) = 'GDT_CInt32
  toCDouble = fromIntegral . realPart
  fromCDouble d = fromCDouble d :+ fromCDouble d
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType (Complex Float) where
  type DataTypeT (Complex Float) = 'GDT_CFloat32
  toCDouble = realToFrac . realPart
  fromCDouble d = fromCDouble d :+ fromCDouble d
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType (Complex Double) where
  type DataTypeT (Complex Double) = 'GDT_CFloat64
  toCDouble = realToFrac . realPart
  fromCDouble d = fromCDouble d :+ fromCDouble d
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}
#endif

{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module GDAL.Internal.DataType (
    GDALType (..)
  , KnownDataType
  , DataType (..)
  , GType

  , dataType
  , dataTypeSize
  , dataTypeByName
  , dataTypeUnion
  , dataTypeIsComplex
) where

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

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

import Data.Int (Int8, Int16, Int32)
import Data.Complex (Complex(..), realPart)
import Data.Coerce (Coercible, coerce)
import Data.Proxy (Proxy(..))
import Data.Word (Word8, Word16, Word32)

import Foreign.C.Types
import Foreign.C.String (withCString)
import Foreign.Marshal.Utils (toBool)
import Foreign.Ptr (Ptr)
import Foreign.Storable (Storable(..))

import System.IO.Unsafe (unsafePerformIO)

import GDAL.Internal.Util (toEnumC, fromEnumC)

{#enum DataType {} omit (GDT_TypeCount) deriving (Eq, Show, Bounded) #}

{#fun pure unsafe GetDataTypeSize as dataTypeSize
    { fromEnumC `DataType' } -> `Int' #}

{#fun pure unsafe DataTypeIsComplex as ^
    { fromEnumC `DataType' } -> `Bool' #}

{#fun pure unsafe GetDataTypeByName as dataTypeByName
    { `String' } -> `DataType' toEnumC #}

{#fun pure unsafe DataTypeUnion as ^
    { fromEnumC `DataType', fromEnumC `DataType' } -> `DataType' toEnumC #}

------------------------------------------------------------------------------
-- GDALType
------------------------------------------------------------------------------

class (
    Eq a
  , Storable a
    -- Make sure we can safely castPtr in RasterIO, etc..
  , Coercible a (GType (DataTypeT a))
  , KnownDataType (DataTypeT a)
  ) => GDALType a where
  type DataTypeT a :: DataType
  toGType   :: a -> GType (DataTypeT a)
  fromGType :: GType (DataTypeT a) -> a

  toCDouble :: a -> CDouble
  fromCDouble :: CDouble -> a

type family GType (k :: DataType) where
  GType 'GDT_Byte     = CUChar
  GType 'GDT_UInt16   = CUShort
  GType 'GDT_UInt32   = CUInt
  GType 'GDT_Int16    = CShort
  GType 'GDT_Int32    = CInt
  GType 'GDT_Float32  = CFloat
  GType 'GDT_Float64  = CDouble
  GType 'GDT_CInt16   = CComplex CShort
  GType 'GDT_CInt32   = CComplex CInt
  GType 'GDT_CFloat32 = CComplex CFloat
  GType 'GDT_CFloat64 = CComplex CDouble

newtype CComplex a = CComplex (Complex a)
  deriving (Eq, Storable, Show)

class KnownDataType (k :: DataType) where
  dataTypeVal :: Proxy (k :: DataType) -> DataType

dataType :: forall a. GDALType a => Proxy a -> DataType
dataType _ = dataTypeVal (Proxy :: Proxy (DataTypeT a))
{-# INLINE dataType #-}

instance KnownDataType 'GDT_Byte      where dataTypeVal _ = GDT_Byte
instance KnownDataType 'GDT_UInt16    where dataTypeVal _ = GDT_UInt16
instance KnownDataType 'GDT_UInt32    where dataTypeVal _ = GDT_UInt32
instance KnownDataType 'GDT_Int16     where dataTypeVal _ = GDT_Int16
instance KnownDataType 'GDT_Int32     where dataTypeVal _ = GDT_Int32
instance KnownDataType 'GDT_Float32   where dataTypeVal _ = GDT_Float32
instance KnownDataType 'GDT_Float64   where dataTypeVal _ = GDT_Float64
instance KnownDataType 'GDT_CInt16    where dataTypeVal _ = GDT_CInt16
instance KnownDataType 'GDT_CInt32    where dataTypeVal _ = GDT_CInt32
instance KnownDataType 'GDT_CFloat32  where dataTypeVal _ = GDT_CFloat32
instance KnownDataType 'GDT_CFloat64  where dataTypeVal _ = GDT_CFloat64

instance GDALType Word8 where
  type DataTypeT Word8 = 'GDT_Byte
  toCDouble = fromIntegral
  fromCDouble = truncate
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType Word16 where
  type DataTypeT Word16 = 'GDT_UInt16
  toCDouble = fromIntegral
  fromCDouble = truncate
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType Word32 where
  type DataTypeT Word32 = 'GDT_UInt32
  toCDouble = fromIntegral
  fromCDouble = truncate
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType Int16 where
  type DataTypeT Int16 = 'GDT_Int16
  toCDouble = fromIntegral
  fromCDouble = truncate
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType Int32 where
  type DataTypeT Int32 = 'GDT_Int32
  toCDouble = fromIntegral
  fromCDouble = truncate
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType Float where
  type DataTypeT Float = 'GDT_Float32
  fromCDouble = realToFrac
  toCDouble = realToFrac
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType Double where
  type DataTypeT Double = 'GDT_Float64
  toCDouble = realToFrac
  fromCDouble = realToFrac
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

#ifdef STORABLE_COMPLEX
instance GDALType (Complex Int16) where
  type DataTypeT (Complex Int16) = 'GDT_CInt16
  toCDouble = fromIntegral . realPart
  fromCDouble d = fromCDouble d :+ fromCDouble d
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType (Complex Int32) where
  type DataTypeT (Complex Int32) = 'GDT_CInt32
  toCDouble = fromIntegral . realPart
  fromCDouble d = fromCDouble d :+ fromCDouble d
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType (Complex Float) where
  type DataTypeT (Complex Float) = 'GDT_CFloat32
  toCDouble = realToFrac . realPart
  fromCDouble d = fromCDouble d :+ fromCDouble d
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

instance GDALType (Complex Double) where
  type DataTypeT (Complex Double) = 'GDT_CFloat64
  toCDouble = realToFrac . realPart
  fromCDouble d = fromCDouble d :+ fromCDouble d
  toGType    = coerce
  fromGType  = coerce
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}
#endif


Fix ref counting bug in sourceBufferCreateMarker

(reported by bwwx in #haskell)
The docs say that gtk_source_buffer_create_marker returns a new
GtkSourceMarker, owned by the buffer. So we need to ref the object, so we
should use makeGObject rather than constructNewGObject.

darcs-hash:20070814182814-adfee-a352692adb9570322a39243e19dace4b50eb0f94.gz


Export TableRowSelectFlag.

Export TableRowSelectFlag.

{-# LANGUAGE CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Graphics.UI.FLTK.LowLevel.TableRow
    (
     tableRowNew,
     TableRowSelectFlag(..)
     -- * Hierarchy
     --
     -- $hierarchy

     -- * Functions
     --
     -- $functions
    )
where
#include "Fl_ExportMacros.h"
#include "Fl_Types.h"
#include "Fl_Table_RowC.h"
import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum)
import Foreign.C.Types
import Graphics.UI.FLTK.LowLevel.Fl_Types
import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
import Graphics.UI.FLTK.LowLevel.Widget
import Graphics.UI.FLTK.LowLevel.Table
import Graphics.UI.FLTK.LowLevel.Utils
import Graphics.UI.FLTK.LowLevel.Hierarchy
import Graphics.UI.FLTK.LowLevel.Dispatch

data TableRowSelectFlag = TableRowSelect | TableRowDeselect | TableRowToggle

{# fun Fl_OverriddenTable_Row_New as tableRowNew' {  `Int',`Int', `Int', `Int', id `Ptr ()'} -> `Ptr ()' id #}
{# fun Fl_OverriddenTable_Row_New_WithLabel as tableRowNewWithLabel' { `Int',`Int',`Int',`Int', unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #}
tableRowNew :: Rectangle -> Maybe String -> Maybe (Ref TableRow -> IO ()) -> (Ref TableRow -> TableContext -> TableCoordinate -> Rectangle -> IO ()) -> CustomWidgetFuncs TableRow -> CustomTableFuncs TableRow -> IO (Ref TableRow)
tableRowNew rectangle label' draw' drawCell' customWidgetFuncs' customTableFuncs' =
    do
      let (x_pos, y_pos, width, height) = fromRectangle rectangle
      ptr <- tableCustomFunctionStruct draw' (Just drawCell') customWidgetFuncs' customTableFuncs'
      case label' of
        (Just l') -> tableRowNewWithLabel' x_pos y_pos width height l' ptr >>= toRef
        Nothing -> tableRowNew' x_pos y_pos width height ptr >>= toRef

{# fun Fl_Table_Row_Destroy as tableRowDestroy' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ (IO ())) => Op (Destroy ()) TableRow orig impl where
  runOp _ _ tableRow = withRef tableRow $ \tableRowPtr -> tableRowDestroy' tableRowPtr
{# fun Fl_Table_Row_rows as rows' { id `Ptr ()' } -> `Int' #}
instance (impl ~ ( IO (Int))) => Op (GetRows ()) TableRow orig impl where
  runOp _ _ tableRow = withRef tableRow $ \tableRowPtr -> rows' tableRowPtr
{# fun Fl_Table_Row_set_type as tableRowSetType' { id `Ptr ()', cFromEnum `TableRowSelectMode'} -> `()' #}
instance (impl ~ (TableRowSelectMode -> IO ())) => Op (SetType ()) TableRow orig impl where
  runOp _ _ tableRow selectionMode = withRef tableRow $ \tableRowPtr' -> tableRowSetType' tableRowPtr' selectionMode
{# fun Fl_Table_Row_type as tableRowType { id `Ptr ()' } -> `TableRowSelectMode' cToEnum  #}
instance (impl ~ (IO TableRowSelectMode)) => Op (GetType_ ()) TableRow orig impl where
  runOp _ _ tableRow = withRef tableRow $ \tableRowPtr' -> tableRowType tableRowPtr'
{# fun Fl_Table_Row_set_rows as setRows' { id `Ptr ()',`Int' } -> `()' #}
instance (impl ~ (Int ->  IO ())) => Op (SetRows ()) TableRow orig impl where
  runOp _ _ table val = withRef table $ \tablePtr -> setRows' tablePtr val
{# fun Fl_Table_Row_set_cols as setCols' { id `Ptr ()',`Int' } -> `()' #}
instance (impl ~ (Int ->  IO ())) => Op (SetCols ()) TableRow orig impl where
  runOp _ _ table val = withRef table $ \tablePtr -> setCols' tablePtr val
{# fun Fl_Table_Row_clear_super as clearSuper' { id `Ptr ()' } -> `()' #}
instance (impl ~ ( IO ())) => Op (ClearSuper ()) TableRow orig impl where
  runOp _ _ table = withRef table $ \tablePtr -> clearSuper' tablePtr
{# fun Fl_Table_Row_clear as clear' { id `Ptr ()' } -> `()' #}
instance (impl ~ ( IO ())) => Op (Clear ()) TableRow orig impl where
  runOp _ _ table = withRef table $ \tablePtr -> clear' tablePtr
{# fun Fl_Table_Row_set_rows_super as setRowsSuper' { id `Ptr ()',`Int' } -> `()' #}
instance (impl ~ (Int ->  IO ())) => Op (SetRowsSuper ()) TableRow orig impl where
  runOp _ _ table val = withRef table $ \tablePtr -> setRowsSuper' tablePtr val
{# fun Fl_Table_Row_set_cols_super as setColsSuper' { id `Ptr ()',`Int' } -> `()' #}
instance (impl ~ (Int ->  IO ())) => Op (SetColsSuper ()) TableRow orig impl where
  runOp _ _ table val = withRef table $ \tablePtr -> setColsSuper' tablePtr val
{# fun Fl_Table_Row_handle_super as handleSuper' { id `Ptr ()', cFromEnum `Event' } -> `Int' #}
instance (impl ~ (Event ->  IO (Int))) => Op (HandleSuper ()) TableRow orig impl where
   runOp _ _ table event = withRef table $ \tablePtr -> handleSuper' tablePtr event
{# fun Fl_Table_Row_handle as handle' { id `Ptr ()', cFromEnum `Event' } -> `Int' #}
instance (impl ~ (Event ->  IO (Int))) => Op (Handle ()) TableRow orig impl where
  runOp _ _ table event = withRef table $ \tablePtr -> handle' tablePtr event
{# fun Fl_Table_Row_resize_super as resizeSuper' { id `Ptr ()',`Int',`Int',`Int',`Int' } -> `()' #}
instance (impl ~ (Rectangle ->  IO ())) => Op (ResizeSuper ()) TableRow orig impl where
  runOp _ _ table rectangle = let (x_pos', y_pos', width', height') = fromRectangle rectangle in withRef table $ \tablePtr -> resizeSuper' tablePtr x_pos' y_pos' width' height'
{# fun Fl_Table_Row_resize as resize' { id `Ptr ()',`Int',`Int',`Int',`Int' } -> `()' #}
instance (impl ~ (Rectangle ->  IO ())) => Op (Resize ()) TableRow orig impl where
  runOp _ _ table rectangle = let (x_pos', y_pos', width', height') = fromRectangle rectangle in withRef table $ \tablePtr -> resize' tablePtr x_pos' y_pos' width' height'
{# fun Fl_Table_Row_row_selected as rowSelected' { id `Ptr ()', `Int'} -> `CInt' id #}
instance (impl ~ ( Int -> IO (Either OutOfRange Bool))) => Op (GetRowSelected ()) TableRow orig impl where
  runOp _ _ table idx' = withRef table $ \tablePtr -> do
    ret' <- rowSelected' tablePtr idx'
    if ret' == -1 then (return $ Left OutOfRange) else (return $ Right $ cToBool ret')
{# fun Fl_Table_Row_select_all_rows_with_flag as selectAllRows' {id `Ptr ()', `Int'} -> `()' #}
instance (impl ~ ( TableRowSelectFlag -> IO ())) => Op (SelectAllRows ()) TableRow orig impl where
  runOp _ _ table flag' = withRef table $
                          \tablePtr ->
                             case flag' of
                              TableRowSelect -> selectAllRows' tablePtr 1
                              TableRowDeselect -> selectAllRows' tablePtr 0
                              TableRowToggle -> selectAllRows' tablePtr 2

-- $functions
-- @
-- clear :: 'Ref' 'TableRow' -> 'IO' ()
--
-- clearSuper :: 'Ref' 'TableRow' -> 'IO' ()
--
-- destroy :: 'Ref' 'TableRow' -> 'IO' ()
--
-- getRowSelected :: 'Ref' 'TableRow' -> 'Int' -> 'IO' ('Either' 'OutOfRange' 'Bool')
--
-- getRows :: 'Ref' 'TableRow' -> 'IO' ('Int')
--
-- getType_ :: 'Ref' 'TableRow' -> 'IO' 'TableRowSelectMode'
--
-- handle :: 'Ref' 'TableRow' -> 'Event' -> 'IO' ('Int')
--
-- handleSuper :: 'Ref' 'TableRow' -> 'Event' -> 'IO' ('Int')
--
-- resize :: 'Ref' 'TableRow' -> 'Rectangle' -> 'IO' ()
--
-- resizeSuper :: 'Ref' 'TableRow' -> 'Rectangle' -> 'IO' ()
--
-- selectAllRows :: 'Ref' 'TableRow' -> 'TableRowSelectFlag' -> 'IO' ()
--
-- setCols :: 'Ref' 'TableRow' -> 'Int' -> 'IO' ()
--
-- setColsSuper :: 'Ref' 'TableRow' -> 'Int' -> 'IO' ()
--
-- setRows :: 'Ref' 'TableRow' -> 'Int' -> 'IO' ()
--
-- setRowsSuper :: 'Ref' 'TableRow' -> 'Int' -> 'IO' ()
--
-- setType :: 'Ref' 'TableRow' -> 'TableRowSelectMode' -> 'IO' ()
--
-- @

-- $hierarchy
-- @
-- "Graphics.UI.FLTK.LowLevel.Widget"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Group"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Table"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.TableRow"
-- @

{-# LANGUAGE CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Graphics.UI.FLTK.LowLevel.TableRow
    (
     tableRowNew,
     TableRowSelectFlag
     -- * Hierarchy
     --
     -- $hierarchy

     -- * Functions
     --
     -- $functions
    )
where
#include "Fl_ExportMacros.h"
#include "Fl_Types.h"
#include "Fl_Table_RowC.h"
import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum)
import Foreign.C.Types
import Graphics.UI.FLTK.LowLevel.Fl_Types
import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
import Graphics.UI.FLTK.LowLevel.Widget
import Graphics.UI.FLTK.LowLevel.Table
import Graphics.UI.FLTK.LowLevel.Utils
import Graphics.UI.FLTK.LowLevel.Hierarchy
import Graphics.UI.FLTK.LowLevel.Dispatch

data TableRowSelectFlag = TableRowSelect | TableRowDeselect | TableRowToggle

{# fun Fl_OverriddenTable_Row_New as tableRowNew' {  `Int',`Int', `Int', `Int', id `Ptr ()'} -> `Ptr ()' id #}
{# fun Fl_OverriddenTable_Row_New_WithLabel as tableRowNewWithLabel' { `Int',`Int',`Int',`Int', unsafeToCString `String', id `Ptr ()'} -> `Ptr ()' id #}
tableRowNew :: Rectangle -> Maybe String -> Maybe (Ref TableRow -> IO ()) -> (Ref TableRow -> TableContext -> TableCoordinate -> Rectangle -> IO ()) -> CustomWidgetFuncs TableRow -> CustomTableFuncs TableRow -> IO (Ref TableRow)
tableRowNew rectangle label' draw' drawCell' customWidgetFuncs' customTableFuncs' =
    do
      let (x_pos, y_pos, width, height) = fromRectangle rectangle
      ptr <- tableCustomFunctionStruct draw' (Just drawCell') customWidgetFuncs' customTableFuncs'
      case label' of
        (Just l') -> tableRowNewWithLabel' x_pos y_pos width height l' ptr >>= toRef
        Nothing -> tableRowNew' x_pos y_pos width height ptr >>= toRef

{# fun Fl_Table_Row_Destroy as tableRowDestroy' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ (IO ())) => Op (Destroy ()) TableRow orig impl where
  runOp _ _ tableRow = withRef tableRow $ \tableRowPtr -> tableRowDestroy' tableRowPtr
{# fun Fl_Table_Row_rows as rows' { id `Ptr ()' } -> `Int' #}
instance (impl ~ ( IO (Int))) => Op (GetRows ()) TableRow orig impl where
  runOp _ _ tableRow = withRef tableRow $ \tableRowPtr -> rows' tableRowPtr
{# fun Fl_Table_Row_set_type as tableRowSetType' { id `Ptr ()', cFromEnum `TableRowSelectMode'} -> `()' #}
instance (impl ~ (TableRowSelectMode -> IO ())) => Op (SetType ()) TableRow orig impl where
  runOp _ _ tableRow selectionMode = withRef tableRow $ \tableRowPtr' -> tableRowSetType' tableRowPtr' selectionMode
{# fun Fl_Table_Row_type as tableRowType { id `Ptr ()' } -> `TableRowSelectMode' cToEnum  #}
instance (impl ~ (IO TableRowSelectMode)) => Op (GetType_ ()) TableRow orig impl where
  runOp _ _ tableRow = withRef tableRow $ \tableRowPtr' -> tableRowType tableRowPtr'
{# fun Fl_Table_Row_set_rows as setRows' { id `Ptr ()',`Int' } -> `()' #}
instance (impl ~ (Int ->  IO ())) => Op (SetRows ()) TableRow orig impl where
  runOp _ _ table val = withRef table $ \tablePtr -> setRows' tablePtr val
{# fun Fl_Table_Row_set_cols as setCols' { id `Ptr ()',`Int' } -> `()' #}
instance (impl ~ (Int ->  IO ())) => Op (SetCols ()) TableRow orig impl where
  runOp _ _ table val = withRef table $ \tablePtr -> setCols' tablePtr val
{# fun Fl_Table_Row_clear_super as clearSuper' { id `Ptr ()' } -> `()' #}
instance (impl ~ ( IO ())) => Op (ClearSuper ()) TableRow orig impl where
  runOp _ _ table = withRef table $ \tablePtr -> clearSuper' tablePtr
{# fun Fl_Table_Row_clear as clear' { id `Ptr ()' } -> `()' #}
instance (impl ~ ( IO ())) => Op (Clear ()) TableRow orig impl where
  runOp _ _ table = withRef table $ \tablePtr -> clear' tablePtr
{# fun Fl_Table_Row_set_rows_super as setRowsSuper' { id `Ptr ()',`Int' } -> `()' #}
instance (impl ~ (Int ->  IO ())) => Op (SetRowsSuper ()) TableRow orig impl where
  runOp _ _ table val = withRef table $ \tablePtr -> setRowsSuper' tablePtr val
{# fun Fl_Table_Row_set_cols_super as setColsSuper' { id `Ptr ()',`Int' } -> `()' #}
instance (impl ~ (Int ->  IO ())) => Op (SetColsSuper ()) TableRow orig impl where
  runOp _ _ table val = withRef table $ \tablePtr -> setColsSuper' tablePtr val
{# fun Fl_Table_Row_handle_super as handleSuper' { id `Ptr ()', cFromEnum `Event' } -> `Int' #}
instance (impl ~ (Event ->  IO (Int))) => Op (HandleSuper ()) TableRow orig impl where
   runOp _ _ table event = withRef table $ \tablePtr -> handleSuper' tablePtr event
{# fun Fl_Table_Row_handle as handle' { id `Ptr ()', cFromEnum `Event' } -> `Int' #}
instance (impl ~ (Event ->  IO (Int))) => Op (Handle ()) TableRow orig impl where
  runOp _ _ table event = withRef table $ \tablePtr -> handle' tablePtr event
{# fun Fl_Table_Row_resize_super as resizeSuper' { id `Ptr ()',`Int',`Int',`Int',`Int' } -> `()' #}
instance (impl ~ (Rectangle ->  IO ())) => Op (ResizeSuper ()) TableRow orig impl where
  runOp _ _ table rectangle = let (x_pos', y_pos', width', height') = fromRectangle rectangle in withRef table $ \tablePtr -> resizeSuper' tablePtr x_pos' y_pos' width' height'
{# fun Fl_Table_Row_resize as resize' { id `Ptr ()',`Int',`Int',`Int',`Int' } -> `()' #}
instance (impl ~ (Rectangle ->  IO ())) => Op (Resize ()) TableRow orig impl where
  runOp _ _ table rectangle = let (x_pos', y_pos', width', height') = fromRectangle rectangle in withRef table $ \tablePtr -> resize' tablePtr x_pos' y_pos' width' height'
{# fun Fl_Table_Row_row_selected as rowSelected' { id `Ptr ()', `Int'} -> `CInt' id #}
instance (impl ~ ( Int -> IO (Either OutOfRange Bool))) => Op (GetRowSelected ()) TableRow orig impl where
  runOp _ _ table idx' = withRef table $ \tablePtr -> do
    ret' <- rowSelected' tablePtr idx'
    if ret' == -1 then (return $ Left OutOfRange) else (return $ Right $ cToBool ret')
{# fun Fl_Table_Row_select_all_rows_with_flag as selectAllRows' {id `Ptr ()', `Int'} -> `()' #}
instance (impl ~ ( TableRowSelectFlag -> IO ())) => Op (SelectAllRows ()) TableRow orig impl where
  runOp _ _ table flag' = withRef table $
                          \tablePtr ->
                             case flag' of
                              TableRowSelect -> selectAllRows' tablePtr 1
                              TableRowDeselect -> selectAllRows' tablePtr 0
                              TableRowToggle -> selectAllRows' tablePtr 2

-- $functions
-- @
-- clear :: 'Ref' 'TableRow' -> 'IO' ()
--
-- clearSuper :: 'Ref' 'TableRow' -> 'IO' ()
--
-- destroy :: 'Ref' 'TableRow' -> 'IO' ()
--
-- getRowSelected :: 'Ref' 'TableRow' -> 'Int' -> 'IO' ('Either' 'OutOfRange' 'Bool')
--
-- getRows :: 'Ref' 'TableRow' -> 'IO' ('Int')
--
-- getType_ :: 'Ref' 'TableRow' -> 'IO' 'TableRowSelectMode'
--
-- handle :: 'Ref' 'TableRow' -> 'Event' -> 'IO' ('Int')
--
-- handleSuper :: 'Ref' 'TableRow' -> 'Event' -> 'IO' ('Int')
--
-- resize :: 'Ref' 'TableRow' -> 'Rectangle' -> 'IO' ()
--
-- resizeSuper :: 'Ref' 'TableRow' -> 'Rectangle' -> 'IO' ()
--
-- selectAllRows :: 'Ref' 'TableRow' -> 'TableRowSelectFlag' -> 'IO' ()
--
-- setCols :: 'Ref' 'TableRow' -> 'Int' -> 'IO' ()
--
-- setColsSuper :: 'Ref' 'TableRow' -> 'Int' -> 'IO' ()
--
-- setRows :: 'Ref' 'TableRow' -> 'Int' -> 'IO' ()
--
-- setRowsSuper :: 'Ref' 'TableRow' -> 'Int' -> 'IO' ()
--
-- setType :: 'Ref' 'TableRow' -> 'TableRowSelectMode' -> 'IO' ()
--
-- @

-- $hierarchy
-- @
-- "Graphics.UI.FLTK.LowLevel.Widget"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Group"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Table"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.TableRow"
-- @


Make valueInit less conservative.

Make valueInit less conservative.

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GValue
--
--  Author : Axel Simon
--
--  Created: 1 June 2001
--
--  Version $Revision: 1.3 $ from $Date: 2005/11/16 13:14:16 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  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)
--
-- This module implements only the necessities for the GTK binding.
--
-- * Everything here is only used by "Graphics.UI.Gtk.TreeList.TreeModel" and
-- friends.
--
module System.Glib.GValue (
  GValue(GValue),
  valueInit,
  valueUnset,
  valueGetType,
  allocaGValue
  ) where

import Monad	(liftM)

import System.Glib.FFI
import System.Glib.GType	(GType)

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

{# pointer *GValue newtype #}

-- | Clear a GValue.
--
valueInit :: GValue -> GType -> IO ()
valueInit gv gt = do
  -- The g_type field of the value must be zero or g_value_init will fail.
  {# call unsafe value_init #} gv gt
  return ()

-- | Free the data in a GValue.
--
valueUnset :: GValue -> IO ()
valueUnset = {#call unsafe value_unset#}

-- | Get the type of the value stored in the GValue
--
valueGetType :: GValue -> IO GType
valueGetType (GValue gvPtr) = {# get GValue->g_type #} gvPtr

-- | Temporarily allocate a GValue.
--
allocaGValue :: (GValue -> IO b) -> IO b
allocaGValue body =
  -- c2hs is broken in that it can't handle arrays of compound arrays in the
  -- sizeof hook
  allocaBytes ({# sizeof GType #}+ 2* {# sizeof guint64 #}) $ \gvPtr -> do
  -- The g_type field of the value must be zero or g_value_init will fail.
  {# set GValue->g_type #} gvPtr (0 :: GType)
  result <- body (GValue gvPtr)
  valueUnset (GValue gvPtr)
  return result

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GValue
--
--  Author : Axel Simon
--
--  Created: 1 June 2001
--
--  Version $Revision: 1.3 $ from $Date: 2005/11/16 13:14:16 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  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)
--
-- This module implements only the necessities for the GTK binding.
--
-- * Everything here is only used by "Graphics.UI.Gtk.TreeList.TreeModel" and
-- friends.
--
module System.Glib.GValue (
  GValue(GValue),
  valueInit,
  valueUnset,
  valueGetType,
  allocaGValue
  ) where

import Monad	(liftM)

import System.Glib.FFI
import System.Glib.GType	(GType)

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

{# pointer *GValue newtype #}

-- | Clear a GValue.
--
valueInit :: GValue -> GType -> IO ()
valueInit gv@(GValue gvPtr) gt = do
  -- The g_type field of the value must be zero or g_value_init will fail.
  {# set GValue->g_type #} gvPtr (0 :: GType)
  {# call unsafe value_init #} gv gt
  return ()

-- | Free the data in a GValue.
--
valueUnset :: GValue -> IO ()
valueUnset = {#call unsafe value_unset#}

-- | Get the type of the value stored in the GValue
--
valueGetType :: GValue -> IO GType
valueGetType (GValue gvPtr) = {# get GValue->g_type #} gvPtr

-- | Temporarily allocate a GValue.
--
allocaGValue :: (GValue -> IO b) -> IO b
allocaGValue body =
  -- c2hs is broken in that it can't handle arrays of compound arrays in the
  -- sizeof hook
  allocaBytes ({# sizeof GType #}+ 2* {# sizeof guint64 #}) $ \gvPtr -> do
  -- The g_type field of the value must be zero or g_value_init will fail.
  {# set GValue->g_type #} gvPtr (0 :: GType)
  result <- body (GValue gvPtr)
  valueUnset (GValue gvPtr)
  return result


Correct matrix inversion.

Correct matrix inversion.

Calculating the determinant was incorrect. Pointed out by
Maurício <briqueabraque@yahoo.com>.

darcs-hash:20060929082643-91c87-14e0697a0ed7104a155d35f39f0f4173f521c57e.gz

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Cairo.Matrix
-- Copyright   :  (c) Paolo Martini 2005
-- License     :  BSD-style (see cairo/COPYRIGHT)
--
-- Maintainer  :  p.martini@neuralnoise.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Matrix math
-----------------------------------------------------------------------------

module Graphics.Rendering.Cairo.Matrix (
    Matrix(Matrix)
  , MatrixPtr
  , identity
  , translate
  , scale
  , rotate
  , transformDistance
  , transformPoint
  , scalarMultiply
  , adjoint
  , invert
  ) where

import Foreign hiding (rotate)
import CForeign

-- | Representation of a 2-D affine transformation as a matrix.
--
-- The 'Matrix' type actually represents as 3x3 matrix but with some elements
-- are constant and so are not included. Specifically if we assume that our
-- coordinates are row vectors then correspondence is:
--
-- >    Matrix xx yx xy yy x0 y0
-- > ==
-- >    / xx yx 0 \
-- >    | xy yy 0 |
-- >    \ x0 y0 1 /
--
-- and the matrix operates on @(x,y)@ coordinates:
--
-- > (x y 1) / xx yx 0 \  = (x' y' 1)
-- >         | xy yy 0 |  where x' = xx * x + xy * y + x0
-- >         \ x0 y0 1 /        y' = yx * x + yy * y + y0
--
data Matrix = Matrix { xx :: !Double, yx :: !Double,
                       xy :: !Double, yy :: !Double,
                       x0 :: !Double, y0 :: !Double }
  deriving (Show, Eq)

{#pointer *cairo_matrix_t as MatrixPtr -> Matrix#}

instance Storable Matrix where
  sizeOf _ = {#sizeof cairo_matrix_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    xx <- {#get cairo_matrix_t->xx#} p
    yx <- {#get cairo_matrix_t->yx#} p
    xy <- {#get cairo_matrix_t->xy#} p
    yy <- {#get cairo_matrix_t->yy#} p
    x0 <- {#get cairo_matrix_t->x0#} p
    y0 <- {#get cairo_matrix_t->y0#} p
    return $ Matrix (realToFrac xx) (realToFrac yx)
                    (realToFrac xy) (realToFrac yy)
                    (realToFrac x0) (realToFrac y0)

  poke p (Matrix xx yx xy yy x0 y0) = do
    {#set cairo_matrix_t->xx#} p (realToFrac xx)
    {#set cairo_matrix_t->yx#} p (realToFrac yx)
    {#set cairo_matrix_t->xy#} p (realToFrac xy)
    {#set cairo_matrix_t->yy#} p (realToFrac yy)
    {#set cairo_matrix_t->x0#} p (realToFrac x0)
    {#set cairo_matrix_t->y0#} p (realToFrac y0)
    return ()

instance Num Matrix where
  (*) (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
    Matrix (xx * xx' + yx * xy')
           (xx * yx' + yx * yy')
           (xy * xx' + yy * xy')
           (xy * yx' + yy * yy')
           (x0 * xx' + y0 * xy' + x0')
           (x0 * yx' + y0 * yy' + y0')

  (+) = pointwise2 (+)
  (-) = pointwise2 (-)

  negate = pointwise negate
  abs    = pointwise abs
  signum = pointwise signum

  -- this definition of fromInteger means that 2*m = scale 2 m
  -- and it means 1 = identity
  fromInteger n = Matrix (fromInteger n) 0 0 (fromInteger n) 0 0

{-# INLINE pointwise #-}
pointwise f (Matrix xx yx xy yy x0 y0) =
  Matrix (f xx) (f yx) (f xy) (f yy) (f x0) (f y0)

{-# INLINE pointwise2 #-}
pointwise2 f (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
  Matrix (f xx xx') (f yx yx') (f xy xy') (f yy yy') (f x0 x0') (f y0 y0')

identity :: Matrix
identity = Matrix 1 0 0 1 0 0

translate :: Double -> Double -> Matrix -> Matrix
translate tx ty m = m * (Matrix 1 0 0 1 tx ty)

scale :: Double -> Double -> Matrix -> Matrix
scale sx sy m = m * (Matrix sx 0 0 sy 0 0)

rotate :: Double -> Matrix -> Matrix
rotate r m = m * (Matrix c s (-s) c 0 0)
  where s = sin r
        c = cos r

transformDistance :: Matrix -> (Double,Double) -> (Double,Double)
transformDistance (Matrix xx yx xy yy _ _) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy
        newY = yx * dx + yy * dy

transformPoint :: Matrix -> (Double,Double) -> (Double,Double)
transformPoint (Matrix xx yx xy yy x0 y0) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy + x0
        newY = yx * dx + yy * dy + y0

scalarMultiply :: Double -> Matrix -> Matrix
scalarMultiply scalar = pointwise (*scalar)

adjoint :: Matrix -> Matrix
adjoint (Matrix a b c d tx ty) =
  Matrix d (-b) (-c) a (c*ty - d*tx) (b*tx - a*ty)

invert :: Matrix -> Matrix
invert m@(Matrix xx yx xy yy _ _) = scalarMultiply (recip det) $ adjoint m
  where det = xx*yy - yx*xy

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Cairo.Matrix
-- Copyright   :  (c) Paolo Martini 2005
-- License     :  BSD-style (see cairo/COPYRIGHT)
--
-- Maintainer  :  p.martini@neuralnoise.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Matrix math
-----------------------------------------------------------------------------

module Graphics.Rendering.Cairo.Matrix (
    Matrix(Matrix)
  , MatrixPtr
  , identity
  , translate
  , scale
  , rotate
  , transformDistance
  , transformPoint
  , scalarMultiply
  , adjoint
  , invert
  ) where

import Foreign hiding (rotate)
import CForeign

-- | Representation of a 2-D affine transformation as a matrix.
--
-- The 'Matrix' type actually represents as 3x3 matrix but with some elements
-- are constant and so are not included. Specifically if we assume that our
-- coordinates are row vectors then correspondence is:
--
-- >    Matrix xx yx xy yy x0 y0
-- > ==
-- >    / xx yx 0 \
-- >    | xy yy 0 |
-- >    \ x0 y0 1 /
--
-- and the matrix operates on @(x,y)@ coordinates:
--
-- > (x y 1) / xx yx 0 \  = (x' y' 1)
-- >         | xy yy 0 |  where x' = xx * x + xy * y + x0
-- >         \ x0 y0 1 /        y' = yx * x + yy * y + y0
--
data Matrix = Matrix { xx :: !Double, yx :: !Double,
                       xy :: !Double, yy :: !Double,
                       x0 :: !Double, y0 :: !Double }
  deriving (Show, Eq)

{#pointer *cairo_matrix_t as MatrixPtr -> Matrix#}

instance Storable Matrix where
  sizeOf _ = {#sizeof cairo_matrix_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    xx <- {#get cairo_matrix_t->xx#} p
    yx <- {#get cairo_matrix_t->yx#} p
    xy <- {#get cairo_matrix_t->xy#} p
    yy <- {#get cairo_matrix_t->yy#} p
    x0 <- {#get cairo_matrix_t->x0#} p
    y0 <- {#get cairo_matrix_t->y0#} p
    return $ Matrix (realToFrac xx) (realToFrac yx)
                    (realToFrac xy) (realToFrac yy)
                    (realToFrac x0) (realToFrac y0)

  poke p (Matrix xx yx xy yy x0 y0) = do
    {#set cairo_matrix_t->xx#} p (realToFrac xx)
    {#set cairo_matrix_t->yx#} p (realToFrac yx)
    {#set cairo_matrix_t->xy#} p (realToFrac xy)
    {#set cairo_matrix_t->yy#} p (realToFrac yy)
    {#set cairo_matrix_t->x0#} p (realToFrac x0)
    {#set cairo_matrix_t->y0#} p (realToFrac y0)
    return ()

instance Num Matrix where
  (*) (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
    Matrix (xx * xx' + yx * xy')
           (xx * yx' + yx * yy')
           (xy * xx' + yy * xy')
           (xy * yx' + yy * yy')
           (x0 * xx' + y0 * xy' + x0')
           (x0 * yx' + y0 * yy' + y0')

  (+) = pointwise2 (+)
  (-) = pointwise2 (-)

  negate = pointwise negate
  abs    = pointwise abs
  signum = pointwise signum

  -- this definition of fromInteger means that 2*m = scale 2 m
  -- and it means 1 = identity
  fromInteger n = Matrix (fromInteger n) 0 0 (fromInteger n) 0 0

{-# INLINE pointwise #-}
pointwise f (Matrix xx yx xy yy x0 y0) =
  Matrix (f xx) (f yx) (f xy) (f yy) (f x0) (f y0)

{-# INLINE pointwise2 #-}
pointwise2 f (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
  Matrix (f xx xx') (f yx yx') (f xy xy') (f yy yy') (f x0 x0') (f y0 y0')

identity :: Matrix
identity = Matrix 1 0 0 1 0 0

translate :: Double -> Double -> Matrix -> Matrix
translate tx ty m = m * (Matrix 1 0 0 1 tx ty)

scale :: Double -> Double -> Matrix -> Matrix
scale sx sy m = m * (Matrix sx 0 0 sy 0 0)

rotate :: Double -> Matrix -> Matrix
rotate r m = m * (Matrix c s (-s) c 0 0)
  where s = sin r
        c = cos r

transformDistance :: Matrix -> (Double,Double) -> (Double,Double)
transformDistance (Matrix xx yx xy yy _ _) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy
        newY = yx * dx + yy * dy

transformPoint :: Matrix -> (Double,Double) -> (Double,Double)
transformPoint (Matrix xx yx xy yy x0 y0) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy + x0
        newY = yx * dx + yy * dy + y0

scalarMultiply :: Double -> Matrix -> Matrix
scalarMultiply scalar = pointwise (*scalar)

adjoint :: Matrix -> Matrix
adjoint (Matrix a b c d tx ty) =
  Matrix d (-b) (-c) a (c*ty - d*tx) (b*tx - a*ty)

invert :: Matrix -> Matrix
invert m@(Matrix xx yx xy yy _ _) = scalarMultiply (recip det) $ adjoint m
  where det = xx*yx - xy*yy