point-free types

point-free types

{-# 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
  , ColorTable
  , RasterAttributeTable
  , GComplex (..)

  , setQuietErrorHandler

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

  , datatypeSize
  , datatypeByName
  , datatypeUnion
  , datatypeIsComplex

  , datasetProjection
  , setDatasetProjection
  , datasetGeotransform
  , setDatasetGeotransform
  , datasetBandCount

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

) 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"

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)

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

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

withAllDrivers act
  = registerAllDrivers >>
    finally act {#call GDALDestroyDriverManager as ^#}

{# 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 a t. Dataset a t -> IO ()
flushCache d = withDataset d flushCache'

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

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 "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 . getXSize_ $ band, fromIntegral . getYSize_ $ band)

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

foreign import ccall unsafe "gdal.h GDALGetRasterBandYSize" getYSize_
  :: (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, Show, Typeable)

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 :: 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 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
  , ColorTable
  , RasterAttributeTable
  , GComplex (..)

  , setQuietErrorHandler

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

  , datatypeSize
  , datatypeByName
  , datatypeUnion
  , datatypeIsComplex

  , datasetProjection
  , setDatasetProjection
  , datasetGeotransform
  , setDatasetGeotransform
  , datasetBandCount

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

) 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"

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)

type RODataset t = Dataset ReadOnly t
type RWDataset t = Dataset ReadWrite t
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)))

type ROBand t = Band ReadOnly t
type RWBand t = Band ReadWrite t

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

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

