fix for 7.8.4

fix for 7.8.4

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

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

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

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

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

import Data.Int (Int8, Int16, Int32)
import Data.Complex (Complex(..), realPart)
import Data.Coerce (coerce)
import Data.Proxy (Proxy(..))
import Data.Word (Word8, Word16, Word32)
import qualified Data.Vector.Storable as St
import qualified Data.Vector.Storable.Mutable as Stm

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

import System.IO.Unsafe (unsafePerformIO)

import GDAL.Internal.Util (toEnumC, fromEnumC)

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

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

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

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

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

------------------------------------------------------------------------------
-- GDALType
------------------------------------------------------------------------------
type CDataTypeT a = GType (DataTypeT a)

class (Eq a , Storable a , KnownDataType (DataTypeT a)) => GDALType a where
  type DataTypeT a :: DataType
  toGType    :: St.Vector    a              -> St.Vector    (CDataTypeT a)
  fromGType  :: St.Vector    (CDataTypeT a) -> St.Vector    a
  toGTypeM   :: St.MVector s a              -> St.MVector s (CDataTypeT a)
  fromGTypeM :: St.MVector s (CDataTypeT a) -> St.MVector s a

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

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

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

class (Storable (GType k), Eq (GType k)) => KnownDataType (k :: DataType) where
  dataTypeVal :: Proxy (k :: DataType) -> DataType

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

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

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

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

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

