fix for 7.8.4

fix for 7.8.4

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}

module GDAL.Internal.OGR (
    GeometryType (..)
  , Geometry
  , ROGeometry
  , RWGeometry
  , Datasource
  , SQLDialect (..)
  , WkbByteOrder (..)
  , Layer
  , RODatasource
  , RWDatasource
  , ROLayer
  , RWLayer

  , unDatasource
  , unLayer
  , withLockedDatasourcePtr
  , openReadOnly
  , openReadWrite
  , withLockedLayerPtr

  , createFromWktIO
  , createFromWkbIO
  , exportToWktIO
  , exportToWkbIO

  , createFromWkt
  , createFromWkb
  , exportToWkt
  , exportToWkb

  , unsafeThawGeometry
  , unsafeFreezeGeometry

  , getLayer
  , getLayerByName
  , executeSQL
  , layerCount
  , datasourceName

  , registerAllDrivers
  , cleanupAll
) where

import Control.Applicative ((<$>))
import Control.Monad (liftM, when, void, (<=<), (>=>))
import Control.Monad.Catch(throwM, catch, catchJust)
import Control.Monad.IO.Class (MonadIO(liftIO))

import Data.ByteString (ByteString)
import Data.ByteString.Char8 (packCString, unpack)
import Data.ByteString.Unsafe (
    unsafeUseAsCString
  , unsafeUseAsCStringLen
  , unsafePackMallocCStringLen
  )
import Data.Coerce (coerce)

import Foreign.C.String (CString, peekCString, withCString)
import Foreign.C.Types (CInt(..), CChar(..), CUChar(..))
import Foreign.Ptr (FunPtr, Ptr, nullPtr, castPtr)
import qualified Foreign.Concurrent as FConc
import Foreign.ForeignPtr (
    ForeignPtr
  , withForeignPtr
  , newForeignPtr
  , newForeignPtr_
  )
import Foreign.Marshal.Alloc (alloca, mallocBytes)
import Foreign.Marshal.Utils (toBool)
import Foreign.Storable (peek, poke)

import System.IO.Unsafe (unsafePerformIO)

import GDAL.Internal.Types
import GDAL.Internal.OGRError
import GDAL.Internal.OSR
import GDAL.Internal.CPLError hiding (None)
import GDAL.Internal.Util

#include "ogr_api.h"