withAllDrivers act
  = registerAllDrivers >>
    finally act {#call GDALDestroyDriverManager as ^#}

{# 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 a t. Dataset a t -> IO ()
flushCache d = withDataset d flushCache'

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

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 "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 . getXSize_ $ band, fromIntegral . getYSize_ $ band)

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

foreign import ccall unsafe "gdal.h GDALGetRasterBandYSize" getYSize_
  :: (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, Show, Typeable)

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 :: 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 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


[project @ 2003-05-17 14:53:11 by as49] Doc fix.

--  GIMP Toolkit (GTK) - text layout functions @entry PangoLayout@
--
--  Author : Axel Simon
--
--  Created: 8 Feburary 2003
--
--  Version $Revision: 1.4 $ from $Date: 2003/05/17 14:53:11 $
--
--  Copyright (c) 1999..2003 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
-- @description@ --------------------------------------------------------------
--
-- * Functions to run the rendering pipeline.
--
-- @documentation@ ------------------------------------------------------------
--
-- * The Pango rendering pipeline takes a string of Unicode characters
--   and converts it into glyphs.  The functions described in this module
--   accomplish various steps of this process.
--
-- @todo@ ---------------------------------------------------------------------
--
-- * Functions that are missing:
--   pango_layout_set_attributes, pango_layout_get_attributes,
--   pango_layout_set_font_description, pango_layout_set_tabs,
--   pango_layout_get_tabs, pango_layout_get_log_attrs,
--   pango_layout_iter_get_run
--
-- * The following functions cannot be bound easily due to Unicode/UTF8 issues:
--   pango_layout_xy_to_index, pango_layout_index_to_pos,
--   pango_layout_get_cursor_pos, pango_layout_move_cursor_visually,
--   pango_layout_iter_get_index, pango_layout_line_index_to_x,
--   pango_layout_line_x_to_index, pango_layout_line_get_x_ranges
--
-- * These functions are not bound, because they're too easy:
--   pango_layout_get_size, pango_layout_get_pixel_size,
--   pango_layout_get_line
--
module PangoLayout(
  PangoLayout,
  layoutCopy,
  layoutGetContext,
  layoutContextChanged,
  layoutSetText,
  layoutGetText,
  layoutSetMarkup,
  layoutSetMarkupWithAccel,
  layoutSetWidth,
  layoutGetWidth,
  LayoutWrapMode(..),
  layoutSetWrap,
  layoutGetWrap,
  layoutSetIndent,
  layoutGetIndent,
  layoutSetSpacing,
  layoutGetSpacing,
  layoutSetJustify,
  layoutGetJustify,
  LayoutAlignment(..),
  layoutSetAlignment,
  layoutGetAlignment,
  layoutSetSingleParagraphMode,
  layoutGetSingleParagraphMode,
  layoutGetExtents,
  layoutGetPixelExtents,
  layoutGetLineCount,
  layoutGetLines,
  LayoutIter,
  layoutGetIter,
  layoutIterNextRun,
  layoutIterNextChar,
  layoutIterNextCluster,
  layoutIterNextLine,
  layoutIterAtLastLine,
  layoutIterGetBaseline,
  layoutIterGetLine,
  layoutIterGetCharExtents,
  layoutIterGetClusterExtents,
  layoutIterGetRunExtents,
  layoutIterGetLineYRange,
  layoutIterGetLineExtents,
  LayoutLine,
  layoutLineGetExtents,
  layoutLineGetPixelExtents
  ) where

import Monad    (liftM)
import Foreign
import UTFCForeign
{#import Hierarchy#}
import GObject  (makeNewGObject)
import Markup	(Markup)
import Char	(ord, chr)
import Enums
import Structs	(Rectangle)
import GList	(readGSList)
{#import PangoTypes#}

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

-- @method layoutCopy@ Create a copy of the @ref data layout@.
--
layoutCopy :: PangoLayout -> IO PangoLayout
layoutCopy pl = makeNewGObject mkPangoLayout
		 ({#call unsafe layout_copy#} (toPangoLayout pl))

-- @method layoutGetContext@ Retrieves the @ref data PangoContext@ from this
-- layout.
--
layoutGetContext :: PangoLayout -> IO PangoContext
layoutGetContext pl = makeNewGObject mkPangoContext
		      ({#call unsafe layout_get_context#} pl)

-- @method layoutContextChanged@ Signal a @ref data Context@ change.
--
-- * Forces recomputation of any state in the @ref data PangoLayout@ that
--   might depend on the layout's context. This function should
--   be called if you make changes to the context subsequent
--   to creating the layout.
--
layoutContextChanged :: PangoLayout -> IO ()
layoutContextChanged pl = {#call unsafe layout_context_changed#} pl

-- @method layoutSetText@ Set the string in the layout.
--
layoutSetText :: PangoLayout -> String -> IO ()
layoutSetText pl txt = withCStringLen txt $ \(strPtr,len) ->
  {#call unsafe layout_set_text#} pl strPtr (fromIntegral len)

-- @method layoutGetText@ Retrieve the string in the layout.
--
layoutGetText :: PangoLayout -> IO String
layoutGetText pl = {#call unsafe layout_get_text#} pl >>= peekCString

-- @method layoutSetMarkup@ Set the string in the layout.
--
-- * The string may include @ref data Markup@.
--
layoutSetMarkup :: PangoLayout -> Markup -> IO ()
layoutSetMarkup pl txt = withCStringLen txt $ \(strPtr,len) ->
  {#call unsafe layout_set_markup#} pl strPtr (fromIntegral len)

-- @method layoutSetMarkupWithAccel@ Set the string in the layout.
--
-- * The string may include @ref data Markup@. Furthermore, any underscore
--   character indicates that the next character should be
--   marked as accelerator (i.e. underlined). A literal underscore character
--   can be produced by placing it twice in the string.
--
-- * The character which follows the underscore is
--   returned so it can be used to add the actual keyboard shortcut.
--
layoutSetMarkupWithAccel :: PangoLayout -> Markup -> IO Char
layoutSetMarkupWithAccel pl txt =
  alloca $ \chrPtr ->
  withCStringLen txt $ \(strPtr,len) -> do
    {#call unsafe layout_set_markup_with_accel#} pl strPtr (fromIntegral len)
      (fromIntegral (ord '_')) chrPtr
    liftM (chr.fromIntegral) $ peek chrPtr

-- there are a couple of functions missing here

-- @method layoutSetWidth@ Set the width of this paragraph.
--
-- * Sets the width to which the lines of the @ref data PangoLayout@
--   should be wrapped.
--
-- * @ref arg width@ is the desired width, or @literal -1@ to indicate that
--   no wrapping should be performed.
--
layoutSetWidth :: PangoLayout -> Int -> IO ()
layoutSetWidth pl width =
  {#call unsafe layout_set_width#} pl (fromIntegral width)

-- @method layoutGetWidth@ Gets the width of this paragraph.
--
-- * Gets the width to which the lines of the @ref data PangoLayout@
--   should be wrapped.
--
-- * Returns is the current width, or @literal -1@ to indicate that
--   no wrapping is performed.
--
layoutGetWidth :: PangoLayout -> IO Int
layoutGetWidth pl = liftM fromIntegral $ {#call unsafe layout_get_width#} pl

-- @data LayoutWarpMode@ Enumerates how a line can be wrapped.
--
-- @variant WrapWholeWords@ Breaks lines only between words.
--
-- * This variant does not guarantee that the requested width is not
--   exceeded. A word that is longer than the paragraph width is not
--   split.

-- @variant WrapAnywhere@ Break lines anywhere.
--
-- @variant WrapPartialWords@ Wrap within a word if it is the only one on
-- this line.
--
-- * This option acts like @ref variant WrapWholeWords@ but will split
--   a word if it is the only one on this line and it exceeds the
--   specified width.
--
{#enum PangoWrapMode as LayoutWrapMode
  {underscoreToCase,
  PANGO_WRAP_WORD as WrapWholeWords,
  PANGO_WRAP_CHAR as WrapAnywhere,
  PANGO_WRAP_WORD_CHAR as WrapPartialWords}#}

-- @method layoutSetWrap@ Set how this paragraph is wrapped.
--
-- * Sets the wrap style; the wrap style only has an effect if a width
--   is set on the layout with @ref method layoutSetWidth@. To turn off
--   wrapping, set the width to -1.
--
layoutSetWrap :: PangoLayout -> LayoutWrapMode -> IO ()
layoutSetWrap pl wm =
  {#call unsafe layout_set_wrap#} pl ((fromIntegral.fromEnum) wm)

-- @method layoutGetWrap@ Get the wrap mode for the layout.
--
layoutGetWrap :: PangoLayout -> IO LayoutWrapMode
layoutGetWrap pl = liftM (toEnum.fromIntegral) $
  {#call unsafe layout_get_wrap#} pl

-- @method layoutSetIndent@ Set the indentation of this paragraph.
--
-- * Sets the amount by which the first line should be shorter than
--   the rest of the lines. This may be negative, in which case the
--   subsequent lines will be shorter than the first line. (However, in
--   either case, the entire width of the layout will be given by the
--   value.
--
layoutSetIndent :: PangoLayout -> Int -> IO ()
layoutSetIndent pl indent =
  {#call unsafe layout_set_indent#} pl (fromIntegral indent)

-- @method layoutGetIndent@ Gets the indentation of this paragraph.
--
-- * Gets the amount by which the first line should be shorter than
--   the rest of the lines.
--
layoutGetIndent :: PangoLayout -> IO Int
layoutGetIndent pl = liftM fromIntegral $ {#call unsafe layout_get_indent#} pl

-- @method layoutSetSpacing@ Set the spacing between lines of this paragraph.
--
layoutSetSpacing :: PangoLayout -> Int -> IO ()
layoutSetSpacing pl spacing =
  {#call unsafe layout_set_spacing#} pl (fromIntegral spacing)

-- @method layoutGetSpacing@ Gets the spacing between the lines.
--
layoutGetSpacing :: PangoLayout -> IO Int
layoutGetSpacing pl =
  liftM fromIntegral $ {#call unsafe layout_get_spacing#} pl

-- @method layoutSetJustify@ Set if text should be streched to fit width.
--
-- * Sets whether or not each complete line should be stretched to
--   fill the entire width of the layout. This stretching is typically
--   done by adding whitespace, but for some scripts (such as Arabic),
--   the justification is done by extending the characters.
--
layoutSetJustify :: PangoLayout -> Bool -> IO ()
layoutSetJustify pl j = {#call unsafe layout_set_justify#} pl (fromBool j)

-- @method layoutGetJustify@ Retrieve the justification flag.
--
-- * See @ref method layoutSetJustify@.
--
layoutGetJustify :: PangoLayout -> IO Bool
layoutGetJustify pl = liftM toBool $ {#call unsafe layout_get_justify#} pl

-- @data LayoutAlignment@ Enumerate to which side incomplete lines are flushed.
--
{#enum PangoAlignment as LayoutAlignment {underscoreToCase}#}

-- @method layoutSetAlignment@ Set how this paragraph is aligned.
--
-- * Sets the alignment for the layout (how partial lines are
--   positioned within the horizontal space available.)
--
layoutSetAlignment :: PangoLayout -> LayoutAlignment -> IO ()
layoutSetAlignment pl am =
  {#call unsafe layout_set_alignment#} pl ((fromIntegral.fromEnum) am)

-- @method layoutGetAlignment@ Get the alignment for the layout.
--
layoutGetAlignment :: PangoLayout -> IO LayoutAlignment
layoutGetAlignment pl = liftM (toEnum.fromIntegral) $
  {#call unsafe layout_get_alignment#} pl

-- functions are missing here

-- @method layoutSetSingleParagraphMode@ Honor newlines or not.
--
-- * If @ref arg honor@ is @literal True@, do not treat newlines and
--   similar characters as paragraph separators; instead, keep all text in
--   a single paragraph, and display a glyph for paragraph separator
--   characters. Used when you want to allow editing of newlines on a
--   single text line.
--
layoutSetSingleParagraphMode :: PangoLayout -> Bool -> IO ()
layoutSetSingleParagraphMode pl honor =
  {#call unsafe layout_set_single_paragraph_mode#} pl (fromBool honor)

-- @method layoutGetSingleParagraphMode@ Retrieve if newlines are honored.
--
-- * See @ref method layoutSetSingleParagraphMode@.
--
layoutGetSingleParagraphMode :: PangoLayout -> IO Bool
layoutGetSingleParagraphMode pl =
  liftM toBool $ {#call unsafe layout_get_single_paragraph_mode#} pl

-- a function is missing here

-- @method layoutGetExtents@ Compute the physical size of the layout.
--
-- * Computes the logical and the ink size of the @ref data Layout@. The
--   logical layout is used for positioning, the ink size is the smallest
--   bounding box that includes all character pixels. The ink size can be
--   smaller or larger that the logical layout.
--
-- * All values are in layout units. To get to device units (pixel for
--   @ref data Drawable@s) divide by @ref constant pangoScale@.
--
layoutGetExtents :: PangoLayout -> IO (Rectangle, Rectangle)
layoutGetExtents pl = alloca $ \logPtr -> alloca $ \inkPtr -> do
  {#call unsafe layout_get_extents#} pl (castPtr logPtr) (castPtr inkPtr)
  log <- peek logPtr
  ink <- peek inkPtr
  return (log,ink)

-- @method layoutGetPixelExtents@ Compute the physical size of the layout.
--
-- * Computes the logical and the ink size of the @ref data Layout@. The
--   logical layout is used for positioning, the ink size is the smallest
--   bounding box that includes all character pixels. The ink size can be
--   smaller or larger that the logical layout.
--
-- * All values are in device units. This function is a wrapper around
--   @ref method layoutGetExtents@ with scaling.
--
layoutGetPixelExtents :: PangoLayout -> IO (Rectangle, Rectangle)
layoutGetPixelExtents pl = alloca $ \logPtr -> alloca $ \inkPtr -> do
  {#call unsafe layout_get_pixel_extents#} pl (castPtr logPtr) (castPtr inkPtr)
  log <- peek logPtr
  ink <- peek inkPtr
  return (log,ink)

-- @method layoutGetLineCount@ Ask for the number of lines in this layout.
--
layoutGetLineCount :: PangoLayout -> IO Int
layoutGetLineCount pl = liftM fromIntegral $
  {#call unsafe layout_get_line_count#} pl

-- @method layoutGetLines@ Extract the single lines of the layout.
--
-- * The lines of each layout are regenerated if any attribute changes.
--   Thus the returned list does not reflect the current state of lines
--   after a change has been made.
--
layoutGetLines :: PangoLayout -> IO [LayoutLine]
layoutGetLines pl = do
  listPtr <- {#call unsafe layout_get_lines#} pl
  list <- readGSList listPtr
  mapM mkLayoutLine list

-- @constructor layoutGetIter@ Create an iterator to examine a layout.
--
layoutGetIter :: PangoLayout -> IO LayoutIter
layoutGetIter pl = do
  iterPtr <- {#call unsafe layout_get_iter#} pl
  liftM LayoutIter $ newForeignPtr iterPtr (layout_iter_free iterPtr)

-- @method layoutNextRun@ Move to the next run.
--
-- * Returns @literal False@ if this was the last run in the layout.
--
layoutIterNextRun :: LayoutIter -> IO Bool
layoutIterNextRun = liftM toBool . {#call unsafe layout_iter_next_run#}

-- @method layoutNextChar@ Move to the next char.
--
-- * Returns @literal False@ if this was the last char in the layout.
--
layoutIterNextChar :: LayoutIter -> IO Bool
layoutIterNextChar = liftM toBool . {#call unsafe layout_iter_next_char#}

-- @method layoutNextCluster@ Move to the next cluster.
--
-- * Returns @literal False@ if this was the last cluster in the layout.
--
layoutIterNextCluster :: LayoutIter -> IO Bool
layoutIterNextCluster = liftM toBool . {#call unsafe layout_iter_next_cluster#}

-- @method layoutNextLine@ Move to the next line.
--
-- * Returns @literal False@ if this was the last line in the layout.
--
layoutIterNextLine :: LayoutIter -> IO Bool
layoutIterNextLine = liftM toBool . {#call unsafe layout_iter_next_line#}

-- @method layoutAtLastLine@ Check if the iterator is on the last line.
--
-- * Returns @literal True@ if the iterator is on the last line of this
--   paragraph.
--
layoutIterAtLastLine :: LayoutIter -> IO Bool
layoutIterAtLastLine = liftM toBool . {#call unsafe layout_iter_at_last_line#}

-- @method layoutIterGetBaseline@ Query the vertical position within the
-- layout.
--
-- * Gets the y position of the current line's baseline, in layout
--   coordinates (origin at top left of the entire layout).
--
layoutIterGetBaseline :: LayoutIter -> IO Int
layoutIterGetBaseline =
  liftM fromIntegral . {#call unsafe pango_layout_iter_get_baseline#}

-- pango_layout_iter_get_run goes here

-- @method layoutIterGetLine@ Extract the line under the iterator.
--
layoutIterGetLine :: LayoutIter -> IO (Maybe LayoutLine)
layoutIterGetLine li = do
  llPtr <- liftM castPtr $ {#call unsafe pango_layout_iter_get_line#} li
  if (llPtr==nullPtr) then return Nothing else
    liftM Just $ mkLayoutLine llPtr

-- @method layoutIterGetCharExtents@ Retrieve a rectangle surrounding
-- a character.
--
-- * Get the extents of the current character in layout cooridnates
--   (origin is the top left of the entire layout). Only logical extents
--   can sensibly be obtained for characters.
--
layoutIterGetCharExtents :: LayoutIter -> IO Rectangle
layoutIterGetCharExtents li = alloca $ \logPtr ->
  {#call unsafe layout_iter_get_char_extents#} li (castPtr logPtr) >>
  peek logPtr

-- @method layoutIterGetClusterExtents@ Compute the physical size of the
-- cluster.
--
-- * Computes the logical and the ink size of the cluster pointed to by
--   @ref data LayoutIter@.
--
-- * All values are in layoutIter units. To get to device units (pixel for
--   @ref data Drawable@s) divide by @ref constant pangoScale@.
--
layoutIterGetClusterExtents :: LayoutIter -> IO (Rectangle, Rectangle)
layoutIterGetClusterExtents li = alloca $ \logPtr -> alloca $ \inkPtr -> do
  {#call unsafe layout_iter_get_cluster_extents#} li (castPtr logPtr)
    (castPtr inkPtr)
  log <- peek logPtr
  ink <- peek inkPtr
  return (log,ink)

-- @method layoutIterGetRunExtents@ Compute the physical size of the run.
--
-- * Computes the logical and the ink size of the run pointed to by
--   @ref data LayoutIter@.
--
-- * All values are in layoutIter units. To get to device units (pixel for
--   @ref data Drawable@s) divide by @ref constant pangoScale@.
--
layoutIterGetRunExtents :: LayoutIter -> IO (Rectangle, Rectangle)
layoutIterGetRunExtents li = alloca $ \logPtr -> alloca $ \inkPtr -> do
  {#call unsafe layout_iter_get_run_extents#} li (castPtr logPtr)
    (castPtr inkPtr)
  log <- peek logPtr
  ink <- peek inkPtr
  return (log,ink)

-- @method layoutIterGetLineYRange@ Retrieve vertical extent of this
-- line.
--
-- * Divides the vertical space in the @ref data PangoLayout@ being
--   iterated over between the lines in the layout, and returns the
--   space belonging to the current line. A line's range includes the
--   line's logical extents, plus half of the spacing above and below
--   the line, if @ref method pangoLayoutSetSpacing@ has been called
--   to set layout spacing. The y positions are in layout coordinates
--   (origin at top left of the entire layout).
--
-- * The first element in the returned tuple is the start, the second is
--   the end of this line.
--
layoutIterGetLineYRange :: LayoutIter -> IO (Int,Int)
layoutIterGetLineYRange li = alloca $ \sPtr -> alloca $ \ePtr -> do
  {#call unsafe layout_iter_get_line_extents#} li (castPtr sPtr) (castPtr ePtr)
  start <- peek sPtr
  end <- peek ePtr
  return (start,end)

-- @method layoutIterGetLineExtents@ Compute the physical size of the line.
--
-- * Computes the logical and the ink size of the line pointed to by
--   @ref data LayoutIter@.
--
-- * Extents are in layout coordinates (origin is the top-left corner
--   of the entire @ref data PangoLayout@). Thus the extents returned
--   by this function will be the same width/height but not at the
--   same x/y as the extents returned from @ref method
--   pangoLayoutLineGetExtents@.
--
layoutIterGetLineExtents :: LayoutIter -> IO (Rectangle, Rectangle)
layoutIterGetLineExtents li = alloca $ \logPtr -> alloca $ \inkPtr -> do
  {#call unsafe layout_iter_get_line_extents#} li (castPtr logPtr)
    (castPtr inkPtr)
  log <- peek logPtr
  ink <- peek inkPtr
  return (log,ink)

-- @method layoutLineGetExtents@ Compute the physical size of the line.
--
-- * Computes the logical and the ink size of the @ref data LayoutLine@. The
--   logical layout is used for positioning, the ink size is the smallest
--   bounding box that includes all character pixels. The ink size can be
--   smaller or larger that the logical layout.
--
-- * All values are in layout units. To get to device units (pixel for
--   @ref data Drawable@s) divide by @ref constant pangoScale@.
--
layoutLineGetExtents :: LayoutLine -> IO (Rectangle, Rectangle)
layoutLineGetExtents pl = alloca $ \logPtr -> alloca $ \inkPtr -> do
  {#call unsafe layout_line_get_extents#} pl (castPtr logPtr) (castPtr inkPtr)
  log <- peek logPtr
  ink <- peek inkPtr
  return (log,ink)

-- @method layoutLineGetPixelExtents@ Compute the physical size of the line.
--
-- * Computes the logical and the ink size of the @ref data LayoutLine@. The
--   logical layout is used for positioning, the ink size is the smallest
--   bounding box that includes all character pixels. The ink size can be
--   smaller or larger that the logical layout.
--
-- * All values are in device units. This function is a wrapper around
--   @ref method layoutLineGetExtents@ with scaling.
--
layoutLineGetPixelExtents :: LayoutLine -> IO (Rectangle, Rectangle)
layoutLineGetPixelExtents pl = alloca $ \logPtr -> alloca $ \inkPtr -> do
  {#call unsafe layout_line_get_pixel_extents#} pl
    (castPtr logPtr) (castPtr inkPtr)
  log <- peek logPtr
  ink <- peek inkPtr
  return (log,ink)

--  GIMP Toolkit (GTK) - text layout functions @entry layout@
--
--  Author : Axel Simon
--
--  Created: 8 Feburary 2003
--
--  Version $Revision: 1.3 $ from $Date: 2003/05/16 05:53:33 $
--
--  Copyright (c) 1999..2003 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
-- @description@ --------------------------------------------------------------
--
-- * Functions to run the rendering pipeline.
--
-- @documentation@ ------------------------------------------------------------
--
-- * The Pango rendering pipeline takes a string of Unicode characters
--   and converts it into glyphs.  The functions described in this module
--   accomplish various steps of this process.
--
-- @todo@ ---------------------------------------------------------------------
--
-- * Functions that are missing:
--   pango_layout_set_attributes, pango_layout_get_attributes,
--   pango_layout_set_font_description, pango_layout_set_tabs,
--   pango_layout_get_tabs, pango_layout_get_log_attrs,
--   pango_layout_iter_get_run
--
-- * The following functions cannot be bound easily due to Unicode/UTF8 issues:
--   pango_layout_xy_to_index, pango_layout_index_to_pos,
--   pango_layout_get_cursor_pos, pango_layout_move_cursor_visually,
--   pango_layout_iter_get_index, pango_layout_line_index_to_x,
--   pango_layout_line_x_to_index, pango_layout_line_get_x_ranges
--
-- * These functions are not bound, because they're too easy:
--   pango_layout_get_size, pango_layout_get_pixel_size,
--   pango_layout_get_line
--
module PangoLayout(
  PangoLayout,
  layoutCopy,
  layoutGetContext,
  layoutContextChanged,
  layoutSetText,
  layoutGetText,
  layoutSetMarkup,
  layoutSetMarkupWithAccel,
  layoutSetWidth,
  layoutGetWidth,
  LayoutWrapMode(..),
  layoutSetWrap,
  layoutGetWrap,
  layoutSetIndent,
  layoutGetIndent,
  layoutSetSpacing,
  layoutGetSpacing,
  layoutSetJustify,
  layoutGetJustify,
  LayoutAlignment(..),
  layoutSetAlignment,
  layoutGetAlignment,
  layoutSetSingleParagraphMode,
  layoutGetSingleParagraphMode,
  layoutGetExtents,
  layoutGetPixelExtents,
  layoutGetLineCount,
  layoutGetLines,
  LayoutIter,
  layoutGetIter,
  layoutIterNextRun,
  layoutIterNextChar,
  layoutIterNextCluster,
  layoutIterNextLine,
  layoutIterAtLastLine,
  layoutIterGetBaseline,
  layoutIterGetLine,
  layoutIterGetCharExtents,
  layoutIterGetClusterExtents,
  layoutIterGetRunExtents,
  layoutIterGetLineYRange,
  layoutIterGetLineExtents,
  LayoutLine,
  layoutLineGetExtents,
  layoutLineGetPixelExtents
  ) where

import Monad    (liftM)
import Foreign
import UTFCForeign
{#import Hierarchy#}
import GObject  (makeNewGObject)
import Markup	(Markup)
import Char	(ord, chr)
import Enums
import Structs	(Rectangle)
import GList	(readGSList)
{#import PangoTypes#}

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

-- @method layoutCopy@ Create a copy of the @ref data layout@.
--
layoutCopy :: PangoLayout -> IO PangoLayout
layoutCopy pl = makeNewGObject mkPangoLayout
		 ({#call unsafe layout_copy#} (toPangoLayout pl))

-- @method layoutGetContext@ Retrieves the @ref data PangoContext@ from this
-- layout.
--
layoutGetContext :: PangoLayout -> IO PangoContext
layoutGetContext pl = makeNewGObject mkPangoContext
		      ({#call unsafe layout_get_context#} pl)

-- @method layoutContextChanged@ Signal a @ref data Context@ change.
--
-- * Forces recomputation of any state in the @ref data PangoLayout@ that
--   might depend on the layout's context. This function should
--   be called if you make changes to the context subsequent
--   to creating the layout.
--
layoutContextChanged :: PangoLayout -> IO ()
layoutContextChanged pl = {#call unsafe layout_context_changed#} pl

-- @method layoutSetText@ Set the string in the layout.
--
layoutSetText :: PangoLayout -> String -> IO ()
layoutSetText pl txt = withCStringLen txt $ \(strPtr,len) ->
  {#call unsafe layout_set_text#} pl strPtr (fromIntegral len)

-- @method layoutGetText@ Retrieve the string in the layout.
--
layoutGetText :: PangoLayout -> IO String
layoutGetText pl = {#call unsafe layout_get_text#} pl >>= peekCString

-- @method layoutSetMarkup@ Set the string in the layout.
--
-- * The string may include @ref data Markup@.
--
layoutSetMarkup :: PangoLayout -> Markup -> IO ()
layoutSetMarkup pl txt = withCStringLen txt $ \(strPtr,len) ->
  {#call unsafe layout_set_markup#} pl strPtr (fromIntegral len)

-- @method layoutSetMarkupWithAccel@ Set the string in the layout.
--
-- * The string may include @ref data Markup@. Furthermore, any underscore
--   character indicates that the next character should be
--   marked as accelerator (i.e. underlined). A literal underscore character
--   can be produced by placing it twice in the string.
--
-- * The character which follows the underscore is
--   returned so it can be used to add the actual keyboard shortcut.
--
layoutSetMarkupWithAccel :: PangoLayout -> Markup -> IO Char
layoutSetMarkupWithAccel pl txt =
  alloca $ \chrPtr ->
  withCStringLen txt $ \(strPtr,len) -> do
    {#call unsafe layout_set_markup_with_accel#} pl strPtr (fromIntegral len)
      (fromIntegral (ord '_')) chrPtr
    liftM (chr.fromIntegral) $ peek chrPtr

-- there are a couple of functions missing here

-- @method layoutSetWidth@ Set the width of this paragraph.
--
-- * Sets the width to which the lines of the @ref data PangoLayout@
--   should be wrapped.
--
-- * @ref arg width@ is the desired width, or @literal -1@ to indicate that
--   no wrapping should be performed.
--
layoutSetWidth :: PangoLayout -> Int -> IO ()
layoutSetWidth pl width =
  {#call unsafe layout_set_width#} pl (fromIntegral width)

-- @method layoutGetWidth@ Gets the width of this paragraph.
--
-- * Gets the width to which the lines of the @ref data PangoLayout@
--   should be wrapped.
--
-- * Returns is the current width, or @literal -1@ to indicate that
--   no wrapping is performed.
--
layoutGetWidth :: PangoLayout -> IO Int
layoutGetWidth pl = liftM fromIntegral $ {#call unsafe layout_get_width#} pl

-- @data LayoutWarpMode@ Enumerates how a line can be wrapped.
--
-- @variant WrapWholeWords@ Breaks lines only between words.
--
-- * This variant does not guarantee that the requested width is not
--   exceeded. A word that is longer than the paragraph width is not
--   split.

-- @variant WrapAnywhere@ Break lines anywhere.
--
-- @variant WrapPartialWords@ Wrap within a word if it is the only one on
-- this line.
--
-- * This option acts like @ref variant WrapWholeWords@ but will split
--   a word if it is the only one on this line and it exceeds the
--   specified width.
--
{#enum PangoWrapMode as LayoutWrapMode
  {underscoreToCase,
  PANGO_WRAP_WORD as WrapWholeWords,
  PANGO_WRAP_CHAR as WrapAnywhere,
  PANGO_WRAP_WORD_CHAR as WrapPartialWords}#}

-- @method layoutSetWrap@ Set how this paragraph is wrapped.
--
-- * Sets the wrap style; the wrap style only has an effect if a width
--   is set on the layout with @ref method layoutSetWidth@. To turn off
--   wrapping, set the width to -1.
--
layoutSetWrap :: PangoLayout -> LayoutWrapMode -> IO ()
layoutSetWrap pl wm =
  {#call unsafe layout_set_wrap#} pl ((fromIntegral.fromEnum) wm)

-- @method layoutGetWrap@ Get the wrap mode for the layout.
--
layoutGetWrap :: PangoLayout -> IO LayoutWrapMode
layoutGetWrap pl = liftM (toEnum.fromIntegral) $
  {#call unsafe layout_get_wrap#} pl

-- @method layoutSetIndent@ Set the indentation of this paragraph.
--
-- * Sets the amount by which the first line should be shorter than
--   the rest of the lines. This may be negative, in which case the
--   subsequent lines will be shorter than the first line. (However, in
--   either case, the entire width of the layout will be given by the
--   value.
--
layoutSetIndent :: PangoLayout -> Int -> IO ()
layoutSetIndent pl indent =
  {#call unsafe layout_set_indent#} pl (fromIntegral indent)

-- @method layoutGetIndent@ Gets the indentation of this paragraph.
--
-- * Gets the amount by which the first line should be shorter than
--   the rest of the lines.
--
layoutGetIndent :: PangoLayout -> IO Int
layoutGetIndent pl = liftM fromIntegral $ {#call unsafe layout_get_indent#} pl

-- @method layoutSetSpacing@ Set the spacing between lines of this paragraph.
--
layoutSetSpacing :: PangoLayout -> Int -> IO ()
layoutSetSpacing pl spacing =
  {#call unsafe layout_set_spacing#} pl (fromIntegral spacing)

-- @method layoutGetSpacing@ Gets the spacing between the lines.
--
layoutGetSpacing :: PangoLayout -> IO Int
layoutGetSpacing pl =
  liftM fromIntegral $ {#call unsafe layout_get_spacing#} pl

-- @method layoutSetJustify@ Set if text should be streched to fit width.
--
-- * Sets whether or not each complete line should be stretched to
--   fill the entire width of the layout. This stretching is typically
--   done by adding whitespace, but for some scripts (such as Arabic),
--   the justification is done by extending the characters.
--
layoutSetJustify :: PangoLayout -> Bool -> IO ()
layoutSetJustify pl j = {#call unsafe layout_set_justify#} pl (fromBool j)

-- @method layoutGetJustify@ Retrieve the justification flag.
--
-- * See @ref method layoutSetJustify@.
--
layoutGetJustify :: PangoLayout -> IO Bool
layoutGetJustify pl = liftM toBool $ {#call unsafe layout_get_justify#} pl

-- @data LayoutAlignment@ Enumerate to which side incomplete lines are flushed.
--
{#enum PangoAlignment as LayoutAlignment {underscoreToCase}#}

-- @method layoutSetAlignment@ Set how this paragraph is aligned.
--
-- * Sets the alignment for the layout (how partial lines are
--   positioned within the horizontal space available.)
--
layoutSetAlignment :: PangoLayout -> LayoutAlignment -> IO ()
layoutSetAlignment pl am =
  {#call unsafe layout_set_alignment#} pl ((fromIntegral.fromEnum) am)

-- @method layoutGetAlignment@ Get the alignment for the layout.
--
layoutGetAlignment :: PangoLayout -> IO LayoutAlignment
layoutGetAlignment pl = liftM (toEnum.fromIntegral) $
  {#call unsafe layout_get_alignment#} pl

-- functions are missing here

-- @method layoutSetSingleParagraphMode@ Honor newlines or not.
--
-- * If @ref arg honor@ is @literal True@, do not treat newlines and
--   similar characters as paragraph separators; instead, keep all text in
--   a single paragraph, and display a glyph for paragraph separator
--   characters. Used when you want to allow editing of newlines on a
--   single text line.
--
layoutSetSingleParagraphMode :: PangoLayout -> Bool -> IO ()
layoutSetSingleParagraphMode pl honor =
  {#call unsafe layout_set_single_paragraph_mode#} pl (fromBool honor)

-- @method layoutGetSingleParagraphMode@ Retrieve if newlines are honored.
--
-- * See @ref method layoutSetSingleParagraphMode@.
--
layoutGetSingleParagraphMode :: PangoLayout -> IO Bool
layoutGetSingleParagraphMode pl =
  liftM toBool $ {#call unsafe layout_get_single_paragraph_mode#} pl

-- a function is missing here

-- @method layoutGetExtents@ Compute the physical size of the layout.
--
-- * Computes the logical and the ink size of the @ref data Layout@. The
--   logical layout is used for positioning, the ink size is the smallest
--   bounding box that includes all character pixels. The ink size can be
--   smaller or larger that the logical layout.
--
-- * All values are in layout units. To get to device units (pixel for
--   @ref data Drawable@s) divide by @ref constant pangoScale@.
--
layoutGetExtents :: PangoLayout -> IO (Rectangle, Rectangle)
layoutGetExtents pl = alloca $ \logPtr -> alloca $ \inkPtr -> do
  {#call unsafe layout_get_extents#} pl (castPtr logPtr) (castPtr inkPtr)
  log <- peek logPtr
  ink <- peek inkPtr
  return (log,ink)

-- @method layoutGetPixelExtents@ Compute the physical size of the layout.
--
-- * Computes the logical and the ink size of the @ref data Layout@. The
--   logical layout is used for positioning, the ink size is the smallest
--   bounding box that includes all character pixels. The ink size can be
--   smaller or larger that the logical layout.
--
-- * All values are in device units. This function is a wrapper around
--   @ref method layoutGetExtents@ with scaling.
--
layoutGetPixelExtents :: PangoLayout -> IO (Rectangle, Rectangle)
layoutGetPixelExtents pl = alloca $ \logPtr -> alloca $ \inkPtr -> do
  {#call unsafe layout_get_pixel_extents#} pl (castPtr logPtr) (castPtr inkPtr)
  log <- peek logPtr
  ink <- peek inkPtr
  return (log,ink)

-- @method layoutGetLineCount@ Ask for the number of lines in this layout.
--
layoutGetLineCount :: PangoLayout -> IO Int
layoutGetLineCount pl = liftM fromIntegral $
  {#call unsafe layout_get_line_count#} pl

-- @method layoutGetLines@ Extract the single lines of the layout.
--
-- * The lines of each layout are regenerated if any attribute changes.
--   Thus the returned list does not reflect the current state of lines
--   after a change has been made.
--
layoutGetLines :: PangoLayout -> IO [LayoutLine]
layoutGetLines pl = do
  listPtr <- {#call unsafe layout_get_lines#} pl
  list <- readGSList listPtr
  mapM mkLayoutLine list

-- @constructor layoutGetIter@ Create an iterator to examine a layout.
--
layoutGetIter :: PangoLayout -> IO LayoutIter
layoutGetIter pl = do
  iterPtr <- {#call unsafe layout_get_iter#} pl
  liftM LayoutIter $ newForeignPtr iterPtr (layout_iter_free iterPtr)

-- @method layoutNextRun@ Move to the next run.
--
-- * Returns @literal False@ if this was the last run in the layout.
--
layoutIterNextRun :: LayoutIter -> IO Bool
layoutIterNextRun = liftM toBool . {#call unsafe layout_iter_next_run#}

-- @method layoutNextChar@ Move to the next char.
--
-- * Returns @literal False@ if this was the last char in the layout.
--
layoutIterNextChar :: LayoutIter -> IO Bool
layoutIterNextChar = liftM toBool . {#call unsafe layout_iter_next_char#}

-- @method layoutNextCluster@ Move to the next cluster.
--
-- * Returns @literal False@ if this was the last cluster in the layout.
--
layoutIterNextCluster :: LayoutIter -> IO Bool
layoutIterNextCluster = liftM toBool . {#call unsafe layout_iter_next_cluster#}

-- @method layoutNextLine@ Move to the next line.
--
-- * Returns @literal False@ if this was the last line in the layout.
--
layoutIterNextLine :: LayoutIter -> IO Bool
layoutIterNextLine = liftM toBool . {#call unsafe layout_iter_next_line#}

-- @method layoutAtLastLine@ Check if the iterator is on the last line.
--
-- * Returns @literal True@ if the iterator is on the last line of this
--   paragraph.
--
layoutIterAtLastLine :: LayoutIter -> IO Bool
layoutIterAtLastLine = liftM toBool . {#call unsafe layout_iter_at_last_line#}

-- @method layoutIterGetBaseline@ Query the vertical position within the
-- layout.
--
-- * Gets the y position of the current line's baseline, in layout
--   coordinates (origin at top left of the entire layout).
--
layoutIterGetBaseline :: LayoutIter -> IO Int
layoutIterGetBaseline =
  liftM fromIntegral . {#call unsafe pango_layout_iter_get_baseline#}

-- pango_layout_iter_get_run goes here

-- @method layoutIterGetLine@ Extract the line under the iterator.
--
layoutIterGetLine :: LayoutIter -> IO (Maybe LayoutLine)
layoutIterGetLine li = do
  llPtr <- liftM castPtr $ {#call unsafe pango_layout_iter_get_line#} li
  if (llPtr==nullPtr) then return Nothing else
    liftM Just $ mkLayoutLine llPtr

-- @method layoutIterGetCharExtents@ Retrieve a rectangle surrounding
-- a character.
--
-- * Get the extents of the current character in layout cooridnates
--   (origin is the top left of the entire layout). Only logical extents
--   can sensibly be obtained for characters.
--
layoutIterGetCharExtents :: LayoutIter -> IO Rectangle
layoutIterGetCharExtents li = alloca $ \logPtr ->
  {#call unsafe layout_iter_get_char_extents#} li (castPtr logPtr) >>
  peek logPtr

-- @method layoutIterGetClusterExtents@ Compute the physical size of the
-- cluster.
--
-- * Computes the logical and the ink size of the cluster pointed to by
--   @ref data LayoutIter@.
--
-- * All values are in layoutIter units. To get to device units (pixel for
--   @ref data Drawable@s) divide by @ref constant pangoScale@.
--
layoutIterGetClusterExtents :: LayoutIter -> IO (Rectangle, Rectangle)
layoutIterGetClusterExtents li = alloca $ \logPtr -> alloca $ \inkPtr -> do
  {#call unsafe layout_iter_get_cluster_extents#} li (castPtr logPtr)
    (castPtr inkPtr)
  log <- peek logPtr
  ink <- peek inkPtr
  return (log,ink)

-- @method layoutIterGetRunExtents@ Compute the physical size of the run.
--
-- * Computes the logical and the ink size of the run pointed to by
--   @ref data LayoutIter@.
--
-- * All values are in layoutIter units. To get to device units (pixel for
--   @ref data Drawable@s) divide by @ref constant pangoScale@.
--
layoutIterGetRunExtents :: LayoutIter -> IO (Rectangle, Rectangle)
layoutIterGetRunExtents li = alloca $ \logPtr -> alloca $ \inkPtr -> do
  {#call unsafe layout_iter_get_run_extents#} li (castPtr logPtr)
    (castPtr inkPtr)
  log <- peek logPtr
  ink <- peek inkPtr
  return (log,ink)

-- @method layoutIterGetLineYRange@ Retrieve vertical extent of this
-- line.
--
-- * Divides the vertical space in the @ref data PangoLayout@ being
--   iterated over between the lines in the layout, and returns the
--   space belonging to the current line. A line's range includes the
--   line's logical extents, plus half of the spacing above and below
--   the line, if @ref method pangoLayoutSetSpacing@ has been called
--   to set layout spacing. The y positions are in layout coordinates
--   (origin at top left of the entire layout).
--
-- * The first element in the returned tuple is the start, the second is
--   the end of this line.
--
layoutIterGetLineYRange :: LayoutIter -> IO (Int,Int)
layoutIterGetLineYRange li = alloca $ \sPtr -> alloca $ \ePtr -> do
  {#call unsafe layout_iter_get_line_extents#} li (castPtr sPtr) (castPtr ePtr)
  start <- peek sPtr
  end <- peek ePtr
  return (start,end)

-- @method layoutIterGetLineExtents@ Compute the physical size of the line.
--
-- * Computes the logical and the ink size of the line pointed to by
--   @ref data LayoutIter@.
--
-- * Extents are in layout coordinates (origin is the top-left corner
--   of the entire @ref data PangoLayout@). Thus the extents returned
--   by this function will be the same width/height but not at the
--   same x/y as the extents returned from @ref method
--   pangoLayoutLineGetExtents@.
--
layoutIterGetLineExtents :: LayoutIter -> IO (Rectangle, Rectangle)
layoutIterGetLineExtents li = alloca $ \logPtr -> alloca $ \inkPtr -> do
  {#call unsafe layout_iter_get_line_extents#} li (castPtr logPtr)
    (castPtr inkPtr)
  log <- peek logPtr
  ink <- peek inkPtr
  return (log,ink)

-- @method layoutLineGetExtents@ Compute the physical size of the line.
--
-- * Computes the logical and the ink size of the @ref data LayoutLine@. The
--   logical layout is used for positioning, the ink size is the smallest
--   bounding box that includes all character pixels. The ink size can be
--   smaller or larger that the logical layout.
--
-- * All values are in layout units. To get to device units (pixel for
--   @ref data Drawable@s) divide by @ref constant pangoScale@.
--
layoutLineGetExtents :: LayoutLine -> IO (Rectangle, Rectangle)
layoutLineGetExtents pl = alloca $ \logPtr -> alloca $ \inkPtr -> do
  {#call unsafe layout_line_get_extents#} pl (castPtr logPtr) (castPtr inkPtr)
  log <- peek logPtr
  ink <- peek inkPtr
  return (log,ink)

-- @method layoutLineGetPixelExtents@ Compute the physical size of the line.
--
-- * Computes the logical and the ink size of the @ref data LayoutLine@. The
--   logical layout is used for positioning, the ink size is the smallest
--   bounding box that includes all character pixels. The ink size can be
--   smaller or larger that the logical layout.
--
-- * All values are in device units. This function is a wrapper around
--   @ref method layoutLineGetExtents@ with scaling.
--
layoutLineGetPixelExtents :: LayoutLine -> IO (Rectangle, Rectangle)
layoutLineGetPixelExtents pl = alloca $ \logPtr -> alloca $ \inkPtr -> do
  {#call unsafe layout_line_get_pixel_extents#} pl
    (castPtr logPtr) (castPtr inkPtr)
  log <- peek logPtr
  ink <- peek inkPtr
  return (log,ink)