explicit imports

explicit imports

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

module Bindings.GDAL.Internal (
    Datatype (..)
  , Access (..)
  , ColorInterpretation (..)
  , PaletteInterpretation (..)
  , Error (..)
  , Geotransform (..)
  , MaybeIOVector
  , ProgressFun

  , DriverOptions

  , MajorObject
  , Dataset
  , RasterBand
  , Driver
  , ColorTable
  , RasterAttributeTable

  , registerAllDrivers
  , driverByName
  , create
  , create'
  , createMem
  , flushCache
  , open
  , openShared
  , createCopy'
  , createCopy

  , datatypeSize
  , datatypeByName
  , datatypeUnion
  , datatypeIsComplex

  , datasetProjection
  , setDatasetProjection
  , datasetGeotransform
  , setDatasetGeotransform

  , withRasterBand
  , bandDatatype
  , blockSize
  , blockLen
  , bandSize
  , readBand
  , readBlock
  , writeBand
  , writeBlock
  , fillBand

) where

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

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

import System.IO.Unsafe (unsafePerformIO)

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

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

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

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

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

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

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

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

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

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

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

instance Show ColorInterpretation where
    show = getColorInterpretationName

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

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

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

instance Show PaletteInterpretation where
    show = getPaletteInterpretationName

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

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

newtype Dataset = Dataset (ForeignPtr Dataset, Mutex)

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

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

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

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

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

driverByName :: String -> IO (Maybe Driver)
driverByName s = do
    driver@(Driver ptr) <- c_driverByName s
    return $ if ptr==nullPtr then Nothing else Just driver

type DriverOptions = [(String,String)]

create :: String -> String -> Int -> Int -> Int -> Datatype -> DriverOptions
       -> IO (Maybe Dataset)
create drv path nx ny bands dtype options = do
    driver <- driverByName drv
    case driver of
      Nothing -> return Nothing
      Just d  -> create' d path nx ny bands dtype options

create' :: Driver -> String -> Int -> Int -> Int -> Datatype -> DriverOptions
       -> IO (Maybe Dataset)
