cosmetic changes

cosmetic changes

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

module OSGeo.GDAL.Internal (
    HasDataset
  , HasBand
  , HasWritebaleBand
  , HasDatatype
  , Datatype (..)
  , GDALException
  , isGDALException
  , Geotransform (..)
  , IOVector
  , DriverOptions
  , MajorObject
  , Dataset
  , ReadWrite
  , ReadOnly
  , RWDataset
  , RODataset
  , RWBand
  , ROBand
  , Band
  , Driver
  , DriverName
  , ColorTable
  , RasterAttributeTable
  , GComplex (..)

  , setQuietErrorHandler
  , unDataset
  , unBand

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

  , datatypeSize
  , datatypeByName
  , datatypeUnion
  , datatypeIsComplex

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

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

  , toComplex
  , fromComplex

  -- Internal Util
  , throwIfError
  , withDataset
) where

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

import Data.Int (Int16, Int32)
import qualified Data.Complex as Complex
import Data.Maybe (isJust)
import Data.Typeable (Typeable, 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)

import OSGeo.Util

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

type DriverName = String

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)

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

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

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

unDataset (Dataset (d, _)) = d

type RODataset = Dataset ReadOnly
type RWDataset = Dataset ReadWrite
withDataset, withDataset' :: (Dataset a t) -> (Ptr (Dataset a t) -> 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 t) = Band (Ptr ((Band a t)))

unBand (Band b) = b

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 GDALDestroyDriverManager as destroyDriverManager {} -> `()'#}

{-# DEPRECATED withAllDriversRegistered "Don't use this since it does not destry the driver manager anymore. registerAllDrivers manually and call destroyDriverManager at your own peril since it will likely cause a double free if a dataset's finalizer runs after destroyDriverManager" #-}
withAllDriversRegistered act
  = registerAllDrivers >> act

{# 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)]

class ( HasDatatype t
      , a ~ ReadWrite
      , d ~ Dataset,
      HasWritebaleBand Band ReadWrite t)
  => HasDataset d a t where
    create :: String -> FilePath -> Int -> Int -> Int -> DriverOptions
           -> IO (d a t)
    create drv path nx ny bands options = do
        d <- driverByName  drv
        create' d path nx ny bands (datatype (undefined :: t)) options

create' :: Driver -> String -> Int -> Int -> Int -> Datatype -> DriverOptions
       -> IO (Dataset ReadWrite t)
create' drv path nx ny bands dtype options = withCString path $ \path' -> do
    let nx'    = fromIntegral nx
        ny'    = fromIntegral ny
        bands' = fromIntegral bands
        dtype' = fromEnumC dtype
    withOptionList options $ \opts ->
        create_ drv path' nx' ny' bands' dtype' opts >>= newDatasetHandle

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

instance HasDataset Dataset ReadWrite Word8 where
instance HasDataset Dataset ReadWrite Int16 where
instance HasDataset Dataset ReadWrite Int32 where
instance HasDataset Dataset ReadWrite Word16 where
instance HasDataset Dataset ReadWrite Word32 where
instance HasDataset Dataset ReadWrite Float where
instance HasDataset Dataset ReadWrite Double where
instance HasDataset Dataset ReadWrite (GComplex Int16) where
instance HasDataset Dataset ReadWrite (GComplex Int32) where
instance HasDataset Dataset ReadWrite (GComplex Float) where
instance HasDataset Dataset ReadWrite (GComplex Double) where

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

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

openReadWrite :: String -> IO (RWDataset t)
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 t))

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

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

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

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

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

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

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

newDatasetHandle :: Ptr (Dataset a t) -> IO (Dataset a t)
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 t) -> IO ())

createMem:: HasDataset d a t
  => Int -> Int -> Int -> DriverOptions -> IO (d a t)
createMem = create "MEM" ""

flushCache :: forall t. RWDataset t -> IO ()
flushCache d = withDataset d flushCache'

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

datasetSize :: Dataset a t -> (Int, Int)
datasetSize ds = unsafePerformIO $ withDataset ds $ \dsPtr ->
    return ( fromIntegral . getDatasetXSize_ $ dsPtr
           , fromIntegral . getDatasetYSize_ $ dsPtr)

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

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

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

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

setDatasetProjection :: (RWDataset t) -> String -> IO ()
setDatasetProjection d p = throwIfError
                           "setDatasetProjection: 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 t) -> Ptr CChar -> IO CInt

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

datasetGeotransform :: Dataset a t -> 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 t) -> Ptr CDouble -> IO CInt

setDatasetGeotransform :: (RWDataset t) -> 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 t) -> Ptr CDouble -> IO CInt

datasetBandCount :: Dataset a t -> IO (Int)
datasetBandCount d = liftM fromIntegral $ withDataset d bandCount_

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

withBand :: Dataset a t -> Int -> (Band a t -> 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 t) -> CInt -> IO ((Band a t))

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

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

bandBlockSize :: (Band a t) -> (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 t) -> Ptr CInt -> Ptr CInt -> IO ()

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

bandSize :: (Band a t) -> (Int, Int)
bandSize band
  = (fromIntegral . getBandXSize_ $ band, fromIntegral . getBandYSize_ $ band)

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

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

bandNodataValue :: (Band a t) -> 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 t) -> Ptr CInt -> IO CDouble

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

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

fillBand :: (RWBand t) -> 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 t) -> CDouble -> CDouble -> IO CInt

data GComplex a = (:+) !a !a deriving (Eq, Typeable)
infix 6 :+
instance Show a => Show (GComplex a) where
  show (r :+ i) = show r ++ " :+ " ++ show i

class IsGComplex a where
   type ComplexType a :: *
   toComplex :: GComplex a -> Complex.Complex (ComplexType a)
   fromComplex :: Complex.Complex (ComplexType a) -> GComplex a

   toComplex (r :+  i) = (toUnit r) Complex.:+ (toUnit i)
   fromComplex (r Complex.:+ i) = (fromUnit r) :+ (fromUnit i)

   toUnit :: a -> ComplexType a
   fromUnit :: ComplexType a -> a

instance IsGComplex Int16 where
   type ComplexType Int16 = Float
   toUnit = fromIntegral
   fromUnit = round

instance IsGComplex Int32 where
   type ComplexType Int32 = Double
   toUnit = fromIntegral
   fromUnit = round

instance IsGComplex Float where
   type ComplexType Float = Float
   toUnit = id
   fromUnit = id

instance IsGComplex Double where
   type ComplexType Double = Double
   toUnit = id
   fromUnit = id

instance Storable a => Storable (GComplex a) where
  sizeOf _ = sizeOf (undefined :: a) * 2
  alignment _ = alignment (undefined :: a)

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

  {-# SPECIALIZE INLINE
      poke :: Ptr (GComplex Float) -> GComplex Float -> IO () #-}
  {-# SPECIALIZE INLINE
      poke :: Ptr (GComplex Double) -> GComplex Double -> IO () #-}
  {-# SPECIALIZE INLINE
      poke :: Ptr (GComplex Int16) -> GComplex Int16 -> IO () #-}
  {-# SPECIALIZE INLINE
      poke :: Ptr (GComplex Int32) -> GComplex Int32 -> IO () #-}
  poke p (r :+ i)
    = pokeElemOff (castPtr p) 0 r >> pokeElemOff (castPtr p) 1 i

readBand' :: HasDatatype a
  => (Band b a)
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> IO (Vector a)
readBand' = readBand

readBand :: forall a b t. HasDatatype a
  => (Band b t)
  -> 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)
    let dtype = fromEnumC (datatype (undefined :: a))
    withForeignPtr fp $ \ptr -> do
      throwIfError "could not advise read" $
        adviseRead_
          band
          (fromIntegral xoff)
          (fromIntegral yoff)
          (fromIntegral sx)
          (fromIntegral sy)
          (fromIntegral bx)
          (fromIntegral by)
          dtype
          (castPtr nullPtr)
      throwIfError "could not read band" $
        rasterIO_
          band
          (fromEnumC GF_Read)
          (fromIntegral xoff)
          (fromIntegral yoff)
          (fromIntegral sx)
          (fromIntegral sy)
          (castPtr ptr)
          (fromIntegral bx)
          (fromIntegral by)
          dtype
          (fromIntegral pxs)
          (fromIntegral lns)
    return $ unsafeFromForeignPtr0 fp (bx * by)

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

writeBand' :: forall a. HasDatatype a
  => (RWBand a)
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Vector a
  -> IO ()
writeBand' = writeBand

writeBand :: forall a t. HasDatatype a
  => (RWBand t)
  -> 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 (undefined :: a)))
            (fromIntegral pxs)
            (fromIntegral lns)

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

type IOVector a = IO (Vector a)

class (HasDatatype t, b ~ Band)
  => HasBand b a t where
    readBandBlock  :: b a t -> Int -> Int -> IOVector t
    readBandBlock b x y
      = if not $ isValidDatatype b (undefined :: Vector t)
            then throw $ GDALException CE_Failure "wrong band type"
            else 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 t) -> CInt -> CInt -> Ptr () -> IO CInt

class (HasBand b a t, a ~ ReadWrite) => HasWritebaleBand b a t where
    writeBandBlock :: b a t -> Int -> Int -> Vector t -> 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 not $ isValidDatatype b vec
                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 t) -> CInt -> CInt -> Ptr () -> IO CInt

instance forall a. HasBand Band a Word8 where
instance forall a. HasBand Band a Word16 where
instance forall a. HasBand Band a Word32 where
instance forall a. HasBand Band a Int16 where
instance forall a. HasBand Band a Int32 where
instance forall a. HasBand Band a Float where
instance forall a. HasBand Band a Double where
instance forall a. HasBand Band a (GComplex Int16) where
instance forall a. HasBand Band a (GComplex Int32) where
instance forall a. HasBand Band a (GComplex Float) where
instance forall a. HasBand Band a (GComplex Double) where

instance HasWritebaleBand Band ReadWrite Word8
instance HasWritebaleBand Band ReadWrite Word16
instance HasWritebaleBand Band ReadWrite Word32
instance HasWritebaleBand Band ReadWrite Int16
instance HasWritebaleBand Band ReadWrite Int32
instance HasWritebaleBand Band ReadWrite Float
instance HasWritebaleBand Band ReadWrite Double
instance HasWritebaleBand Band ReadWrite (GComplex Int16) where
instance HasWritebaleBand Band ReadWrite (GComplex Int32) where
instance HasWritebaleBand Band ReadWrite (GComplex Float) where
instance HasWritebaleBand Band ReadWrite (GComplex Double) where

class (Storable a, Typeable a) => HasDatatype a where
    datatype :: a -> Datatype

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

isValidDatatype :: forall a t v.  Typeable v
  => Band a t -> v -> Bool
isValidDatatype b v = typeOfBand b == typeOf v
  where
    typeOfBand        = typeOfdatatype . bandDatatype
    typeOfdatatype dt =
      case dt of
        GDT_Byte     -> typeOf (undefined :: Vector Word8)
        GDT_UInt16   -> typeOf (undefined :: Vector Word16)
        GDT_UInt32   -> typeOf (undefined :: Vector Word32)
        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 (GComplex Int16))
        GDT_CInt32   -> typeOf (undefined :: Vector (GComplex Int32))
        GDT_CFloat32 -> typeOf (undefined :: Vector (GComplex Float))
        GDT_CFloat64 -> typeOf (undefined :: Vector (GComplex Double))
        _            -> typeOf (undefined :: Bool) -- will never match a vector

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

module OSGeo.GDAL.Internal (
    HasDataset
  , HasBand
  , HasWritebaleBand
  , HasDatatype
  , Datatype (..)
  , GDALException
  , isGDALException
  , Geotransform (..)
  , IOVector
  , DriverOptions
  , MajorObject
  , Dataset
  , ReadWrite
  , ReadOnly
  , RWDataset
  , RODataset
  , RWBand
  , ROBand
  , Band
  , Driver
  , DriverName
  , ColorTable
  , RasterAttributeTable
  , GComplex (..)

  , setQuietErrorHandler
  , unDataset
  , unBand

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

  , datatypeSize
  , datatypeByName
  , datatypeUnion
  , datatypeIsComplex

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

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

  , toComplex
  , fromComplex

  -- Internal Util
  , throwIfError
  , withDataset
) where

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

import Data.Int (Int16, Int32)
import qualified Data.Complex as Complex
import Data.Maybe (isJust)
import Data.Typeable (Typeable, 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)

import OSGeo.Util

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

type DriverName = String

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)

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

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

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

unDataset (Dataset (d, _)) = d

type RODataset = Dataset ReadOnly
type RWDataset = Dataset ReadWrite
withDataset, withDataset' :: (Dataset a t) -> (Ptr (Dataset a t) -> 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 t) = Band (Ptr ((Band a t)))

unBand (Band b) = b

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 GDALDestroyDriverManager as destroyDriverManager {} -> `()'#}