{#context prefix = "OGR" #}

{#fun OGRRegisterAll as registerAllDrivers {} -> `()'  #}
{#fun OGRCleanupAll  as cleanupAll {} -> `()'  #}

{#pointer OGRDataSourceH as Datasource foreign newtype nocode#}

newtype Datasource s (t::AccessMode) a
  = Datasource (Mutex, Ptr (Datasource s t a))

unDatasource :: Datasource s t a -> Ptr (Datasource s t a)
unDatasource (Datasource (_,p)) = p

type RODatasource s = Datasource s ReadOnly
type RWDatasource s = Datasource s ReadWrite

withLockedDatasourcePtr
  :: Datasource s t a -> (Ptr (Datasource s t a) -> IO b) -> IO b
withLockedDatasourcePtr (Datasource (m,p)) f = withMutex m (f p)

{#enum define OGRAccess
  { FALSE  as OGR_ReadOnly
  , TRUE   as OGR_Update
  } deriving (Eq, Show) #}

{#enum define WkbByteOrder
  { wkbXDR  as WkbXDR
  , wkbNDR  as WkbNDR
  } deriving (Eq, Show) #}

openReadOnly :: String -> GDAL s (RODatasource s a)
openReadOnly p = openWithMode OGR_ReadOnly p

openReadWrite :: String -> GDAL s (RWDatasource s a)
openReadWrite p = openWithMode OGR_Update p

openWithMode :: OGRAccess -> String -> GDAL s (Datasource s t a)
openWithMode m p = do
  ptr <- liftIO $ withCString p $ \p' ->
           throwIfError "open" (c_open p' (fromEnumC m) nullPtr)
  newDatasourceHandle ptr `catch` (\NullDatasource ->
    throwM (GDALException CE_Failure OpenFailed "OGROpen returned a NULL ptr"))

foreign import ccall safe "ogr_api.h OGROpen" c_open
   :: CString -> CInt -> Ptr () -> IO (Ptr (Datasource s t a))

newDatasourceHandle :: Ptr (Datasource s t a) -> GDAL s (Datasource s t a)
newDatasourceHandle p
  | p==nullPtr  = throwBindingException NullDatasource
  | otherwise   = do
      registerFinalizer (c_releaseDatasource p)
      m <- liftIO newMutex
      return $ Datasource (m,p)

foreign import ccall safe "ogr_api.h OGRReleaseDataSource"
  c_releaseDatasource :: Ptr (Datasource s t a) -> IO ()

{#pointer OGRLayerH as Layer newtype nocode#}

newtype (Layer s (t::AccessMode) a)
  = Layer (Mutex, Ptr (Layer s t a))

unLayer :: Layer s t a -> Ptr (Layer s t a)
unLayer (Layer (_,p)) = p

withLockedLayerPtr
  :: Layer s t a -> (Ptr (Layer s t a) -> IO b) -> IO b
withLockedLayerPtr (Layer (m,p)) f = withMutex m $ f p

type ROLayer s = Layer s ReadOnly
type RWLayer s = Layer s ReadWrite

getLayer :: Int -> Datasource s t a -> GDAL s (Layer s t a)
getLayer layer (Datasource (m,dp)) = liftIO $ do
  p <- throwIfError "getLayer" (c_getLayer dp (fromIntegral layer))
  when (p==nullPtr) $ throwBindingException (InvalidLayerIndex layer)
  return (Layer (m, p))

foreign import ccall safe "ogr_api.h OGR_DS_GetLayer" c_getLayer
  :: Ptr (Datasource s t a) -> CInt -> IO (Ptr (Layer s t a))

getLayerByName :: String -> Datasource s t a -> GDAL s (Layer s t a)
getLayerByName layer (Datasource (m,dp)) = liftIO $
  withCString layer $ \lyr -> do
    p <- throwIfError "getLayerByName" (c_getLayerByName dp lyr)
    when (p==nullPtr) $ throwBindingException (InvalidLayerName layer)
    return (Layer (m,p))

foreign import ccall safe "ogr_api.h OGR_DS_GetLayerByName" c_getLayerByName
  :: Ptr (Datasource s t a) -> CString -> IO (Ptr (Layer s t a))

layerCount :: Datasource s t a -> GDAL s Int
layerCount = liftM fromIntegral . liftIO . c_getLayerCount . unDatasource

foreign import ccall unsafe "ogr_api.h OGR_DS_GetLayerCount" c_getLayerCount
  :: Ptr (Datasource s t a) -> IO CInt

datasourceName :: Datasource s t a -> GDAL s String
datasourceName = liftIO . (peekCString <=< c_getName . unDatasource)

foreign import ccall unsafe "ogr_api.h OGR_DS_GetName" c_getName
  :: Ptr (Datasource s t a) -> IO CString

data SQLDialect
  = DefaultDialect
  | SqliteDialect
  | OGRDialect
  deriving (Eq, Show, Enum)

withSQLDialect :: SQLDialect -> (CString -> IO a) -> IO a
withSQLDialect DefaultDialect = ($ nullPtr)
withSQLDialect SqliteDialect  = withCString "SQLITE"
withSQLDialect OGRDialect     = withCString "OGRSQL"

executeSQL
  :: SQLDialect -> String -> Maybe ROGeometry -> RODatasource s a
  -> GDAL s (ROLayer s a)
executeSQL dialect query mSpatialFilter ds@(Datasource (m,dsP)) = do
  p <- catchJust selectExc execute (throwBindingException . SQLQueryError)
  when (p==nullPtr) $ throwBindingException NullLayer
  registerFinalizer (c_releaseResultSet dsP p)
  return (Layer (m, p))
  where
    selectExc GDALException{..} | gdalErrNum==AppDefined = Just gdalErrMsg
    selectExc _                                          = Nothing
    execute = liftIO $
      withLockedDatasourcePtr ds $ \dsPtr ->
      withMaybeGeometry mSpatialFilter $ \sFilter ->
      withSQLDialect dialect $ \sDialect ->
      withCString query $ \sQuery ->
        throwIfError "executeSQL" (c_executeSQL dsPtr sQuery sFilter sDialect)

foreign import ccall safe "ogr_api.h OGR_DS_ExecuteSQL"
  c_executeSQL
    :: Ptr (RODatasource s a) -> CString -> Ptr ROGeometry -> CString
    -> IO (Ptr (ROLayer s a))

foreign import ccall safe "ogr_api.h OGR_DS_ReleaseResultSet"
  c_releaseResultSet
    :: Ptr (RODatasource s a) -> Ptr (ROLayer s a) -> IO ()

newtype Geometry (t::AccessMode) = Geometry (ForeignPtr (Geometry t))

withMaybeGeometry :: Maybe (Geometry t) -> (Ptr (Geometry t) -> IO a) -> IO a
withMaybeGeometry (Just (Geometry ptr)) = withForeignPtr ptr
withMaybeGeometry Nothing               = ($ nullPtr)

withGeometry :: Geometry t -> (Ptr (Geometry t) -> IO a) -> IO a
withGeometry (Geometry ptr) = withForeignPtr ptr

type ROGeometry = Geometry ReadOnly
type RWGeometry = Geometry ReadWrite

foreign import ccall "ogr_api.h &OGR_G_DestroyGeometry"
  c_destroyGeometry :: FunPtr (Ptr (Geometry t) -> IO ())

newGeometryHandle :: Ptr (Geometry t) -> IO (Geometry t)
newGeometryHandle p
  | p==nullPtr = throwBindingException NullGeometry
  | otherwise  = Geometry <$> newForeignPtr c_destroyGeometry p

createFromWkb
  :: ByteString -> Maybe SpatialReference -> Either OGRError ROGeometry
createFromWkb bs = unsafePerformIO . createFromWkbIO bs

createFromWkbIO
  :: ByteString -> Maybe SpatialReference -> IO (Either OGRError (Geometry t))
createFromWkbIO bs mSrs =
  alloca $ \gPtr ->
  unsafeUseAsCStringLen bs $ \(sPtr, len) ->
  withMaybeSpatialReference mSrs $ \srs ->
    checkOGRError
      (c_createFromWkb sPtr srs gPtr (fromIntegral len))
      (peek gPtr >>= newGeometryHandle)

foreign import ccall unsafe "ogr_api.h OGR_G_CreateFromWkb"
  c_createFromWkb ::
    CString -> Ptr SpatialReference -> Ptr (Ptr (Geometry t)) -> CInt -> IO CInt

createFromWkt
  :: ByteString -> Maybe SpatialReference -> Either OGRError ROGeometry
createFromWkt bs = unsafePerformIO . createFromWktIO bs

createFromWktIO
  :: ByteString -> Maybe SpatialReference -> IO (Either OGRError (Geometry t))
createFromWktIO bs mSrs =
  alloca $ \gPtr ->
  alloca $ \sPtrPtr ->
  unsafeUseAsCString bs $ \sPtr ->
  withMaybeSpatialReference mSrs $ \srs ->
    checkOGRError
      (poke sPtrPtr sPtr >> c_createFromWkt sPtrPtr srs gPtr)
      (peek gPtr >>= newGeometryHandle)

foreign import ccall unsafe "ogr_api.h OGR_G_CreateFromWkt"
  c_createFromWkt ::
    Ptr CString -> Ptr SpatialReference -> Ptr (Ptr (Geometry t)) -> IO CInt

unsafeFreezeGeometry :: RWGeometry -> ROGeometry
unsafeFreezeGeometry = coerce

unsafeThawGeometry :: RWGeometry -> ROGeometry
unsafeThawGeometry = coerce

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

peekAndPack :: Ptr CString -> IO ByteString
peekAndPack = peek >=> packCString

exportToWktIO :: Geometry t -> IO ByteString
exportToWktIO g = withGeometry g $ \gPtr -> alloca $ \sPtrPtr -> do
  void $ {#call OGR_G_ExportToWkt as ^ #} (castPtr gPtr) sPtrPtr
  peekAndPack sPtrPtr

exportToWkt :: ROGeometry -> ByteString
exportToWkt = unsafePerformIO . exportToWktIO

exportToWkbIO :: WkbByteOrder -> Geometry t -> IO ByteString
exportToWkbIO bo g = withGeometry g $ \gPtr -> do
  len <- liftM fromIntegral ({#call OGR_G_WkbSize as ^ #} (castPtr gPtr))
  buf <- mallocBytes len
  void $ {#call OGR_G_ExportToWkb as ^ #} (castPtr gPtr) (fromEnumC bo) buf
  unsafePackMallocCStringLen (castPtr buf, len)

exportToWkb :: WkbByteOrder -> ROGeometry -> ByteString
exportToWkb bo = unsafePerformIO . exportToWkbIO bo

geomEqIO :: Geometry t -> Geometry t1 -> IO Bool
geomEqIO a b = withGeometry a $ \aPtr -> withGeometry b $ \bPtr ->
  liftM toBool ({#call OGR_G_Equals as ^#} (castPtr aPtr) (castPtr bPtr))

instance Show ROGeometry where
  show = unpack . exportToWkt

instance Eq ROGeometry where
  a == b = unsafePerformIO (geomEqIO a b)

{#enum OGRwkbGeometryType as GeometryType {underscoreToCase}#}

instance Show GeometryType where
  show s = unsafePerformIO $
            {#call unsafe OGRGeometryTypeToName as ^#} s' >>= peekCString
    where s' = fromEnumC s

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}

module GDAL.Internal.OGR (
    GeometryType (..)
  , Geometry
  , ROGeometry
  , RWGeometry
  , Datasource
  , SQLDialect (..)
  , WkbByteOrder (..)
  , Layer
  , RODatasource
  , RWDatasource
  , ROLayer
  , RWLayer

  , unDatasource
  , unLayer
  , withLockedDatasourcePtr
  , openReadOnly
  , openReadWrite
  , withLockedLayerPtr

  , createFromWktIO
  , createFromWkbIO
  , exportToWktIO
  , exportToWkbIO

  , createFromWkt
  , createFromWkb
  , exportToWkt
  , exportToWkb

  , unsafeThawGeometry
  , unsafeFreezeGeometry

  , getLayer
  , getLayerByName
  , executeSQL
  , layerCount
  , datasourceName

  , registerAllDrivers
  , cleanupAll
) where

import Control.Monad (liftM, when, void, (<=<), (>=>))
import Control.Monad.Catch(throwM, catch, catchJust)
import Control.Monad.IO.Class (MonadIO(liftIO))

import Data.ByteString (ByteString)
import Data.ByteString.Char8 (packCString, unpack)
import Data.ByteString.Unsafe (
    unsafeUseAsCString
  , unsafeUseAsCStringLen
  , unsafePackMallocCStringLen
  )
import Data.Coerce (coerce)

import Foreign.C.String (CString, peekCString, withCString)
import Foreign.C.Types (CInt(..), CChar(..), CUChar(..))
import Foreign.Ptr (FunPtr, Ptr, nullPtr, castPtr)
import qualified Foreign.Concurrent as FConc
import Foreign.ForeignPtr (
    ForeignPtr
  , withForeignPtr
  , newForeignPtr
  , newForeignPtr_
  )
import Foreign.Marshal.Alloc (alloca, mallocBytes)
import Foreign.Marshal.Utils (toBool)
import Foreign.Storable (peek, poke)

import System.IO.Unsafe (unsafePerformIO)

import GDAL.Internal.Types
import GDAL.Internal.OGRError
import GDAL.Internal.OSR
import GDAL.Internal.CPLError hiding (None)
import GDAL.Internal.Util

#include "ogr_api.h"

{#context prefix = "OGR" #}

{#fun OGRRegisterAll as registerAllDrivers {} -> `()'  #}
{#fun OGRCleanupAll  as cleanupAll {} -> `()'  #}

{#pointer OGRDataSourceH as Datasource foreign newtype nocode#}

newtype Datasource s (t::AccessMode) a
  = Datasource (Mutex, Ptr (Datasource s t a))

unDatasource :: Datasource s t a -> Ptr (Datasource s t a)
unDatasource (Datasource (_,p)) = p

type RODatasource s = Datasource s ReadOnly
type RWDatasource s = Datasource s ReadWrite

withLockedDatasourcePtr
  :: Datasource s t a -> (Ptr (Datasource s t a) -> IO b) -> IO b
withLockedDatasourcePtr (Datasource (m,p)) f = withMutex m (f p)

{#enum define OGRAccess
  { FALSE  as OGR_ReadOnly
  , TRUE   as OGR_Update
  } deriving (Eq, Show) #}

{#enum define WkbByteOrder
  { wkbXDR  as WkbXDR
  , wkbNDR  as WkbNDR
  } deriving (Eq, Show) #}

openReadOnly :: String -> GDAL s (RODatasource s a)
openReadOnly p = openWithMode OGR_ReadOnly p

openReadWrite :: String -> GDAL s (RWDatasource s a)
openReadWrite p = openWithMode OGR_Update p

openWithMode :: OGRAccess -> String -> GDAL s (Datasource s t a)
openWithMode m p = do
  ptr <- liftIO $ withCString p $ \p' ->
           throwIfError "open" (c_open p' (fromEnumC m) nullPtr)
  newDatasourceHandle ptr `catch` (\NullDatasource ->
    throwM (GDALException CE_Failure OpenFailed "OGROpen returned a NULL ptr"))

foreign import ccall safe "ogr_api.h OGROpen" c_open
   :: CString -> CInt -> Ptr () -> IO (Ptr (Datasource s t a))

newDatasourceHandle :: Ptr (Datasource s t a) -> GDAL s (Datasource s t a)
newDatasourceHandle p
  | p==nullPtr  = throwBindingException NullDatasource
  | otherwise   = do
      registerFinalizer (c_releaseDatasource p)
      m <- liftIO newMutex
      return $ Datasource (m,p)

foreign import ccall safe "ogr_api.h OGRReleaseDataSource"
  c_releaseDatasource :: Ptr (Datasource s t a) -> IO ()

{#pointer OGRLayerH as Layer newtype nocode#}

newtype (Layer s (t::AccessMode) a)
  = Layer (Mutex, Ptr (Layer s t a))

unLayer :: Layer s t a -> Ptr (Layer s t a)
unLayer (Layer (_,p)) = p

withLockedLayerPtr
  :: Layer s t a -> (Ptr (Layer s t a) -> IO b) -> IO b
withLockedLayerPtr (Layer (m,p)) f = withMutex m $ f p

type ROLayer s = Layer s ReadOnly
type RWLayer s = Layer s ReadWrite

getLayer :: Int -> Datasource s t a -> GDAL s (Layer s t a)
getLayer layer (Datasource (m,dp)) = liftIO $ do
  p <- throwIfError "getLayer" (c_getLayer dp (fromIntegral layer))
  when (p==nullPtr) $ throwBindingException (InvalidLayerIndex layer)
  return (Layer (m, p))

foreign import ccall safe "ogr_api.h OGR_DS_GetLayer" c_getLayer
  :: Ptr (Datasource s t a) -> CInt -> IO (Ptr (Layer s t a))

getLayerByName :: String -> Datasource s t a -> GDAL s (Layer s t a)
getLayerByName layer (Datasource (m,dp)) = liftIO $
  withCString layer $ \lyr -> do
    p <- throwIfError "getLayerByName" (c_getLayerByName dp lyr)
    when (p==nullPtr) $ throwBindingException (InvalidLayerName layer)
    return (Layer (m,p))

foreign import ccall safe "ogr_api.h OGR_DS_GetLayerByName" c_getLayerByName
  :: Ptr (Datasource s t a) -> CString -> IO (Ptr (Layer s t a))

layerCount :: Datasource s t a -> GDAL s Int
layerCount = liftM fromIntegral . liftIO . c_getLayerCount . unDatasource

foreign import ccall unsafe "ogr_api.h OGR_DS_GetLayerCount" c_getLayerCount
  :: Ptr (Datasource s t a) -> IO CInt

datasourceName :: Datasource s t a -> GDAL s String
datasourceName = liftIO . (peekCString <=< c_getName . unDatasource)

foreign import ccall unsafe "ogr_api.h OGR_DS_GetName" c_getName
  :: Ptr (Datasource s t a) -> IO CString

data SQLDialect
  = DefaultDialect
  | SqliteDialect
  | OGRDialect
  deriving (Eq, Show, Enum)

withSQLDialect :: SQLDialect -> (CString -> IO a) -> IO a
withSQLDialect DefaultDialect = ($ nullPtr)
withSQLDialect SqliteDialect  = withCString "SQLITE"
withSQLDialect OGRDialect     = withCString "OGRSQL"

executeSQL
  :: SQLDialect -> String -> Maybe ROGeometry -> RODatasource s a
  -> GDAL s (ROLayer s a)
executeSQL dialect query mSpatialFilter ds@(Datasource (m,dsP)) = do
  p <- catchJust selectExc execute (throwBindingException . SQLQueryError)
  when (p==nullPtr) $ throwBindingException NullLayer
  registerFinalizer (c_releaseResultSet dsP p)
  return (Layer (m, p))
  where
    selectExc GDALException{..} | gdalErrNum==AppDefined = Just gdalErrMsg
    selectExc _                                          = Nothing
    execute = liftIO $
      withLockedDatasourcePtr ds $ \dsPtr ->
      withMaybeGeometry mSpatialFilter $ \sFilter ->
      withSQLDialect dialect $ \sDialect ->
      withCString query $ \sQuery ->
        throwIfError "executeSQL" (c_executeSQL dsPtr sQuery sFilter sDialect)

foreign import ccall safe "ogr_api.h OGR_DS_ExecuteSQL"
  c_executeSQL
    :: Ptr (RODatasource s a) -> CString -> Ptr ROGeometry -> CString
    -> IO (Ptr (ROLayer s a))

foreign import ccall safe "ogr_api.h OGR_DS_ReleaseResultSet"
  c_releaseResultSet
    :: Ptr (RODatasource s a) -> Ptr (ROLayer s a) -> IO ()

newtype Geometry (t::AccessMode) = Geometry (ForeignPtr (Geometry t))

withMaybeGeometry :: Maybe (Geometry t) -> (Ptr (Geometry t) -> IO a) -> IO a
withMaybeGeometry (Just (Geometry ptr)) = withForeignPtr ptr
withMaybeGeometry Nothing               = ($ nullPtr)

withGeometry :: Geometry t -> (Ptr (Geometry t) -> IO a) -> IO a
withGeometry (Geometry ptr) = withForeignPtr ptr

type ROGeometry = Geometry ReadOnly
type RWGeometry = Geometry ReadWrite

foreign import ccall "ogr_api.h &OGR_G_DestroyGeometry"
  c_destroyGeometry :: FunPtr (Ptr (Geometry t) -> IO ())

newGeometryHandle :: Ptr (Geometry t) -> IO (Geometry t)
newGeometryHandle p
  | p==nullPtr = throwBindingException NullGeometry
  | otherwise  = Geometry <$> newForeignPtr c_destroyGeometry p

createFromWkb
  :: ByteString -> Maybe SpatialReference -> Either OGRError ROGeometry
createFromWkb bs = unsafePerformIO . createFromWkbIO bs

createFromWkbIO
  :: ByteString -> Maybe SpatialReference -> IO (Either OGRError (Geometry t))
createFromWkbIO bs mSrs =
  alloca $ \gPtr ->
  unsafeUseAsCStringLen bs $ \(sPtr, len) ->
  withMaybeSpatialReference mSrs $ \srs ->
    checkOGRError
      (c_createFromWkb sPtr srs gPtr (fromIntegral len))
      (peek gPtr >>= newGeometryHandle)

foreign import ccall unsafe "ogr_api.h OGR_G_CreateFromWkb"
  c_createFromWkb ::
    CString -> Ptr SpatialReference -> Ptr (Ptr (Geometry t)) -> CInt -> IO CInt

createFromWkt
  :: ByteString -> Maybe SpatialReference -> Either OGRError ROGeometry
createFromWkt bs = unsafePerformIO . createFromWktIO bs

createFromWktIO
  :: ByteString -> Maybe SpatialReference -> IO (Either OGRError (Geometry t))
createFromWktIO bs mSrs =
  alloca $ \gPtr ->
  alloca $ \sPtrPtr ->
  unsafeUseAsCString bs $ \sPtr ->
  withMaybeSpatialReference mSrs $ \srs ->
    checkOGRError
      (poke sPtrPtr sPtr >> c_createFromWkt sPtrPtr srs gPtr)
      (peek gPtr >>= newGeometryHandle)

foreign import ccall unsafe "ogr_api.h OGR_G_CreateFromWkt"
  c_createFromWkt ::
    Ptr CString -> Ptr SpatialReference -> Ptr (Ptr (Geometry t)) -> IO CInt

unsafeFreezeGeometry :: RWGeometry -> ROGeometry
unsafeFreezeGeometry = coerce

unsafeThawGeometry :: RWGeometry -> ROGeometry
unsafeThawGeometry = coerce

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

peekAndPack :: Ptr CString -> IO ByteString
peekAndPack = peek >=> packCString

exportToWktIO :: Geometry t -> IO ByteString
exportToWktIO g = withGeometry g $ \gPtr -> alloca $ \sPtrPtr -> do
  void $ {#call OGR_G_ExportToWkt as ^ #} (castPtr gPtr) sPtrPtr
  peekAndPack sPtrPtr

exportToWkt :: ROGeometry -> ByteString
exportToWkt = unsafePerformIO . exportToWktIO

exportToWkbIO :: WkbByteOrder -> Geometry t -> IO ByteString
exportToWkbIO bo g = withGeometry g $ \gPtr -> do
  len <- liftM fromIntegral ({#call OGR_G_WkbSize as ^ #} (castPtr gPtr))
  buf <- mallocBytes len
  void $ {#call OGR_G_ExportToWkb as ^ #} (castPtr gPtr) (fromEnumC bo) buf
  unsafePackMallocCStringLen (castPtr buf, len)

exportToWkb :: WkbByteOrder -> ROGeometry -> ByteString
exportToWkb bo = unsafePerformIO . exportToWkbIO bo

geomEqIO :: Geometry t -> Geometry t1 -> IO Bool
geomEqIO a b = withGeometry a $ \aPtr -> withGeometry b $ \bPtr ->
  liftM toBool ({#call OGR_G_Equals as ^#} (castPtr aPtr) (castPtr bPtr))

instance Show ROGeometry where
  show = unpack . exportToWkt

instance Eq ROGeometry where
  a == b = unsafePerformIO (geomEqIO a b)

{#enum OGRwkbGeometryType as GeometryType {underscoreToCase}#}

instance Show GeometryType where
  show s = unsafePerformIO $
            {#call unsafe OGRGeometryTypeToName as ^#} s' >>= peekCString
    where s' = fromEnumC s


change for new cudd version

change for new cudd version

{-#LANGUAGE ForeignFunctionInterface #-}

module CuddReorder (
    CuddReorderingType(..),
    cuddReorderingStatus,
    cuddAutodynEnable,
    cuddAutodynDisable,
    cuddReduceHeap,
    cuddMakeTreeNode,
    cuddReadReorderingTime,
    cuddReadReorderings,
    cuddEnableReorderingReporting,
    cuddDisableReorderingReporting,
    cuddReorderingReporting,
    regStdPreReordHook,
    regStdPostReordHook,
    cuddTurnOnCountDead,
    cuddTurnOffCountDead,
    cuddDeadAreCounted,
    cuddReadSiftMaxSwap,
    cuddSetSiftMaxSwap,
    cuddReadSiftMaxVar,
    cuddSetSiftMaxVar,
    cuddReadNextReordering,
    cuddSetNextReordering,
    cuddReadMaxGrowthAlternate,
    cuddSetMaxGrowthAlternate,
    cuddReadMaxGrowth,
    cuddReadReorderingCycle,
    cuddSetReorderingCycle,
    cuddSetPopulationSize,
    cuddReadNumberXovers,
    cuddSetNumberXovers,
    regReordGCHook
    ) where

import System.IO
import System.Mem
import Foreign
import Foreign.Ptr
import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Marshal.Array
import Foreign.Marshal.Utils
import Control.Monad
import Control.Monad.ST.Lazy

import CuddInternal
import CuddHook

#include <stdio.h>
#include <cudd.h>

readIntegral :: (Integral i, Num j) => (Ptr CDdManager -> IO i) -> STDdManager s u -> ST s j
readIntegral f (STDdManager m) = unsafeIOToST $ liftM fromIntegral $ f m

setIntegral :: (Integral i, Num j) => (Ptr CDdManager -> j -> IO ()) -> STDdManager s u -> i -> ST s ()
setIntegral f (STDdManager m) v = unsafeIOToST $ f m (fromIntegral v)

readFloat :: (Real r, Fractional f) => (Ptr CDdManager -> IO r) -> STDdManager s u -> ST s f
readFloat f (STDdManager m) = unsafeIOToST $ liftM realToFrac $ f m

setFloat :: (Real r, Fractional f) => (Ptr CDdManager -> f -> IO ()) -> STDdManager s u -> r -> ST s ()
setFloat f (STDdManager m) v = unsafeIOToST $ f m (realToFrac v)

--Reordering types
{#enum Cudd_ReorderingType as CuddReorderingType {underscoreToCase} deriving (Show, Eq) #}

--Reorder when needed
foreign import ccall safe "cudd.h Cudd_ReorderingStatus"
	c_cuddReorderingStatus :: Ptr CDdManager -> Ptr CInt -> IO (CInt)

cuddReorderingStatus :: STDdManager s u -> ST s (Int, CuddReorderingType)
cuddReorderingStatus (STDdManager m) = unsafeIOToST $ do
	alloca $ \mem -> do
		res <- c_cuddReorderingStatus m mem
		typ <- peek mem
		return $ (fromIntegral res, toEnum $ fromIntegral typ)

foreign import ccall safe "cudd.h Cudd_AutodynEnable"
	c_cuddAutodynEnable :: Ptr CDdManager -> CInt -> IO ()

cuddAutodynEnable :: STDdManager s u -> CuddReorderingType -> ST s ()
cuddAutodynEnable (STDdManager m) t = unsafeIOToST $ c_cuddAutodynEnable m (fromIntegral $ fromEnum t)

foreign import ccall safe "cudd.h Cudd_AutodynDisable"
	c_cuddAutodynDisable :: Ptr CDdManager -> IO ()

cuddAutodynDisable :: STDdManager s u -> ST s ()
cuddAutodynDisable (STDdManager m) = unsafeIOToST $ c_cuddAutodynDisable m

--Reorder right now
foreign import ccall safe "cudd.h Cudd_ReduceHeap"
	c_cuddReduceHeap :: Ptr CDdManager -> CInt -> CInt -> IO (CInt)

cuddReduceHeap :: STDdManager s u -> CuddReorderingType -> Int -> ST s Int
cuddReduceHeap (STDdManager m) typ minsize = unsafeIOToST $ liftM fromIntegral $ c_cuddReduceHeap m (fromIntegral $ fromEnum typ) (fromIntegral minsize)

--Grouping
foreign import ccall safe "cudd.h Cudd_MakeTreeNode"
	c_cuddMakeTreeNode :: Ptr CDdManager -> CUInt -> CUInt -> CUInt -> IO (Ptr ())

cuddMakeTreeNode :: STDdManager s u -> Int -> Int -> Int -> ST s (Ptr ())
cuddMakeTreeNode (STDdManager m) low size typ = unsafeIOToST $ do
    res <- c_cuddMakeTreeNode m (fromIntegral low) (fromIntegral size) (fromIntegral typ)
    when (res==nullPtr) (error "cuddMakeTreeNode returned error")
    return res

--Reordering stats
foreign import ccall safe "cudd.h Cudd_ReadReorderingTime"
	c_cuddReadReorderingTime :: Ptr CDdManager -> IO (CLong)

cuddReadReorderingTime :: STDdManager s u -> ST s Int
cuddReadReorderingTime = readIntegral c_cuddReadReorderingTime

foreign import ccall safe "cudd.h Cudd_ReadReorderings"
	c_cuddReadReorderings :: Ptr CDdManager -> IO (CUInt)

cuddReadReorderings :: STDdManager s u -> ST s Int
cuddReadReorderings = readIntegral c_cuddReadReorderings

--Hooks
foreign import ccall safe "cudd.h &Cudd_StdPreReordHook"
	c_cuddStdPreReordHook :: HookFP

foreign import ccall safe "cudd.h &Cudd_StdPostReordHook"
	c_cuddStdPostReordHook :: HookFP

foreign import ccall safe "cudd.h Cudd_EnableReorderingReporting"
	c_cuddEnableReorderingReporting :: Ptr CDdManager -> IO (CInt)

cuddEnableReorderingReporting :: STDdManager s u -> ST s Int
cuddEnableReorderingReporting (STDdManager m) = unsafeIOToST $ liftM fromIntegral $ c_cuddEnableReorderingReporting m

foreign import ccall safe "cudd.h Cudd_DisableReorderingReporting"
	c_cuddDisableReorderingReporting :: Ptr CDdManager -> IO (CInt)

cuddDisableReorderingReporting :: STDdManager s u -> ST s Int
cuddDisableReorderingReporting (STDdManager m) = unsafeIOToST $ liftM fromIntegral $ c_cuddDisableReorderingReporting m

foreign import ccall safe "cudd.h Cudd_ReorderingReporting"
	c_cuddReorderingReporting :: Ptr CDdManager -> IO (CInt)

cuddReorderingReporting :: STDdManager s u -> ST s Int
cuddReorderingReporting (STDdManager m) = unsafeIOToST $ liftM fromIntegral $ c_cuddReorderingReporting m

regStdPreReordHook :: STDdManager s u -> ST s Int
regStdPreReordHook m = cuddAddHook m c_cuddStdPreReordHook CuddPreReorderingHook

regStdPostReordHook :: STDdManager s u -> ST s Int
regStdPostReordHook m = cuddAddHook m c_cuddStdPostReordHook CuddPostReorderingHook

--Universal reordering params
foreign import ccall safe "cudd.h Cudd_TurnOffCountDead"
	c_cuddTurnOffCountDead :: Ptr CDdManager -> IO ()

cuddTurnOffCountDead :: STDdManager s u -> ST s ()
cuddTurnOffCountDead (STDdManager m) = unsafeIOToST $ c_cuddTurnOffCountDead m

foreign import ccall safe "cudd.h Cudd_TurnOnCountDead"
	c_cuddTurnOnCountDead :: Ptr CDdManager -> IO ()

cuddTurnOnCountDead :: STDdManager s u -> ST s ()
cuddTurnOnCountDead (STDdManager m) = unsafeIOToST $ c_cuddTurnOnCountDead m

foreign import ccall safe "cudd.h Cudd_DeadAreCounted"
	c_cuddDeadAreCounted :: Ptr CDdManager -> IO CInt

cuddDeadAreCounted :: STDdManager s u -> ST s Int
cuddDeadAreCounted (STDdManager m) = unsafeIOToST $ liftM fromIntegral $ c_cuddDeadAreCounted m

--Sifting parameters
foreign import ccall safe "cudd.h Cudd_ReadSiftMaxSwap"
	c_cuddReadSiftMaxSwap :: Ptr CDdManager -> IO (CInt)

cuddReadSiftMaxSwap :: STDdManager s u -> ST s Int
cuddReadSiftMaxSwap = readIntegral c_cuddReadSiftMaxSwap

foreign import ccall safe "cudd.h Cudd_SetSiftMaxSwap"
	c_cuddSetSiftMaxSwap :: Ptr CDdManager -> CInt -> IO ()

cuddSetSiftMaxSwap :: STDdManager s u -> Int -> ST s ()
cuddSetSiftMaxSwap = setIntegral c_cuddSetSiftMaxSwap

foreign import ccall safe "cudd.h Cudd_ReadSiftMaxVar"
	c_cuddReadSiftMaxVar :: Ptr CDdManager -> IO (Int)

cuddReadSiftMaxVar :: STDdManager s u -> ST s Int
cuddReadSiftMaxVar = readIntegral c_cuddReadSiftMaxVar

foreign import ccall safe "cudd.h Cudd_SetSiftMaxVar"
	c_cuddSetSiftMaxVar :: Ptr CDdManager -> CInt -> IO ()

cuddSetSiftMaxVar :: STDdManager s u -> Int -> ST s ()
cuddSetSiftMaxVar = setIntegral c_cuddSetSiftMaxVar

foreign import ccall safe "cudd.h Cudd_ReadNextReordering"
	c_cuddReadNextReordering :: Ptr CDdManager -> IO (Int)

cuddReadNextReordering :: STDdManager s u -> ST s Int
cuddReadNextReordering = readIntegral c_cuddReadNextReordering

foreign import ccall safe "cudd.h Cudd_SetNextReordering"
	c_cuddSetNextReordering :: Ptr CDdManager -> CInt -> IO ()

cuddSetNextReordering :: STDdManager s u -> Int -> ST s ()
cuddSetNextReordering = setIntegral c_cuddSetNextReordering

foreign import ccall safe "cudd.h Cudd_ReadMaxGrowthAlternate"
	c_cuddReadMaxGrowthAlternate :: Ptr CDdManager -> IO CDouble

cuddReadMaxGrowthAlternate :: STDdManager s u -> ST s Double
cuddReadMaxGrowthAlternate = readFloat c_cuddReadMaxGrowthAlternate

foreign import ccall safe "cudd.h Cudd_SetMaxGrowthAlternate"
	c_cuddSetMaxGrowthAlternate :: Ptr CDdManager -> CDouble -> IO ()

cuddSetMaxGrowthAlternate :: STDdManager s u -> Double -> ST s ()
cuddSetMaxGrowthAlternate = setFloat c_cuddSetMaxGrowthAlternate

foreign import ccall safe "cudd.h Cudd_ReadMaxGrowth"
	c_cuddReadMaxGrowth :: Ptr CDdManager -> IO CDouble

cuddReadMaxGrowth :: STDdManager s u -> ST s Double
cuddReadMaxGrowth = readFloat c_cuddReadMaxGrowth

foreign import ccall safe "cudd.h Cudd_SetMaxGrowth"
	c_cuddSetMaxGrowth :: Ptr CDdManager -> CDouble -> IO ()

cuddSetMaxGrowth :: STDdManager s u -> Double -> ST s ()
cuddSetMaxGrowth = setFloat c_cuddSetMaxGrowth

foreign import ccall safe "cudd.h Cudd_ReadReorderingCycle"
	c_cuddReadReorderingCycle :: Ptr CDdManager -> IO (CInt)

cuddReadReorderingCycle :: STDdManager s u -> ST s Int
cuddReadReorderingCycle = readIntegral c_cuddReadReorderingCycle

foreign import ccall safe "cudd.h Cudd_SetReorderingCycle"
	c_cuddSetReorderingCycle :: Ptr CDdManager -> CInt -> IO ()

cuddSetReorderingCycle :: STDdManager s u -> Int -> ST s ()
cuddSetReorderingCycle = setIntegral c_cuddSetReorderingCycle

--Genetic algorithm
foreign import ccall safe "cudd.h Cudd_ReadPopulationSize"
	c_cuddReadPopulationSize :: Ptr CDdManager -> IO (CInt)

cuddReadPopulationSize :: STDdManager s u -> ST s Int
cuddReadPopulationSize = readIntegral c_cuddReadPopulationSize

foreign import ccall safe "cudd.h Cudd_SetPopulationSize"
	c_cuddSetPopulationSize :: Ptr CDdManager -> CInt -> IO ()

cuddSetPopulationSize :: STDdManager s u -> Int -> ST s ()
cuddSetPopulationSize = setIntegral c_cuddSetPopulationSize

foreign import ccall safe "cudd.h Cudd_ReadNumberXovers"
	c_cuddReadNumberXovers :: Ptr CDdManager -> IO (CInt)

cuddReadNumberXovers :: STDdManager s u -> ST s Int
cuddReadNumberXovers = readIntegral c_cuddReadNumberXovers

foreign import ccall safe "cudd.h Cudd_SetNumberXovers"
	c_cuddSetNumberXovers :: Ptr CDdManager -> CInt -> IO ()

cuddSetNumberXovers :: STDdManager s u -> Int -> ST s ()
cuddSetNumberXovers = setIntegral c_cuddSetNumberXovers

reordGCHook :: HookTyp
reordGCHook _ _ _ = do
    --putStrLn "reordGCHook"
    performGC
    --putStrLn "gc done"
    return (fromIntegral 1)

foreign import ccall "wrapper"
    makeFunPtr :: HookTyp -> IO (FunPtr HookTyp)

regReordGCHook :: STDdManager s u -> ST s Int
regReordGCHook m = do
    hk <- unsafeIOToST $ makeFunPtr reordGCHook
    cuddAddHook m hk CuddPreReorderingHook

{-#LANGUAGE ForeignFunctionInterface #-}

module CuddReorder (
    CuddReorderingType(..),
    cuddReorderingStatus,
    cuddAutodynEnable,
    cuddAutodynDisable,
    cuddReduceHeap,
    cuddMakeTreeNode,
    cuddReadReorderingTime,
    cuddReadReorderings,
    cuddEnableReorderingReporting,
    cuddDisableReorderingReporting,
    cuddReorderingReporting,
    regStdPreReordHook,
    regStdPostReordHook,
    cuddTurnOnCountDead,
    cuddTurnOffCountDead,
    cuddDeadAreCounted,
    cuddReadSiftMaxSwap,
    cuddSetSiftMaxSwap,
    cuddReadSiftMaxVar,
    cuddSetSiftMaxVar,
    cuddReadNextReordering,
    cuddSetNextReordering,
    cuddReadMaxGrowthAlternate,
    cuddSetMaxGrowthAlternate,
    cuddReadMaxGrowth,
    cuddReadReorderingCycle,
    cuddSetReorderingCycle,
    cuddSetPopulationSize,
    cuddReadNumberXovers,
    cuddSetNumberXovers,
    regReordGCHook
    ) where

import System.IO
import System.Mem
import Foreign
import Foreign.Ptr
import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Marshal.Array
import Foreign.Marshal.Utils
import Control.Monad
import Control.Monad.ST.Lazy

import CuddInternal
import CuddHook

#include <stdio.h>
#include <cudd.h>

readIntegral :: (Integral i, Num j) => (Ptr CDdManager -> IO i) -> STDdManager s u -> ST s j
readIntegral f (STDdManager m) = unsafeIOToST $ liftM fromIntegral $ f m

setIntegral :: (Integral i, Num j) => (Ptr CDdManager -> j -> IO ()) -> STDdManager s u -> i -> ST s ()
setIntegral f (STDdManager m) v = unsafeIOToST $ f m (fromIntegral v)

readFloat :: (Real r, Fractional f) => (Ptr CDdManager -> IO r) -> STDdManager s u -> ST s f
readFloat f (STDdManager m) = unsafeIOToST $ liftM realToFrac $ f m

setFloat :: (Real r, Fractional f) => (Ptr CDdManager -> f -> IO ()) -> STDdManager s u -> r -> ST s ()
setFloat f (STDdManager m) v = unsafeIOToST $ f m (realToFrac v)

--Reordering types
{#enum Cudd_ReorderingType as CuddReorderingType {underscoreToCase} deriving (Show, Eq) #}

--Reorder when needed
foreign import ccall safe "cudd.h Cudd_ReorderingStatus"
	c_cuddReorderingStatus :: Ptr CDdManager -> Ptr CInt -> IO (CInt)

cuddReorderingStatus :: STDdManager s u -> ST s (Int, CuddReorderingType)
cuddReorderingStatus (STDdManager m) = unsafeIOToST $ do
	alloca $ \mem -> do
		res <- c_cuddReorderingStatus m mem
		typ <- peek mem
		return $ (fromIntegral res, toEnum $ fromIntegral typ)

foreign import ccall safe "cudd.h Cudd_AutodynEnable"
	c_cuddAutodynEnable :: Ptr CDdManager -> CInt -> IO ()

cuddAutodynEnable :: STDdManager s u -> CuddReorderingType -> ST s ()
cuddAutodynEnable (STDdManager m) t = unsafeIOToST $ c_cuddAutodynEnable m (fromIntegral $ fromEnum t)

foreign import ccall safe "cudd.h Cudd_AutodynDisable"
	c_cuddAutodynDisable :: Ptr CDdManager -> IO ()

cuddAutodynDisable :: STDdManager s u -> ST s ()
cuddAutodynDisable (STDdManager m) = unsafeIOToST $ c_cuddAutodynDisable m

--Reorder right now
foreign import ccall safe "cudd.h Cudd_ReduceHeap"
	c_cuddReduceHeap :: Ptr CDdManager -> CInt -> CInt -> IO (CInt)

cuddReduceHeap :: STDdManager s u -> CuddReorderingType -> Int -> ST s Int
cuddReduceHeap (STDdManager m) typ minsize = unsafeIOToST $ liftM fromIntegral $ c_cuddReduceHeap m (fromIntegral $ fromEnum typ) (fromIntegral minsize)

--Grouping
foreign import ccall safe "cudd.h Cudd_MakeTreeNode"
	c_cuddMakeTreeNode :: Ptr CDdManager -> CUInt -> CUInt -> CUInt -> IO (Ptr ())

cuddMakeTreeNode :: STDdManager s u -> Int -> Int -> Int -> ST s (Ptr ())
cuddMakeTreeNode (STDdManager m) low size typ = unsafeIOToST $ do
    res <- c_cuddMakeTreeNode m (fromIntegral low) (fromIntegral size) (fromIntegral typ)
    when (res==nullPtr) (error "cuddMakeTreeNode returned error")
    return res

--Reordering stats
foreign import ccall safe "cudd.h Cudd_ReadReorderingTime"
	c_cuddReadReorderingTime :: Ptr CDdManager -> IO (CLong)

cuddReadReorderingTime :: STDdManager s u -> ST s Int
cuddReadReorderingTime = readIntegral c_cuddReadReorderingTime

foreign import ccall safe "cudd.h Cudd_ReadReorderings"
	c_cuddReadReorderings :: Ptr CDdManager -> IO (CInt)

cuddReadReorderings :: STDdManager s u -> ST s Int
cuddReadReorderings = readIntegral c_cuddReadReorderings

--Hooks
foreign import ccall safe "cudd.h &Cudd_StdPreReordHook"
	c_cuddStdPreReordHook :: HookFP

foreign import ccall safe "cudd.h &Cudd_StdPostReordHook"
	c_cuddStdPostReordHook :: HookFP

foreign import ccall safe "cudd.h Cudd_EnableReorderingReporting"
	c_cuddEnableReorderingReporting :: Ptr CDdManager -> IO (CInt)

cuddEnableReorderingReporting :: STDdManager s u -> ST s Int
cuddEnableReorderingReporting (STDdManager m) = unsafeIOToST $ liftM fromIntegral $ c_cuddEnableReorderingReporting m

foreign import ccall safe "cudd.h Cudd_DisableReorderingReporting"
	c_cuddDisableReorderingReporting :: Ptr CDdManager -> IO (CInt)

cuddDisableReorderingReporting :: STDdManager s u -> ST s Int
cuddDisableReorderingReporting (STDdManager m) = unsafeIOToST $ liftM fromIntegral $ c_cuddDisableReorderingReporting m

foreign import ccall safe "cudd.h Cudd_ReorderingReporting"
	c_cuddReorderingReporting :: Ptr CDdManager -> IO (CInt)

cuddReorderingReporting :: STDdManager s u -> ST s Int
cuddReorderingReporting (STDdManager m) = unsafeIOToST $ liftM fromIntegral $ c_cuddReorderingReporting m

regStdPreReordHook :: STDdManager s u -> ST s Int
regStdPreReordHook m = cuddAddHook m c_cuddStdPreReordHook CuddPreReorderingHook

regStdPostReordHook :: STDdManager s u -> ST s Int
regStdPostReordHook m = cuddAddHook m c_cuddStdPostReordHook CuddPostReorderingHook

--Universal reordering params
foreign import ccall safe "cudd.h Cudd_TurnOffCountDead"
	c_cuddTurnOffCountDead :: Ptr CDdManager -> IO ()

cuddTurnOffCountDead :: STDdManager s u -> ST s ()
cuddTurnOffCountDead (STDdManager m) = unsafeIOToST $ c_cuddTurnOffCountDead m

foreign import ccall safe "cudd.h Cudd_TurnOnCountDead"
	c_cuddTurnOnCountDead :: Ptr CDdManager -> IO ()

cuddTurnOnCountDead :: STDdManager s u -> ST s ()
cuddTurnOnCountDead (STDdManager m) = unsafeIOToST $ c_cuddTurnOnCountDead m

foreign import ccall safe "cudd.h Cudd_DeadAreCounted"
	c_cuddDeadAreCounted :: Ptr CDdManager -> IO CInt

cuddDeadAreCounted :: STDdManager s u -> ST s Int
cuddDeadAreCounted (STDdManager m) = unsafeIOToST $ liftM fromIntegral $ c_cuddDeadAreCounted m

--Sifting parameters
foreign import ccall safe "cudd.h Cudd_ReadSiftMaxSwap"
	c_cuddReadSiftMaxSwap :: Ptr CDdManager -> IO (CInt)

cuddReadSiftMaxSwap :: STDdManager s u -> ST s Int
cuddReadSiftMaxSwap = readIntegral c_cuddReadSiftMaxSwap

foreign import ccall safe "cudd.h Cudd_SetSiftMaxSwap"
	c_cuddSetSiftMaxSwap :: Ptr CDdManager -> CInt -> IO ()

cuddSetSiftMaxSwap :: STDdManager s u -> Int -> ST s ()
cuddSetSiftMaxSwap = setIntegral c_cuddSetSiftMaxSwap

foreign import ccall safe "cudd.h Cudd_ReadSiftMaxVar"
	c_cuddReadSiftMaxVar :: Ptr CDdManager -> IO (Int)

cuddReadSiftMaxVar :: STDdManager s u -> ST s Int
cuddReadSiftMaxVar = readIntegral c_cuddReadSiftMaxVar

foreign import ccall safe "cudd.h Cudd_SetSiftMaxVar"
	c_cuddSetSiftMaxVar :: Ptr CDdManager -> CInt -> IO ()

cuddSetSiftMaxVar :: STDdManager s u -> Int -> ST s ()
cuddSetSiftMaxVar = setIntegral c_cuddSetSiftMaxVar

foreign import ccall safe "cudd.h Cudd_ReadNextReordering"
	c_cuddReadNextReordering :: Ptr CDdManager -> IO (Int)

cuddReadNextReordering :: STDdManager s u -> ST s Int
cuddReadNextReordering = readIntegral c_cuddReadNextReordering

foreign import ccall safe "cudd.h Cudd_SetNextReordering"
	c_cuddSetNextReordering :: Ptr CDdManager -> CInt -> IO ()

cuddSetNextReordering :: STDdManager s u -> Int -> ST s ()
cuddSetNextReordering = setIntegral c_cuddSetNextReordering

foreign import ccall safe "cudd.h Cudd_ReadMaxGrowthAlternate"
	c_cuddReadMaxGrowthAlternate :: Ptr CDdManager -> IO CDouble

cuddReadMaxGrowthAlternate :: STDdManager s u -> ST s Double
cuddReadMaxGrowthAlternate = readFloat c_cuddReadMaxGrowthAlternate

foreign import ccall safe "cudd.h Cudd_SetMaxGrowthAlternate"
	c_cuddSetMaxGrowthAlternate :: Ptr CDdManager -> CDouble -> IO ()

cuddSetMaxGrowthAlternate :: STDdManager s u -> Double -> ST s ()
cuddSetMaxGrowthAlternate = setFloat c_cuddSetMaxGrowthAlternate

foreign import ccall safe "cudd.h Cudd_ReadMaxGrowth"
	c_cuddReadMaxGrowth :: Ptr CDdManager -> IO CDouble

cuddReadMaxGrowth :: STDdManager s u -> ST s Double
cuddReadMaxGrowth = readFloat c_cuddReadMaxGrowth

foreign import ccall safe "cudd.h Cudd_SetMaxGrowth"
	c_cuddSetMaxGrowth :: Ptr CDdManager -> CDouble -> IO ()

cuddSetMaxGrowth :: STDdManager s u -> Double -> ST s ()
cuddSetMaxGrowth = setFloat c_cuddSetMaxGrowth

foreign import ccall safe "cudd.h Cudd_ReadReorderingCycle"
	c_cuddReadReorderingCycle :: Ptr CDdManager -> IO (CInt)

cuddReadReorderingCycle :: STDdManager s u -> ST s Int
cuddReadReorderingCycle = readIntegral c_cuddReadReorderingCycle

foreign import ccall safe "cudd.h Cudd_SetReorderingCycle"
	c_cuddSetReorderingCycle :: Ptr CDdManager -> CInt -> IO ()

cuddSetReorderingCycle :: STDdManager s u -> Int -> ST s ()
cuddSetReorderingCycle = setIntegral c_cuddSetReorderingCycle

--Genetic algorithm
foreign import ccall safe "cudd.h Cudd_ReadPopulationSize"
	c_cuddReadPopulationSize :: Ptr CDdManager -> IO (CInt)

cuddReadPopulationSize :: STDdManager s u -> ST s Int
cuddReadPopulationSize = readIntegral c_cuddReadPopulationSize

foreign import ccall safe "cudd.h Cudd_SetPopulationSize"
	c_cuddSetPopulationSize :: Ptr CDdManager -> CInt -> IO ()

cuddSetPopulationSize :: STDdManager s u -> Int -> ST s ()
cuddSetPopulationSize = setIntegral c_cuddSetPopulationSize

foreign import ccall safe "cudd.h Cudd_ReadNumberXovers"
	c_cuddReadNumberXovers :: Ptr CDdManager -> IO (CInt)

cuddReadNumberXovers :: STDdManager s u -> ST s Int
cuddReadNumberXovers = readIntegral c_cuddReadNumberXovers

foreign import ccall safe "cudd.h Cudd_SetNumberXovers"
	c_cuddSetNumberXovers :: Ptr CDdManager -> CInt -> IO ()

cuddSetNumberXovers :: STDdManager s u -> Int -> ST s ()
cuddSetNumberXovers = setIntegral c_cuddSetNumberXovers

reordGCHook :: HookTyp
reordGCHook _ _ _ = do
    --putStrLn "reordGCHook"
    performGC
    --putStrLn "gc done"
    return (fromIntegral 1)

foreign import ccall "wrapper"
    makeFunPtr :: HookTyp -> IO (FunPtr HookTyp)

regReordGCHook :: STDdManager s u -> ST s Int
regReordGCHook m = do
    hk <- unsafeIOToST $ makeFunPtr reordGCHook
    cuddAddHook m hk CuddPreReorderingHook


Documentation fixes

Documentation fixes

{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}

-- | To catch GError exceptions use the
-- catchGError* or handleGError* functions. They work in a similar
-- way to the standard 'Control.Exception.catch' and
-- 'Control.Exception.handle' functions.
--
-- To catch just a single specific error use 'catchGErrorJust' \/
-- 'handleGErrorJust'. To catch any error in a particular error domain
-- use 'catchGErrorJustDomain' \/ 'handleGErrorJustDomain'
--
-- For convenience, generated code also includes specialized variants
-- of 'catchGErrorJust' \/ 'handleGErrorJust' for each error type. For
-- example, for errors of type 'GI.GdkPixbuf.PixbufError' one could
-- invoke 'GI.GdkPixbuf.catchPixbufError' \/
-- 'GI.GdkPixbuf.handlePixbufError'. The definition is simply
--
-- > catchPixbufError :: IO a -> (PixbufError -> GErrorMessage -> IO a) -> IO a
-- > catchPixbufError = catchGErrorJustDomain
--
-- Notice that the type is suitably specialized, so only
-- errors of type 'GI.GdkPixbuf.PixbufError' will be caught.
module GI.Utils.GError
    (
    -- * Unpacking GError
    --
      GError(..)
    , gerrorDomain
    , gerrorCode
    , gerrorMessage

    , GErrorDomain
    , GErrorCode
    , GErrorMessage

    -- * Catching GError exceptions
    , catchGErrorJust
    , catchGErrorJustDomain

    , handleGErrorJust
    , handleGErrorJustDomain

    -- * Creating new 'GError's
    , gerrorNew

    -- * Implementation specific details
    -- | The following are used in the implementation
    -- of the bindings, and are in general not necessary for using the
    -- API.
    , GErrorClass(..)

    , propagateGError
    , checkGError

    ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif

import Foreign (poke, peek)
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
import Foreign.Ptr (Ptr, plusPtr, nullPtr)
import Foreign.C
import Control.Exception
import Data.Text (Text)
import Data.Typeable (Typeable)

import GI.Utils.BasicTypes (BoxedObject(..), GType(..))
import GI.Utils.BasicConversions (withTextCString, cstringToText)
import GI.Utils.ManagedPtr (wrapBoxed)
import GI.Utils.Utils (allocMem, freeMem)

#include <glib.h>

-- | A GError, consisting of a domain, code and a human readable
-- message. These can be accessed by 'gerrorDomain', 'gerrorCode' and
-- 'gerrorMessage' below.
newtype GError = GError (ForeignPtr GError)
    deriving (Typeable, Show)

instance Exception GError

foreign import ccall "g_error_get_type" g_error_get_type :: IO GType

instance BoxedObject GError where
    boxedType _ = g_error_get_type

-- | A GQuark.
type GQuark = {# type GQuark #}

-- | A code used to identify the "namespace" of the error. Within each error
--   domain all the error codes are defined in an enumeration. Each gtk\/gnome
--   module that uses GErrors has its own error domain. The rationale behind
--   using error domains is so that each module can organise its own error codes
--   without having to coordinate on a global error code list.
type GErrorDomain  = GQuark

-- | A code to identify a specific error within a given 'GErrorDomain'. Most of
--   time you will not need to deal with this raw code since there is an
--   enumeration type for each error domain. Of course which enumeration to use
--   depends on the error domain, but if you use 'catchGErrorJustDomain' or
--   'handleGErrorJustDomain', this is worked out for you automatically.
type GErrorCode = {# type gint #}

-- | A human readable error message.
type GErrorMessage = Text

foreign import ccall "g_error_new_literal" g_error_new_literal ::
    GQuark -> GErrorCode -> CString -> IO (Ptr GError)

-- | Create a new 'GError'.
gerrorNew :: GErrorDomain -> GErrorCode -> GErrorMessage -> IO GError
gerrorNew domain code message =
    withTextCString message $ \cstring ->
        g_error_new_literal domain code cstring >>= wrapBoxed GError

-- | Return the domain for the given `GError`. This is a GQuark, a
-- textual representation can be obtained with
-- `GI.GLib.quarkToString`.
gerrorDomain :: GError -> IO GQuark
gerrorDomain (GError fptr) =
    withForeignPtr fptr $ \ptr ->
      peek $ ptr `plusPtr` {# offsetof GError->domain #}

-- | The numeric code for the given `GError`.
gerrorCode :: GError -> IO GErrorCode
gerrorCode (GError fptr) =
    withForeignPtr fptr $ \ptr ->
        peek $ ptr `plusPtr` {# offsetof GError->code #}

-- | A text message describing the `GError`.
gerrorMessage :: GError -> IO GErrorMessage
gerrorMessage (GError fptr) =
    withForeignPtr fptr $ \ptr ->
      (peek $ ptr `plusPtr` {# offsetof GError->message #}) >>= cstringToText

-- | Each error domain's error enumeration type should be an instance of this
--   class. This class helps to hide the raw error and domain codes from the
--   user.
--
-- Example for 'GI.GdkPixbuf.PixbufError':
--
-- > instance GErrorClass PixbufError where
-- >   gerrorClassDomain _ = "gdk-pixbuf-error-quark"
--
class Enum err => GErrorClass err where
  gerrorClassDomain :: err -> Text   -- ^ This must not use the value of its
                                     -- parameter so that it is safe to pass
                                     -- 'undefined'.

foreign import ccall unsafe "g_quark_try_string" g_quark_try_string ::
    CString -> IO GQuark

-- | Given the string representation of an error domain returns the
--   corresponding error quark.
gErrorQuarkFromDomain :: Text -> IO GQuark
gErrorQuarkFromDomain domain = withTextCString domain g_quark_try_string

-- | This will catch just a specific GError exception. If you need to catch a
--   range of related errors, 'catchGErrorJustDomain' is probably more
--   appropriate. Example:
--
-- > do image <- catchGErrorJust PixbufErrorCorruptImage
-- >               loadImage
-- >               (\errorMessage -> do log errorMessage
-- >                                    return mssingImagePlaceholder)
--
catchGErrorJust :: GErrorClass err => err  -- ^ The error to catch
                -> IO a                    -- ^ The computation to run
                -> (GErrorMessage -> IO a) -- ^ Handler to invoke if
                                           -- an exception is raised
                -> IO a
catchGErrorJust code action handler = do
  domainQuark <- gErrorQuarkFromDomain $ gerrorClassDomain code
  catch action (handler' domainQuark)
  where handler' quark gerror = do
          domain <- gerrorDomain gerror
          code' <- gerrorCode gerror
          if domain == quark && code' == (fromIntegral . fromEnum) code
          then gerrorMessage gerror >>= handler
          else throw gerror -- Pass it on

-- | Catch all GErrors from a particular error domain. The handler function
--   should just deal with one error enumeration type. If you need to catch
--   errors from more than one error domain, use this function twice with an
--   appropriate handler functions for each.
--
-- > catchGErrorJustDomain
-- >   loadImage
-- >   (\err message -> case err of
-- >       PixbufErrorCorruptImage -> ...
-- >       PixbufErrorInsufficientMemory -> ...
-- >       PixbufErrorUnknownType -> ...
-- >       _ -> ...)
--
catchGErrorJustDomain :: forall err a. GErrorClass err =>
                         IO a        -- ^ The computation to run
                      -> (err -> GErrorMessage -> IO a) -- ^ Handler to invoke if an exception is raised
                      -> IO a
catchGErrorJustDomain action handler = do
  domainQuark <- gErrorQuarkFromDomain $ gerrorClassDomain (undefined::err)
  catch action (handler' domainQuark)
  where handler' quark gerror = do
          domain <- gerrorDomain gerror
          if domain == quark
          then do
            code <- (toEnum . fromIntegral) <$> gerrorCode gerror
            msg <- gerrorMessage gerror
            handler code msg
          else throw gerror

-- | A verson of 'handleGErrorJust' with the arguments swapped around.
handleGErrorJust :: GErrorClass err => err -> (GErrorMessage -> IO a) -> IO a -> IO a
handleGErrorJust code = flip (catchGErrorJust code)

-- | A verson of 'catchGErrorJustDomain' with the arguments swapped around.
handleGErrorJustDomain :: GErrorClass err => (err -> GErrorMessage -> IO a) -> IO a -> IO a
handleGErrorJustDomain = flip catchGErrorJustDomain

-- | Run the given function catching possible 'GError's in its
-- execution. If a 'GError' is emitted this throws the corresponding
-- exception.
propagateGError :: (Ptr (Ptr GError) -> IO a) -> IO a
propagateGError f = checkGError f throw

-- | Like 'propagateGError', but allows to specify a custom handler
-- instead of just throwing the exception.
checkGError :: (Ptr (Ptr GError) -> IO a) -> (GError -> IO a) -> IO a
checkGError f handler = do
  gerrorPtr <- allocMem
  poke gerrorPtr nullPtr
  result <- f gerrorPtr
  gerror <- peek gerrorPtr
  freeMem gerrorPtr
  if gerror /= nullPtr
  then wrapBoxed GError gerror >>= handler
  else return result

{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}

-- | To catch GError exceptions use the
-- catchGError* or handleGError* functions. They work in a similar
-- way to the standard 'Control.Exception.catch' and
-- 'Control.Exception.handle' functions.
--
-- To catch just a single specific error use 'catchGErrorJust' \/
-- 'handleGErrorJust'. To catch any error in a particular error domain
-- use 'catchGErrorJustDomain' \/ 'handleGErrorJustDomain'
--
-- For convenience, generated code also includes specialized variants
-- of 'catchGErrorJust' \/ 'handleGErrorJust' for each error type. For
-- example, for errors of type 'GI.GdkPixbuf.PixbufError' one could
-- invoke 'GI.GdkPixbuf.catchPixbufError' \/
-- 'GI.GdkPixbuf.handlePixbufError'. The definition is simply
--
-- > catchPixbufError :: IO a -> (PixbufError -> GErrorMessage -> IO a) -> IO a
-- > catchPixbufError = catchGErrorJustDomain
--
-- Notice that the type is suitably specialized, so only
-- errors of type 'GI.GdkPixbuf.PixbufError' will be caught.
module GI.Utils.GError
    (
    -- * Unpacking GError
    --
      GError(..)
    , gerrorDomain
    , gerrorCode
    , gerrorMessage

    , GErrorDomain
    , GErrorCode
    , GErrorMessage

    -- * Catching GError exceptions
    , catchGErrorJust
    , catchGErrorJustDomain

    , handleGErrorJust
    , handleGErrorJustDomain

    -- * Creating new 'GError's
    , gerrorNew

    -- * Implementation specific details
    -- | The following are used in the implementation
    -- of the bindings, and are in general not necessary for using the
    -- API.
    , GErrorClass(..)

    , propagateGError
    , checkGError

    ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif

import Foreign (poke, peek)
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
import Foreign.Ptr (Ptr, plusPtr, nullPtr)
import Foreign.C
import Control.Exception
import Data.Text (Text)
import Data.Typeable (Typeable)

import GI.Utils.BasicTypes (BoxedObject(..), GType(..))
import GI.Utils.BasicConversions (withTextCString, cstringToText)
import GI.Utils.ManagedPtr (wrapBoxed)
import GI.Utils.Utils (allocMem, freeMem)

#include <glib.h>

-- | A GError, consisting of a domain, code and a human readable
-- message. These can be accessed by 'gerrorDomain', 'gerrorCode' and
-- 'gerrorMessage' below.
newtype GError = GError (ForeignPtr GError)
    deriving (Typeable, Show)

instance Exception GError

foreign import ccall "g_error_get_type" g_error_get_type :: IO GType

instance BoxedObject GError where
    boxedType _ = g_error_get_type

-- | A GQuark.
type GQuark = {# type GQuark #}

-- | A code used to identify the \'namespace\' of the error. Within each error
--   domain all the error codes are defined in an enumeration. Each gtk\/gnome
--   module that uses GErrors has its own error domain. The rationale behind
--   using error domains is so that each module can organise its own error codes
--   without having to coordinate on a global error code list.
type GErrorDomain  = GQuark

-- | A code to identify a specific error within a given 'GErrorDomain'. Most of
--   time you will not need to deal with this raw code since there is an
--   enumeration type for each error domain. Of course which enumeraton to use
--   depends on the error domain, but if you use 'catchGErrorJustDomain' or
--   'handleGErrorJustDomain', this is worked out for you automatically.
type GErrorCode = {# type gint #}

-- | A human readable error message.
type GErrorMessage = Text

foreign import ccall "g_error_new_literal" g_error_new_literal ::
    GQuark -> GErrorCode -> CString -> IO (Ptr GError)

-- | Create a new 'GError'.
gerrorNew :: GErrorDomain -> GErrorCode -> GErrorMessage -> IO GError
gerrorNew domain code message =
    withTextCString message $ \cstring ->
        g_error_new_literal domain code cstring >>= wrapBoxed GError

-- | Return the domain for the given `GError`. This is a GQuark, a
-- textual representation can be obtained with
-- `GI.GLib.quarkToString`.
gerrorDomain :: GError -> IO GQuark
gerrorDomain (GError fptr) =
    withForeignPtr fptr $ \ptr ->
      peek $ ptr `plusPtr` {# offsetof GError->domain #}

-- | The numeric code for the given `GError`.
gerrorCode :: GError -> IO GErrorCode
gerrorCode (GError fptr) =
    withForeignPtr fptr $ \ptr ->
        peek $ ptr `plusPtr` {# offsetof GError->code #}

-- | A text message describing the `GError`.
gerrorMessage :: GError -> IO GErrorMessage
gerrorMessage (GError fptr) =
    withForeignPtr fptr $ \ptr ->
      (peek $ ptr `plusPtr` {# offsetof GError->message #}) >>= cstringToText

-- | Each error domain's error enumeration type should be an instance of this
--   class. This class helps to hide the raw error and domain codes from the
--   user.
--
-- Example for 'GI.GdkPixbuf.PixbufError':
--
-- > instance GErrorClass PixbufError where
-- >   gerrorClassDomain _ = "gdk-pixbuf-error-quark"
--
class Enum err => GErrorClass err where
  gerrorClassDomain :: err -> Text   -- ^ This must not use the value of its
                                     -- parameter so that it is safe to pass
                                     -- 'undefined'.

foreign import ccall unsafe "g_quark_try_string" g_quark_try_string ::
    CString -> IO GQuark

-- | Given the string representation of an error domain returns the
--   corresponding error quark.
gErrorQuarkFromDomain :: Text -> IO GQuark
gErrorQuarkFromDomain domain = withTextCString domain g_quark_try_string

-- | This will catch just a specific GError exception. If you need to catch a
--   range of related errors, 'catchGErrorJustDomain' is probably more
--   appropriate. Example:
--
-- > do image <- catchGErrorJust PixbufErrorCorruptImage
-- >               loadImage
-- >               (\errorMessage -> do log errorMessage
-- >                                    return mssingImagePlaceholder)
--
catchGErrorJust :: GErrorClass err => err  -- ^ The error to catch
                -> IO a                    -- ^ The computation to run
                -> (GErrorMessage -> IO a) -- ^ Handler to invoke if
                                           -- an exception is raised
                -> IO a
catchGErrorJust code action handler = do
  domainQuark <- gErrorQuarkFromDomain $ gerrorClassDomain code
  catch action (handler' domainQuark)
  where handler' quark gerror = do
          domain <- gerrorDomain gerror
          code' <- gerrorCode gerror
          if domain == quark && code' == (fromIntegral . fromEnum) code
          then gerrorMessage gerror >>= handler
          else throw gerror -- Pass it on

-- | Catch all GErrors from a particular error domain. The handler function
--   should just deal with one error enumeration type. If you need to catch
--   errors from more than one error domain, use this function twice with an
--   appropriate handler functions for each.
--
-- > catchGErrorJustDomain
-- >   loadImage
-- >   (\err message -> case err of
-- >       PixbufErrorCorruptImage -> ...
-- >       PixbufErrorInsufficientMemory -> ...
-- >       PixbufErrorUnknownType -> ...
-- >       _ -> ...)
--
catchGErrorJustDomain :: forall err a. GErrorClass err =>
                         IO a        -- ^ The computation to run
                      -> (err -> GErrorMessage -> IO a) -- ^ Handler to invoke if an exception is raised
                      -> IO a
catchGErrorJustDomain action handler = do
  domainQuark <- gErrorQuarkFromDomain $ gerrorClassDomain (undefined::err)
  catch action (handler' domainQuark)
  where handler' quark gerror = do
          domain <- gerrorDomain gerror
          if domain == quark
          then do
            code <- (toEnum . fromIntegral) <$> gerrorCode gerror
            msg <- gerrorMessage gerror
            handler code msg
          else throw gerror

-- | A verson of 'handleGErrorJust' with the arguments swapped around.
handleGErrorJust :: GErrorClass err => err -> (GErrorMessage -> IO a) -> IO a -> IO a
handleGErrorJust code = flip (catchGErrorJust code)

-- | A verson of 'catchGErrorJustDomain' with the arguments swapped around.
handleGErrorJustDomain :: GErrorClass err => (err -> GErrorMessage -> IO a) -> IO a -> IO a
handleGErrorJustDomain = flip catchGErrorJustDomain

-- | Run the given function catching possible GErrors in its
-- execution. If a GError is emitted this throws the corresponding
-- exception.
propagateGError :: (Ptr (Ptr GError) -> IO a) -> IO a
propagateGError f = checkGError f throw

-- | Like propagateGError, but allows to specify a custom handler
-- instead of just throwing the exception.
checkGError :: (Ptr (Ptr GError) -> IO a) -> (GError -> IO a) -> IO a
checkGError f handler = do
  gerrorPtr <- allocMem
  poke gerrorPtr nullPtr
  result <- f gerrorPtr
  gerror <- peek gerrorPtr
  freeMem gerrorPtr
  if gerror /= nullPtr
  then wrapBoxed GError gerror >>= handler
  else return result