instance GDALType Int8 where
  type DataTypeT Int8 = 'GDT_Byte
  toCDouble = fromIntegral
  fromCDouble = truncate
  toGType    = St.unsafeCast
  fromGType  = St.unsafeCast
  toGTypeM   = Stm.unsafeCast
  fromGTypeM = Stm.unsafeCast
  {-# INLINE toGTypeM #-}
  {-# INLINE fromGTypeM #-}
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

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

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

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

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

#ifdef STORABLE_COMPLEX

deriving instance Storable a => Storable (CComplex a)

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

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

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

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

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

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

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

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

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

import Data.Int (Int8, Int16, Int32)
import Data.Complex (Complex(..), realPart)
import Data.Coerce (coerce)
import Data.Proxy (Proxy(..))
import Data.Word (Word8, Word16, Word32)
import qualified Data.Vector.Storable as St
import qualified Data.Vector.Storable.Mutable as Stm

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

import System.IO.Unsafe (unsafePerformIO)

import GDAL.Internal.Util (toEnumC, fromEnumC)

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

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

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

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

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

------------------------------------------------------------------------------
-- GDALType
------------------------------------------------------------------------------
type CDataTypeT a = GType (DataTypeT a)

class (Eq a , Storable a , KnownDataType (DataTypeT a)) => GDALType a where
  type DataTypeT a :: DataType
  toGType    :: St.Vector    a              -> St.Vector    (CDataTypeT a)
  fromGType  :: St.Vector    (CDataTypeT a) -> St.Vector    a
  toGTypeM   :: St.MVector s a              -> St.MVector s (CDataTypeT a)
  fromGTypeM :: St.MVector s (CDataTypeT a) -> St.MVector s a

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

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

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

class (Storable (GType k), Eq (GType k)) => KnownDataType (k :: DataType) where
  dataTypeVal :: Proxy (k :: DataType) -> DataType

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

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

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

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

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

instance GDALType Int8 where
  type DataTypeT Int8 = 'GDT_Byte
  toCDouble = fromIntegral
  fromCDouble = truncate
  toGType    = St.unsafeCast
  fromGType  = St.unsafeCast
  toGTypeM   = Stm.unsafeCast
  fromGTypeM = Stm.unsafeCast
  {-# INLINE toGTypeM #-}
  {-# INLINE fromGTypeM #-}
  {-# INLINE toGType #-}
  {-# INLINE fromGType #-}
  {-# INLINE toCDouble #-}
  {-# INLINE fromCDouble #-}

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

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

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

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

#ifdef STORABLE_COMPLEX

deriving instance Storable a => Storable (CComplex a)

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

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

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

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


Remove extra file with conflicting case

Remove extra file with conflicting case

{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Graphics.UI.FLTK.LowLevel.GlWindow ()
where
#include "Fl_C.h"
#include "Fl_Gl_WindowC.h"
import Foreign
import Foreign.C
import Graphics.UI.FLTK.LowLevel.Fl_Types
import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
import Graphics.UI.FLTK.LowLevel.Utils
import Graphics.UI.FLTK.LowLevel.Dispatch
import Graphics.UI.FLTK.LowLevel.Hierarchy

{# fun Fl_DerivedGl_Window_flush as flush' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Flush ()) GlWindow orig impl where
  runOp _ _ win = withRef win $ \winPtr -> flush' winPtr
{# fun Fl_DerivedGl_Window_hide as hide' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Hide ()) GlWindow orig impl where
  runOp _ _ win = withRef win $ \winPtr -> hide' winPtr
{# fun Fl_DerivedGl_Window_show as show' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (ShowWidget ()) GlWindow orig impl where
  runOp _ _ win = withRef win $ \winPtr -> show' winPtr
{# fun Fl_DerivedGl_Window_handle as handle' { id `Ptr ()', cFromEnum `Event' } -> `Int' #}
instance (impl ~ (Event ->  IO(Either UnknownEvent ()))) => Op (Handle ()) GlWindow orig impl where
  runOp _ _ self event = withRef self $ \selfPtr -> handle' selfPtr event >>= return  . successOrUnknownEvent
{# fun Fl_DerivedGl_Window_Destroy as windowDestroy' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ (IO ())) => Op (Destroy ()) GlWindow orig impl where
  runOp _ _ win = withRef win $ \winPtr -> windowDestroy' winPtr
{# fun Fl_DerivedGl_Window_resize as resize' { id `Ptr ()',`Int',`Int',`Int',`Int' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Rectangle ->  IO ())) => Op (Resize ()) GlWindow orig impl where
  runOp _ _ win rectangle' =
    let (x_pos', y_pos', width', height') = fromRectangle rectangle' in
    withRef win $ \winPtr -> resize' winPtr x_pos' y_pos' width' height'


Haddock for ComparisonResult

Haddock for ComparisonResult

{-# LANGUAGE ForeignFunctionInterface #-}

#include "comparison_result.h"

-----------------------------------------------------------------------------
{- |
Module      : Control.Parallel.MPI.ComparisonResult
Copyright   : (c) 2010 Bernie Pope, Dmitry Astapov
License     : BSD-style
Maintainer  : florbitous@gmail.com
Stability   : experimental
Portability : ghc

This module provides Haskell enum that comprises of MPI constants
@MPI_IDENT@, @MPI_CONGRUENT@, @MPI_SIMILAR@ and @MPI_UNEQUAL@.

Those are used to compare communicators (f.e. 'commCompare') and
process groups (f.e. 'groupCompare').
-}
-----------------------------------------------------------------------------
module Control.Parallel.MPI.ComparisonResult (ComparisonResult (..)) where

{# context prefix = "MPI" #}

{# enum ComparisonResult {underscoreToCase} deriving (Eq,Ord,Show) #}

{-# LANGUAGE ForeignFunctionInterface #-}

#include "comparison_result.h"

module Control.Parallel.MPI.ComparisonResult (ComparisonResult (..)) where

{# context prefix = "MPI" #}

{# enum ComparisonResult {underscoreToCase} deriving (Eq,Ord,Show) #}


[project @ 2002-07-12 13:09:23 by dg22] Fixed references that used the old names for packing widgets.

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Widget Notebook@
--
--  Author : Axel Simon
--
--  Created: 15 May 2001
--
--  Version $Revision: 1.3 $ from $Date: 2002/07/12 13:09:23 $
--
--  Copyright (c) 1999..2002 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@ --------------------------------------------------------------
--
-- * This widget can display several pages of widgets. Each page can be
--   selected by a tab at the top of the widget. It is useful in dialogs where
--   a lot of information has to be displayed.
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------
--
-- * check if it is sensible and possible to have something else than a Label
--   widget in the context menu. If so, change the notebook*PageMenu function
--   and add notebookSetMenuLabel and notebookSetMenuText.
--
-- * notebookSetTabLabelText is not bound.
--
-- * The signals focus-tab and select-page are not bound because it is unclear
--   what they mean. As far as I can see they are not emitted anywhere.
--
module Notebook(
  Notebook,
  NotebookClass,
  castToNotebook,
  notebookNew,
  notebookAppendPage,
  notebookAppendPageMenu,
  notebookPrependPage,
  notebookPrependPageMenu,
  notebookInsertPage,
  notebookInsertPageMenu,
  notebookRemovePage,
  notebookPageNum,
  notebookSetCurrentPage,
  notebookNextPage,
  notebookPrevPage,
  notebookReorderChild,
  PositionType(..),
  notebookSetTabPos,
  notebookSetShowTabs,
  notebookSetShowBorder,
  notebookSetScrollable,
  notebookSetTabBorder,
  notebookSetTabHBorder,
  notebookSetTabVBorder,
  notebookSetPopup,
  notebookGetCurrentPage,
  notebookGetMenuLabel,
  notebookGetNthPage,
  notebookGetTabLabel,
  Packing(..), PackType(..),
  notebookQueryTabLabelPacking,
  notebookSetTabLabelPacking,
  notebookSetHomogeneousTabs,
  notebookSetTabLabel,
  onSwitchPage,
  afterSwitchPage
  ) where

import Monad	(liftM)
import Maybe	(maybe)
import Foreign
import UTFCForeign
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Label	(labelNew)
import Enums	(Packing(..), PackType(..), PositionType(..))

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

-- methods

-- @constructor notebookNew@ Create a new notebook.
--
notebookNew :: IO Notebook
notebookNew  = makeNewObject mkNotebook $
  liftM castPtr {#call unsafe notebook_new#}

-- @method notebookAppendPage@ Insert a new tab to the right of the existing
-- tabs.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookAppendPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookAppendPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                      String -> IO ()
notebookAppendPage nb child tabLabel = do
  tab <- labelNew (Just tabLabel)
  {#call notebook_append_page#} (toNotebook nb) (toWidget child)
    (toWidget tab)

-- @method notebookAppendPageMenu@ Insert a new tab to the right of the
-- existing tabs. @ref arg menuLabel@ is the label for the context menu
-- (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookAppendPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> IO ()
notebookAppendPageMenu nb child tabWidget menuLabel = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_append_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu)

-- @method notebookPrependPage@ Insert a new tab to the left of the existing
-- tabs.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookPrependPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookPrependPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                       String -> IO ()
notebookPrependPage nb child tabLabel = do
  tab <- labelNew (Just tabLabel)
  {#call notebook_prepend_page#} (toNotebook nb) (toWidget child) (toWidget tab)

-- @method notebookPrependPageMenu@ Insert a new tab to the left of the
-- existing tabs. @ref arg menuLabel@ is the label for the context menu
-- (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookPrependPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> IO ()
notebookPrependPageMenu nb child tabWidget menuLabel = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_prepend_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu)

-- @method notebookInsertPage@ Insert a new tab at the specified position.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookInsertPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookInsertPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                      String -> Int -> IO ()
notebookInsertPage nb child tabLabel pos = do
  lbl <- labelNew (Just tabLabel)
  {#call notebook_insert_page#} (toNotebook nb) (toWidget child)
     (toWidget lbl) (fromIntegral pos)

-- @method notebookInsertPageMenu@ Insert a new tab between the tab no.
-- @ref arg pos@ and @ref arg pos@+1. @ref arg menuLabel@ is the label for the
-- context menu (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookInsertPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> Int -> IO ()
notebookInsertPageMenu nb child tabWidget menuLabel pos = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_insert_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu) (fromIntegral pos)

-- @method notebookRemovePage@ Remove a specific page from the notebook,
-- counting from 0.
--
notebookRemovePage :: NotebookClass nb => nb -> Int -> IO ()
notebookRemovePage nb pos =
  {#call notebook_remove_page#} (toNotebook nb) (fromIntegral pos)

-- @method notebookPageNum@ Query the page the @ref arg child@ widget is
-- contained in.
--
-- * The function returns the page number if the child was found, Nothing
--   otherwise.
--
notebookPageNum :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                   IO (Maybe Int)
notebookPageNum nb child =
  liftM (\page -> if page==(-1) then Nothing else Just (fromIntegral page)) $
  {#call unsafe notebook_page_num#} (toNotebook nb) (toWidget child)

-- @method notebookSetCurrentPage@ Move to the specified page of the notebook.
--
-- * If @ref arg pos@ is out of range (e.g. negative) select the last page.
--
notebookSetCurrentPage :: NotebookClass nb => nb -> Int -> IO ()
notebookSetCurrentPage nb pos =
  {#call notebook_set_current_page#} (toNotebook nb) (fromIntegral pos)

-- @method notebookNextPage@ Move to the right neighbour of the current page.
--
-- * Nothing happens if there is no such page.
--
notebookNextPage :: NotebookClass nb => nb -> IO ()
notebookNextPage nb = {#call notebook_next_page#} (toNotebook nb)

-- @method notebookPrevPage@ Move to the left neighbour of the current page.
--
-- * Nothing happens if there is no such page.
--
notebookPrevPage :: NotebookClass nb => nb -> IO ()
notebookPrevPage nb = {#call notebook_prev_page#} (toNotebook nb)

-- @method notebookReorderChild@ Move a page withing the notebook.
--
notebookReorderChild :: (NotebookClass nb, WidgetClass w) => nb -> w -> Int ->
                        IO ()
notebookReorderChild nb child pos = {#call notebook_reorder_child#}
  (toNotebook nb) (toWidget child) (fromIntegral pos)

-- @method notebookSetTabPos@ Specify at which border the tabs should be
-- drawn.
--
notebookSetTabPos :: NotebookClass nb => nb -> PositionType -> IO ()
notebookSetTabPos nb pt = {#call notebook_set_tab_pos#}
  (toNotebook nb) ((fromIntegral.fromEnum) pt)

-- @method notebookSetShowTabs@ Show or hide the tabs of a notebook.
--
notebookSetShowTabs :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetShowTabs nb showTabs = {#call notebook_set_show_tabs#}
  (toNotebook nb) (fromBool showTabs)

-- @method notebookSetShowBorder@ In case the tabs are not shown, specify
-- whether to draw a border around the notebook.
--
notebookSetShowBorder :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetShowBorder nb showBorder = {#call notebook_set_show_border#}
  (toNotebook nb) (fromBool showBorder)

-- @method notebookSetScrollable@ Set whether scroll bars will be added in
-- case the notebook has too many tabs to fit the widget size.
--
notebookSetScrollable :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetScrollable nb scrollable = {#call unsafe notebook_set_scrollable#}
  (toNotebook nb) (fromBool scrollable)

-- @method notebookSetTabBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets both vertical and horizontal widths.
--
notebookSetTabBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabBorder nb width = {#call notebook_set_tab_border#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetTabHBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets horizontal widths.
--
notebookSetTabHBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabHBorder nb width = {#call notebook_set_tab_hborder#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetTabVBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets vertical widths.
--
notebookSetTabVBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabVBorder nb width = {#call notebook_set_tab_vborder#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetPopup@ Enable or disable context menus with all tabs in
-- it.
--
notebookSetPopup :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetPopup nb enable = (if enable
  then {#call notebook_popup_enable#} else {#call notebook_popup_disable#})
  (toNotebook nb)

-- @method notebookGetCurrentPage@ Query the currently selected page.
--
-- * Returns -1 if notebook has no pages.
--
notebookGetCurrentPage :: NotebookClass nb => nb -> IO Int
notebookGetCurrentPage nb = liftM fromIntegral $
  {#call unsafe notebook_get_current_page#} (toNotebook nb)

-- @method notebookGetMenuLabel@ Extract the menu label from the given
-- @ref arg child@.
--
-- * Returns Nothing if @ref arg child@ was not found.
--
notebookGetMenuLabel :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                        IO (Maybe Label)
notebookGetMenuLabel nb child = do
  wPtr <- {#call unsafe notebook_get_menu_label#}
    (toNotebook nb) (toWidget child)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkLabel $ return $ castPtr wPtr

-- @method notebookGetNthPage@ Retrieve the child widget at positon
-- @ref arg pos@ (stating from 0).
--
-- * Returns Nothing if the index is out of bounds.
--
notebookGetNthPage :: NotebookClass nb => nb -> Int -> IO (Maybe Widget)
notebookGetNthPage nb pos = do
  wPtr <- {#call unsafe notebook_get_nth_page#}
    (toNotebook nb) (fromIntegral pos)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkWidget $ return wPtr

-- @method notebookGetTabLabel@ Extract the tab label from the given
-- @ref arg child@.
--
notebookGetTabLabel :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                       IO (Maybe Label)
notebookGetTabLabel nb child = do
  wPtr <- {#call unsafe notebook_get_tab_label#}
    (toNotebook nb) (toWidget child)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkLabel $ return $ castPtr wPtr

-- @method notebookQueryTabLabelPacking@ Query the packing attributes of the
-- given @ref arg child@.
--
notebookQueryTabLabelPacking :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                                IO (Packing,PackType)
notebookQueryTabLabelPacking nb child =
  alloca $ \expPtr -> alloca $ \fillPtr -> alloca $ \packPtr -> do
    {#call unsafe notebook_query_tab_label_packing#} (toNotebook nb)
      (toWidget child) expPtr fillPtr packPtr
    expand <- liftM toBool $ peek expPtr
    fill <- liftM toBool $ peek fillPtr
    pt <- liftM (toEnum.fromIntegral) $ peek packPtr
    return (if fill then PackGrow else
             (if expand then PackRepel else PackNatural),
	    pt)

-- @method notebookSetTabLabelPacking@ Set the packing attributes of the given
-- @ref arg child@.
--
notebookSetTabLabelPacking :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                              Packing -> PackType -> IO ()
notebookSetTabLabelPacking nb child pack pt =
  {#call notebook_set_tab_label_packing#} (toNotebook nb) (toWidget child)
    (fromBool $ pack/=PackNatural) (fromBool $ pack==PackGrow)
    ((fromIntegral.fromEnum) pt)

-- @method notebookSetHomogeneousTabs@ Sets whether the tabs must have all the
-- same size or not.
--
notebookSetHomogeneousTabs :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetHomogeneousTabs nb hom = {#call notebook_set_homogeneous_tabs#}
  (toNotebook nb) (fromBool hom)

-- @method notebookSetTabLabel@ Set a new tab label for a given
-- @ref arg child@.
--
notebookSetTabLabel :: (NotebookClass nb, WidgetClass ch, WidgetClass tab) =>
                       nb -> ch -> tab -> IO ()
notebookSetTabLabel nb child tab = {#call notebook_set_tab_label#}
  (toNotebook nb) (toWidget child) (toWidget tab)

-- signals

-- @signal connectToSwitchPage@ This signal is emitted when a new page is
-- selected.
--
onSwitchPage, afterSwitchPage :: NotebookClass nb => nb -> (Int -> IO ()) ->
                                 IO (ConnectId nb)
onSwitchPage nb fun = connect_BOXED_WORD__NONE "switch-page"
		      (const $ return ()) False nb
		      (\_ page -> fun (fromIntegral page))
afterSwitchPage nb fun = connect_BOXED_WORD__NONE "switch-page"
			 (const $ return ()) True nb
			 (\_ page -> fun (fromIntegral page))

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Widget Notebook@
--
--  Author : Axel Simon
--
--  Created: 15 May 2001
--
--  Version $Revision: 1.2 $ from $Date: 2002/05/24 09:43:25 $
--
--  Copyright (c) 1999..2002 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@ --------------------------------------------------------------
--
-- * This widget can display several pages of widgets. Each page can be
--   selected by a tab at the top of the widget. It is useful in dialogs where
--   a lot of information has to be displayed.
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------
--
-- * check if it is sensible and possible to have something else than a Label
--   widget in the context menu. If so, change the notebook*PageMenu function
--   and add notebookSetMenuLabel and notebookSetMenuText.
--
-- * notebookSetTabLabelText is not bound.
--
-- * The signals focus-tab and select-page are not bound because it is unclear
--   what they mean. As far as I can see they are not emitted anywhere.
--
module Notebook(
  Notebook,
  NotebookClass,
  castToNotebook,
  notebookNew,
  notebookAppendPage,
  notebookAppendPageMenu,
  notebookPrependPage,
  notebookPrependPageMenu,
  notebookInsertPage,
  notebookInsertPageMenu,
  notebookRemovePage,
  notebookPageNum,
  notebookSetCurrentPage,
  notebookNextPage,
  notebookPrevPage,
  notebookReorderChild,
  PositionType(..),
  notebookSetTabPos,
  notebookSetShowTabs,
  notebookSetShowBorder,
  notebookSetScrollable,
  notebookSetTabBorder,
  notebookSetTabHBorder,
  notebookSetTabVBorder,
  notebookSetPopup,
  notebookGetCurrentPage,
  notebookGetMenuLabel,
  notebookGetNthPage,
  notebookGetTabLabel,
  Packing(..), PackType(..),
  notebookQueryTabLabelPacking,
  notebookSetTabLabelPacking,
  notebookSetHomogeneousTabs,
  notebookSetTabLabel,
  onSwitchPage,
  afterSwitchPage
  ) where

import Monad	(liftM)
import Maybe	(maybe)
import Foreign
import UTFCForeign
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Label	(labelNew)
import Enums	(Packing(..), PackType(..), PositionType(..))

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

-- methods

-- @constructor notebookNew@ Create a new notebook.
--
notebookNew :: IO Notebook
notebookNew  = makeNewObject mkNotebook $
  liftM castPtr {#call unsafe notebook_new#}

-- @method notebookAppendPage@ Insert a new tab to the right of the existing
-- tabs.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookAppendPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookAppendPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                      String -> IO ()
notebookAppendPage nb child tabLabel = do
  tab <- labelNew (Just tabLabel)
  {#call notebook_append_page#} (toNotebook nb) (toWidget child)
    (toWidget tab)

-- @method notebookAppendPageMenu@ Insert a new tab to the right of the
-- existing tabs. @ref arg menuLabel@ is the label for the context menu
-- (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookAppendPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> IO ()
notebookAppendPageMenu nb child tabWidget menuLabel = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_append_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu)

-- @method notebookPrependPage@ Insert a new tab to the left of the existing
-- tabs.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookPrependPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookPrependPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                       String -> IO ()
notebookPrependPage nb child tabLabel = do
  tab <- labelNew (Just tabLabel)
  {#call notebook_prepend_page#} (toNotebook nb) (toWidget child) (toWidget tab)

-- @method notebookPrependPageMenu@ Insert a new tab to the left of the
-- existing tabs. @ref arg menuLabel@ is the label for the context menu
-- (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookPrependPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> IO ()
notebookPrependPageMenu nb child tabWidget menuLabel = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_prepend_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu)

-- @method notebookInsertPage@ Insert a new tab at the specified position.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookInsertPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookInsertPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                      String -> Int -> IO ()
notebookInsertPage nb child tabLabel pos = do
  lbl <- labelNew (Just tabLabel)
  {#call notebook_insert_page#} (toNotebook nb) (toWidget child)
     (toWidget lbl) (fromIntegral pos)

-- @method notebookInsertPageMenu@ Insert a new tab between the tab no.
-- @ref arg pos@ and @ref arg pos@+1. @ref arg menuLabel@ is the label for the
-- context menu (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookInsertPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> Int -> IO ()
notebookInsertPageMenu nb child tabWidget menuLabel pos = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_insert_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu) (fromIntegral pos)

-- @method notebookRemovePage@ Remove a specific page from the notebook,
-- counting from 0.
--
notebookRemovePage :: NotebookClass nb => nb -> Int -> IO ()
notebookRemovePage nb pos =
  {#call notebook_remove_page#} (toNotebook nb) (fromIntegral pos)

-- @method notebookPageNum@ Query the page the @ref arg child@ widget is
-- contained in.
--
-- * The function returns the page number if the child was found, Nothing
--   otherwise.
--
notebookPageNum :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                   IO (Maybe Int)
notebookPageNum nb child =
  liftM (\page -> if page==(-1) then Nothing else Just (fromIntegral page)) $
  {#call unsafe notebook_page_num#} (toNotebook nb) (toWidget child)

-- @method notebookSetCurrentPage@ Move to the specified page of the notebook.
--
-- * If @ref arg pos@ is out of range (e.g. negative) select the last page.
--
notebookSetCurrentPage :: NotebookClass nb => nb -> Int -> IO ()
notebookSetCurrentPage nb pos =
  {#call notebook_set_current_page#} (toNotebook nb) (fromIntegral pos)

-- @method notebookNextPage@ Move to the right neighbour of the current page.
--
-- * Nothing happens if there is no such page.
--
notebookNextPage :: NotebookClass nb => nb -> IO ()
notebookNextPage nb = {#call notebook_next_page#} (toNotebook nb)

-- @method notebookPrevPage@ Move to the left neighbour of the current page.
--
-- * Nothing happens if there is no such page.
--
notebookPrevPage :: NotebookClass nb => nb -> IO ()
notebookPrevPage nb = {#call notebook_prev_page#} (toNotebook nb)

-- @method notebookReorderChild@ Move a page withing the notebook.
--
notebookReorderChild :: (NotebookClass nb, WidgetClass w) => nb -> w -> Int ->
                        IO ()
notebookReorderChild nb child pos = {#call notebook_reorder_child#}
  (toNotebook nb) (toWidget child) (fromIntegral pos)

-- @method notebookSetTabPos@ Specify at which border the tabs should be
-- drawn.
--
notebookSetTabPos :: NotebookClass nb => nb -> PositionType -> IO ()
notebookSetTabPos nb pt = {#call notebook_set_tab_pos#}
  (toNotebook nb) ((fromIntegral.fromEnum) pt)

-- @method notebookSetShowTabs@ Show or hide the tabs of a notebook.
--
notebookSetShowTabs :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetShowTabs nb showTabs = {#call notebook_set_show_tabs#}
  (toNotebook nb) (fromBool showTabs)

-- @method notebookSetShowBorder@ In case the tabs are not shown, specify
-- whether to draw a border around the notebook.
--
notebookSetShowBorder :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetShowBorder nb showBorder = {#call notebook_set_show_border#}
  (toNotebook nb) (fromBool showBorder)

-- @method notebookSetScrollable@ Set whether scroll bars will be added in
-- case the notebook has too many tabs to fit the widget size.
--
notebookSetScrollable :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetScrollable nb scrollable = {#call unsafe notebook_set_scrollable#}
  (toNotebook nb) (fromBool scrollable)

-- @method notebookSetTabBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets both vertical and horizontal widths.
--
notebookSetTabBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabBorder nb width = {#call notebook_set_tab_border#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetTabHBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets horizontal widths.
--
notebookSetTabHBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabHBorder nb width = {#call notebook_set_tab_hborder#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetTabVBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets vertical widths.
--
notebookSetTabVBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabVBorder nb width = {#call notebook_set_tab_vborder#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetPopup@ Enable or disable context menus with all tabs in
-- it.
--
notebookSetPopup :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetPopup nb enable = (if enable
  then {#call notebook_popup_enable#} else {#call notebook_popup_disable#})
  (toNotebook nb)

-- @method notebookGetCurrentPage@ Query the currently selected page.
--
-- * Returns -1 if notebook has no pages.
--
notebookGetCurrentPage :: NotebookClass nb => nb -> IO Int
notebookGetCurrentPage nb = liftM fromIntegral $
  {#call unsafe notebook_get_current_page#} (toNotebook nb)

-- @method notebookGetMenuLabel@ Extract the menu label from the given
-- @ref arg child@.
--
-- * Returns Nothing if @ref arg child@ was not found.
--
notebookGetMenuLabel :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                        IO (Maybe Label)
notebookGetMenuLabel nb child = do
  wPtr <- {#call unsafe notebook_get_menu_label#}
    (toNotebook nb) (toWidget child)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkLabel $ return $ castPtr wPtr

-- @method notebookGetNthPage@ Retrieve the child widget at positon
-- @ref arg pos@ (stating from 0).
--
-- * Returns Nothing if the index is out of bounds.
--
notebookGetNthPage :: NotebookClass nb => nb -> Int -> IO (Maybe Widget)
notebookGetNthPage nb pos = do
  wPtr <- {#call unsafe notebook_get_nth_page#}
    (toNotebook nb) (fromIntegral pos)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkWidget $ return wPtr

-- @method notebookGetTabLabel@ Extract the tab label from the given
-- @ref arg child@.
--
notebookGetTabLabel :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                       IO (Maybe Label)
notebookGetTabLabel nb child = do
  wPtr <- {#call unsafe notebook_get_tab_label#}
    (toNotebook nb) (toWidget child)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkLabel $ return $ castPtr wPtr

-- @method notebookQueryTabLabelPacking@ Query the packing attributes of the
-- given @ref arg child@.
--
notebookQueryTabLabelPacking :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                                IO (Packing,PackType)
notebookQueryTabLabelPacking nb child =
  alloca $ \expPtr -> alloca $ \fillPtr -> alloca $ \packPtr -> do
    {#call unsafe notebook_query_tab_label_packing#} (toNotebook nb)
      (toWidget child) expPtr fillPtr packPtr
    expand <- liftM toBool $ peek expPtr
    fill <- liftM toBool $ peek fillPtr
    pt <- liftM (toEnum.fromIntegral) $ peek packPtr
    return (if fill then PackFill else
             (if expand then PackExpand else PackNatural),
	    pt)

-- @method notebookSetTabLabelPacking@ Set the packing attributes of the given
-- @ref arg child@.
--
notebookSetTabLabelPacking :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                              Packing -> PackType -> IO ()
notebookSetTabLabelPacking nb child pack pt =
  {#call notebook_set_tab_label_packing#} (toNotebook nb) (toWidget child)
    (fromBool $ pack/=PackNatural) (fromBool $ pack==PackFill)
    ((fromIntegral.fromEnum) pt)

-- @method notebookSetHomogeneousTabs@ Sets whether the tabs must have all the
-- same size or not.
--
notebookSetHomogeneousTabs :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetHomogeneousTabs nb hom = {#call notebook_set_homogeneous_tabs#}
  (toNotebook nb) (fromBool hom)

-- @method notebookSetTabLabel@ Set a new tab label for a given
-- @ref arg child@.
--
notebookSetTabLabel :: (NotebookClass nb, WidgetClass ch, WidgetClass tab) =>
                       nb -> ch -> tab -> IO ()
notebookSetTabLabel nb child tab = {#call notebook_set_tab_label#}
  (toNotebook nb) (toWidget child) (toWidget tab)

-- signals

-- @signal connectToSwitchPage@ This signal is emitted when a new page is
-- selected.
--
onSwitchPage, afterSwitchPage :: NotebookClass nb => nb -> (Int -> IO ()) ->
                                 IO (ConnectId nb)
onSwitchPage nb fun = connect_BOXED_WORD__NONE "switch-page"
		      (const $ return ()) False nb
		      (\_ page -> fun (fromIntegral page))
afterSwitchPage nb fun = connect_BOXED_WORD__NONE "switch-page"
			 (const $ return ()) True nb
			 (\_ page -> fun (fromIntegral page))


cleanup

cleanup

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE BangPatterns #-}

module GDAL.Internal.OSR (
    SpatialReference
  , CoordinateTransformation

  , srsFromWkt
  , srsFromProj4
  , srsFromEPSG
  , srsFromXML

  , srsToWkt
  , srsToProj4
  , srsToXML

  , isGeographic
  , isLocal
  , isProjected
  , isSameGeogCS
  , isSame

  , getAngularUnits
  , getLinearUnits

  , coordinateTransformation

  , cleanup
  , initialize
  , srsFromWktIO
  , withSpatialReference
  , withMaybeSRAsCString
  , withMaybeSpatialReference
  , withCoordinateTransformation
  , newSpatialRefHandle
  , newSpatialRefBorrowedHandle
  , maybeNewSpatialRefHandle
  , maybeNewSpatialRefBorrowedHandle
) where

#include "ogr_srs_api.h"

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

import Control.Applicative ((<$>), (<*>))
import Control.Exception (catch, bracketOnError, try)
import Control.Monad (liftM, (>=>), when, void)

import Data.ByteString (ByteString)
import Data.ByteString.Unsafe (unsafeUseAsCString)

import Foreign.C.String (CString, peekCString)
import Foreign.C.Types (CInt(..), CDouble(..), CChar(..))
import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr)
import Foreign.Storable (Storable(..))
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, newForeignPtr)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Utils (toBool)

import System.IO.Unsafe (unsafePerformIO)

import GDAL.Internal.OGRError
import GDAL.Internal.CPLError hiding (None)
import GDAL.Internal.CPLString (peekCPLString)

{#pointer OGRSpatialReferenceH as SpatialReference foreign newtype#}

instance Show SpatialReference where
   show = show . srsToWkt

srsToWkt :: SpatialReference -> ByteString
srsToWkt s = exportWith fun s
  where
    fun s' p = {#call unsafe ExportToPrettyWkt as ^#} s' p 1

srsToProj4 :: SpatialReference -> ByteString
srsToProj4 = exportWith {#call unsafe ExportToProj4 as ^#}

srsToXML :: SpatialReference -> ByteString
srsToXML = exportWith fun
  where
    fun s' p = {#call unsafe ExportToXML as ^#} s' p (castPtr nullPtr)

exportWith
  :: (Ptr SpatialReference -> Ptr CString -> IO CInt)
  -> SpatialReference
  -> ByteString
exportWith fun srs =
  unsafePerformIO $
  withSpatialReference srs $ \pSrs ->
  peekCPLString $
  checkOGRError . fun pSrs
{-# NOINLINE exportWith #-}

foreign import ccall "ogr_srs_api.h &OSRRelease"
  c_release :: FunPtr (Ptr SpatialReference -> IO ())

newSpatialRefHandle
  :: IO (Ptr SpatialReference) -> IO SpatialReference
newSpatialRefHandle = maybeNewSpatialRefHandle >=> maybe exc return
  where exc = throwBindingException NullSpatialReference

maybeNewSpatialRefHandle
  :: IO (Ptr SpatialReference) -> IO (Maybe SpatialReference)
maybeNewSpatialRefHandle alloc = bracketOnError alloc freeIfNotNull go
  where
    go p
      | p==nullPtr = return Nothing
      | otherwise  = liftM (Just . SpatialReference) (newForeignPtr c_release p)
    freeIfNotNull p
      | p/=nullPtr = {#call unsafe OSRRelease as ^#} p
      | otherwise  = return ()

newSpatialRefBorrowedHandle
  :: IO (Ptr SpatialReference) -> IO SpatialReference
newSpatialRefBorrowedHandle =
  maybeNewSpatialRefBorrowedHandle >=> maybe exc return
  where exc = throwBindingException NullSpatialReference

maybeNewSpatialRefBorrowedHandle
  :: IO (Ptr SpatialReference) -> IO (Maybe SpatialReference)
maybeNewSpatialRefBorrowedHandle alloc = maybeNewSpatialRefHandle $ do
  p <- alloc
  when (p /= nullPtr) (void ({#call unsafe OSRReference as ^#} p))
  return p

emptySpatialRef :: IO SpatialReference
emptySpatialRef =
  newSpatialRefHandle ({#call unsafe NewSpatialReference as ^#} nullPtr)

srsFromWkt, srsFromProj4, srsFromXML
  :: ByteString -> Either OGRException SpatialReference
srsFromWkt = unsafePerformIO . (flip unsafeUseAsCString srsFromWktIO)
{-# NOINLINE srsFromWkt #-}

srsFromWktIO :: CString -> IO (Either OGRException SpatialReference)
srsFromWktIO a =
  (liftM Right
    (newSpatialRefHandle ({#call unsafe NewSpatialReference as ^#} a)))
  `catch` (return . Left)

srsFromProj4 = fromImporter importFromProj4
{-# NOINLINE srsFromProj4 #-}

srsFromXML = fromImporter importFromXML
{-# NOINLINE srsFromXML #-}

srsFromEPSG :: Int -> Either OGRException SpatialReference
srsFromEPSG = fromImporter importFromEPSG
{-# NOINLINE srsFromEPSG #-}

fromImporter
  :: (SpatialReference -> a -> IO CInt) -> a
  -> Either OGRException SpatialReference
fromImporter f s = unsafePerformIO $ do
  r <- emptySpatialRef
  try (checkOGRError (f r s) >> return r)
{-# NOINLINE fromImporter #-}

{#fun ImportFromProj4 as ^
   { withSpatialReference* `SpatialReference'
   , unsafeUseAsCString* `ByteString'} -> `CInt' #}

{#fun ImportFromEPSG as ^
   {withSpatialReference* `SpatialReference', `Int'} -> `CInt' #}

{#fun ImportFromXML as ^
   { withSpatialReference* `SpatialReference'
   , unsafeUseAsCString* `ByteString'} -> `CInt' #}

{#fun pure unsafe IsGeographic as ^
   {withSpatialReference* `SpatialReference'} -> `Bool'#}

{#fun pure unsafe IsLocal as ^
   {withSpatialReference* `SpatialReference'} -> `Bool'#}

{#fun pure unsafe IsProjected as ^
   {withSpatialReference* `SpatialReference'} -> `Bool'#}

{#fun pure unsafe IsSameGeogCS as ^
   { withSpatialReference* `SpatialReference'
   , withSpatialReference* `SpatialReference'} -> `Bool'#}

{#fun pure unsafe IsSame as ^
   { withSpatialReference* `SpatialReference'
   , withSpatialReference* `SpatialReference'} -> `Bool'#}

instance Eq SpatialReference where
  (==) = isSame

getLinearUnits :: SpatialReference -> (Double, String)
getLinearUnits =
  unsafePerformIO . getUnitsWith {#call unsafe OSRGetLinearUnits as ^#}

getAngularUnits :: SpatialReference -> (Double, String)
getAngularUnits =
  unsafePerformIO . getUnitsWith {#call unsafe OSRGetAngularUnits as ^#}

getUnitsWith
  :: (Ptr SpatialReference -> Ptr CString -> IO CDouble)
  -> SpatialReference
  -> IO (Double, String)
getUnitsWith fun s = alloca $ \p -> do
  value <- withSpatialReference s (\s' -> fun s' p)
  ptr <- peek p
  units <- peekCString ptr
  return (realToFrac value, units)

withMaybeSRAsCString :: Maybe SpatialReference -> (CString -> IO a) -> IO a
withMaybeSRAsCString Nothing    = ($ nullPtr)
withMaybeSRAsCString (Just srs) = unsafeUseAsCString (srsToWkt srs)

withMaybeSpatialReference
  :: Maybe SpatialReference -> (Ptr SpatialReference -> IO a) -> IO a
withMaybeSpatialReference Nothing  = ($ nullPtr)
withMaybeSpatialReference (Just s) = withSpatialReference s

{#pointer OGRCoordinateTransformationH as CoordinateTransformation
  foreign newtype#}

coordinateTransformation
  :: SpatialReference -> SpatialReference -> Maybe CoordinateTransformation
coordinateTransformation source =
  unsafePerformIO . coordinateTransformationIO source
{-# NOINLINE coordinateTransformation #-}

coordinateTransformationIO
  :: SpatialReference
  -> SpatialReference
  -> IO (Maybe CoordinateTransformation)
coordinateTransformationIO source target =
  bracketOnError alloc freeIfNotNull go
  where
    alloc =
      withSpatialReference source $ \pSource ->
      withSpatialReference target $ \pTarget ->
      {#call unsafe OCTNewCoordinateTransformation as ^#} pSource pTarget

    go p
      | p==nullPtr = return Nothing
      | otherwise  = liftM (Just . CoordinateTransformation)
                           (newForeignPtr c_destroyCT p)
    freeIfNotNull p
      | p/=nullPtr = {#call unsafe OCTDestroyCoordinateTransformation as ^#} p
      | otherwise  = return ()

foreign import ccall "ogr_srs_api.h &OCTDestroyCoordinateTransformation"
  c_destroyCT :: FunPtr (Ptr CoordinateTransformation -> IO ())

{#fun OSRCleanup as cleanup {} -> `()'#}

-- | GDAL doesn't call ogr/ogrct.cpp:LoadProj4Library in a thread-safe way
--   (at least in 1.11.2). We indirectly make sure it is called at startup
--   in the main thread (via 'withGDAL') with this function which creates
--   a dummy 'CoordinateTransformation'
initialize :: IO ()
initialize = do
  dummy <- emptySpatialRef
  void (coordinateTransformationIO dummy dummy)

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}

module GDAL.Internal.OSR (
    SpatialReference
  , CoordinateTransformation

  , srsFromWkt
  , srsFromProj4
  , srsFromEPSG
  , srsFromXML

  , srsToWkt
  , srsToProj4
  , srsToXML

  , coordinateTransformation

  , isGeographic
  , isLocal
  , isProjected
  , isSameGeogCS
  , isSame

  , getAngularUnits
  , getLinearUnits

  , cleanup
  , initialize
  , srsFromWktIO
  , withSpatialReference
  , withMaybeSRAsCString
  , withMaybeSpatialReference
  , withCoordinateTransformation
  , newSpatialRefHandle
  , newSpatialRefBorrowedHandle
  , maybeNewSpatialRefHandle
  , maybeNewSpatialRefBorrowedHandle
) where

#include "ogr_srs_api.h"

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

import Control.Applicative ((<$>), (<*>))
import Control.Exception (catch, bracketOnError, try)
import Control.Monad (liftM, (>=>), when, void)

import Data.ByteString (ByteString)
import Data.ByteString.Unsafe (unsafeUseAsCString)

import Foreign.C.String (CString, peekCString)
import Foreign.C.Types (CInt(..), CDouble(..), CChar(..))
import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr)
import Foreign.Storable (Storable(..))
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, newForeignPtr)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Utils (toBool)

import System.IO.Unsafe (unsafePerformIO)

import GDAL.Internal.OGRError
import GDAL.Internal.CPLError hiding (None)
import GDAL.Internal.CPLString (peekCPLString)
import GDAL.Internal.CPLConv (cplFree)

{#pointer OGRSpatialReferenceH as SpatialReference foreign newtype#}

instance Show SpatialReference where
   show = show . srsToWkt

srsToWkt :: SpatialReference -> ByteString
srsToWkt s = exportWith fun s
  where
    fun s' p = {#call unsafe ExportToPrettyWkt as ^#} s' p 1

srsToProj4 :: SpatialReference -> ByteString
srsToProj4 = exportWith {#call unsafe ExportToProj4 as ^#}

srsToXML :: SpatialReference -> ByteString
srsToXML = exportWith fun
  where
    fun s' p = {#call unsafe ExportToXML as ^#} s' p (castPtr nullPtr)

exportWith
  :: (Ptr SpatialReference -> Ptr CString -> IO CInt)
  -> SpatialReference
  -> ByteString
exportWith fun srs =
  unsafePerformIO $
  withSpatialReference srs $ \pSrs ->
  peekCPLString $
  checkOGRError . fun pSrs
{-# NOINLINE exportWith #-}

foreign import ccall "ogr_srs_api.h &OSRRelease"
  c_release :: FunPtr (Ptr SpatialReference -> IO ())

newSpatialRefHandle
  :: IO (Ptr SpatialReference) -> IO SpatialReference
newSpatialRefHandle = maybeNewSpatialRefHandle >=> maybe exc return
  where exc = throwBindingException NullSpatialReference

maybeNewSpatialRefHandle
  :: IO (Ptr SpatialReference) -> IO (Maybe SpatialReference)
maybeNewSpatialRefHandle alloc = bracketOnError alloc freeIfNotNull go
  where
    go p
      | p==nullPtr = return Nothing
      | otherwise  = liftM (Just . SpatialReference) (newForeignPtr c_release p)
    freeIfNotNull p
      | p/=nullPtr = {#call unsafe OSRRelease as ^#} p
      | otherwise  = return ()

newSpatialRefBorrowedHandle
  :: IO (Ptr SpatialReference) -> IO SpatialReference
newSpatialRefBorrowedHandle =
  maybeNewSpatialRefBorrowedHandle >=> maybe exc return
  where exc = throwBindingException NullSpatialReference

maybeNewSpatialRefBorrowedHandle
  :: IO (Ptr SpatialReference) -> IO (Maybe SpatialReference)
maybeNewSpatialRefBorrowedHandle alloc = maybeNewSpatialRefHandle $ do
  p <- alloc
  when (p /= nullPtr) (void ({#call unsafe OSRReference as ^#} p))
  return p

emptySpatialRef :: IO SpatialReference
emptySpatialRef =
  newSpatialRefHandle ({#call unsafe NewSpatialReference as ^#} nullPtr)

srsFromWkt, srsFromProj4, srsFromXML
  :: ByteString -> Either OGRException SpatialReference
srsFromWkt = unsafePerformIO . (flip unsafeUseAsCString srsFromWktIO)
{-# NOINLINE srsFromWkt #-}

srsFromWktIO :: CString -> IO (Either OGRException SpatialReference)
srsFromWktIO a =
  (liftM Right
    (newSpatialRefHandle ({#call unsafe NewSpatialReference as ^#} a)))
  `catch` (return . Left)

srsFromProj4 = fromImporter importFromProj4
{-# NOINLINE srsFromProj4 #-}

srsFromXML = fromImporter importFromXML
{-# NOINLINE srsFromXML #-}

srsFromEPSG :: Int -> Either OGRException SpatialReference
srsFromEPSG = fromImporter importFromEPSG
{-# NOINLINE srsFromEPSG #-}

fromImporter
  :: (SpatialReference -> a -> IO CInt)
  -> a
  -> Either OGRException SpatialReference
fromImporter f s = unsafePerformIO $ do
  r <- emptySpatialRef
  try (checkOGRError (f r s) >> return r)

{#fun ImportFromProj4 as ^
   { withSpatialReference* `SpatialReference'
   , unsafeUseAsCString* `ByteString'} -> `CInt' id  #}

{#fun ImportFromEPSG as ^
   {withSpatialReference* `SpatialReference', `Int'} -> `CInt' id  #}

{#fun ImportFromXML as ^
   { withSpatialReference* `SpatialReference'
   , unsafeUseAsCString* `ByteString'} -> `CInt' id  #}

{#fun pure unsafe IsGeographic as ^
   {withSpatialReference * `SpatialReference'} -> `Bool'#}

{#fun pure unsafe IsLocal as ^
   {withSpatialReference * `SpatialReference'} -> `Bool'#}

{#fun pure unsafe IsProjected as ^
   {withSpatialReference * `SpatialReference'} -> `Bool'#}

{#fun pure unsafe IsSameGeogCS as ^
   { withSpatialReference * `SpatialReference'
   , withSpatialReference * `SpatialReference'} -> `Bool'#}

{#fun pure unsafe IsSame as ^
   { withSpatialReference * `SpatialReference'
   , withSpatialReference * `SpatialReference'} -> `Bool'#}

instance Eq SpatialReference where
  (==) = isSame

getLinearUnits :: SpatialReference -> (Double, String)
getLinearUnits = getUnitsWith {#call unsafe OSRGetLinearUnits as ^#}

getAngularUnits :: SpatialReference -> (Double, String)
getAngularUnits = getUnitsWith {#call unsafe OSRGetAngularUnits as ^#}

getUnitsWith ::
     (Ptr SpatialReference -> Ptr CString -> IO CDouble)
  -> SpatialReference
  -> (Double, String)
getUnitsWith fun s = unsafePerformIO $
    alloca $ \p -> do
      value <- withSpatialReference s (\s' -> fun s' p)
      ptr <- peek p
      units <- peekCString ptr
      return (realToFrac value, units)

withMaybeSRAsCString :: Maybe SpatialReference -> (CString -> IO a) -> IO a
withMaybeSRAsCString Nothing    = ($ nullPtr)
withMaybeSRAsCString (Just srs) = unsafeUseAsCString (srsToWkt srs)

withMaybeSpatialReference
  :: Maybe SpatialReference -> (Ptr SpatialReference -> IO a) -> IO a
withMaybeSpatialReference Nothing  = ($ nullPtr)
withMaybeSpatialReference (Just s) = withSpatialReference s

{#pointer OGRCoordinateTransformationH as CoordinateTransformation
  foreign newtype#}

coordinateTransformation
  :: SpatialReference -> SpatialReference -> Maybe CoordinateTransformation
coordinateTransformation source target =
  unsafePerformIO $
  withSpatialReference source $ \pSource ->
  withSpatialReference target $ \pTarget ->
  maybeNewCoordinateTransformation pSource pTarget
{-# NOINLINE coordinateTransformation #-}

maybeNewCoordinateTransformation
  :: Ptr SpatialReference
  -> Ptr SpatialReference
  -> IO (Maybe CoordinateTransformation)
maybeNewCoordinateTransformation pSource pTarget =
  bracketOnError alloc freeIfNotNull go
  where
    alloc =
      {#call unsafe OCTNewCoordinateTransformation as ^#} pSource pTarget
    go p
      | p==nullPtr = return Nothing
      | otherwise  = liftM (Just . CoordinateTransformation)
                           (newForeignPtr c_destroyCT p)
    freeIfNotNull p
      | p/=nullPtr = {#call unsafe OCTDestroyCoordinateTransformation as ^#} p
      | otherwise  = return ()

foreign import ccall "ogr_srs_api.h &OCTDestroyCoordinateTransformation"
  c_destroyCT :: FunPtr (Ptr CoordinateTransformation -> IO ())

{#fun OSRCleanup as cleanup {} -> `()'#}

initialize :: IO ()
initialize =
  void (maybeNewCoordinateTransformation nullPtr nullPtr)