{-# DEPRECATED withAllDriversRegistered "Don't use this since it does not destry the driver manager anymore. registerAllDrivers manually and call destroyDriverManager at your own peril since it will likely cause a double free if a dataset's finalizer runs after destroyDriverManager" #-}
withAllDriversRegistered act
  = registerAllDrivers >> act

{# 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)]

class ( HasDatatype t
      , a ~ ReadWrite
      , d ~ Dataset,
      HasWritebaleBand Band ReadWrite t)
  => HasDataset d a t where
    create :: String -> String -> Int -> Int -> Int -> DriverOptions
           -> IO (d a t)
    create drv path nx ny bands options = do
        d <- driverByName  drv
        create' d path nx ny bands (datatype (undefined :: t)) options

create' :: Driver -> String -> Int -> Int -> Int -> Datatype -> DriverOptions
       -> IO (Dataset ReadWrite t)
create' drv path nx ny bands dtype options = withCString path $ \path' -> do
    let nx'    = fromIntegral nx
        ny'    = fromIntegral ny
        bands' = fromIntegral bands
        dtype' = fromEnumC dtype
    withOptionList options $ \opts ->
        create_ drv path' nx' ny' bands' dtype' opts >>= newDatasetHandle

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

instance HasDataset Dataset ReadWrite Word8 where
instance HasDataset Dataset ReadWrite Int16 where
instance HasDataset Dataset ReadWrite Int32 where
instance HasDataset Dataset ReadWrite Word16 where
instance HasDataset Dataset ReadWrite Word32 where
instance HasDataset Dataset ReadWrite Float where
instance HasDataset Dataset ReadWrite Double where
instance HasDataset Dataset ReadWrite (GComplex Int16) where
instance HasDataset Dataset ReadWrite (GComplex Int32) where
instance HasDataset Dataset ReadWrite (GComplex Float) where
instance HasDataset Dataset ReadWrite (GComplex Double) where

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

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

openReadWrite :: String -> IO (RWDataset t)
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 t))

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

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

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

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

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

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

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

newDatasetHandle :: Ptr (Dataset a t) -> IO (Dataset a t)
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 t) -> IO ())

createMem:: HasDataset d a t
  => Int -> Int -> Int -> DriverOptions -> IO (d a t)
createMem = create "MEM" ""

flushCache :: forall t. RWDataset t -> IO ()
flushCache d = withDataset d flushCache'

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

datasetSize :: Dataset a t -> (Int, Int)
datasetSize ds = unsafePerformIO $ withDataset ds $ \dsPtr ->
    return ( fromIntegral . getDatasetXSize_ $ dsPtr
           , fromIntegral . getDatasetYSize_ $ dsPtr)

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

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

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

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

setDatasetProjection :: (RWDataset t) -> String -> IO ()
setDatasetProjection d p = throwIfError
                           "setDatasetProjection: 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 t) -> Ptr CChar -> IO CInt

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

datasetGeotransform :: Dataset a t -> 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 t) -> Ptr CDouble -> IO CInt

setDatasetGeotransform :: (RWDataset t) -> 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 t) -> Ptr CDouble -> IO CInt

datasetBandCount :: Dataset a t -> IO (Int)
datasetBandCount d = liftM fromIntegral $ withDataset d bandCount_

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

withBand :: Dataset a t -> Int -> (Band a t -> 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 t) -> CInt -> IO ((Band a t))

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

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

bandBlockSize :: (Band a t) -> (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 t) -> Ptr CInt -> Ptr CInt -> IO ()

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

bandSize :: (Band a t) -> (Int, Int)
bandSize band
  = (fromIntegral . getBandXSize_ $ band, fromIntegral . getBandYSize_ $ band)

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

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

bandNodataValue :: (Band a t) -> 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 t) -> Ptr CInt -> IO CDouble

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

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

fillBand :: (RWBand t) -> 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 t) -> CDouble -> CDouble -> IO CInt

data GComplex a = (:+) !a !a deriving (Eq, Typeable)
infix 6 :+
instance Show a => Show (GComplex a) where
  show (r :+ i) = show r ++ " :+ " ++ show i