create' drv path nx ny bands dtype options = withCString path $ \path' -> do
    opts <- toOptionList options
    ptr <- {#call GDALCreate as ^#}
             drv
             path'
             (fromIntegral nx)
             (fromIntegral ny)
             (fromIntegral bands)
             (fromEnumC dtype)
             opts
    newDatasetHandle ptr

{# fun GDALOpen as open
    { `String', fromEnumC `Access'} -> `Maybe Dataset' newDatasetHandle* #}

{# fun GDALOpen as openShared
    { `String', fromEnumC `Access'} -> `Maybe Dataset' newDatasetHandle* #}

createCopy' :: Driver -> String -> Dataset -> Bool -> DriverOptions
            -> ProgressFun -> IO (Maybe Dataset)
createCopy' driver path dataset strict options progressFun
  = withCString path $ \p ->
    withDataset dataset $ \ds ->
    withProgressFun progressFun $ \pFunc -> do
        let s = fromBool strict
        o <- toOptionList options
        {#call GDALCreateCopy as ^#} driver p ds s o pFunc (castPtr nullPtr) >>=
            newDatasetHandle

withProgressFun f = bracket (wrapProgressFun f) freeHaskellFunPtr

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

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

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

newDatasetHandle :: Ptr Dataset -> IO (Maybe Dataset)
newDatasetHandle p =
    if p==nullPtr then return Nothing
    else do fp <- newForeignPtr closeDataset p
            mutex <- newMutex
            return $ Just $ Dataset (fp, mutex)

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

createMem:: Int -> Int -> Int -> Datatype -> DriverOptions -> IO (Maybe Dataset)
createMem = create "MEM" ""

{# fun GDALFlushCache as flushCache
    {  withDataset*  `Dataset'} -> `()' #}

{# fun unsafe GDALGetProjectionRef as datasetProjection
    {  withDataset*  `Dataset'} -> `String' #}

{# fun unsafe GDALSetProjection as setDatasetProjection
    {  withDataset*  `Dataset', `String'} -> `Error' toEnumC #}

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

datasetGeotransform :: Dataset -> IO (Maybe Geotransform)
datasetGeotransform ds = withDataset' ds $ \dPtr -> do
    allocaArray 6 $ \a -> do
      err <- {#call unsafe GDALGetGeoTransform as ^#} dPtr a
      case toEnumC err of
           CE_None -> liftM Just $ 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)
           _       -> return Nothing

setDatasetGeotransform :: Dataset -> Geotransform -> IO (Error)
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)
        liftM toEnumC $ {#call unsafe GDALSetGeoTransform as ^#} dPtr a

withRasterBand :: Dataset -> Int -> (Maybe RasterBand -> IO a) -> IO a
withRasterBand ds band f = withDataset ds $ \dPtr -> do
    rBand@(RasterBand p) <- {# call unsafe GDALGetRasterBand as ^ #}
                              dPtr (fromIntegral band)
    f (if p == nullPtr then Nothing else Just rBand)

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

blockSize :: RasterBand -> (Int,Int)
blockSize band = unsafePerformIO $ alloca $ \xPtr -> alloca $ \yPtr ->
   {#call unsafe GDALGetBlockSize as ^#} band xPtr yPtr >>
   liftA2 (,) (liftM fromIntegral $ peek xPtr) (liftM fromIntegral $ peek yPtr)

blockLen :: RasterBand -> Int
blockLen = uncurry (*) . blockSize

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

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

class HasDatatype a where
    datatype :: a -> Datatype

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

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

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

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

readBand :: (Storable a, HasDatatype (Ptr a))
  => RasterBand
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> IO (Maybe (Vector a))
readBand band xoff yoff sx sy bx by pxs lns = do
    fp <- mallocForeignPtrArray (bx * by)
    err <- withForeignPtr fp $ \ptr -> do
        _ <- {#call GDALRasterAdviseRead as ^#}
          band
          (fromIntegral xoff)
          (fromIntegral yoff)
          (fromIntegral sx)
          (fromIntegral sy)
          (fromIntegral bx)
          (fromIntegral by)
          (fromEnumC (datatype ptr))
          (castPtr nullPtr)
        {#call GDALRasterIO as ^#}
          band
          (fromEnumC GF_Read)
          (fromIntegral xoff)
          (fromIntegral yoff)
          (fromIntegral sx)
          (fromIntegral sy)
          (castPtr ptr)
          (fromIntegral bx)
          (fromIntegral by)
          (fromEnumC (datatype ptr))
          (fromIntegral pxs)
          (fromIntegral lns)
    case toEnumC err of
         CE_None -> return $ Just $ unsafeFromForeignPtr0 fp (bx * by)
         _       -> return Nothing

writeBand :: (Storable a, HasDatatype (Ptr a))
  => RasterBand
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Vector a
  -> IO (Error)
writeBand band xoff yoff sx sy bx by pxs lns vec = do
    let nElems    = bx * by
        (fp, len) = unsafeToForeignPtr0 vec
    if nElems /= len
      then return CE_Failure
      else withForeignPtr fp $ \ptr -> liftM toEnumC $
          {#call GDALRasterIO as ^#}
            band
            (fromEnumC GF_Write)
            (fromIntegral xoff)
            (fromIntegral yoff)
            (fromIntegral sx)
            (fromIntegral sy)
            (castPtr ptr)
            (fromIntegral bx)
            (fromIntegral by)
            (fromEnumC (datatype ptr))
            (fromIntegral pxs)
            (fromIntegral lns)

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

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

readBlock' :: RasterBand -> Int -> Int -> IO (Maybe Block)
readBlock' b x y =
  case bandDatatype b of
    GDT_Byte ->
      maybeReturn Block (readIt b x y :: MaybeIOVector Word8)
    GDT_Int16 ->
      maybeReturn Block (readIt b x y :: MaybeIOVector Int16)
    GDT_Int32 ->
      maybeReturn Block (readIt b x y :: MaybeIOVector Int32)
    GDT_Float32 ->
      maybeReturn Block (readIt b x y :: MaybeIOVector Float)
    GDT_Float64 ->
      maybeReturn Block (readIt b x y :: MaybeIOVector Double)
    GDT_CInt16 ->
      maybeReturn Block (readIt b x y :: MaybeIOVector (Complex Float))
    GDT_CInt32 ->
      maybeReturn Block (readIt b x y :: MaybeIOVector (Complex Double))
    GDT_CFloat32 ->
      maybeReturn Block (readIt b x y :: MaybeIOVector (Complex Float))
    GDT_CFloat64 ->
      maybeReturn Block (readIt b x y :: MaybeIOVector (Complex Double))
    _ -> return Nothing
  where
    maybeReturn f act = act >>= maybe (return Nothing) (return . Just . f)
    readIt b x y = do
      let l  = blockLen b
          rb = {#call GDALReadBlock as ^#} b (fromIntegral x) (fromIntegral y)
      f <- mallocForeignPtrArray l
      e <- withForeignPtr f (rb . castPtr)
      if toEnumC e == CE_None
         then return $ Just $ unsafeFromForeignPtr0 f l
         else return Nothing

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

writeBlock :: (Storable a, Typeable a)
  => RasterBand
  -> Int -> Int
  -> Vector a
  -> IO (Error)
writeBlock b x y vec = do
    let nElems    = blockLen b
        (fp, len) = unsafeToForeignPtr0 vec
    if nElems /= len || typeOf vec /= typeOfBand b
      then return CE_Failure
      else withForeignPtr fp $ \ptr -> liftM toEnumC $
          {#call GDALWriteBlock as ^#}
            b
            (fromIntegral x)
            (fromIntegral y)
            (castPtr ptr)

typeOfBand = typeOfdatatype . bandDatatype

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

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

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

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

type Mutex = MVar ()

newMutex :: IO Mutex
newMutex = newMVar ()

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

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

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

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

module Bindings.GDAL.Internal (
    Datatype (..)
  , Access (..)
  , ColorInterpretation (..)
  , PaletteInterpretation (..)
  , Error (..)
  , Geotransform (..)
  , MaybeIOVector
  , ProgressFun

  , DriverOptions

  , MajorObject
  , Dataset
  , RasterBand
  , Driver
  , ColorTable
  , RasterAttributeTable

  , registerAllDrivers
  , driverByName
  , create
  , create'
  , createMem
  , flushCache
  , open
  , openShared
  , createCopy'
  , createCopy

  , datatypeSize
  , datatypeByName
  , datatypeUnion
  , datatypeIsComplex

  , datasetProjection
  , setDatasetProjection
  , datasetGeotransform
  , setDatasetGeotransform

  , withRasterBand
  , bandDatatype
  , blockSize
  , blockLen
  , bandSize
  , readBand
  , readBlock
  , writeBand
  , writeBlock
  , fillBand

) where

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

import Data.Int (Int16, Int32)
import Data.Complex (Complex(..), realPart, imagPart)
import Data.Typeable (Typeable, cast, typeOf)
import Data.Word (Word8, Word16, Word32)
import Data.Vector.Storable (Vector, unsafeFromForeignPtr0, unsafeToForeignPtr0)
import Foreign.C.String
import Foreign.C.Types
import Foreign.Ptr
import Foreign.Storable
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Marshal.Utils

import System.IO.Unsafe (unsafePerformIO)

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

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

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

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

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

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

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

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

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

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

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

instance Show ColorInterpretation where
    show = getColorInterpretationName

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

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

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

instance Show PaletteInterpretation where
    show = getPaletteInterpretationName

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

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

newtype Dataset = Dataset (ForeignPtr Dataset, Mutex)

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

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

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

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

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

driverByName :: String -> IO (Maybe Driver)
driverByName s = do
    driver@(Driver ptr) <- c_driverByName s
    return $ if ptr==nullPtr then Nothing else Just driver

type DriverOptions = [(String,String)]

create :: String -> String -> Int -> Int -> Int -> Datatype -> DriverOptions
       -> IO (Maybe Dataset)
create drv path nx ny bands dtype options = do
    driver <- driverByName drv
    case driver of
      Nothing -> return Nothing
      Just d  -> create' d path nx ny bands dtype options

create' :: Driver -> String -> Int -> Int -> Int -> Datatype -> DriverOptions
       -> IO (Maybe Dataset)
create' drv path nx ny bands dtype options = withCString path $ \path' -> do
    opts <- toOptionList options
    ptr <- {#call GDALCreate as ^#}
             drv
             path'
             (fromIntegral nx)
             (fromIntegral ny)
             (fromIntegral bands)
             (fromEnumC dtype)
             opts
    newDatasetHandle ptr

{# fun GDALOpen as open
    { `String', fromEnumC `Access'} -> `Maybe Dataset' newDatasetHandle* #}

{# fun GDALOpen as openShared
    { `String', fromEnumC `Access'} -> `Maybe Dataset' newDatasetHandle* #}

createCopy' :: Driver -> String -> Dataset -> Bool -> DriverOptions
            -> ProgressFun -> IO (Maybe Dataset)
createCopy' driver path dataset strict options progressFun
  = withCString path $ \p ->
    withDataset dataset $ \ds ->
    withProgressFun progressFun $ \pFunc -> do
        let s = if strict then 1 else 0
        o <- toOptionList options
        {#call GDALCreateCopy as ^#} driver p ds s o pFunc (castPtr nullPtr) >>=
            newDatasetHandle

withProgressFun f = bracket (wrapProgressFun f) freeHaskellFunPtr

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

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

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

newDatasetHandle :: Ptr Dataset -> IO (Maybe Dataset)
newDatasetHandle p =
    if p==nullPtr then return Nothing
    else do fp <- newForeignPtr closeDataset p
            mutex <- newMutex
            return $ Just $ Dataset (fp, mutex)

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

createMem:: Int -> Int -> Int -> Datatype -> DriverOptions -> IO (Maybe Dataset)
createMem = create "MEM" ""

{# fun GDALFlushCache as flushCache
    {  withDataset*  `Dataset'} -> `()' #}

{# fun unsafe GDALGetProjectionRef as datasetProjection
    {  withDataset*  `Dataset'} -> `String' #}

{# fun unsafe GDALSetProjection as setDatasetProjection
    {  withDataset*  `Dataset', `String'} -> `Error' toEnumC #}

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

datasetGeotransform :: Dataset -> IO (Maybe Geotransform)
datasetGeotransform ds = withDataset' ds $ \dPtr -> do
    allocaArray 6 $ \a -> do
      err <- {#call unsafe GDALGetGeoTransform as ^#} dPtr a
      case toEnumC err of
           CE_None -> liftM Just $ 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)
           _       -> return Nothing

setDatasetGeotransform :: Dataset -> Geotransform -> IO (Error)
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)
        liftM toEnumC $ {#call unsafe GDALSetGeoTransform as ^#} dPtr a

withRasterBand :: Dataset -> Int -> (Maybe RasterBand -> IO a) -> IO a
withRasterBand ds band f = withDataset ds $ \dPtr -> do
    rBand@(RasterBand p) <- {# call unsafe GDALGetRasterBand as ^ #}
                              dPtr (fromIntegral band)
    f (if p == nullPtr then Nothing else Just rBand)

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

blockSize :: RasterBand -> (Int,Int)
blockSize band = unsafePerformIO $ alloca $ \xPtr -> alloca $ \yPtr ->
   {#call unsafe GDALGetBlockSize as ^#} band xPtr yPtr >>
   liftA2 (,) (liftM fromIntegral $ peek xPtr) (liftM fromIntegral $ peek yPtr)

blockLen :: RasterBand -> Int
blockLen = uncurry (*) . blockSize

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

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

class HasDatatype a where
    datatype :: a -> Datatype

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

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

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

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

readBand :: (Storable a, HasDatatype (Ptr a))
  => RasterBand
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> IO (Maybe (Vector a))
readBand band xoff yoff sx sy bx by pxs lns = do
    fp <- mallocForeignPtrArray (bx * by)
    err <- withForeignPtr fp $ \ptr -> do
        _ <- {#call GDALRasterAdviseRead as ^#}
          band
          (fromIntegral xoff)
          (fromIntegral yoff)
          (fromIntegral sx)
          (fromIntegral sy)
          (fromIntegral bx)
          (fromIntegral by)
          (fromEnumC (datatype ptr))
          (castPtr nullPtr)
        {#call GDALRasterIO as ^#}
          band
          (fromEnumC GF_Read)
          (fromIntegral xoff)
          (fromIntegral yoff)
          (fromIntegral sx)
          (fromIntegral sy)
          (castPtr ptr)
          (fromIntegral bx)
          (fromIntegral by)
          (fromEnumC (datatype ptr))
          (fromIntegral pxs)
          (fromIntegral lns)
    case toEnumC err of
         CE_None -> return $ Just $ unsafeFromForeignPtr0 fp (bx * by)
         _       -> return Nothing

writeBand :: (Storable a, HasDatatype (Ptr a))
  => RasterBand
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Int -> Int
  -> Vector a
  -> IO (Error)
writeBand band xoff yoff sx sy bx by pxs lns vec = do
    let nElems    = bx * by
        (fp, len) = unsafeToForeignPtr0 vec
    if nElems /= len
      then return CE_Failure
      else withForeignPtr fp $ \ptr -> liftM toEnumC $
          {#call GDALRasterIO as ^#}
            band
            (fromEnumC GF_Write)
            (fromIntegral xoff)
            (fromIntegral yoff)
            (fromIntegral sx)
            (fromIntegral sy)
            (castPtr ptr)
            (fromIntegral bx)
            (fromIntegral by)
            (fromEnumC (datatype ptr))
            (fromIntegral pxs)
            (fromIntegral lns)

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

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

readBlock' :: RasterBand -> Int -> Int -> IO (Maybe Block)
readBlock' b x y =
  case bandDatatype b of
    GDT_Byte ->
      maybeReturn Block (readIt b x y :: MaybeIOVector Word8)
    GDT_Int16 ->
      maybeReturn Block (readIt b x y :: MaybeIOVector Int16)
    GDT_Int32 ->
      maybeReturn Block (readIt b x y :: MaybeIOVector Int32)
    GDT_Float32 ->
      maybeReturn Block (readIt b x y :: MaybeIOVector Float)
    GDT_Float64 ->
      maybeReturn Block (readIt b x y :: MaybeIOVector Double)
    GDT_CInt16 ->
      maybeReturn Block (readIt b x y :: MaybeIOVector (Complex Float))
    GDT_CInt32 ->
      maybeReturn Block (readIt b x y :: MaybeIOVector (Complex Double))
    GDT_CFloat32 ->
      maybeReturn Block (readIt b x y :: MaybeIOVector (Complex Float))
    GDT_CFloat64 ->
      maybeReturn Block (readIt b x y :: MaybeIOVector (Complex Double))
    _ -> return Nothing
  where
    maybeReturn f act = act >>= maybe (return Nothing) (return . Just . f)
    readIt b x y = do
      let l  = blockLen b
          rb = {#call GDALReadBlock as ^#} b (fromIntegral x) (fromIntegral y)
      f <- mallocForeignPtrArray l
      e <- withForeignPtr f (rb . castPtr)
      if toEnumC e == CE_None
         then return $ Just $ unsafeFromForeignPtr0 f l
         else return Nothing

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

writeBlock :: (Storable a, Typeable a)
  => RasterBand
  -> Int -> Int
  -> Vector a
  -> IO (Error)
writeBlock b x y vec = do
    let nElems    = blockLen b
        (fp, len) = unsafeToForeignPtr0 vec
    if nElems /= len || typeOf vec /= typeOfBand b
      then return CE_Failure
      else withForeignPtr fp $ \ptr -> liftM toEnumC $
          {#call GDALWriteBlock as ^#}
            b
            (fromIntegral x)
            (fromIntegral y)
            (castPtr ptr)

typeOfBand = typeOfdatatype . bandDatatype

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

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

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

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

type Mutex = MVar ()

newMutex :: IO Mutex
newMutex = newMVar ()

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

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

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


Fix SourceStyleScheme docs.

Fix SourceStyleScheme docs.

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) SourceStyleScheme
--
--  Author : Peter Gavin
--  derived from sourceview bindings by Axel Simon and Duncan Coutts
--
--  Created: 18 December 2008
--
--  Copyright (C) 2004-2008 Peter Gavin, Duncan Coutts, 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 Graphics.UI.Gtk.SourceView.SourceStyleScheme (
-- * Description
-- | 'SourceStyleScheme' contains all the text styles to be used in 'SourceView' and
-- 'SourceBuffer'. For instance, it contains text styles for syntax highlighting, it may contain
-- foreground and background color for non-highlighted text, color for the line numbers, etc.
--
-- Style schemes are stored in XML files. The format of a scheme file is the documented in the style
-- scheme reference.

-- * Types
  SourceStyleScheme,

-- * Methods
  castToSourceStyleScheme,
  sourceStyleSchemeGetId,
  sourceStyleSchemeGetName,
  sourceStyleSchemeGetDescription,
  sourceStyleSchemeGetAuthors,
  sourceStyleSchemeGetFilename,
  sourceStyleSchemeGetStyle,

-- * Attributes
  sourceStyleSchemeDescription,
  sourceStyleSchemeFilename,
  sourceStyleSchemeId,
  sourceStyleSchemeName,
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GObject	(constructNewGObject)
import System.Glib.Attributes
{#import System.Glib.Properties#}
{#import Graphics.UI.Gtk.SourceView.Types#}
import Graphics.UI.Gtk.SourceView.SourceStyle
{#import Graphics.UI.Gtk.SourceView.SourceStyle.Internal#}

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

-- methods

-- |
--
sourceStyleSchemeGetId :: SourceStyleScheme
                       -> IO String -- ^ returns scheme id.
sourceStyleSchemeGetId ss =
  {#call source_style_scheme_get_id#} ss >>= peekUTFString

-- |
--
sourceStyleSchemeGetName :: SourceStyleScheme
                         -> IO String -- ^ returns scheme name.
sourceStyleSchemeGetName ss =
  {#call source_style_scheme_get_name#} ss >>= peekUTFString

-- |
--
sourceStyleSchemeGetDescription :: SourceStyleScheme
                                -> IO String -- ^ returns scheme description (if defined) or empty.
sourceStyleSchemeGetDescription ss =
  {#call source_style_scheme_get_description#} ss >>= peekUTFString

-- |
--
sourceStyleSchemeGetAuthors :: SourceStyleScheme
                            -> IO [String] -- ^ returns an array containing the scheme authors or empty if no author is specified by the style scheme.
sourceStyleSchemeGetAuthors ss =
  {#call source_style_scheme_get_authors#} ss >>= peekUTFStringArray0

-- |
--
sourceStyleSchemeGetFilename :: SourceStyleScheme
                             -> IO String -- ^ returns scheme file name if the scheme was created parsing a style scheme file or empty in the other cases.
sourceStyleSchemeGetFilename ss =
  {#call source_style_scheme_get_filename#} ss >>= peekUTFString

-- |
--
sourceStyleSchemeGetStyle :: SourceStyleScheme
                          -> String  -- ^ @styleId@ id of the style to retrieve.
                          -> IO SourceStyle -- ^ returns  style which corresponds to @styleId@ in the scheme
sourceStyleSchemeGetStyle ss id = do
  styleObj <- makeNewGObject mkSourceStyleObject $
              withUTFString id ({#call source_style_scheme_get_style#} ss)
  sourceStyleFromObject styleObj

-- | Style scheme description.
--
-- Default value: \"\"
--
sourceStyleSchemeDescription :: ReadAttr SourceStyleScheme String
sourceStyleSchemeDescription = readAttrFromStringProperty "description"

-- | Style scheme filename or 'Nothing'.
--
-- Default value: \"\"
--
sourceStyleSchemeFilename :: ReadAttr SourceStyleScheme FilePath
sourceStyleSchemeFilename = readAttrFromStringProperty "filename"

-- | Style scheme id, a unique string used to identify the style scheme in 'SourceStyleSchemeManager'.
--
-- Default value: \"\"
--
sourceStyleSchemeId :: ReadAttr SourceStyleScheme String
sourceStyleSchemeId = readAttrFromStringProperty "id"

-- | Style scheme name, a translatable string to present to user.
--
-- Default value: \"\"
--
sourceStyleSchemeName :: ReadAttr SourceStyleScheme String
sourceStyleSchemeName = readAttrFromStringProperty "name"

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) SourceStyleScheme
--
--  Author : Peter Gavin
--  derived from sourceview bindings by Axel Simon and Duncan Coutts
--
--  Created: 18 December 2008
--
--  Copyright (C) 2004-2008 Peter Gavin, Duncan Coutts, 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 Graphics.UI.Gtk.SourceView.SourceStyleScheme (
  SourceStyleScheme,
  castToSourceStyleScheme,
  sourceStyleSchemeGetId,
  sourceStyleSchemeGetName,
  sourceStyleSchemeGetDescription,
  sourceStyleSchemeGetAuthors,
  sourceStyleSchemeGetFilename,
  sourceStyleSchemeGetStyle,
  sourceStyleSchemeDescription,
  sourceStyleSchemeFilename,
  sourceStyleSchemeId,
  sourceStyleSchemeName,
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GObject	(constructNewGObject)
import System.Glib.Attributes
{#import System.Glib.Properties#}
{#import Graphics.UI.Gtk.SourceView.Types#}
import Graphics.UI.Gtk.SourceView.SourceStyle
{#import Graphics.UI.Gtk.SourceView.SourceStyle.Internal#}

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

-- methods

-- |
--
sourceStyleSchemeGetId :: SourceStyleScheme -> IO String
sourceStyleSchemeGetId ss =
  {#call source_style_scheme_get_id#} ss >>= peekUTFString

-- |
--
sourceStyleSchemeGetName :: SourceStyleScheme -> IO String
sourceStyleSchemeGetName ss =
  {#call source_style_scheme_get_name#} ss >>= peekUTFString

-- |
--
sourceStyleSchemeGetDescription :: SourceStyleScheme -> IO String
sourceStyleSchemeGetDescription ss =
  {#call source_style_scheme_get_description#} ss >>= peekUTFString

-- |
--
sourceStyleSchemeGetAuthors :: SourceStyleScheme -> IO [String]
sourceStyleSchemeGetAuthors ss =
  {#call source_style_scheme_get_authors#} ss >>= peekUTFStringArray0

-- |
--
sourceStyleSchemeGetFilename :: SourceStyleScheme -> IO String
sourceStyleSchemeGetFilename ss =
  {#call source_style_scheme_get_filename#} ss >>= peekUTFString

-- |
--
sourceStyleSchemeGetStyle :: SourceStyleScheme -> String -> IO SourceStyle
sourceStyleSchemeGetStyle ss id = do
  styleObj <- makeNewGObject mkSourceStyleObject $
              withUTFString id ({#call source_style_scheme_get_style#} ss)
  sourceStyleFromObject styleObj

-- |
--
sourceStyleSchemeDescription :: ReadAttr SourceStyleScheme String
sourceStyleSchemeDescription = readAttrFromStringProperty "description"

-- |
--
sourceStyleSchemeFilename :: ReadAttr SourceStyleScheme FilePath
sourceStyleSchemeFilename = readAttrFromStringProperty "filename"

-- |
--
sourceStyleSchemeId :: ReadAttr SourceStyleScheme String
sourceStyleSchemeId = readAttrFromStringProperty "id"

-- |
--
sourceStyleSchemeName :: ReadAttr SourceStyleScheme String
sourceStyleSchemeName = readAttrFromStringProperty "name"


gnomevfs: add function S.G.V.Volume.volumeUnmount

--  GIMP Toolkit (GTK) Binding for Haskell: binding to libgnomevfs -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GnomeVFS, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GnomeVFS documentation,
--  Copyright (c) 2001 Seth Nickell <snickell@stanford.edu>. The
--  documentation is covered by the GNU Free Documentation License,
--  version 1.2.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module System.Gnome.VFS.Volume (

-- * Types
  -- | An abstraction for a mounted filesystem or network location.
  Volume,
  VolumeClass,
  VolumeID,
  -- | Safely cast an object to a 'Volume'.
  castToVolume,

-- * Volume Operations
  volumeCompare,
  volumeEject,
  volumeGetActivationURI,
  volumeGetDevicePath,
  volumeGetDeviceType,
  volumeGetDisplayName,
  volumeGetDrive,
  volumeGetFilesystemType,
  volumeGetHalUDI,
  volumeGetIcon,
  volumeGetID,
  volumeGetVolumeType,
  volumeHandlesTrash,
  volumeIsMounted,
  volumeIsReadOnly,
  volumeIsUserVisible,
  volumeUnmount

  ) where

import Control.Exception
import Control.Monad (liftM)
import System.Glib.UTFString
import System.Glib.FFI
{#import System.Gnome.VFS.Marshal#}
{#import System.Gnome.VFS.Types#}

{# context lib = "gnomevfs" prefix = "gnome_vfs" #}

-- | Compares two 'Volume' objects @a@ and @b@. Two 'Volume'
--   objects referring to different volumes are guaranteed to not
--   return 'EQ' when comparing them. If they refer to the same volume 'EQ'
--   is returned.
--
--   The resulting gint should be used to determine the order in which
--   @a@ and @b@ are displayed in graphical user interfaces.
--
--   The comparison algorithm first of all peeks the device type of
--   @a@ and @b@, they will be sorted in the following order:
--
--     * Magnetic and opto-magnetic volumes (ZIP, floppy)
--
--     * Optical volumes (CD, DVD)
--
--     * External volumes (USB sticks, music players)
--
--     * Mounted hard disks
--
--     * Network mounts
--
--     * Other volumes
--
--   Afterwards, the display name of @a@ and @b@ is compared using a
--   locale-sensitive sorting algorithm.
--
--   If two volumes have the same display name, their unique ID is
--   compared which can be queried using 'volumeGetID'.
volumeCompare :: (VolumeClass volume1, VolumeClass volume2)
              => volume1
              -> volume2
              -> IO Ordering
volumeCompare a b =
    do result <- liftM fromIntegral $ {# call volume_compare #} (castToVolume a) (castToVolume b)
       let ordering | result < 0 = LT
                    | result > 0 = GT
                    | otherwise  = EQ
       return ordering

-- Requests ejection of a 'Volume'.
--
-- Before the unmount operation is executed, the
-- 'Volume' object's @pre-unmount@ signal is emitted.
--
-- If the volume is a mount point, i.e. its type is
-- 'VolumeTypeMountpoint', it is unmounted, and if it refers to a
-- disk, it is also ejected.
--
-- If the volume is a special VFS mount, i.e. its type is
-- 'VolumeTypeMount', it is ejected.
--
-- If the volume is a connected server, it is removed from the list of
-- connected servers.
--
-- Otherwise, no further action is done.
volumeEject   :: VolumeClass volume
              => volume                  -- ^ @volume@ - the volume to eject
              -> VolumeOpSuccessCallback -- ^ @successCallback@ - the
                                         --   callback to call once
                                         --   the operation has
                                         --   completed successfully
              -> VolumeOpFailureCallback -- ^ @failureCallback@ - the
                                         --   callback to call if the
                                         --   operation fails
              -> IO ()
volumeEject volume successCallback failureCallback =
    do cCallback <- volumeOpCallbackMarshal successCallback failureCallback
       {# call volume_eject #} (castToVolume volume) cCallback $ castFunPtrToPtr cCallback

marshalString cAction volume =
    cAction (castToVolume volume) >>= readUTFString
marshalMaybeString cAction volume =
    cAction (castToVolume volume) >>= maybePeek readUTFString

-- | Returns the activation URI of @volume@.
--
--   The returned URI usually refers to a valid location. You can
--   check the validity of the location by calling 'uriFromString'
--   with the URI, and checking whether the return value is not
--   'Nothing'.
volumeGetActivationURI  :: VolumeClass volume
                        => volume     -- ^ @volume@ - the volume to query
                        -> IO TextURI -- ^ the volume's activation URI.
volumeGetActivationURI =
    marshalString {# call volume_get_activation_uri #}

-- | Returns the device path of a 'Volume' object.
--
--   For HAL volumes, this returns the value of the volume's
--   @block.device@ key. For UNIX mounts, it returns the @mntent@'s
--   @mnt_fsname@ entry.
--
--   Otherwise, it returns 'Nothing'.
volumeGetDevicePath     :: VolumeClass volume =>
                           volume    -- ^ @volume@ - the volume object to query
                        -> IO String -- ^ the volume's device path
volumeGetDevicePath =
    marshalString {# call volume_get_device_path #}

-- | Returns the 'DeviceType' of a 'Volume' object.
volumeGetDeviceType     :: VolumeClass volume =>
                           volume        -- ^ @volume@ - the volume object to query
                        -> IO DeviceType -- the volume's device type
volumeGetDeviceType volume =
    liftM cToEnum $ {# call volume_get_device_type #} (castToVolume volume)

-- | Returns the display name of a 'Volume' object.
volumeGetDisplayName    :: VolumeClass volume =>
                           volume    -- ^ @volume@ - the volume object to query
                        -> IO String -- ^ the volume's display name
volumeGetDisplayName =
    marshalString {# call volume_get_display_name #}

-- | Returns the 'Drive' that @volume@ is on.
volumeGetDrive          :: VolumeClass volume =>
                           volume   -- ^ @volume@ - the volume object to query
                        -> IO Drive -- ^ the containing drive
volumeGetDrive volume =
    {# call volume_get_drive #} (castToVolume volume) >>= newDrive

-- | Returns a string describing the file system on @volume@, or
--   'Nothing' if no information on the underlying file system is
--   available.
--
--   The file system may be used to provide special functionality that
--   depends on the file system type, for instance to determine
--   whether trashing is supported (cf. 'volumeHandlesTrash').
--
--   For HAL mounts, this returns the value of the @\"volume.fstype\"@
--   key, for traditional UNIX mounts it is set to the mntent's
--   mnt_type key, for connected servers, 'Nothing' is returned.
volumeGetFilesystemType :: VolumeClass volume =>
                           volume            -- ^ @volume@ - the
                                             -- volume object to query
                        -> IO (Maybe String) -- ^ a string describing
                                             -- the filesystem type,
                                             -- or 'Nothing' if no
                                             -- information is
                                             -- available
volumeGetFilesystemType =
    marshalMaybeString {# call volume_get_filesystem_type #}

-- | Returns the HAL UDI of a 'Volume' object.
--
--   For HAL volumes, this matches the value of the @info.udi@ key,
--   for other volumes it is 'Nothing'.
volumeGetHalUDI :: VolumeClass volume =>
                   volume            -- ^ @volume@ - the volume object to query
                -> IO (Maybe String) -- ^ the volume's HAL UDI
volumeGetHalUDI =
    marshalMaybeString {# call volume_get_hal_udi #}

-- | Returns the icon filename for a 'Volume' object.
volumeGetIcon :: VolumeClass volume =>
                 volume      -- ^ @volume@ - a volume object
              -> IO FilePath -- ^ the icon that should be used for this volume
volumeGetIcon =
    marshalString {# call volume_get_icon #}

-- | Returns a unique identifier for a 'Volume' object.
volumeGetID :: VolumeClass volume =>
               volume      -- ^ @volume@ - a volume object
            -> IO VolumeID -- ^ a unique identifier for the volume
volumeGetID volume =
    {# call volume_get_id #} (castToVolume volume)

-- | Returns the volume type of @volume@.
volumeGetVolumeType     :: VolumeClass volume =>
                           volume        -- ^ @volume@ - the volume object to query
                        -> IO VolumeType -- ^ the volume's volume type
volumeGetVolumeType volume =
    liftM cToEnum $ {# call volume_get_volume_type #} (castToVolume volume)

marshalBool cAction volume =
    liftM toBool $ cAction (castToVolume volume)

-- | Returns whether the file system on a volume supports trashing of
--   files.
--
--   If the volume has an AutoFS file system (i.e.,
--   'volumeGetDeviceType' returns 'DeviceTypeAutofs'), or if the
--   volume is mounted read-only (i.e., 'volumeIsReadOnly' returns
--   'True'), it is assumed to not support trashing of files.
--
--   Otherwise, if the volume provides file system information, it is
--   determined whether the file system supports trashing of
--   files.
volumeHandlesTrash      :: VolumeClass volume =>
                           volume  -- ^ @volume@ -
                        -> IO Bool -- ^ 'True' if the volume handles trash, otherwise 'False'
volumeHandlesTrash =
    marshalBool {# call volume_handles_trash #}

-- | Returns whether the file system on a volume is currently mounted.
--
--   For HAL volumes, this reflects the value of the
--   @\"volume.is_mounted\"@ key, for traditional UNIX mounts and
--   connected servers, 'True' is returned, because their existence
--   implies that they are mounted.
volumeIsMounted         :: VolumeClass volume =>
                           volume  -- ^ @volume@ -
                        -> IO Bool -- ^ 'True' if the volume is mounted, otherwise 'False'
volumeIsMounted =
    marshalBool {# call volume_is_mounted #}

-- | Returns whether the file system on a volume is read-only.
--
--   For HAL volumes, the @\"volume.is_mounted_read_only\"@ key is
--   authoritative, for traditional UNIX mounts it returns TRUE if the
--   mount was done with the @\"ro\"@ option. For servers, 'False' is
--   returned.
volumeIsReadOnly        :: VolumeClass volume =>
                           volume  -- ^ @volume@ -
                        -> IO Bool -- ^ 'True' if the volume is read-only, otherwise 'False'
volumeIsReadOnly =
    marshalBool {# call volume_is_read_only #}

-- | Returns a 'Bool' for whether a volume is user-visible. This should
--   be used by applications to determine whether the volume should be
--   listed in user interfaces listing available volumes.
volumeIsUserVisible     :: VolumeClass volume =>
                           volume  -- @volume@ -
                        -> IO Bool -- ^ 'True' if the volume is user visible, otherwise 'False'
volumeIsUserVisible =
    marshalBool {# call volume_is_user_visible #}

-- Requests unmount of a 'Volume'.
--
-- Note that 'volumeUnmount' may also unvoke 'volumeEject', if
-- @volume@ signals that it should be ejected when it is unmounted.
-- This may be true for CD-ROMs, USB sticks, and other devices,
-- depending on the backend providing the volume.
volumeUnmount :: VolumeClass volume
              => volume                  -- ^ @volume@ - the volume to eject
              -> VolumeOpSuccessCallback -- ^ @successCallback@ - the
                                         --   callback to call once
                                         --   the operation has
                                         --   completed successfully
              -> VolumeOpFailureCallback -- ^ @failureCallback@ - the
                                         --   callback to call if the
                                         --   operation fails
              -> IO ()
volumeUnmount volume successCallback failureCallback =
    do cCallback <- volumeOpCallbackMarshal successCallback failureCallback
       {# call volume_unmount #} (castToVolume volume) cCallback $ castFunPtrToPtr cCallback

--  GIMP Toolkit (GTK) Binding for Haskell: binding to libgnomevfs -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GnomeVFS, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GnomeVFS documentation,
--  Copyright (c) 2001 Seth Nickell <snickell@stanford.edu>. The
--  documentation is covered by the GNU Free Documentation License,
--  version 1.2.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module System.Gnome.VFS.Volume (

-- * Types
  -- | An abstraction for a mounted filesystem or network location.
  Volume,
  VolumeClass,
  VolumeID,
  -- | Safely cast an object to a 'Volume'.
  castToVolume,

-- * Volume Operations
  volumeCompare,
  volumeEject,
  volumeGetActivationURI,
  volumeGetDevicePath,
  volumeGetDeviceType,
  volumeGetDisplayName,
  volumeGetDrive,
  volumeGetFilesystemType,
  volumeGetHalUDI,
  volumeGetIcon,
  volumeGetID,
  volumeGetVolumeType,
  volumeHandlesTrash,
  volumeIsMounted,
  volumeIsReadOnly,
  volumeIsUserVisible

  ) where

import Control.Exception
import Control.Monad (liftM)
import System.Glib.UTFString
import System.Glib.FFI
{#import System.Gnome.VFS.Marshal#}
{#import System.Gnome.VFS.Types#}

{# context lib = "gnomevfs" prefix = "gnome_vfs" #}

-- | Compares two 'Volume' objects @a@ and @b@. Two 'Volume'
--   objects referring to different volumes are guaranteed to not
--   return 'EQ' when comparing them. If they refer to the same volume 'EQ'
--   is returned.
--
--   The resulting gint should be used to determine the order in which
--   @a@ and @b@ are displayed in graphical user interfaces.
--
--   The comparison algorithm first of all peeks the device type of
--   @a@ and @b@, they will be sorted in the following order:
--
--     * Magnetic and opto-magnetic volumes (ZIP, floppy)
--
--     * Optical volumes (CD, DVD)
--
--     * External volumes (USB sticks, music players)
--
--     * Mounted hard disks
--
--     * Network mounts
--
--     * Other volumes
--
--   Afterwards, the display name of @a@ and @b@ is compared using a
--   locale-sensitive sorting algorithm.
--
--   If two volumes have the same display name, their unique ID is
--   compared which can be queried using 'volumeGetID'.
volumeCompare :: (VolumeClass volume1, VolumeClass volume2)
              => volume1
              -> volume2
              -> IO Ordering
volumeCompare a b =
    do result <- liftM fromIntegral $ {# call volume_compare #} (castToVolume a) (castToVolume b)
       let ordering | result < 0 = LT
                    | result > 0 = GT
                    | otherwise  = EQ
       return ordering

-- Requests ejection of a 'Volume'.
--
-- Before the unmount operation is executed, the
-- 'Volume' object's @pre-unmount@ signal is emitted.
--
-- If the volume is a mount point, i.e. its type is
-- 'VolumeTypeMountpoint', it is unmounted, and if it refers to a
-- disk, it is also ejected.
--
-- If the volume is a special VFS mount, i.e. its type is
-- 'VolumeTypeMount', it is ejected.
--
-- If the volume is a connected server, it is removed from the list of
-- connected servers.
--
-- Otherwise, no further action is done.
volumeEject   :: VolumeClass volume
              => volume                  -- ^ @volume@ - the volume to eject
              -> VolumeOpSuccessCallback -- ^ @successCallback@ - the
                                         --   callback to call once
                                         --   the operation has
                                         --   completed successfully
              -> VolumeOpFailureCallback -- ^ @failureCallback@ - the
                                         --   callback to call if the
                                         --   operation fails
              -> IO ()
volumeEject volume successCallback failureCallback =
    do cCallback <- volumeOpCallbackMarshal successCallback failureCallback
       {# call volume_eject #} (castToVolume volume) cCallback $ castFunPtrToPtr cCallback

marshalString cAction volume =
    cAction (castToVolume volume) >>= readUTFString
marshalMaybeString cAction volume =
    cAction (castToVolume volume) >>= maybePeek readUTFString

-- | Returns the activation URI of @volume@.
--
--   The returned URI usually refers to a valid location. You can
--   check the validity of the location by calling 'uriFromString'
--   with the URI, and checking whether the return value is not
--   'Nothing'.
volumeGetActivationURI  :: VolumeClass volume
                        => volume     -- ^ @volume@ - the volume to query
                        -> IO TextURI -- ^ the volume's activation URI.
volumeGetActivationURI =
    marshalString {# call volume_get_activation_uri #}

-- | Returns the device path of a 'Volume' object.
--
--   For HAL volumes, this returns the value of the volume's
--   @block.device@ key. For UNIX mounts, it returns the @mntent@'s
--   @mnt_fsname@ entry.
--
--   Otherwise, it returns 'Nothing'.
volumeGetDevicePath     :: VolumeClass volume =>
                           volume    -- ^ @volume@ - the volume object to query
                        -> IO String -- ^ the volume's device path
volumeGetDevicePath =
    marshalString {# call volume_get_device_path #}

-- | Returns the 'DeviceType' of a 'Volume' object.
volumeGetDeviceType     :: VolumeClass volume =>
                           volume        -- ^ @volume@ - the volume object to query
                        -> IO DeviceType -- the volume's device type
volumeGetDeviceType volume =
    liftM cToEnum $ {# call volume_get_device_type #} (castToVolume volume)

-- | Returns the display name of a 'Volume' object.
volumeGetDisplayName    :: VolumeClass volume =>
                           volume    -- ^ @volume@ - the volume object to query
                        -> IO String -- ^ the volume's display name
volumeGetDisplayName =
    marshalString {# call volume_get_display_name #}

-- | Returns the 'Drive' that @volume@ is on.
volumeGetDrive          :: VolumeClass volume =>
                           volume   -- ^ @volume@ - the volume object to query
                        -> IO Drive -- ^ the containing drive
volumeGetDrive volume =
    {# call volume_get_drive #} (castToVolume volume) >>= newDrive

-- | Returns a string describing the file system on @volume@, or
--   'Nothing' if no information on the underlying file system is
--   available.
--
--   The file system may be used to provide special functionality that
--   depends on the file system type, for instance to determine
--   whether trashing is supported (cf. 'volumeHandlesTrash').
--
--   For HAL mounts, this returns the value of the @\"volume.fstype\"@
--   key, for traditional UNIX mounts it is set to the mntent's
--   mnt_type key, for connected servers, 'Nothing' is returned.
volumeGetFilesystemType :: VolumeClass volume =>
                           volume            -- ^ @volume@ - the
                                             -- volume object to query
                        -> IO (Maybe String) -- ^ a string describing
                                             -- the filesystem type,
                                             -- or 'Nothing' if no
                                             -- information is
                                             -- available
volumeGetFilesystemType =
    marshalMaybeString {# call volume_get_filesystem_type #}

-- | Returns the HAL UDI of a 'Volume' object.
--
--   For HAL volumes, this matches the value of the @info.udi@ key,
--   for other volumes it is 'Nothing'.
volumeGetHalUDI :: VolumeClass volume =>
                   volume            -- ^ @volume@ - the volume object to query
                -> IO (Maybe String) -- ^ the volume's HAL UDI
volumeGetHalUDI =
    marshalMaybeString {# call volume_get_hal_udi #}

-- | Returns the icon filename for a 'Volume' object.
volumeGetIcon :: VolumeClass volume =>
                 volume      -- ^ @volume@ - a volume object
              -> IO FilePath -- ^ the icon that should be used for this volume
volumeGetIcon =
    marshalString {# call volume_get_icon #}

-- | Returns a unique identifier for a 'Volume' object.
volumeGetID :: VolumeClass volume =>
               volume      -- ^ @volume@ - a volume object
            -> IO VolumeID -- ^ a unique identifier for the volume
volumeGetID volume =
    {# call volume_get_id #} (castToVolume volume)

-- | Returns the volume type of @volume@.
volumeGetVolumeType     :: VolumeClass volume =>
                           volume        -- ^ @volume@ - the volume object to query
                        -> IO VolumeType -- ^ the volume's volume type
volumeGetVolumeType volume =
    liftM cToEnum $ {# call volume_get_volume_type #} (castToVolume volume)

marshalBool cAction volume =
    liftM toBool $ cAction (castToVolume volume)

-- | Returns whether the file system on a volume supports trashing of
--   files.
--
--   If the volume has an AutoFS file system (i.e.,
--   'volumeGetDeviceType' returns 'DeviceTypeAutofs'), or if the
--   volume is mounted read-only (i.e., 'volumeIsReadOnly' returns
--   'True'), it is assumed to not support trashing of files.
--
--   Otherwise, if the volume provides file system information, it is
--   determined whether the file system supports trashing of
--   files.
volumeHandlesTrash      :: VolumeClass volume =>
                           volume  -- ^ @volume@ -
                        -> IO Bool -- ^ 'True' if the volume handles trash, otherwise 'False'
volumeHandlesTrash =
    marshalBool {# call volume_handles_trash #}

-- | Returns whether the file system on a volume is currently mounted.
--
--   For HAL volumes, this reflects the value of the
--   @\"volume.is_mounted\"@ key, for traditional UNIX mounts and
--   connected servers, 'True' is returned, because their existence
--   implies that they are mounted.
volumeIsMounted         :: VolumeClass volume =>
                           volume  -- ^ @volume@ -
                        -> IO Bool -- ^ 'True' if the volume is mounted, otherwise 'False'
volumeIsMounted =
    marshalBool {# call volume_is_mounted #}

-- | Returns whether the file system on a volume is read-only.
--
--   For HAL volumes, the @\"volume.is_mounted_read_only\"@ key is
--   authoritative, for traditional UNIX mounts it returns TRUE if the
--   mount was done with the @\"ro\"@ option. For servers, 'False' is
--   returned.
volumeIsReadOnly        :: VolumeClass volume =>
                           volume  -- ^ @volume@ -
                        -> IO Bool -- ^ 'True' if the volume is read-only, otherwise 'False'
volumeIsReadOnly =
    marshalBool {# call volume_is_read_only #}

-- | Returns a 'Bool' for whether a volume is user-visible. This should
--   be used by applications to determine whether the volume should be
--   listed in user interfaces listing available volumes.
volumeIsUserVisible     :: VolumeClass volume =>
                           volume  -- @volume@ -
                        -> IO Bool -- ^ 'True' if the volume is user visible, otherwise 'False'
volumeIsUserVisible =
    marshalBool {# call volume_is_user_visible #}