class IsGComplex a where
   type ComplexType a :: *
   toComplex :: GComplex a -> Complex.Complex (ComplexType a)
   fromComplex :: Complex.Complex (ComplexType a) -> GComplex a

   toComplex (r :+  i) = (toUnit r) Complex.:+ (toUnit i)
   fromComplex (r Complex.:+ i) = (fromUnit r) :+ (fromUnit i)

   toUnit :: a -> ComplexType a
   fromUnit :: ComplexType a -> a

instance IsGComplex Int16 where
   type ComplexType Int16 = Float
   toUnit = fromIntegral
   fromUnit = round

instance IsGComplex Int32 where
   type ComplexType Int32 = Double
   toUnit = fromIntegral
   fromUnit = round

instance IsGComplex Float where
   type ComplexType Float = Float
   toUnit = id
   fromUnit = id

instance IsGComplex Double where
   type ComplexType Double = Double
   toUnit = id
   fromUnit = id

instance Storable a => Storable (GComplex a) where
  sizeOf _ = sizeOf (undefined :: a) * 2
  alignment _ = alignment (undefined :: a)

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

  {-# SPECIALIZE INLINE
      poke :: Ptr (GComplex Float) -> GComplex Float -> IO () #-}
  {-# SPECIALIZE INLINE
      poke :: Ptr (GComplex Double) -> GComplex Double -> IO () #-}
  {-# SPECIALIZE INLINE
      poke :: Ptr (GComplex Int16) -> GComplex Int16 -> IO () #-}
  {-# SPECIALIZE INLINE
      poke :: Ptr (GComplex Int32) -> GComplex Int32 -> IO () #-}
  poke p (r :+ i)
    = pokeElemOff (castPtr p) 0 r >> pokeElemOff (castPtr p) 1 i

readBand' :: HasDatatype a
  => (Band b a)
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> IO (Vector a)
readBand' = readBand

readBand :: forall a b t. HasDatatype a
  => (Band b t)
  -> 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)
    let dtype = fromEnumC (datatype (undefined :: a))
    withForeignPtr fp $ \ptr -> do
      throwIfError "could not advise read" $
        adviseRead_
          band
          (fromIntegral xoff)
          (fromIntegral yoff)
          (fromIntegral sx)
          (fromIntegral sy)
          (fromIntegral bx)
          (fromIntegral by)
          dtype
          (castPtr nullPtr)
      throwIfError "could not read band" $
        rasterIO_
          band
          (fromEnumC GF_Read)
          (fromIntegral xoff)
          (fromIntegral yoff)
          (fromIntegral sx)
          (fromIntegral sy)
          (castPtr ptr)
          (fromIntegral bx)
          (fromIntegral by)
          dtype
          (fromIntegral pxs)
          (fromIntegral lns)
    return $ unsafeFromForeignPtr0 fp (bx * by)

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

writeBand' :: forall a. HasDatatype a
  => (RWBand a)
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Vector a
  -> IO ()
writeBand' = writeBand

writeBand :: forall a t. HasDatatype a
  => (RWBand t)
  -> 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 (undefined :: a)))
            (fromIntegral pxs)
            (fromIntegral lns)

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

type IOVector a = IO (Vector a)

class (HasDatatype t, b ~ Band)
  => HasBand b a t where
    readBandBlock  :: b a t -> Int -> Int -> IOVector t
    readBandBlock b x y
      = if not $ isValidDatatype b (undefined :: Vector t)
            then throw $ GDALException CE_Failure "wrong band type"
            else 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 t) -> CInt -> CInt -> Ptr () -> IO CInt

class (HasBand b a t, a ~ ReadWrite) => HasWritebaleBand b a t where
    writeBandBlock :: b a t -> Int -> Int -> Vector t -> 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 not $ isValidDatatype b vec
                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 t) -> CInt -> CInt -> Ptr () -> IO CInt

instance forall a. HasBand Band a Word8 where
instance forall a. HasBand Band a Word16 where
instance forall a. HasBand Band a Word32 where
instance forall a. HasBand Band a Int16 where
instance forall a. HasBand Band a Int32 where
instance forall a. HasBand Band a Float where
instance forall a. HasBand Band a Double where
instance forall a. HasBand Band a (GComplex Int16) where
instance forall a. HasBand Band a (GComplex Int32) where
instance forall a. HasBand Band a (GComplex Float) where
instance forall a. HasBand Band a (GComplex Double) where

instance HasWritebaleBand Band ReadWrite Word8
instance HasWritebaleBand Band ReadWrite Word16
instance HasWritebaleBand Band ReadWrite Word32
instance HasWritebaleBand Band ReadWrite Int16
instance HasWritebaleBand Band ReadWrite Int32
instance HasWritebaleBand Band ReadWrite Float
instance HasWritebaleBand Band ReadWrite Double
instance HasWritebaleBand Band ReadWrite (GComplex Int16) where
instance HasWritebaleBand Band ReadWrite (GComplex Int32) where
instance HasWritebaleBand Band ReadWrite (GComplex Float) where
instance HasWritebaleBand Band ReadWrite (GComplex Double) where

class (Storable a, Typeable a) => HasDatatype a where
    datatype :: a -> Datatype

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

isValidDatatype :: forall a t v.  Typeable v
  => Band a t -> v -> Bool
isValidDatatype b v = typeOfBand b == typeOf v
  where
    typeOfBand        = typeOfdatatype . bandDatatype
    typeOfdatatype dt =
      case dt of
        GDT_Byte     -> typeOf (undefined :: Vector Word8)
        GDT_UInt16   -> typeOf (undefined :: Vector Word16)
        GDT_UInt32   -> typeOf (undefined :: Vector Word32)
        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 (GComplex Int16))
        GDT_CInt32   -> typeOf (undefined :: Vector (GComplex Int32))
        GDT_CFloat32 -> typeOf (undefined :: Vector (GComplex Float))
        GDT_CFloat64 -> typeOf (undefined :: Vector (GComplex Double))
        _            -> typeOf (undefined :: Bool) -- will never match a vector


Fixed a typedec

Fixed a typedec

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns, ScopedTypeVariables, PatternGuards, FlexibleContexts#-}
#include "cvWrapLEO.h"
-- |Various image transformations from opencv and other sources.
module CV.Transforms  where

import CV.Image
import Foreign.Ptr
import Foreign.C.Types
import Foreign.Marshal.Array
import System.IO.Unsafe
{#import CV.Image#}
import CV.ImageMathOp

-- |Since DCT is valid only for even sized images, we provide a
-- function to crop images to even sizes.
takeEvenSized img = getRegion (0,0) (w-wadjust,h-hadjust) img
    where
     (w,h) = getSize img
     hadjust | odd h = 1
             | otherwise = 2
     wadjust | odd w = 1
             | otherwise = 2

-- |Perform Discrete Cosine Transform
dct :: Image GrayScale d -> Image GrayScale d
dct img | (x,y) <- getSize img, even x && even y
        = unsafePerformIO $
            withGenImage img $ \i ->
              withClone img $ \c' ->
                withGenImage c' $ \c ->
                  ({#call cvDCT#} i c 0)
        | otherwise = error "DCT needs even sized image"

-- |Perform Inverse Discrete Cosine Transform
idct :: Image GrayScale d -> Image GrayScale d
idct img | (x,y) <- getSize img, even x && even y
        = unsafePerformIO $
            withGenImage img $ \i ->
              withClone img $ \c' ->
                withGenImage c' $ \c ->
                  ({#call cvDCT#} i c 1)
        | otherwise = error "IDCT needs even sized image"

data MirrorAxis = Vertical | Horizontal deriving (Show,Eq)

-- |Mirror an image over a cardinal axis
flip :: CreateImage (Image c d) => MirrorAxis -> Image c d -> Image c d
flip axis img = unsafePerformIO $ do
                 let cl = emptyCopy img
                 withGenImage img $ \cimg ->
                  withGenImage cl $ \ccl -> do
                    {#call cvFlip#} cimg ccl (if axis == Vertical then 0 else 1)
                 return cl

-- |Rotate `img` `angle` radians.
rotate :: Double -> Image c d -> Image c d
rotate (realToFrac -> angle) img = unsafePerformIO $
                    withImage img $ \i ->
                        creatingImage
                         ({#call rotateImage#} i 1 angle)

data Interpolation = NearestNeighbour | Linear
                   | Area | Cubic
                deriving (Eq,Ord,Enum,Show)

-- |Simulate a radial distortion over an image
radialDistort :: Image GrayScale D32 -> Double -> Image GrayScale D32
radialDistort img k = unsafePerformIO $ do
                       let target = emptyCopy img
                       withImage img $ \cimg ->
                        withImage target $ \ctarget ->
                         {#call radialRemap#} cimg ctarget (realToFrac k)
                       return target

-- |Scale image by one ratio on both of the axes
scaleSingleRatio tpe x img = scale tpe (x,x) img

-- |Scale an image with different ratios for axes
scale :: (CreateImage (Image c D32), RealFloat a) => Interpolation -> (a,a) -> Image c D32 -> Image c D32
scale tpe (x,y) img = unsafePerformIO $ do
                    target <- create (w',h')
                    withGenImage img $ \i ->
                     withGenImage target $ \t ->
                        {#call cvResize#} i t
                            (fromIntegral.fromEnum $ tpe)
                    return target
            where
             (w,h) = getSize img
             (w',h') = (round $ fromIntegral w*y
                       ,round $ fromIntegral h*x)

-- |Scale an image to a given size
scaleToSize :: (CreateImage (Image c D32)) =>
    Interpolation -> Bool -> (Int,Int) -> Image c D32 -> Image c D32
scaleToSize tpe retainRatio (w,h) img = unsafePerformIO $ do
                    target <- create (w',h')
                    withGenImage img $ \i ->
                     withGenImage target $ \t ->
                        {#call cvResize#} i t
                            (fromIntegral.fromEnum $ tpe)
                    return target
            where
             (ow,oh) = getSize img
             (w',h') = if retainRatio
                         then (floor $ fromIntegral ow*ratio,floor $ fromIntegral oh*ratio)
                         else (w,h)
             ratio  = max (fromIntegral w/fromIntegral ow)
                          (fromIntegral h/fromIntegral oh)

-- |Apply a perspective transform to the image. The transformation 3x3 matrix is supplied as
--  a row ordered, flat, list.
perspectiveTransform :: Real a => Image c d -> [a] -> Image c d
perspectiveTransform img (map realToFrac -> [a1,a2,a3,a4,a5,a6,a7,a8,a9])
    = unsafePerformIO $
       withImage img $ \cimg -> creatingImage $ {#call wrapPerspective#} cimg a1 a2 a3 a4 a5 a6 a7 a8 a9

-- |Find a homography between two sets of points in. The resulting 3x3 matrix is returned as a list.
getHomography srcPts dstPts =
    unsafePerformIO $ withArray src $ \c_src ->
                       withArray dst $ \c_dst ->
                        allocaArray (3*3) $ \c_hmg -> do
                         {#call findHomography#} c_src c_dst (fromIntegral $ length srcPts) c_hmg
                         peekArray (3*3) c_hmg
    where
     flatten = map realToFrac . concatMap (\(a,b) -> [a,b])
     src = flatten srcPts
     dst = flatten dstPts

--- Pyramid transforms
-- |Return a copy of an image with an even size
evenize :: Image channels depth -> Image channels depth
evenize img = if (odd w || odd h)
              then
                unsafePerformIO $
                 creatingImage $
                  withGenImage img $ \cImg -> {#call makeEvenUp#} cImg
              else img
    where
     (w,h)  = getSize img

-- |Return a copy of an image with an odd size
oddize :: Image channels depth -> Image channels depth
oddize img = if (even w || even h)
              then
                unsafePerformIO $
                 creatingImage $
                  withGenImage img $ \cImg -> {#call padUp#} cImg (toI $ even w) (toI $ even h)
              else img
    where
     toI True = 1
     toI False = 0
     (w,h)  = getSize img

-- |Pad images to same size
sameSizePad :: Image channels depth -> Image c d -> Image channels depth
sameSizePad img img2 = if (size1 /= size2)
              then unsafePerformIO $ do
                r <- creatingImage $
                       withGenImage img2 $ \cImg -> {#call padUp#} cImg (toI $ w2<w1) (toI $ h2<h1)
                if getSize r /= getSize img
                    then error ("Couldn't pad: "++show size1++"/"++show size2)
                    else return r
              else img
    where
     toI True = 1
     toI False = 0
     size1@(w1,h1)  = getSize img
     size2@(w2,h2)  = getSize img2

cv_Gaussian = 7
-- |Downsize image by 50% efficiently. Image dimensions must be even.
pyrDown ::(CreateImage (Image GrayScale a)) => Image GrayScale a -> Image GrayScale a
pyrDown image = unsafePerformIO $ do
                 res <- create size
                 withGenImage image $ \cImg ->
                   withGenImage res $ \cResImg ->
                     {#call cvPyrDown#} cImg cResImg cv_Gaussian
                 return res
            where
                size = (x`div`2,y`div`2)
                (x,y) = getSize image

-- |Enlarge image to double in each dimension. Used to recover pyramidal layers
pyrUp :: (CreateImage (Image GrayScale a)) => Image GrayScale a -> Image GrayScale a
pyrUp image = unsafePerformIO $ do
                 res <- create size
                 withGenImage image $ \cImg ->
                   withGenImage res $ \cResImg ->
                     {#call cvPyrUp#} cImg cResImg cv_Gaussian
                 return res
            where
                size = (x*2,y*2)
                (x,y) = getSize image

-- TODO: For additional efficiency, make this so that pyrDown result is directly put into
--       proper size image which is then padded
safePyrDown img = evenize result
    where
     result = pyrDown img
     (w,h)  = getSize result

-- |Calculate the laplacian pyramid of an image up to the nth level.
--  Notice that the image size must be divisible by 2^n or opencv
--  will abort (TODO!)
laplacianPyramid :: Int -> Image GrayScale D32 -> [Image GrayScale D32]
laplacianPyramid depth image = reverse laplacian
  where
   downs :: [Image GrayScale D32] = take depth $ iterate pyrDown (image)
   upsampled :: [Image GrayScale D32] = map pyrUp (tail downs)
   laplacian = zipWith (#-) downs upsampled ++ [last downs]

-- |Reconstruct an image from a laplacian pyramid
reconstructFromLaplacian :: [Image GrayScale D32] -> Image GrayScale D32
reconstructFromLaplacian pyramid = foldl1 (\a b -> (pyrUp a) #+ b) (pyramid)
  --  where
  --   safeAdd x y = sameSizePad y x #+ y

-- TODO: Could have wider type
-- |Enlarge image so, that it's size is divisible by 2^n
enlarge :: Int -> Image GrayScale D32 -> Image GrayScale D32
enlarge n img =  unsafePerformIO $ do
                   i <- create (w2,h2)
                   blit i img (0,0)
                   return i
    where
     (w,h) = getSize img
     (w2,h2) = (pad w, pad h)
     pad x = x + (np - x `mod` np)
     np = 2^n

#c
enum DistanceType {
     C =  CV_DIST_C
    ,L1 =  CV_DIST_L1
    ,L2 =  CV_DIST_L2
};
#endc
{#enum DistanceType {}#}

-- |Mask sizes accepted by distanceTransform
data MaskSize = M3 | M5 deriving (Eq,Ord,Enum,Show)

-- |Perform a distance transform on the image
distanceTransform :: DistanceType -> MaskSize -> Image GrayScale D8 -> Image GrayScale D32 --TODO: Input should be a black and white image
distanceTransform dtype maskSize source = unsafePerformIO $ do
    result :: Image GrayScale D32 <- create (getSize source)
    withGenImage source $ \c_source ->
     withGenImage result $ \c_result ->
        {#call cvDistTransform #} c_source c_result
                                  (fromIntegral . fromEnum $ dtype)
                                  (fromIntegral . fromEnum $ maskSize)
                                   nullPtr nullPtr
    return result
    -- TODO: Add handling for labels
    -- TODO: Add handling for custom masks

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns, ScopedTypeVariables, PatternGuards, FlexibleContexts#-}
#include "cvWrapLEO.h"
-- |Various image transformations from opencv and other sources.
module CV.Transforms  where

import CV.Image
import Foreign.Ptr
import Foreign.C.Types
import Foreign.Marshal.Array
import System.IO.Unsafe
{#import CV.Image#}
import CV.ImageMathOp

-- |Since DCT is valid only for even sized images, we provide a
-- function to crop images to even sizes.
takeEvenSized img = getRegion (0,0) (w-wadjust,h-hadjust) img
    where
     (w,h) = getSize img
     hadjust | odd h = 1
             | otherwise = 2
     wadjust | odd w = 1
             | otherwise = 2

-- |Perform Discrete Cosine Transform
dct :: Image GrayScale d -> Image GrayScale d
dct img | (x,y) <- getSize img, even x && even y
        = unsafePerformIO $
            withGenImage img $ \i ->
              withClone img $ \c' ->
                withGenImage c' $ \c ->
                  ({#call cvDCT#} i c 0)
        | otherwise = error "DCT needs even sized image"

-- |Perform Inverse Discrete Cosine Transform
idct :: Image GrayScale d -> Image GrayScale d
idct img | (x,y) <- getSize img, even x && even y
        = unsafePerformIO $
            withGenImage img $ \i ->
              withClone img $ \c' ->
                withGenImage c' $ \c ->
                  ({#call cvDCT#} i c 1)
        | otherwise = error "IDCT needs even sized image"

data MirrorAxis = Vertical | Horizontal deriving (Show,Eq)

-- |Mirror an image over a cardinal axis
flip :: CreateImage (Image c d) => MirrorAxis -> Image c d -> Image c d
flip axis img = unsafePerformIO $ do
                 let cl = emptyCopy img
                 withGenImage img $ \cimg ->
                  withGenImage cl $ \ccl -> do
                    {#call cvFlip#} cimg ccl (if axis == Vertical then 0 else 1)
                 return cl

-- |Rotate `img` `angle` radians.
rotate :: Double -> Image c d -> Image c d
rotate (realToFrac -> angle) img = unsafePerformIO $
                    withImage img $ \i ->
                        creatingImage
                         ({#call rotateImage#} i 1 angle)

data Interpolation = NearestNeighbour | Linear
                   | Area | Cubic
                deriving (Eq,Ord,Enum,Show)

-- |Simulate a radial distortion over an image
radialDistort :: Image GrayScale D32 -> Double -> Image GrayScale D32
radialDistort img k = unsafePerformIO $ do
                       let target = emptyCopy img
                       withImage img $ \cimg ->
                        withImage target $ \ctarget ->
                         {#call radialRemap#} cimg ctarget (realToFrac k)
                       return target

-- |Scale image by one ratio on both of the axes
scaleSingleRatio tpe x img = scale tpe (x,x) img

-- |Scale an image with different ratios for axes
scale :: (CreateImage (Image c D32), RealFloat a) => Interpolation -> (a,a) -> Image c D32 -> Image c D32
scale tpe (x,y) img = unsafePerformIO $ do
                    target <- create (w',h')
                    withGenImage img $ \i ->
                     withGenImage target $ \t ->
                        {#call cvResize#} i t
                            (fromIntegral.fromEnum $ tpe)
                    return target
            where
             (w,h) = getSize img
             (w',h') = (round $ fromIntegral w*y
                       ,round $ fromIntegral h*x)

-- |Scale an image to a given size
scaleToSize :: (CreateImage (Image c D32)) =>
    Interpolation -> Bool -> (Int,Int) -> Image c D32 -> Image c D32
scaleToSize tpe retainRatio (w,h) img = unsafePerformIO $ do
                    target <- create (w',h')
                    withGenImage img $ \i ->
                     withGenImage target $ \t ->
                        {#call cvResize#} i t
                            (fromIntegral.fromEnum $ tpe)
                    return target
            where
             (ow,oh) = getSize img
             (w',h') = if retainRatio
                         then (floor $ fromIntegral ow*ratio,floor $ fromIntegral oh*ratio)
                         else (w,h)
             ratio  = max (fromIntegral w/fromIntegral ow)
                          (fromIntegral h/fromIntegral oh)

-- |Apply a perspective transform to the image. The transformation 3x3 matrix is supplied as
--  a row ordered, flat, list.
perspectiveTransform :: Real a => Image c d -> [a] -> Image c d
perspectiveTransform img (map realToFrac -> [a1,a2,a3,a4,a5,a6,a7,a8,a9])
    = unsafePerformIO $
       withImage img $ \cimg -> creatingImage $ {#call wrapPerspective#} cimg a1 a2 a3 a4 a5 a6 a7 a8 a9

-- |Find a homography between two sets of points in. The resulting 3x3 matrix is returned as a list.
getHomography srcPts dstPts =
    unsafePerformIO $ withArray src $ \c_src ->
                       withArray dst $ \c_dst ->
                        allocaArray (3*3) $ \c_hmg -> do
                         {#call findHomography#} c_src c_dst (fromIntegral $ length srcPts) c_hmg
                         peekArray (3*3) c_hmg
    where
     flatten = concatMap (\(a,b) -> [a,b])
     src = flatten srcPts
     dst = flatten dstPts

--- Pyramid transforms
-- |Return a copy of an image with an even size
evenize :: Image channels depth -> Image channels depth
evenize img = if (odd w || odd h)
              then
                unsafePerformIO $
                 creatingImage $
                  withGenImage img $ \cImg -> {#call makeEvenUp#} cImg
              else img
    where
     (w,h)  = getSize img

-- |Return a copy of an image with an odd size
oddize :: Image channels depth -> Image channels depth
oddize img = if (even w || even h)
              then
                unsafePerformIO $
                 creatingImage $
                  withGenImage img $ \cImg -> {#call padUp#} cImg (toI $ even w) (toI $ even h)
              else img
    where
     toI True = 1
     toI False = 0
     (w,h)  = getSize img

-- |Pad images to same size
sameSizePad :: Image channels depth -> Image c d -> Image channels depth
sameSizePad img img2 = if (size1 /= size2)
              then unsafePerformIO $ do
                r <- creatingImage $
                       withGenImage img2 $ \cImg -> {#call padUp#} cImg (toI $ w2<w1) (toI $ h2<h1)
                if getSize r /= getSize img
                    then error ("Couldn't pad: "++show size1++"/"++show size2)
                    else return r
              else img
    where
     toI True = 1
     toI False = 0
     size1@(w1,h1)  = getSize img
     size2@(w2,h2)  = getSize img2

cv_Gaussian = 7
-- |Downsize image by 50% efficiently. Image dimensions must be even.
pyrDown ::(CreateImage (Image GrayScale a)) => Image GrayScale a -> Image GrayScale a
pyrDown image = unsafePerformIO $ do
                 res <- create size
                 withGenImage image $ \cImg ->
                   withGenImage res $ \cResImg ->
                     {#call cvPyrDown#} cImg cResImg cv_Gaussian
                 return res
            where
                size = (x`div`2,y`div`2)
                (x,y) = getSize image

-- |Enlarge image to double in each dimension. Used to recover pyramidal layers
pyrUp :: (CreateImage (Image GrayScale a)) => Image GrayScale a -> Image GrayScale a
pyrUp image = unsafePerformIO $ do
                 res <- create size
                 withGenImage image $ \cImg ->
                   withGenImage res $ \cResImg ->
                     {#call cvPyrUp#} cImg cResImg cv_Gaussian
                 return res
            where
                size = (x*2,y*2)
                (x,y) = getSize image

-- TODO: For additional efficiency, make this so that pyrDown result is directly put into
--       proper size image which is then padded
safePyrDown img = evenize result
    where
     result = pyrDown img
     (w,h)  = getSize result

-- |Calculate the laplacian pyramid of an image up to the nth level.
--  Notice that the image size must be divisible by 2^n or opencv
--  will abort (TODO!)
laplacianPyramid :: Int -> Image GrayScale D32 -> [Image GrayScale D32]
laplacianPyramid depth image = reverse laplacian
  where
   downs :: [Image GrayScale D32] = take depth $ iterate pyrDown (image)
   upsampled :: [Image GrayScale D32] = map pyrUp (tail downs)
   laplacian = zipWith (#-) downs upsampled ++ [last downs]

-- |Reconstruct an image from a laplacian pyramid
reconstructFromLaplacian :: [Image GrayScale D32] -> Image GrayScale D32
reconstructFromLaplacian pyramid = foldl1 (\a b -> (pyrUp a) #+ b) (pyramid)
  --  where
  --   safeAdd x y = sameSizePad y x #+ y

-- TODO: Could have wider type
-- |Enlarge image so, that it's size is divisible by 2^n
enlarge :: Int -> Image GrayScale D32 -> Image GrayScale D32
enlarge n img =  unsafePerformIO $ do
                   i <- create (w2,h2)
                   blit i img (0,0)
                   return i
    where
     (w,h) = getSize img
     (w2,h2) = (pad w, pad h)
     pad x = x + (np - x `mod` np)
     np = 2^n

#c
enum DistanceType {
     C =  CV_DIST_C
    ,L1 =  CV_DIST_L1
    ,L2 =  CV_DIST_L2
};
#endc
{#enum DistanceType {}#}

-- |Mask sizes accepted by distanceTransform
data MaskSize = M3 | M5 deriving (Eq,Ord,Enum,Show)

-- |Perform a distance transform on the image
distanceTransform :: DistanceType -> MaskSize -> Image GrayScale D8 -> Image GrayScale D32 --TODO: Input should be a black and white image
distanceTransform dtype maskSize source = unsafePerformIO $ do
    result :: Image GrayScale D32 <- create (getSize source)
    withGenImage source $ \c_source ->
     withGenImage result $ \c_result ->
        {#call cvDistTransform #} c_source c_result
                                  (fromIntegral . fromEnum $ dtype)
                                  (fromIntegral . fromEnum $ maskSize)
                                   nullPtr nullPtr
    return result
    -- TODO: Add handling for labels
    -- TODO: Add handling for custom masks


Added Documentation and more type safety for CV.Edges

{-#LANGUAGE ForeignFunctionInterface#-}
#include "cvWrapLEO.h"
module CV.Edges (sobelOp,sobel
                ,sScharr,s1,s3,s5,s7
                ,l1,l3,l5,l7
                ,laplaceOp,laplace,canny,susan) where
import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr

import CV.ImageOp

import CV.Image
{#import CV.Image#}

import C2HSTools

-- | Perform Sobel filtering on image. First argument gives order of horizontal and vertical
--   derivative estimates and second one is the aperture. This function can also calculate
--   Scharr filter with aperture specification of sScharr
-- TODO: Type the aperture size and possibly the derivative orders as well
-- TODO: It is possible to define sobel with different target image with other bit depths.
sobelOp :: (Int,Int) -> SobelAperture -> ImageOperation GrayScale D32
sobelOp (dx,dy) (Sb aperture)
    | dx >=0 && dx <3
    && not ((aperture == -1) && (dx>1 || dy>1))
    && dy >=0 && dy<3 = ImgOp $ \i -> withGenImage i $ \image ->
                                      ({#call cvSobel#} image image cdx cdy cap)

   | otherwise = error "Invalid aperture"
      where [cdx,cdy,cap] = map fromIntegral [dx,dy,aperture]

sobel dd ap im = unsafeOperate (sobelOp dd ap) im

-- | Aperture sizes for sobel operator
newtype SobelAperture = Sb Int
sScharr = Sb (-1)
s1 = Sb 1
s3 = Sb 3
s5 = Sb 5
s7 = Sb 7

-- | Aperture sizes for laplacian operator
newtype LaplacianAperture = L Int
l1 = L 1
l3 = L 3
l5 = L 5
l7 = L 7

-- |Perform laplacian filtering of given aperture to image
laplaceOp :: LaplacianAperture -> ImageOperation GrayScale D32
laplaceOp (L s) = ImgOp $ \img ->  withGenImage img $ \image ->
                        ({#call cvLaplace #} image image (fromIntegral s))

laplace s i = unsafeOperate (laplaceOp s) i

-- |Perform canny thresholding using two threshold values and given aperture
--  Works only on 8-bit images
canny :: Int -> Int -> Int -> Image GrayScale D8 -> Image GrayScale D8
canny t1 t2 aperture src = unsafePerformIO $ do
                           withClone src $ \clone ->
                            withGenImage src $ \si ->
                             withGenImage clone $ \ci -> do
                               {#call cvCanny#} si ci (fromIntegral t1)
                                                      (fromIntegral t2)
                                                      (fromIntegral aperture)
                               return clone

-- | SUSAN edge detection filter, see http://users.fmrib.ox.ac.uk/~steve/susan/susan/susan.html
-- TODO: Should return a binary image
susan :: (Int,Int) -> D32 -> Image GrayScale D32 -> Image GrayScale D8
susan (w,h) t image = unsafePerformIO $ do
                    withGenImage image $ \img ->
                     creatingImage
                      ({#call susanEdge#} img (fromIntegral w) (fromIntegral h) (realToFrac t))

{-#LANGUAGE ForeignFunctionInterface#-}
#include "cvWrapLEO.h"
module CV.Edges where
import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr

import CV.ImageOp

import CV.Image
{#import CV.Image#}

import C2HSTools

sobelOp :: (Int,Int) -> Int -> ImageOperation GrayScale D32
sobelOp (dx,dy) aperture
    | dx >=0 && dx <3
    && aperture `elem` [-1,1,3,5,7]
    && not ((aperture == -1) && (dx>1 || dy>1))
    && dy >=0 && dy<3 = ImgOp $ \i -> withGenImage i $ \image ->
                                      ({#call cvSobel#} image image cdx cdy cap)

   | otherwise = error "Invalid aperture"
      where [cdx,cdy,cap] = map fromIntegral [dx,dy,aperture]

sobel dd ap im = unsafeOperate (sobelOp dd ap) im

laplaceOp :: Int -> ImageOperation GrayScale D32
laplaceOp s = ImgOp $ \img ->  withGenImage img $ \image ->
                    if s `elem` [1,3,5,7]
                       then ({#call cvLaplace #} image image (fromIntegral s))
                       else error "Laplace aperture must be 1, 3, 5 or 7"
laplace s i = unsafeOperate (laplaceOp s) i

-- TODO: Add tests below!
canny :: Int -> Int -> Int -> Image GrayScale D8 -> Image GrayScale D8
canny t1 t2 aperture src = unsafePerformIO $ do
                           withClone src $ \clone ->
                            withGenImage src $ \si ->
                             withGenImage clone $ \ci -> do
                               {#call cvCanny#} si ci (fromIntegral t1)
                                                      (fromIntegral t2)
                                                      (fromIntegral aperture)
                               return clone

susan :: (Int,Int) -> D32 -> Image GrayScale D32 -> Image GrayScale D8
susan (w,h) t image = unsafePerformIO $ do
                    withGenImage image $ \img ->
                     creatingImage
                      ({#call susanEdge#} img (fromIntegral w) (fromIntegral h) (realToFrac t))


glib: make module name for GDateTime the same as the filename :)

darcs-hash:20070712013200-21862-605397d819e2751a2a694a37a4d652365133d064.gz

-- -*-haskell-*-
--  GIMP Toolkit (GTK)
--
--  Author : Peter Gavin
--
--  Created: 19 March 2002
--
--  Copyright (C) 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)
--
module System.Glib.GDateTime (
  GTimeValPart,
  GTimeVal(..),
  gGetCurrentTime,
  gUSleep,
  gTimeValAdd,
  gTimeValFromISO8601,
  gTimeValToISO8601,
  GDate(..),
  GDateDay,
  GDateMonth,
  GDateYear,
  GDateJulianDay,
  GDateWeekday,
  gDateValidJulian,
  gDateValidDMY,
  gDateNewJulian,
  gDateNewDMY,
  gDateSetDay,
  gDateSetMonth,
  gDateSetYear,
  gDateNewTimeVal,
  gDateParse,
  gDateAddDays,
  gDateSubtractDays,
  gDateAddMonths,
  gDateSubtractMonths,
  gDateAddYears,
  gDateSubtractYears,
  gDateDaysBetween,
  gDateCompare,
  gDateClamp,
  gDateDay,
  gDateMonth,
  gDateYear,
  gDateWeekday
  ) where

import Control.Monad (liftM)
import System.Glib.FFI
import System.Glib.UTFString

type GTimeValPart = {# type glong #}
data GTimeVal = GTimeVal { gTimeValSec  :: GTimeValPart
                         , gTimeValUSec :: GTimeValPart }
                deriving (Eq, Ord)
instance Storable GTimeVal where
    sizeOf _ = {# sizeof GTimeVal #}
    alignment _ = alignment (undefined :: CString)
    peek ptr =
        do sec <- {# get GTimeVal->tv_sec #} ptr
           uSec <- {# get GTimeVal->tv_usec #} ptr
           return $ GTimeVal sec uSec
    poke ptr (GTimeVal sec uSec) =
        do {# set GTimeVal->tv_sec #} ptr sec
           {# set GTimeVal->tv_usec #} ptr uSec

gGetCurrentTime :: IO GTimeVal
gGetCurrentTime =
    alloca $ \ptr ->
        do {# call g_get_current_time #} $ castPtr ptr
           peek ptr

gUSleep :: GTimeValPart
        -> IO ()
gUSleep microseconds =
    {# call g_usleep #} $ fromIntegral microseconds

gTimeValAdd :: GTimeVal
            -> GTimeValPart
            -> GTimeVal
gTimeValAdd time microseconds =
    unsafePerformIO $ with time $ \ptr ->
        do {# call g_time_val_add #} (castPtr ptr) microseconds
           peek ptr

gTimeValFromISO8601 :: String
                    -> Maybe GTimeVal
gTimeValFromISO8601 isoDate =
    unsafePerformIO $ withUTFString isoDate $ \cISODate ->
        alloca $ \ptr ->
            do success <- liftM toBool $ {# call g_time_val_from_iso8601 #} cISODate $ castPtr ptr
               if success
                   then liftM Just $ peek ptr
                   else return Nothing

gTimeValToISO8601 :: GTimeVal
                  -> String
gTimeValToISO8601 time =
    unsafePerformIO $ with time $ \ptr ->
        {# call g_time_val_to_iso8601 #} (castPtr ptr) >>= readUTFString

newtype GDateDay = GDateDay {# type GDateDay #}
    deriving (Eq, Ord)
instance Bounded GDateDay where
    minBound = GDateDay 1
    maxBound = GDateDay 31

{# enum GDateMonth {underscoreToCase} deriving (Eq, Ord) #}
instance Bounded GDateMonth where
    minBound = GDateJanuary
    maxBound = GDateDecember

newtype GDateYear = GDateYear {# type GDateYear #}
    deriving (Eq, Ord)
instance Bounded GDateYear where
    minBound = GDateYear 1
    maxBound = GDateYear (maxBound :: {# type guint16 #})

type GDateJulianDay = {# type guint32 #}
newtype GDate = GDate { gDateJulianDay :: GDateJulianDay }
    deriving (Eq)
instance Storable GDate where
    sizeOf _ = {# sizeof GDate #}
    alignment _ = alignment (undefined :: CString)
    peek =
        (liftM (GDate . fromIntegral)) . {# call g_date_get_julian #} . castPtr
    poke ptr val =
        {# call g_date_set_julian #} (castPtr ptr) $ gDateJulianDay val

{# enum GDateWeekday {underscoreToCase} deriving (Eq, Ord) #}
instance Bounded GDateWeekday where
    minBound = GDateMonday
    maxBound = GDateSunday

gDateValidJulian :: GDateJulianDay
                 -> Bool
gDateValidJulian =
    toBool . {# call fun g_date_valid_julian #}

gDateValidDMY :: GDateDay
              -> GDateMonth
              -> GDateYear
              -> Bool
gDateValidDMY (GDateDay day) month (GDateYear year) =
    toBool $ {# call fun g_date_valid_dmy #} day
                                             (fromIntegral $ fromEnum month)
                                             year

gDateNewJulian :: GDateJulianDay
               -> Maybe GDate
gDateNewJulian julian =
    if gDateValidJulian julian
        then Just $ GDate julian
        else Nothing

gDateNewDMY :: GDateDay
            -> GDateMonth
            -> GDateYear
            -> Maybe GDate
gDateNewDMY day month year =
    if gDateValidDMY day month year
        then Just $ unsafePerformIO $ alloca $ \ptr ->
            do let GDateDay day' = day
                   GDateYear year' = year
               {# call g_date_set_dmy #} (castPtr ptr)
                                         day'
                                         (fromIntegral $ fromEnum month)
                                         year'
               peek ptr
        else Nothing

gDateSetDay :: GDate
            -> GDateDay
            -> Maybe GDate
gDateSetDay date (GDateDay day) =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_day #} (castPtr ptr) day
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateSetMonth :: GDate
              -> GDateMonth
              -> Maybe GDate
gDateSetMonth date month =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_month #} (castPtr ptr) $ fromIntegral $ fromEnum month
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateSetYear :: GDate
             -> GDateYear
             -> Maybe GDate
gDateSetYear date (GDateYear year) =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_year #} (castPtr ptr) year
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateNewTimeVal :: GTimeVal
                -> GDate
gDateNewTimeVal timeVal =
    unsafePerformIO $ alloca $ \ptr ->
        with timeVal $ \timeValPtr ->
        do {# call g_date_set_time_val #} (castPtr ptr) $ castPtr timeValPtr
           peek ptr

gDateParse :: String
           -> IO (Maybe GDate)
gDateParse str =
    alloca $ \ptr ->
        do withUTFString str $ {# call g_date_set_parse #} $ castPtr ptr
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateAddDays :: GDate
             -> Word
             -> GDate
gDateAddDays date nDays =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_days #} (castPtr ptr) $ fromIntegral nDays
           peek ptr

gDateSubtractDays :: GDate
                  -> Word
                  -> GDate
gDateSubtractDays date nDays =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_days #} (castPtr ptr) $ fromIntegral nDays
           peek ptr

gDateAddMonths :: GDate
               -> Word
               -> GDate
gDateAddMonths date nMonths =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_months #} (castPtr ptr) $ fromIntegral nMonths
           peek ptr

gDateSubtractMonths :: GDate
                    -> Word
                    -> GDate
gDateSubtractMonths date nMonths =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_months #} (castPtr ptr) $ fromIntegral nMonths
           peek ptr

gDateAddYears :: GDate
              -> Word
              -> GDate
gDateAddYears date nYears =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_years #} (castPtr ptr) $ fromIntegral nYears
           peek ptr

gDateSubtractYears :: GDate
                   -> Word
                   -> GDate
gDateSubtractYears date nYears =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_years #} (castPtr ptr) $ fromIntegral nYears
           peek ptr

gDateDaysBetween :: GDate
                 -> GDate
                 -> Int
gDateDaysBetween date1 date2 =
    fromIntegral $ unsafePerformIO $ with date1 $ \ptr1 ->
        with date2 $ \ptr2 ->
            {# call g_date_days_between #} (castPtr ptr1) $ castPtr ptr2

gDateCompare :: GDate
             -> GDate
             -> Ordering
gDateCompare date1 date2 =
    let result = fromIntegral $ unsafePerformIO $ with date1 $ \ptr1 ->
                     with date2 $ \ptr2 ->
                         {# call g_date_compare #} (castPtr ptr1) $ castPtr ptr2
        ordering | result < 0 = LT
                 | result > 0 = GT
                 | otherwise  = EQ
    in ordering

instance Ord GDate where
    compare = gDateCompare

gDateClamp :: GDate
           -> GDate
           -> GDate
           -> GDate
gDateClamp date minDate maxDate =
    unsafePerformIO $ with date $ \ptr ->
        with minDate $ \minPtr ->
            with maxDate $ \maxPtr ->
                do {# call g_date_clamp #} (castPtr ptr) (castPtr minPtr) $ castPtr maxPtr
                   peek ptr

gDateDay :: GDate
         -> GDateDay
gDateDay date =
    GDateDay $ unsafePerformIO $ with date $ {# call g_date_get_day #} . castPtr

gDateMonth :: GDate
           -> GDateMonth
gDateMonth date =
    toEnum $ fromIntegral $ unsafePerformIO $ with date $ {# call g_date_get_month #} . castPtr

gDateYear :: GDate
          -> GDateYear
gDateYear date =
    GDateYear $ unsafePerformIO $ with date $ {# call g_date_get_year #} . castPtr

gDateWeekday :: GDate
             -> GDateWeekday
gDateWeekday date =
    toEnum $ fromIntegral $ unsafePerformIO $ with date $ {# call g_date_get_weekday #} . castPtr

-- -*-haskell-*-
--  GIMP Toolkit (GTK)
--
--  Author : Peter Gavin
--
--  Created: 19 March 2002
--
--  Copyright (C) 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)
--
module System.Glib.GDate (
  GTimeValPart,
  GTimeVal(..),
  gGetCurrentTime,
  gUSleep,
  gTimeValAdd,
  gTimeValFromISO8601,
  gTimeValToISO8601,
  GDate(..),
  GDateDay,
  GDateMonth,
  GDateYear,
  GDateJulianDay,
  GDateWeekday,
  gDateValidJulian,
  gDateValidDMY,
  gDateNewJulian,
  gDateNewDMY,
  gDateSetDay,
  gDateSetMonth,
  gDateSetYear,
  gDateNewTimeVal,
  gDateParse,
  gDateAddDays,
  gDateSubtractDays,
  gDateAddMonths,
  gDateSubtractMonths,
  gDateAddYears,
  gDateSubtractYears,
  gDateDaysBetween,
  gDateCompare,
  gDateClamp,
  gDateDay,
  gDateMonth,
  gDateYear,
  gDateWeekday
  ) where

import Control.Monad (liftM)
import System.Glib.FFI
import System.Glib.UTFString

type GTimeValPart = {# type glong #}
data GTimeVal = GTimeVal { gTimeValSec  :: GTimeValPart
                         , gTimeValUSec :: GTimeValPart }
                deriving (Eq, Ord)
instance Storable GTimeVal where
    sizeOf _ = {# sizeof GTimeVal #}
    alignment _ = alignment (undefined :: CString)
    peek ptr =
        do sec <- {# get GTimeVal->tv_sec #} ptr
           uSec <- {# get GTimeVal->tv_usec #} ptr
           return $ GTimeVal sec uSec
    poke ptr (GTimeVal sec uSec) =
        do {# set GTimeVal->tv_sec #} ptr sec
           {# set GTimeVal->tv_usec #} ptr uSec

gGetCurrentTime :: IO GTimeVal
gGetCurrentTime =
    alloca $ \ptr ->
        do {# call g_get_current_time #} $ castPtr ptr
           peek ptr

gUSleep :: GTimeValPart
        -> IO ()
gUSleep microseconds =
    {# call g_usleep #} $ fromIntegral microseconds

gTimeValAdd :: GTimeVal
            -> GTimeValPart
            -> GTimeVal
gTimeValAdd time microseconds =
    unsafePerformIO $ with time $ \ptr ->
        do {# call g_time_val_add #} (castPtr ptr) microseconds
           peek ptr

gTimeValFromISO8601 :: String
                    -> Maybe GTimeVal
gTimeValFromISO8601 isoDate =
    unsafePerformIO $ withUTFString isoDate $ \cISODate ->
        alloca $ \ptr ->
            do success <- liftM toBool $ {# call g_time_val_from_iso8601 #} cISODate $ castPtr ptr
               if success
                   then liftM Just $ peek ptr
                   else return Nothing

gTimeValToISO8601 :: GTimeVal
                  -> String
gTimeValToISO8601 time =
    unsafePerformIO $ with time $ \ptr ->
        {# call g_time_val_to_iso8601 #} (castPtr ptr) >>= readUTFString

newtype GDateDay = GDateDay {# type GDateDay #}
    deriving (Eq, Ord)
instance Bounded GDateDay where
    minBound = GDateDay 1
    maxBound = GDateDay 31

{# enum GDateMonth {underscoreToCase} deriving (Eq, Ord) #}
instance Bounded GDateMonth where
    minBound = GDateJanuary
    maxBound = GDateDecember

newtype GDateYear = GDateYear {# type GDateYear #}
    deriving (Eq, Ord)
instance Bounded GDateYear where
    minBound = GDateYear 1
    maxBound = GDateYear (maxBound :: {# type guint16 #})

type GDateJulianDay = {# type guint32 #}
newtype GDate = GDate { gDateJulianDay :: GDateJulianDay }
    deriving (Eq)
instance Storable GDate where
    sizeOf _ = {# sizeof GDate #}
    alignment _ = alignment (undefined :: CString)
    peek =
        (liftM (GDate . fromIntegral)) . {# call g_date_get_julian #} . castPtr
    poke ptr val =
        {# call g_date_set_julian #} (castPtr ptr) $ gDateJulianDay val

{# enum GDateWeekday {underscoreToCase} deriving (Eq, Ord) #}
instance Bounded GDateWeekday where
    minBound = GDateMonday
    maxBound = GDateSunday

gDateValidJulian :: GDateJulianDay
                 -> Bool
gDateValidJulian =
    toBool . {# call fun g_date_valid_julian #}

gDateValidDMY :: GDateDay
              -> GDateMonth
              -> GDateYear
              -> Bool
gDateValidDMY (GDateDay day) month (GDateYear year) =
    toBool $ {# call fun g_date_valid_dmy #} day
                                             (fromIntegral $ fromEnum month)
                                             year

gDateNewJulian :: GDateJulianDay
               -> Maybe GDate
gDateNewJulian julian =
    if gDateValidJulian julian
        then Just $ GDate julian
        else Nothing

gDateNewDMY :: GDateDay
            -> GDateMonth
            -> GDateYear
            -> Maybe GDate
gDateNewDMY day month year =
    if gDateValidDMY day month year
        then Just $ unsafePerformIO $ alloca $ \ptr ->
            do let GDateDay day' = day
                   GDateYear year' = year
               {# call g_date_set_dmy #} (castPtr ptr)
                                         day'
                                         (fromIntegral $ fromEnum month)
                                         year'
               peek ptr
        else Nothing

gDateSetDay :: GDate
            -> GDateDay
            -> Maybe GDate
gDateSetDay date (GDateDay day) =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_day #} (castPtr ptr) day
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateSetMonth :: GDate
              -> GDateMonth
              -> Maybe GDate
gDateSetMonth date month =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_month #} (castPtr ptr) $ fromIntegral $ fromEnum month
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateSetYear :: GDate
             -> GDateYear
             -> Maybe GDate
gDateSetYear date (GDateYear year) =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_year #} (castPtr ptr) year
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateNewTimeVal :: GTimeVal
                -> GDate
gDateNewTimeVal timeVal =
    unsafePerformIO $ alloca $ \ptr ->
        with timeVal $ \timeValPtr ->
        do {# call g_date_set_time_val #} (castPtr ptr) $ castPtr timeValPtr
           peek ptr

gDateParse :: String
           -> IO (Maybe GDate)
gDateParse str =
    alloca $ \ptr ->
        do withUTFString str $ {# call g_date_set_parse #} $ castPtr ptr
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateAddDays :: GDate
             -> Word
             -> GDate
gDateAddDays date nDays =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_days #} (castPtr ptr) $ fromIntegral nDays
           peek ptr

gDateSubtractDays :: GDate
                  -> Word
                  -> GDate
gDateSubtractDays date nDays =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_days #} (castPtr ptr) $ fromIntegral nDays
           peek ptr

gDateAddMonths :: GDate
               -> Word
               -> GDate
gDateAddMonths date nMonths =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_months #} (castPtr ptr) $ fromIntegral nMonths
           peek ptr

gDateSubtractMonths :: GDate
                    -> Word
                    -> GDate
gDateSubtractMonths date nMonths =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_months #} (castPtr ptr) $ fromIntegral nMonths
           peek ptr

gDateAddYears :: GDate
              -> Word
              -> GDate
gDateAddYears date nYears =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_years #} (castPtr ptr) $ fromIntegral nYears
           peek ptr

gDateSubtractYears :: GDate
                   -> Word
                   -> GDate
gDateSubtractYears date nYears =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_years #} (castPtr ptr) $ fromIntegral nYears
           peek ptr

gDateDaysBetween :: GDate
                 -> GDate
                 -> Int
gDateDaysBetween date1 date2 =
    fromIntegral $ unsafePerformIO $ with date1 $ \ptr1 ->
        with date2 $ \ptr2 ->
            {# call g_date_days_between #} (castPtr ptr1) $ castPtr ptr2

gDateCompare :: GDate
             -> GDate
             -> Ordering
gDateCompare date1 date2 =
    let result = fromIntegral $ unsafePerformIO $ with date1 $ \ptr1 ->
                     with date2 $ \ptr2 ->
                         {# call g_date_compare #} (castPtr ptr1) $ castPtr ptr2
        ordering | result < 0 = LT
                 | result > 0 = GT
                 | otherwise  = EQ
    in ordering

instance Ord GDate where
    compare = gDateCompare

gDateClamp :: GDate
           -> GDate
           -> GDate
           -> GDate
gDateClamp date minDate maxDate =
    unsafePerformIO $ with date $ \ptr ->
        with minDate $ \minPtr ->
            with maxDate $ \maxPtr ->
                do {# call g_date_clamp #} (castPtr ptr) (castPtr minPtr) $ castPtr maxPtr
                   peek ptr

gDateDay :: GDate
         -> GDateDay
gDateDay date =
    GDateDay $ unsafePerformIO $ with date $ {# call g_date_get_day #} . castPtr

gDateMonth :: GDate
           -> GDateMonth
gDateMonth date =
    toEnum $ fromIntegral $ unsafePerformIO $ with date $ {# call g_date_get_month #} . castPtr

gDateYear :: GDate
          -> GDateYear
gDateYear date =
    GDateYear $ unsafePerformIO $ with date $ {# call g_date_get_year #} . castPtr

gDateWeekday :: GDate
             -> GDateWeekday
gDateWeekday date =
    toEnum $ fromIntegral $ unsafePerformIO $ with date $ {# call g_date_get_weekday #} . castPtr