add option flags to host allocation

add option flags to host allocation

Ignore-this: 89c53d2f0e3d8ec6c14de4a96492c805
- correspondingly, get a device pointer from mapped, pinned host memory

darcs-hash:20091209234733-9241b-b4e2536923ec1d5fcb34b4aeb0d29e75446e516c.gz

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Marshal
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- Memory management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Marshal
  (
    DevicePtr, HostPtr, AllocFlag(..), withHostPtr,
    malloc, free, mallocHost, freeHost,
    peekArray, peekArrayAsync, pokeArray, pokeArrayAsync, memset,
    getDevicePtr
  )
  where

#include <cuda.h>
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Stream               (Stream, withStream)

-- System
import Foreign                           hiding (peekArray, pokeArray, malloc, free)
import Foreign.C
import Control.Monad                            (liftM)
import Unsafe.Coerce

#c
typedef enum CUmemhostalloc_option_enum {
    CU_MEMHOSTALLOC_OPTION_PORTABLE       = CU_MEMHOSTALLOC_PORTABLE,
    CU_MEMHOSTALLOC_OPTION_DEVICE_MAPPED  = CU_MEMHOSTALLOC_DEVICEMAP,
    CU_MEMHOSTALLOC_OPTION_WRITE_COMBINED = CU_MEMHOSTALLOC_WRITECOMBINED
} CUmemhostalloc_option;
#endc

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

-- |
-- A reference to memory allocated on the device
--
newtype DevicePtr a = DevicePtr { useDevicePtr :: {# type CUdeviceptr #}}
  deriving (Show)

-- |
-- A reference to memory on the host that is page-locked and directly-accessible
-- from the device. Since the memory can be accessed directly, it can be read or
-- written at a much higher bandwidth than pageable memory from the traditional
-- malloc.
--
-- The driver automatically accelerates calls to functions such as `memcpy'
-- which reference page-locked memory.
--
newtype HostPtr a = HostPtr (ForeignPtr a)

withHostPtr :: HostPtr a -> (Ptr a -> IO b) -> IO b
withHostPtr (HostPtr hptr) = withForeignPtr hptr

newHostPtr :: IO (HostPtr a)
newHostPtr = HostPtr `fmap` mallocForeignPtrBytes (sizeOf (undefined :: Ptr ()))

-- |
-- Options for host allocation
--
{# enum CUmemhostalloc_option as AllocFlag
    { underscoreToCase }
    with prefix="CU_MEMHOSTALLOC_OPTION" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Host Allocation
--------------------------------------------------------------------------------

-- |
-- Allocate a section of linear memory on the host which is page-locked and
-- directly accessible from the device. Note that since the amount of pageable
-- memory is thusly reduced, overall system performance may suffer. This is best
-- used sparingly to allocate staging areas for data exchange.
--
mallocHost :: [AllocFlag] -> Int -> IO (Either String (HostPtr a))
mallocHost flags bytes =
  newHostPtr >>= \hp -> withHostPtr hp $ \p ->
  cuMemHostAlloc p bytes flags >>= \rv ->
  return $ case nothingIfOk rv of
    Nothing  -> Right hp
    Just err -> Left err

{# fun unsafe cuMemHostAlloc
  { with'* `Ptr a'
  ,        `Int'
  , combineBitMasks `[AllocFlag]' } -> `Status' cToEnum #}
  where with' = with . castPtr

-- |
-- Free a section of page-locked host memory
--
freeHost :: HostPtr a -> IO (Maybe String)
freeHost hp = withHostPtr hp $ \p -> (nothingIfOk `fmap` cuMemFreeHost p)

{# fun unsafe cuMemFreeHost
  { castPtr `Ptr a' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Device Allocation
--------------------------------------------------------------------------------

-- |
-- Allocate a section of linear memory on the device, and return a reference to
-- it. The memory is suitably aligned for any type, and is not cleared.
--
malloc :: Int -> IO (Either String (DevicePtr a))
malloc bytes = resultIfOk `fmap` cuMemAlloc bytes

{# fun unsafe cuMemAlloc
  { alloca-  `DevicePtr a' dptr*
  ,          `Int'               } -> `Status' cToEnum #}
  where dptr = liftM DevicePtr . peekIntConv

-- |
-- Release a section of device memory
--
free :: DevicePtr a -> IO (Maybe String)
free dp = nothingIfOk `fmap` cuMemFree dp

{# fun unsafe cuMemFree
  { useDevicePtr `DevicePtr a' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Transfer
--------------------------------------------------------------------------------

-- |
-- Copy a number of elements from the device to host memory. This is a
-- synchronous operation
--
peekArray :: Storable a => Int -> DevicePtr a -> Ptr a -> IO (Maybe String)
peekArray n dptr hptr = doPeek undefined dptr
  where
    doPeek :: Storable a' => a' -> DevicePtr a' -> IO (Maybe String)
    doPeek x _ = nothingIfOk `fmap` cuMemcpyDtoH hptr dptr (n * sizeOf x)

{# fun unsafe cuMemcpyDtoH
  { castPtr      `Ptr a'
  , useDevicePtr `DevicePtr a'
  ,              `Int'         } -> `Status' cToEnum #}

-- |
-- Copy memory from the device asynchronously, possibly associated with a
-- particular stream. The destination host memory must be page-locked (allocated
-- by mallocHost)
--
peekArrayAsync :: Storable a => Int -> DevicePtr a -> Ptr a -> Maybe Stream -> IO (Maybe String)
peekArrayAsync n dptr hptr mst = doPeek undefined dptr
  where
    doPeek :: Storable a' => a' -> DevicePtr a' -> IO (Maybe String)
    doPeek x _ =
      nothingIfOk `fmap` case mst of
        Nothing -> cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) nullPtr
        Just st -> (withStream st $ \s -> cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) s)

{# fun unsafe cuMemcpyDtoHAsync
  { castPtr      `Ptr a'
  , useDevicePtr `DevicePtr a'
  ,              `Int'
  , castPtr      `Ptr Stream'  } -> `Status' cToEnum #}

-- |
-- Copy a number of elements onto the device. This is a synchronous operation
--
pokeArray :: Storable a => Int -> Ptr a -> DevicePtr a -> IO (Maybe String)
pokeArray n hptr dptr = doPoke undefined dptr
  where
    doPoke :: Storable a' => a' -> DevicePtr a' -> IO (Maybe String)
    doPoke x _ = nothingIfOk `fmap` cuMemcpyHtoD dptr hptr (n * sizeOf x)

{# fun unsafe cuMemcpyHtoD
  { useDevicePtr `DevicePtr a'
  , castPtr      `Ptr a'
  ,              `Int'         } -> `Status' cToEnum #}

-- |
-- Copy memory onto the device asynchronously, possibly associated with a
-- particular stream. The source host memory must be page-locked (allocated by
-- mallocHost)
--
pokeArrayAsync :: Storable a => Int -> Ptr a -> DevicePtr a -> Maybe Stream -> IO (Maybe String)
pokeArrayAsync n hptr dptr mst = dopoke undefined dptr
  where
    dopoke :: Storable a' => a' -> DevicePtr a' -> IO (Maybe String)
    dopoke x _ =
      nothingIfOk `fmap` case mst of
        Nothing -> cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) nullPtr
        Just st -> (withStream st $ \s -> cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) s)

{# fun unsafe cuMemcpyHtoDAsync
  { useDevicePtr `DevicePtr a'
  , castPtr      `Ptr a'
  ,              `Int'
  , castPtr      `Ptr Stream'  } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Utility
--------------------------------------------------------------------------------

-- |
-- Set a number of data elements to the specified value, which may be either 8-,
-- 16-, or 32-bits wide.
--
memset :: Storable a => DevicePtr a -> Int -> a -> IO (Maybe String)
memset dptr n val = case sizeOf val of
    1 -> nothingIfOk `fmap` cuMemsetD8  dptr val n
    2 -> nothingIfOk `fmap` cuMemsetD16 dptr val n
    4 -> nothingIfOk `fmap` cuMemsetD32 dptr val n
    _ -> return $ Just "can only memset 8-, 16-, and 32-bit values"

--
-- We use unsafe coerce below to reinterpret the bits of the value to memset as,
-- into the integer type required by the setting functions.
--
{# fun unsafe cuMemsetD8
  { useDevicePtr `DevicePtr a'
  , unsafeCoerce `a'
  ,              `Int'         } -> `Status' cToEnum #}

{# fun unsafe cuMemsetD16
  { useDevicePtr `DevicePtr a'
  , unsafeCoerce `a'
  ,              `Int'         } -> `Status' cToEnum #}

{# fun unsafe cuMemsetD32
  { useDevicePtr `DevicePtr a'
  , unsafeCoerce `a'
  ,              `Int'         } -> `Status' cToEnum #}

-- |
-- Return the device pointer associated with a mapped, pinned host buffer, which
-- was allocated with the DEVICE_MAPPED option.
--
-- Currently, no options are supported and this must be empty.
--
getDevicePtr :: [AllocFlag] -> HostPtr a -> IO (Either String (DevicePtr a))
getDevicePtr flags hptr = withHostPtr hptr $ \hp -> (resultIfOk `fmap` cuMemHostGetDevicePointer hp flags)

{# fun unsafe cuMemHostGetDevicePointer
  { alloca-         `DevicePtr a' dptr*
  , castPtr         `Ptr a'
  , combineBitMasks `[AllocFlag]'       } -> `Status' cToEnum #}
  where dptr = liftM DevicePtr . peekIntConv

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Marshal
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- Memory management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Marshal
  (
    DevicePtr, HostPtr,
    malloc, free, mallocHost, freeHost,
    peekArray, peekArrayAsync, pokeArray, pokeArrayAsync, memset
  )
  where

#include <cuda.h>
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Stream               (Stream, withStream)

-- System
import Foreign                           hiding (peekArray, pokeArray, malloc, free)
import Foreign.C
import Control.Monad                            (liftM)
import Unsafe.Coerce

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

-- |
-- A reference to memory allocated on the device
--
newtype DevicePtr a = DevicePtr { useDevicePtr :: {# type CUdeviceptr #}}
  deriving (Show)

-- |
-- A reference to memory on the host that is page-locked and directly-accessible
-- from the device. Since the memory can be accessed directly, it can be read or
-- written at a much higher bandwidth than pageable memory from the traditional
-- malloc.
--
-- The driver automatically accelerates calls to functions such as `memcpy'
-- which reference page-locked memory.
--
newtype HostPtr a = HostPtr (ForeignPtr a)

withHostPtr :: HostPtr a -> (Ptr a -> IO b) -> IO b
withHostPtr (HostPtr hptr) = withForeignPtr hptr

newHostPtr :: IO (HostPtr a)
newHostPtr = HostPtr `fmap` mallocForeignPtrBytes (sizeOf (undefined :: Ptr ()))

--------------------------------------------------------------------------------
-- Host Allocation
--------------------------------------------------------------------------------

-- |
-- Allocate a section of linear memory on the host which is page-locked and
-- directly accessible from the device. Note that since the amount of pageable
-- memory is thusly reduced, overall system performance may suffer. This is best
-- used sparingly to allocate staging areas for data exchange.
--
mallocHost :: Int -> IO (Either String (HostPtr a))
mallocHost bytes =
  newHostPtr >>= \hp -> withHostPtr hp $ \p ->
  cuMemAllocHost p bytes >>= \rv ->
  return $ case nothingIfOk rv of
    Nothing  -> Right hp
    Just err -> Left err

{# fun unsafe cuMemAllocHost
  { with'* `Ptr a'
  ,        `Int'         } -> `Status' cToEnum #}
  where with' = with . castPtr

-- |
-- Free a section of page-locked host memory
--
freeHost :: HostPtr a -> IO (Maybe String)
freeHost hp = withHostPtr hp $ \p -> (nothingIfOk `fmap` cuMemFreeHost p)

{# fun unsafe cuMemFreeHost
  { castPtr `Ptr a' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Device Allocation
--------------------------------------------------------------------------------

-- |
-- Allocate a section of linear memory on the device, and return a reference to
-- it. The memory is suitably aligned for any type, and is not cleared.
--
malloc :: Int -> IO (Either String (DevicePtr a))
malloc bytes = resultIfOk `fmap` cuMemAlloc bytes

{# fun unsafe cuMemAlloc
  { alloca-  `DevicePtr a' dptr*
  ,          `Int'               } -> `Status' cToEnum #}
  where dptr = liftM DevicePtr . peekIntConv

-- |
-- Release a section of device memory
--
free :: DevicePtr a -> IO (Maybe String)
free dp = nothingIfOk `fmap` cuMemFree dp

{# fun unsafe cuMemFree
  { useDevicePtr `DevicePtr a' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Transfer
--------------------------------------------------------------------------------

-- |
-- Copy a number of elements from the device to host memory. This is a
-- synchronous operation
--
peekArray :: Storable a => Int -> DevicePtr a -> Ptr a -> IO (Maybe String)
peekArray n dptr hptr = doPeek undefined dptr
  where
    doPeek :: Storable a' => a' -> DevicePtr a' -> IO (Maybe String)
    doPeek x _ = nothingIfOk `fmap` cuMemcpyDtoH hptr dptr (n * sizeOf x)

{# fun unsafe cuMemcpyDtoH
  { castPtr      `Ptr a'
  , useDevicePtr `DevicePtr a'
  ,              `Int'         } -> `Status' cToEnum #}

-- |
-- Copy memory from the device asynchronously, possibly associated with a
-- particular stream. The destination host memory must be page-locked (allocated
-- by mallocHost)
--
peekArrayAsync :: Storable a => Int -> DevicePtr a -> Ptr a -> Maybe Stream -> IO (Maybe String)
peekArrayAsync n dptr hptr mst = doPeek undefined dptr
  where
    doPeek :: Storable a' => a' -> DevicePtr a' -> IO (Maybe String)
    doPeek x _ =
      nothingIfOk `fmap` case mst of
        Nothing -> cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) nullPtr
        Just st -> (withStream st $ \s -> cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) s)

{# fun unsafe cuMemcpyDtoHAsync
  { castPtr      `Ptr a'
  , useDevicePtr `DevicePtr a'
  ,              `Int'
  , castPtr      `Ptr Stream'  } -> `Status' cToEnum #}

-- |
-- Copy a number of elements onto the device. This is a synchronous operation
--
pokeArray :: Storable a => Int -> Ptr a -> DevicePtr a -> IO (Maybe String)
pokeArray n hptr dptr = doPoke undefined dptr
  where
    doPoke :: Storable a' => a' -> DevicePtr a' -> IO (Maybe String)
    doPoke x _ = nothingIfOk `fmap` cuMemcpyHtoD dptr hptr (n * sizeOf x)

{# fun unsafe cuMemcpyHtoD
  { useDevicePtr `DevicePtr a'
  , castPtr      `Ptr a'
  ,              `Int'         } -> `Status' cToEnum #}

-- |
-- Copy memory onto the device asynchronously, possibly associated with a
-- particular stream. The source host memory must be page-locked (allocated by
-- mallocHost)
--
pokeArrayAsync :: Storable a => Int -> Ptr a -> DevicePtr a -> Maybe Stream -> IO (Maybe String)
pokeArrayAsync n hptr dptr mst = dopoke undefined dptr
  where
    dopoke :: Storable a' => a' -> DevicePtr a' -> IO (Maybe String)
    dopoke x _ =
      nothingIfOk `fmap` case mst of
        Nothing -> cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) nullPtr
        Just st -> (withStream st $ \s -> cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) s)

{# fun unsafe cuMemcpyHtoDAsync
  { useDevicePtr `DevicePtr a'
  , castPtr      `Ptr a'
  ,              `Int'
  , castPtr      `Ptr Stream'  } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Utility
--------------------------------------------------------------------------------

-- |
-- Set a number of data elements to the specified value, which may be either 8-,
-- 16-, or 32-bits wide.
--
memset :: Storable a => DevicePtr a -> Int -> a -> IO (Maybe String)
memset dptr n val = case sizeOf val of
    1 -> nothingIfOk `fmap` cuMemsetD8  dptr val n
    2 -> nothingIfOk `fmap` cuMemsetD16 dptr val n
    4 -> nothingIfOk `fmap` cuMemsetD32 dptr val n
    _ -> return $ Just "can only memset 8-, 16-, and 32-bit values"

--
-- We use unsafe coerce below to reinterpret the bits of the value to memset
-- into the required integer type.
--
{# fun unsafe cuMemsetD8
  { useDevicePtr `DevicePtr a'
  , unsafeCoerce `a'
  ,              `Int'         } -> `Status' cToEnum #}

{# fun unsafe cuMemsetD16
  { useDevicePtr `DevicePtr a'
  , unsafeCoerce `a'
  ,              `Int'         } -> `Status' cToEnum #}

{# fun unsafe cuMemsetD32
  { useDevicePtr `DevicePtr a'
  , unsafeCoerce `a'
  ,              `Int'         } -> `Status' cToEnum #}


removed unused import

removed unused import

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE LambdaCase #-}

module GDAL.Internal.CPLError (
    GDALException (..)
  , ErrorType (..)
  , ErrorNum (..)
  , isGDALException
  , isBindingException
  , throwBindingException
  , bindingExceptionToException
  , bindingExceptionFromException
  , checkCPLError
  , checkGDALCall
  , checkGDALCall_
  , withQuietErrorHandler
) where

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

import Control.Concurrent (runInBoundThread, rtsSupportsBoundThreads)
import Control.Monad (void, liftM)
import Control.Monad.Catch (MonadThrow(throwM))
import Control.Exception (
    Exception (..)
  , SomeException
  , throw
  , finally
  )
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Typeable (Typeable, cast)

import Foreign.C.Types (CInt(..), CChar(..))
import Foreign.Ptr (Ptr, FunPtr, nullPtr)
import Foreign.Storable (peekByteOff, peek)
import Foreign.Marshal.Utils (with)

-- work around  https://github.com/haskell/c2hs/issues/151
import qualified Foreign.C.Types as C2HSImp

import GDAL.Internal.Util (toEnumC)
import GDAL.Internal.CPLString (peekEncodedCString)

#include "cpl_error.h"
#include "errorhandler.h"

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

data GDALException
  = forall e. Exception e =>
    GDALBindingException !e
  | GDALException        { gdalErrType :: !ErrorType
                         , gdalErrNum  :: !ErrorNum
                         , gdalErrMsg  :: !Text}
  deriving Typeable

deriving instance Show GDALException

instance Exception GDALException

bindingExceptionToException :: Exception e=> e -> SomeException
bindingExceptionToException = toException . GDALBindingException

bindingExceptionFromException :: Exception e => SomeException -> Maybe e
bindingExceptionFromException x = do
  GDALBindingException a <- fromException x
  cast a

throwBindingException :: (MonadThrow m, Exception e) => e -> m a
throwBindingException = throwM . bindingExceptionToException

isGDALException :: SomeException -> Bool
isGDALException e = isJust (fromException e :: Maybe GDALException)

isBindingException :: SomeException -> Bool
isBindingException e
  = case fromException e of
      Just (GDALBindingException _) -> True
      _                             -> False

{#enum define ErrorNum {
    CPLE_None            as None
  , CPLE_AppDefined      as AppDefined
  , CPLE_OutOfMemory     as OutOfMemory
  , CPLE_FileIO          as FileIO
  , CPLE_OpenFailed      as OpenFailed
  , CPLE_IllegalArg      as IllegalArg
  , CPLE_NotSupported    as NotSupported
  , CPLE_AssertionFailed as AssertionFailed
  , CPLE_NoWriteAccess   as NoWriteAccess
  , CPLE_UserInterrupt   as UserInterrupt
  , CPLE_ObjectNull      as ObjectNull
  } deriving (Eq, Bounded, Show) #}

checkGDALCall
  :: Exception e
  => (Maybe GDALException -> a -> Maybe e) -> IO a -> IO a
checkGDALCall isOk act = withErrorHandler $ \ stack -> do
  a <- act
  err <- peekLastError stack
  case isOk err a of
    Nothing -> return a
    Just e  -> throw e
{-# INLINE checkGDALCall #-}

checkGDALCall_
  :: Exception e
  => (Maybe GDALException -> a -> Maybe e) -> IO a -> IO ()
{-# INLINE checkGDALCall_ #-}
checkGDALCall_ isOk = void . checkGDALCall isOk

checkCPLError :: Text -> IO CInt -> IO ()
checkCPLError msg = checkGDALCall_ $ \mExc r ->
  case (mExc, toEnumC r) of
    (Nothing, CE_None) -> Nothing
    (Nothing, e)       -> Just (GDALException e AssertionFailed msg)
    (e, _)             -> e
{-# INLINE checkCPLError #-}

{#pointer ErrorCell #}
type ErrorStack = Ptr ErrorCell

peekLastError :: ErrorStack -> IO (Maybe GDALException)
peekLastError stack = do
  ec <- peek stack
  if ec == nullPtr
    then return Nothing
    else do
      msg <- peekEncodedCString =<< {#get ErrorCell->msg #} ec
      errClass <- liftM toEnumC ({#get ErrorCell->errClass#} ec)
      errNo <- liftM toEnumC ({#get ErrorCell->errNo#} ec)
      return (Just (GDALException errClass errNo msg))

withErrorHandler :: (ErrorStack -> IO a) -> IO a
withErrorHandler act = runBounded $ with nullPtr $ \stack ->
  ({#call unsafe push_error_handler as ^#} stack >> act stack)
    `finally` ({#call unsafe pop_error_handler as ^#} stack)
{-# INLINE withErrorHandler #-}

runBounded :: IO a -> IO a
runBounded
  | rtsSupportsBoundThreads = runInBoundThread
  | otherwise               = id
{-# INLINE runBounded #-}

withQuietErrorHandler :: IO a -> IO a
withQuietErrorHandler a = runBounded ((pushIt >> a) `finally` popIt)
  where
    pushIt = {#call unsafe CPLPushErrorHandler as ^#} c_quietErrorHandler
    popIt  = {#call unsafe CPLPopErrorHandler as ^#}

foreign import ccall "cpl_error.h &CPLQuietErrorHandler"
  c_quietErrorHandler :: FunPtr (CInt -> CInt -> Ptr CChar -> IO ())

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE LambdaCase #-}

module GDAL.Internal.CPLError (
    GDALException (..)
  , ErrorType (..)
  , ErrorNum (..)
  , isGDALException
  , isBindingException
  , throwBindingException
  , bindingExceptionToException
  , bindingExceptionFromException
  , checkCPLError
  , checkGDALCall
  , checkGDALCall_
  , withQuietErrorHandler
) where

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

import Control.Concurrent (runInBoundThread, rtsSupportsBoundThreads)
import Control.Monad (void, liftM)
import Control.Monad.Catch (MonadThrow(throwM))
import Control.Exception (
    Exception (..)
  , SomeException
  , throw
  , bracket
  , finally
  )
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Typeable (Typeable, cast)

import Foreign.C.Types (CInt(..), CChar(..))
import Foreign.Ptr (Ptr, FunPtr, nullPtr)
import Foreign.Storable (peekByteOff, peek)
import Foreign.Marshal.Utils (with)

-- work around  https://github.com/haskell/c2hs/issues/151
import qualified Foreign.C.Types as C2HSImp

import GDAL.Internal.Util (toEnumC)
import GDAL.Internal.CPLString (peekEncodedCString)

#include "cpl_error.h"
#include "errorhandler.h"

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

data GDALException
  = forall e. Exception e =>
    GDALBindingException !e
  | GDALException        { gdalErrType :: !ErrorType
                         , gdalErrNum  :: !ErrorNum
                         , gdalErrMsg  :: !Text}
  deriving Typeable

deriving instance Show GDALException

instance Exception GDALException

bindingExceptionToException :: Exception e=> e -> SomeException
bindingExceptionToException = toException . GDALBindingException

bindingExceptionFromException :: Exception e => SomeException -> Maybe e
bindingExceptionFromException x = do
  GDALBindingException a <- fromException x
  cast a

throwBindingException :: (MonadThrow m, Exception e) => e -> m a
throwBindingException = throwM . bindingExceptionToException

isGDALException :: SomeException -> Bool
isGDALException e = isJust (fromException e :: Maybe GDALException)

isBindingException :: SomeException -> Bool
isBindingException e
  = case fromException e of
      Just (GDALBindingException _) -> True
      _                             -> False

{#enum define ErrorNum {
    CPLE_None            as None
  , CPLE_AppDefined      as AppDefined
  , CPLE_OutOfMemory     as OutOfMemory
  , CPLE_FileIO          as FileIO
  , CPLE_OpenFailed      as OpenFailed
  , CPLE_IllegalArg      as IllegalArg
  , CPLE_NotSupported    as NotSupported
  , CPLE_AssertionFailed as AssertionFailed
  , CPLE_NoWriteAccess   as NoWriteAccess
  , CPLE_UserInterrupt   as UserInterrupt
  , CPLE_ObjectNull      as ObjectNull
  } deriving (Eq, Bounded, Show) #}

checkGDALCall
  :: Exception e
  => (Maybe GDALException -> a -> Maybe e) -> IO a -> IO a
checkGDALCall isOk act = withErrorHandler $ \ stack -> do
  a <- act
  err <- peekLastError stack
  case isOk err a of
    Nothing -> return a
    Just e  -> throw e
{-# INLINE checkGDALCall #-}

checkGDALCall_
  :: Exception e
  => (Maybe GDALException -> a -> Maybe e) -> IO a -> IO ()
{-# INLINE checkGDALCall_ #-}
checkGDALCall_ isOk = void . checkGDALCall isOk

checkCPLError :: Text -> IO CInt -> IO ()
checkCPLError msg = checkGDALCall_ $ \mExc r ->
  case (mExc, toEnumC r) of
    (Nothing, CE_None) -> Nothing
    (Nothing, e)       -> Just (GDALException e AssertionFailed msg)
    (e, _)             -> e
{-# INLINE checkCPLError #-}

{#pointer ErrorCell #}
type ErrorStack = Ptr ErrorCell

peekLastError :: ErrorStack -> IO (Maybe GDALException)
peekLastError stack = do
  ec <- peek stack
  if ec == nullPtr
    then return Nothing
    else do
      msg <- peekEncodedCString =<< {#get ErrorCell->msg #} ec
      errClass <- liftM toEnumC ({#get ErrorCell->errClass#} ec)
      errNo <- liftM toEnumC ({#get ErrorCell->errNo#} ec)
      return (Just (GDALException errClass errNo msg))

withErrorHandler :: (ErrorStack -> IO a) -> IO a
withErrorHandler act = runBounded $ with nullPtr $ \stack ->
  ({#call unsafe push_error_handler as ^#} stack >> act stack)
    `finally` ({#call unsafe pop_error_handler as ^#} stack)
{-# INLINE withErrorHandler #-}

runBounded :: IO a -> IO a
runBounded
  | rtsSupportsBoundThreads = runInBoundThread
  | otherwise               = id
{-# INLINE runBounded #-}

withQuietErrorHandler :: IO a -> IO a
withQuietErrorHandler a = runBounded ((pushIt >> a) `finally` popIt)
  where
    pushIt = {#call unsafe CPLPushErrorHandler as ^#} c_quietErrorHandler
    popIt  = {#call unsafe CPLPopErrorHandler as ^#}

foreign import ccall "cpl_error.h &CPLQuietErrorHandler"
  c_quietErrorHandler :: FunPtr (CInt -> CInt -> Ptr CChar -> IO ())


Bindings for MPI_COMM_SELF (predefined handle)

{-# LANGUAGE ForeignFunctionInterface #-}

#include <mpi.h>

module Control.Parallel.MPI.Comm (Comm, commWorld, commSelf) where

import C2HS

{# context prefix = "MPI" #}

type Comm = {# type MPI_Comm #}
foreign import ccall "mpi_comm_world" commWorld :: Comm
foreign import ccall "mpi_comm_self" commSelf :: Comm

{-# LANGUAGE ForeignFunctionInterface #-}

#include <mpi.h>

module Control.Parallel.MPI.Comm (Comm, commWorld) where

import C2HS

{# context prefix = "MPI" #}

type Comm = {# type MPI_Comm #}
foreign import ccall "mpi_comm_world" commWorld :: Comm


Add missing Node functions

Add missing Node functions

module Graphics.UI.Gtk.WebKit.DOM.Node
       (nodeInsertBefore, nodeReplaceChild, nodeRemoveChild,
        nodeAppendChild, nodeHasChildNodes, nodeCloneNode, nodeNormalize,
        nodeIsSupported, nodeHasAttributes, nodeIsSameNode,
        nodeIsEqualNode, nodeLookupPrefix, nodeIsDefaultNamespace,
        nodeLookupNamespaceURI, nodeCompareDocumentPosition, nodeContains,
        nodeDispatchEvent, cELEMENT_NODE, cATTRIBUTE_NODE, cTEXT_NODE,
        cCDATA_SECTION_NODE, cENTITY_REFERENCE_NODE, cENTITY_NODE,
        cPROCESSING_INSTRUCTION_NODE, cCOMMENT_NODE, cDOCUMENT_NODE,
        cDOCUMENT_TYPE_NODE, cDOCUMENT_FRAGMENT_NODE, cNOTATION_NODE,
        cDOCUMENT_POSITION_DISCONNECTED, cDOCUMENT_POSITION_PRECEDING,
        cDOCUMENT_POSITION_FOLLOWING, cDOCUMENT_POSITION_CONTAINS,
        cDOCUMENT_POSITION_CONTAINED_BY,
        cDOCUMENT_POSITION_IMPLEMENTATION_SPECIFIC, nodeGetNodeName,
        nodeSetNodeValue, nodeGetNodeValue, nodeGetNodeType,
        nodeGetParentNode, nodeGetChildNodes, nodeGetFirstChild,
        nodeGetLastChild, nodeGetPreviousSibling, nodeGetNextSibling,
        nodeGetAttributes, nodeGetOwnerDocument, nodeGetNamespaceURI,
        nodeSetPrefix, nodeGetPrefix, nodeGetLocalName, nodeGetBaseURI,
        nodeSetTextContent, nodeGetTextContent, nodeGetParentElement)
       where
import System.Glib.FFI
import System.Glib.UTFString
import Control.Applicative
{#import Graphics.UI.Gtk.WebKit.Types#}
import System.Glib.GError
import Graphics.UI.Gtk.WebKit.DOM.EventM

nodeInsertBefore ::
                 (NodeClass self, NodeClass newChild, NodeClass refChild) =>
                   self -> Maybe newChild -> Maybe refChild -> IO (Maybe Node)
nodeInsertBefore self newChild refChild
  = maybeNull (makeNewGObject mkNode)
      (propagateGError $
         \ errorPtr_ ->
           {# call webkit_dom_node_insert_before #} (toNode self)
             (maybe (Node nullForeignPtr) toNode newChild)
             (maybe (Node nullForeignPtr) toNode refChild)
             errorPtr_)

nodeReplaceChild ::
                 (NodeClass self, NodeClass newChild, NodeClass oldChild) =>
                   self -> Maybe newChild -> Maybe oldChild -> IO (Maybe Node)
nodeReplaceChild self newChild oldChild
  = maybeNull (makeNewGObject mkNode)
      (propagateGError $
         \ errorPtr_ ->
           {# call webkit_dom_node_replace_child #} (toNode self)
             (maybe (Node nullForeignPtr) toNode newChild)
             (maybe (Node nullForeignPtr) toNode oldChild)
             errorPtr_)

nodeRemoveChild ::
                (NodeClass self, NodeClass oldChild) =>
                  self -> Maybe oldChild -> IO (Maybe Node)
nodeRemoveChild self oldChild
  = maybeNull (makeNewGObject mkNode)
      (propagateGError $
         \ errorPtr_ ->
           {# call webkit_dom_node_remove_child #} (toNode self)
             (maybe (Node nullForeignPtr) toNode oldChild)
             errorPtr_)

nodeAppendChild ::
                (NodeClass self, NodeClass newChild) =>
                  self -> Maybe newChild -> IO (Maybe Node)
nodeAppendChild self newChild
  = maybeNull (makeNewGObject mkNode)
      (propagateGError $
         \ errorPtr_ ->
           {# call webkit_dom_node_append_child #} (toNode self)
             (maybe (Node nullForeignPtr) toNode newChild)
             errorPtr_)

nodeHasChildNodes :: (NodeClass self) => self -> IO Bool
nodeHasChildNodes self
  = toBool <$>
      ({# call webkit_dom_node_has_child_nodes #} (toNode self))

nodeCloneNode ::
              (NodeClass self) => self -> Bool -> IO (Maybe Node)
nodeCloneNode self deep
  = maybeNull (makeNewGObject mkNode)
      ({# call webkit_dom_node_clone_node #} (toNode self)
         (fromBool deep))

nodeNormalize :: (NodeClass self) => self -> IO ()
nodeNormalize self
  = {# call webkit_dom_node_normalize #} (toNode self)

nodeIsSupported ::
                (NodeClass self) => self -> String -> String -> IO Bool
nodeIsSupported self feature version
  = toBool <$>
      (withUTFString version $
         \ versionPtr ->
           withUTFString feature $
             \ featurePtr ->
               {# call webkit_dom_node_is_supported #} (toNode self) featurePtr
             versionPtr)

nodeHasAttributes :: (NodeClass self) => self -> IO Bool
nodeHasAttributes self
  = toBool <$>
      ({# call webkit_dom_node_has_attributes #} (toNode self))

nodeIsSameNode ::
               (NodeClass self, NodeClass other) => self -> Maybe other -> IO Bool
nodeIsSameNode self other
  = toBool <$>
      ({# call webkit_dom_node_is_same_node #} (toNode self)
         (maybe (Node nullForeignPtr) toNode other))

nodeIsEqualNode ::
                (NodeClass self, NodeClass other) => self -> Maybe other -> IO Bool
nodeIsEqualNode self other
  = toBool <$>
      ({# call webkit_dom_node_is_equal_node #} (toNode self)
         (maybe (Node nullForeignPtr) toNode other))

nodeLookupPrefix :: (NodeClass self) => self -> String -> IO String
nodeLookupPrefix self namespaceURI
  = (withUTFString namespaceURI $
       \ namespaceURIPtr ->
         {# call webkit_dom_node_lookup_prefix #} (toNode self)
           namespaceURIPtr)
      >>=
      readUTFString

nodeIsDefaultNamespace ::
                       (NodeClass self) => self -> String -> IO Bool
nodeIsDefaultNamespace self namespaceURI
  = toBool <$>
      (withUTFString namespaceURI $
         \ namespaceURIPtr ->
           {# call webkit_dom_node_is_default_namespace #} (toNode self)
             namespaceURIPtr)

nodeLookupNamespaceURI ::
                       (NodeClass self) => self -> String -> IO String
nodeLookupNamespaceURI self prefix
  = (withUTFString prefix $
       \ prefixPtr ->
         {# call webkit_dom_node_lookup_namespace_uri #} (toNode self)
           prefixPtr)
      >>=
      readUTFString

nodeCompareDocumentPosition ::
                            (NodeClass self, NodeClass other) => self -> Maybe other -> IO Word
nodeCompareDocumentPosition self other
  = fromIntegral <$>
      ({# call webkit_dom_node_compare_document_position #} (toNode self)
         (maybe (Node nullForeignPtr) toNode other))

nodeContains ::
             (NodeClass self, NodeClass other) => self -> Maybe other -> IO Bool
nodeContains self other
  = toBool <$>
      ({# call webkit_dom_node_contains #} (toNode self)
         (maybe (Node nullForeignPtr) toNode other))

nodeDispatchEvent ::
                  (NodeClass self, EventClass event) =>
                    self -> Maybe event -> IO Bool
nodeDispatchEvent self event
  = toBool <$>
      (propagateGError $
         \ errorPtr_ ->
           {# call webkit_dom_node_dispatch_event #} (toNode self)
             (maybe (Event nullForeignPtr) toEvent event)
             errorPtr_)
cELEMENT_NODE = 1
cATTRIBUTE_NODE = 2
cTEXT_NODE = 3
cCDATA_SECTION_NODE = 4
cENTITY_REFERENCE_NODE = 5
cENTITY_NODE = 6
cPROCESSING_INSTRUCTION_NODE = 7
cCOMMENT_NODE = 8
cDOCUMENT_NODE = 9
cDOCUMENT_TYPE_NODE = 10
cDOCUMENT_FRAGMENT_NODE = 11
cNOTATION_NODE = 12
cDOCUMENT_POSITION_DISCONNECTED = 1
cDOCUMENT_POSITION_PRECEDING = 2
cDOCUMENT_POSITION_FOLLOWING = 4
cDOCUMENT_POSITION_CONTAINS = 8
cDOCUMENT_POSITION_CONTAINED_BY = 16
cDOCUMENT_POSITION_IMPLEMENTATION_SPECIFIC = 32

nodeGetNodeName :: (NodeClass self) => self -> IO String
nodeGetNodeName self
  = ({# call webkit_dom_node_get_node_name #} (toNode self)) >>=
      readUTFString

nodeSetNodeValue :: (NodeClass self) => self -> String -> IO ()
nodeSetNodeValue self val
  = propagateGError $
      \ errorPtr_ ->
        withUTFString val $
          \ valPtr ->
            {# call webkit_dom_node_set_node_value #} (toNode self) valPtr
          errorPtr_

nodeGetNodeValue :: (NodeClass self) => self -> IO String
nodeGetNodeValue self
  = ({# call webkit_dom_node_get_node_value #} (toNode self)) >>=
      readUTFString

nodeGetNodeType :: (NodeClass self) => self -> IO Word
nodeGetNodeType self
  = fromIntegral <$>
      ({# call webkit_dom_node_get_node_type #} (toNode self))

nodeGetParentNode :: (NodeClass self) => self -> IO (Maybe Node)
nodeGetParentNode self
  = maybeNull (makeNewGObject mkNode)
      ({# call webkit_dom_node_get_parent_node #} (toNode self))

nodeGetChildNodes ::
                  (NodeClass self) => self -> IO (Maybe NodeList)
nodeGetChildNodes self
  = maybeNull (makeNewGObject mkNodeList)
      ({# call webkit_dom_node_get_child_nodes #} (toNode self))

nodeGetFirstChild :: (NodeClass self) => self -> IO (Maybe Node)
nodeGetFirstChild self
  = maybeNull (makeNewGObject mkNode)
      ({# call webkit_dom_node_get_first_child #} (toNode self))

nodeGetLastChild :: (NodeClass self) => self -> IO (Maybe Node)
nodeGetLastChild self
  = maybeNull (makeNewGObject mkNode)
      ({# call webkit_dom_node_get_last_child #} (toNode self))

nodeGetPreviousSibling ::
                       (NodeClass self) => self -> IO (Maybe Node)
nodeGetPreviousSibling self
  = maybeNull (makeNewGObject mkNode)
      ({# call webkit_dom_node_get_previous_sibling #} (toNode self))

nodeGetNextSibling :: (NodeClass self) => self -> IO (Maybe Node)
nodeGetNextSibling self
  = maybeNull (makeNewGObject mkNode)
      ({# call webkit_dom_node_get_next_sibling #} (toNode self))

nodeGetAttributes ::
                  (NodeClass self) => self -> IO (Maybe NamedNodeMap)
nodeGetAttributes self
  = maybeNull (makeNewGObject mkNamedNodeMap)
      ({# call webkit_dom_node_get_attributes #} (toNode self))

nodeGetOwnerDocument ::
                     (NodeClass self) => self -> IO (Maybe Document)
nodeGetOwnerDocument self
  = maybeNull (makeNewGObject mkDocument)
      ({# call webkit_dom_node_get_owner_document #} (toNode self))

nodeGetNamespaceURI :: (NodeClass self) => self -> IO String
nodeGetNamespaceURI self
  = ({# call webkit_dom_node_get_namespace_uri #} (toNode self)) >>=
      readUTFString

nodeSetPrefix :: (NodeClass self) => self -> String -> IO ()
nodeSetPrefix self val
  = propagateGError $
      \ errorPtr_ ->
        withUTFString val $
          \ valPtr ->
            {# call webkit_dom_node_set_prefix #} (toNode self) valPtr
          errorPtr_

nodeGetPrefix :: (NodeClass self) => self -> IO String
nodeGetPrefix self
  = ({# call webkit_dom_node_get_prefix #} (toNode self)) >>=
      readUTFString

nodeGetLocalName :: (NodeClass self) => self -> IO String
nodeGetLocalName self
  = ({# call webkit_dom_node_get_local_name #} (toNode self)) >>=
      readUTFString

nodeGetBaseURI :: (NodeClass self) => self -> IO String
nodeGetBaseURI self
  = ({# call webkit_dom_node_get_base_uri #} (toNode self)) >>=
      readUTFString

nodeSetTextContent :: (NodeClass self) => self -> String -> IO ()
nodeSetTextContent self val
  = propagateGError $
      \ errorPtr_ ->
        withUTFString val $
          \ valPtr ->
            {# call webkit_dom_node_set_text_content #} (toNode self) valPtr
          errorPtr_

nodeGetTextContent :: (NodeClass self) => self -> IO String
nodeGetTextContent self
  = ({# call webkit_dom_node_get_text_content #} (toNode self)) >>=
      readUTFString

nodeGetParentElement ::
                     (NodeClass self) => self -> IO (Maybe Element)
nodeGetParentElement self
  = maybeNull (makeNewGObject mkElement)
      ({# call webkit_dom_node_get_parent_element #} (toNode self))

module Graphics.UI.Gtk.WebKit.DOM.Node
       (nodeHasChildNodes, nodeCloneNode, nodeNormalize, nodeIsSupported,
        nodeHasAttributes, nodeIsSameNode, nodeIsEqualNode,
        nodeLookupPrefix, nodeIsDefaultNamespace, nodeLookupNamespaceURI,
        nodeCompareDocumentPosition, nodeContains, nodeDispatchEvent,
        cELEMENT_NODE, cATTRIBUTE_NODE, cTEXT_NODE, cCDATA_SECTION_NODE,
        cENTITY_REFERENCE_NODE, cENTITY_NODE, cPROCESSING_INSTRUCTION_NODE,
        cCOMMENT_NODE, cDOCUMENT_NODE, cDOCUMENT_TYPE_NODE,
        cDOCUMENT_FRAGMENT_NODE, cNOTATION_NODE,
        cDOCUMENT_POSITION_DISCONNECTED, cDOCUMENT_POSITION_PRECEDING,
        cDOCUMENT_POSITION_FOLLOWING, cDOCUMENT_POSITION_CONTAINS,
        cDOCUMENT_POSITION_CONTAINED_BY,
        cDOCUMENT_POSITION_IMPLEMENTATION_SPECIFIC, nodeGetNodeName,
        nodeSetNodeValue, nodeGetNodeValue, nodeGetNodeType,
        nodeGetParentNode, nodeGetChildNodes, nodeGetFirstChild,
        nodeGetLastChild, nodeGetPreviousSibling, nodeGetNextSibling,
        nodeGetAttributes, nodeGetOwnerDocument, nodeGetNamespaceURI,
        nodeSetPrefix, nodeGetPrefix, nodeGetLocalName, nodeGetBaseURI,
        nodeSetTextContent, nodeGetTextContent, nodeGetParentElement)
       where
import System.Glib.FFI
import System.Glib.UTFString
import Control.Applicative
{#import Graphics.UI.Gtk.WebKit.Types#}
import System.Glib.GError
import Graphics.UI.Gtk.WebKit.DOM.EventM

nodeHasChildNodes :: (NodeClass self) => self -> IO Bool
nodeHasChildNodes self
  = toBool <$>
      ({# call webkit_dom_node_has_child_nodes #} (toNode self))

nodeCloneNode ::
              (NodeClass self) => self -> Bool -> IO (Maybe Node)
nodeCloneNode self deep
  = maybeNull (makeNewGObject mkNode)
      ({# call webkit_dom_node_clone_node #} (toNode self)
         (fromBool deep))

nodeNormalize :: (NodeClass self) => self -> IO ()
nodeNormalize self
  = {# call webkit_dom_node_normalize #} (toNode self)

nodeIsSupported ::
                (NodeClass self) => self -> String -> String -> IO Bool
nodeIsSupported self feature version
  = toBool <$>
      (withUTFString version $
         \ versionPtr ->
           withUTFString feature $
             \ featurePtr ->
               {# call webkit_dom_node_is_supported #} (toNode self) featurePtr
             versionPtr)

nodeHasAttributes :: (NodeClass self) => self -> IO Bool
nodeHasAttributes self
  = toBool <$>
      ({# call webkit_dom_node_has_attributes #} (toNode self))

nodeIsSameNode ::
               (NodeClass self, NodeClass other) => self -> Maybe other -> IO Bool
nodeIsSameNode self other
  = toBool <$>
      ({# call webkit_dom_node_is_same_node #} (toNode self)
         (maybe (Node nullForeignPtr) toNode other))

nodeIsEqualNode ::
                (NodeClass self, NodeClass other) => self -> Maybe other -> IO Bool
nodeIsEqualNode self other
  = toBool <$>
      ({# call webkit_dom_node_is_equal_node #} (toNode self)
         (maybe (Node nullForeignPtr) toNode other))

nodeLookupPrefix :: (NodeClass self) => self -> String -> IO String
nodeLookupPrefix self namespaceURI
  = (withUTFString namespaceURI $
       \ namespaceURIPtr ->
         {# call webkit_dom_node_lookup_prefix #} (toNode self)
           namespaceURIPtr)
      >>=
      readUTFString

nodeIsDefaultNamespace ::
                       (NodeClass self) => self -> String -> IO Bool
nodeIsDefaultNamespace self namespaceURI
  = toBool <$>
      (withUTFString namespaceURI $
         \ namespaceURIPtr ->
           {# call webkit_dom_node_is_default_namespace #} (toNode self)
             namespaceURIPtr)

nodeLookupNamespaceURI ::
                       (NodeClass self) => self -> String -> IO String
nodeLookupNamespaceURI self prefix
  = (withUTFString prefix $
       \ prefixPtr ->
         {# call webkit_dom_node_lookup_namespace_uri #} (toNode self)
           prefixPtr)
      >>=
      readUTFString

nodeCompareDocumentPosition ::
                            (NodeClass self, NodeClass other) => self -> Maybe other -> IO Word
nodeCompareDocumentPosition self other
  = fromIntegral <$>
      ({# call webkit_dom_node_compare_document_position #} (toNode self)
         (maybe (Node nullForeignPtr) toNode other))

nodeContains ::
             (NodeClass self, NodeClass other) => self -> Maybe other -> IO Bool
nodeContains self other
  = toBool <$>
      ({# call webkit_dom_node_contains #} (toNode self)
         (maybe (Node nullForeignPtr) toNode other))

nodeDispatchEvent ::
                  (NodeClass self, EventClass event) =>
                    self -> Maybe event -> IO Bool
nodeDispatchEvent self event
  = toBool <$>
      (propagateGError $
         \ errorPtr_ ->
           {# call webkit_dom_node_dispatch_event #} (toNode self)
             (maybe (Event nullForeignPtr) toEvent event)
             errorPtr_)
cELEMENT_NODE = 1
cATTRIBUTE_NODE = 2
cTEXT_NODE = 3
cCDATA_SECTION_NODE = 4
cENTITY_REFERENCE_NODE = 5
cENTITY_NODE = 6
cPROCESSING_INSTRUCTION_NODE = 7
cCOMMENT_NODE = 8
cDOCUMENT_NODE = 9
cDOCUMENT_TYPE_NODE = 10
cDOCUMENT_FRAGMENT_NODE = 11
cNOTATION_NODE = 12
cDOCUMENT_POSITION_DISCONNECTED = 1
cDOCUMENT_POSITION_PRECEDING = 2
cDOCUMENT_POSITION_FOLLOWING = 4
cDOCUMENT_POSITION_CONTAINS = 8
cDOCUMENT_POSITION_CONTAINED_BY = 16
cDOCUMENT_POSITION_IMPLEMENTATION_SPECIFIC = 32

nodeGetNodeName :: (NodeClass self) => self -> IO String
nodeGetNodeName self
  = ({# call webkit_dom_node_get_node_name #} (toNode self)) >>=
      readUTFString

nodeSetNodeValue :: (NodeClass self) => self -> String -> IO ()
nodeSetNodeValue self val
  = propagateGError $
      \ errorPtr_ ->
        withUTFString val $
          \ valPtr ->
            {# call webkit_dom_node_set_node_value #} (toNode self) valPtr
          errorPtr_

nodeGetNodeValue :: (NodeClass self) => self -> IO String
nodeGetNodeValue self
  = ({# call webkit_dom_node_get_node_value #} (toNode self)) >>=
      readUTFString

nodeGetNodeType :: (NodeClass self) => self -> IO Word
nodeGetNodeType self
  = fromIntegral <$>
      ({# call webkit_dom_node_get_node_type #} (toNode self))

nodeGetParentNode :: (NodeClass self) => self -> IO (Maybe Node)
nodeGetParentNode self
  = maybeNull (makeNewGObject mkNode)
      ({# call webkit_dom_node_get_parent_node #} (toNode self))

nodeGetChildNodes ::
                  (NodeClass self) => self -> IO (Maybe NodeList)
nodeGetChildNodes self
  = maybeNull (makeNewGObject mkNodeList)
      ({# call webkit_dom_node_get_child_nodes #} (toNode self))

nodeGetFirstChild :: (NodeClass self) => self -> IO (Maybe Node)
nodeGetFirstChild self
  = maybeNull (makeNewGObject mkNode)
      ({# call webkit_dom_node_get_first_child #} (toNode self))

nodeGetLastChild :: (NodeClass self) => self -> IO (Maybe Node)
nodeGetLastChild self
  = maybeNull (makeNewGObject mkNode)
      ({# call webkit_dom_node_get_last_child #} (toNode self))

nodeGetPreviousSibling ::
                       (NodeClass self) => self -> IO (Maybe Node)
nodeGetPreviousSibling self
  = maybeNull (makeNewGObject mkNode)
      ({# call webkit_dom_node_get_previous_sibling #} (toNode self))

nodeGetNextSibling :: (NodeClass self) => self -> IO (Maybe Node)
nodeGetNextSibling self
  = maybeNull (makeNewGObject mkNode)
      ({# call webkit_dom_node_get_next_sibling #} (toNode self))

nodeGetAttributes ::
                  (NodeClass self) => self -> IO (Maybe NamedNodeMap)
nodeGetAttributes self
  = maybeNull (makeNewGObject mkNamedNodeMap)
      ({# call webkit_dom_node_get_attributes #} (toNode self))

nodeGetOwnerDocument ::
                     (NodeClass self) => self -> IO (Maybe Document)
nodeGetOwnerDocument self
  = maybeNull (makeNewGObject mkDocument)
      ({# call webkit_dom_node_get_owner_document #} (toNode self))

nodeGetNamespaceURI :: (NodeClass self) => self -> IO String
nodeGetNamespaceURI self
  = ({# call webkit_dom_node_get_namespace_uri #} (toNode self)) >>=
      readUTFString

nodeSetPrefix :: (NodeClass self) => self -> String -> IO ()
nodeSetPrefix self val
  = propagateGError $
      \ errorPtr_ ->
        withUTFString val $
          \ valPtr ->
            {# call webkit_dom_node_set_prefix #} (toNode self) valPtr
          errorPtr_

nodeGetPrefix :: (NodeClass self) => self -> IO String
nodeGetPrefix self
  = ({# call webkit_dom_node_get_prefix #} (toNode self)) >>=
      readUTFString

nodeGetLocalName :: (NodeClass self) => self -> IO String
nodeGetLocalName self
  = ({# call webkit_dom_node_get_local_name #} (toNode self)) >>=
      readUTFString

nodeGetBaseURI :: (NodeClass self) => self -> IO String
nodeGetBaseURI self
  = ({# call webkit_dom_node_get_base_uri #} (toNode self)) >>=
      readUTFString

nodeSetTextContent :: (NodeClass self) => self -> String -> IO ()
nodeSetTextContent self val
  = propagateGError $
      \ errorPtr_ ->
        withUTFString val $
          \ valPtr ->
            {# call webkit_dom_node_set_text_content #} (toNode self) valPtr
          errorPtr_

nodeGetTextContent :: (NodeClass self) => self -> IO String
nodeGetTextContent self
  = ({# call webkit_dom_node_get_text_content #} (toNode self)) >>=
      readUTFString

nodeGetParentElement ::
                     (NodeClass self) => self -> IO (Maybe Element)
nodeGetParentElement self
  = maybeNull (makeNewGObject mkElement)
      ({# call webkit_dom_node_get_parent_element #} (toNode self))


Fix egregious memory unsafety.

Fix egregious memory unsafety.

-- -*- haskell -*-- -----------------------------------------------
-- |
-- Module      :  Data.Boolean.CUDD
-- Copyright   :  (C) 2002-2005, 2009 University of New South Wales, (C) 2009-2011 Peter Gammie
-- License     :  LGPL (see COPYING.LIB for details)
--
-- A binding for CUDD (Fabio Somenzi, University of Colorado).
--
-- Note this library is not thread-safe.
-------------------------------------------------------------------
module Data.Boolean.CUDD
    (
        BDD
    ,	module Data.Boolean

        -- * CUDD-specific functions
--          ,	gc
    ,	stats
    ,	dynamicReOrdering
    ,	varIndices
    ,	bddSize
    ) where

-------------------------------------------------------------------
-- Dependencies.
-------------------------------------------------------------------

#include "cudd_im.h"

import Control.DeepSeq  ( NFData )
import Control.Monad	( foldM, liftM, mapAndUnzipM, zipWithM_ )

import Data.IORef	( IORef, newIORef, readIORef, writeIORef )
import Data.List	( genericLength )
import Data.Maybe	( fromJust, isJust )

import Data.Map         ( Map )
import qualified Data.Map as Map

import Foreign
import Foreign.C

import GHC.ForeignPtr   ( newConcForeignPtr )

import System.IO	( Handle, hIsReadable, hIsWritable )
-- import System.Mem	( performGC )
import System.Posix.IO	( handleToFd )

import Data.Boolean

-------------------------------------------------------------------
-- Extra FFI functions.
-------------------------------------------------------------------

-- | A C file handle.
{#pointer *FILE -> CFile#}

-- | Convert a Haskell Handle into a C FILE *.
-- - FIXME: throw exception on error.
-- - suggested by Simon Marlow.
handleToCFile :: Handle -> IO FILE
handleToCFile h =
    do r <- hIsReadable h
       w <- hIsWritable h
       modestr <- newCString $ mode r w
       fd <- handleToFd h
       {#call unsafe fdopen#} (cToNum fd) modestr
    where mode :: Bool -> Bool -> String
          mode False False = error "Handle not readable or writable!"
          mode False True  = "w"
          mode True  False = "r"
          mode True  True  = "r+" -- FIXME

-- | The Haskell Handle is unusable after calling 'handleToCFile',
-- so provide a neutered "fprintf"-style thing here.
printCFile :: FILE -> String -> IO ()
printCFile file str =
    withCString str ({#call unsafe fprintf_neutered#} file)

--  Close a C FILE *.
-- - FIXME: throw exception on error.
-- closeCFile :: FILE -> IO ()
-- closeCFile cfile = do {#call unsafe fclose#} cfile
--                    return ()

cToNum :: (Num i, Integral e) => e -> i
cToNum  = fromIntegral . toInteger

cFromEnum :: (Integral i, Enum e) => e -> i
cFromEnum  = fromIntegral . fromEnum

-------------------------------------------------------------------
-- Types.
-------------------------------------------------------------------

-- | The BDD manager, which we hide from clients.
{#pointer *DdManager as DDManager newtype#}

-- | The arguments to 'Cudd_Init'.
{#enum CuddSubtableSize {} #}
{#enum CuddCacheSize {} #}

-- | Variable reordering tree options.
{#enum CuddMTRParams {} #}

-- | The abstract type of BDDs.
{#pointer *DdNode as BDD foreign newtype#}

withBDD :: BDD -> (Ptr BDD -> IO a) -> IO a

-- BDDs are just pointers, so there's no work to do when we @deepseq@ them.
instance Control.DeepSeq.NFData BDD

-- Belt-and-suspenders equality checking and ordering.
instance Eq BDD where
    bdd0 == bdd1 = unsafePerformIO $
      withBDD bdd0 $ \bdd0p -> withBDD bdd1 $ \bdd1p ->
        return $ bdd0p == bdd1p

instance Ord BDD where
    bdd0 <= bdd1 = unsafePerformIO $
      withBDD bdd0 $ \bdd0p -> withBDD bdd1 $ \bdd1p ->
        return $ bdd0p == bdd1p || bdd0p < bdd1p

instance Show BDD where
-- Print out the BDD as a sum-of-products.
    showsPrec _ = sop

-------------------------------------------------------------------
-- Administrative functions.
-------------------------------------------------------------------

-- | The BDD manager. This needs to be invoked before any of the
-- following functions... which we arrange for automagically.
ddmanager :: DDManager
ddmanager = unsafePerformIO $
  {#call unsafe Cudd_Init as _cudd_Init #}
    0 0 (cFromEnum UNIQUE_SLOTS) (cFromEnum CACHE_SLOTS) 0
{-# NOINLINE ddmanager #-}

-- | A map to and from BDD variable numbers.
-- FIXME: the second one would be more efficiently Data.IntMap, but we don't use it often.
type VarMap = (Map String BDD, Map CUInt String)

-- | Tracks existing variables.
bdd_vars :: IORef VarMap
bdd_vars = unsafePerformIO $ newIORef (Map.empty, Map.empty)
{-# NOINLINE bdd_vars #-}

-- | Attaches a finalizer to a BDD object.
-- The call to "Cudd_Ref" happens in C to ensure atomicity.
-- Returning objects with initial refcount 0 is a bad design decision.
addBDDfinalizer :: Ptr BDD -> IO BDD
addBDDfinalizer bddp = liftM BDD $ newConcForeignPtr bddp bddf
    where bddf = {#call unsafe Cudd_RecursiveDeref as _cudd_RecursiveDeref#} ddmanager bddp
                   >> return ()
{-# INLINE addBDDfinalizer #-}

-- | Attaches a null finalizer to a 'BDD' object.
-- Used for variables and constants.
addBDDnullFinalizer :: Ptr BDD -> IO BDD
addBDDnullFinalizer bddp = fmap BDD $ newForeignPtr_ bddp
{-# INLINE addBDDnullFinalizer #-}

-- Simulate an "apply" function to simplify atomic refcount incrementing.
{#enum CuddBinOp {} #}

-------------------------------------------------------------------
-- Logical operations.
-------------------------------------------------------------------

-- | Allocate a variable.
newVar :: IO (Ptr BDD) -> String -> IO (Maybe CUInt, BDD)
newVar allocVar label =
      do (toBDD, fromBDD) <- readIORef bdd_vars
         case label `Map.lookup` toBDD of
           Just bdd -> return (Nothing, bdd)
           Nothing ->
             do putStrLn $ "Allocating: " ++ label
                bddp <- allocVar
                vid <- fmap cToNum $
                         {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#} bddp
                --putStrLn $ label ++ " -> " ++ (show (vid, bdd))
                bdd <- addBDDnullFinalizer bddp
                writeIORef bdd_vars ( Map.insert label bdd   toBDD
                                    , Map.insert vid   label fromBDD )
                return (Just vid, bdd)

instance BooleanVariable BDD where
    bvar label = unsafePerformIO $
      fmap snd $ newVar ({#call unsafe Cudd_bddNewVar as _cudd_bddNewVar#} ddmanager)  label

    bvars labels =
      case labels of
        [] -> []
        ls -> unsafePerformIO $
          do (vids, vars) <- mapAndUnzipM (newVar ({#call unsafe Cudd_bddNewVar as _cudd_bddNewVar#} ddmanager)) ls
             if all isJust vids
               then groupVars (fromJust (head vids)) (genericLength vids)
               else putStrLn $ "hBDD-CUDD warning: not grouping variables " ++ show ls
             return vars
      where
        groupVars vid len = makeTreeNode ddmanager vid len (cFromEnum CUDD_MTR_DEFAULT) >> return ()
        makeTreeNode = {#call unsafe Cudd_MakeTreeNode as _cudd_MakeTreeNode#}

    unbvar bdd = unsafePerformIO $ bdd `seq`
                   withBDD bdd $ \bddp ->
                     do vid <- {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#} bddp
                        (_, fromBDD) <- readIORef bdd_vars
                        return $ case cToNum vid `Map.lookup` fromBDD of
                                   Nothing -> "(VID: " ++ show vid ++ ")"
                                   Just v  -> v

instance Boolean BDD where
    true  = bddConstant {#call unsafe Cudd_ReadOne as _cudd_ReadOne#}
    false = bddConstant {#call unsafe Cudd_ReadLogicZero as _cudd_ReadLogicZero#}

    (/\)  = bddBinOp AND
    neg x = unsafePerformIO $ withBDD x $ \xp ->
      {#call unsafe cudd_bddNot#} xp >>= addBDDfinalizer

    nand  = bddBinOp NAND
    (\/)  = bddBinOp OR
    nor   = bddBinOp NOR
    xor   = bddBinOp XOR
    -- (-->) = FIXME ???
    (<->) = bddBinOp XNOR

    -- bITE i t e = unsafePerformIO $
    --   withBDD i $ \ip -> withBDD t $ \tp -> withBDD e $ \ep ->
    --     {#call unsafe cudd_bddIte#} ddmanager ip tp ep
    --       >>= addBDDfinalizer

bddConstant :: (DDManager -> IO (Ptr BDD)) -> BDD
bddConstant f = unsafePerformIO $ f ddmanager >>= addBDDnullFinalizer

bddBinOp :: CuddBinOp -> BDD -> BDD -> BDD
bddBinOp op x y = unsafePerformIO $
  withBDD x $ \xp -> withBDD y $ \yp ->
    {#call unsafe cudd_BinOp#} ddmanager (cFromEnum op) xp yp >>= addBDDfinalizer

instance QBF BDD where
    data Group BDD = MkGroup BDD

    mkGroup = MkGroup . conjoin -- FIXME maybe use Cudd_bddComputeCube
    exists = cudd_exists
    forall = cudd_forall
    rel_product = cudd_rel_product

instance Substitution BDD where
    data Subst BDD = MkSubst [(BDD, BDD)]

    mkSubst = MkSubst
    rename = cudd_rename
    substitute = error "CUDD substitute" -- cudd_substitute

instance BDDOps BDD where
    bif bdd = unsafePerformIO $
      do vid <- withBDD bdd {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#}
         {#call unsafe Cudd_bddIthVar as _cudd_bddIthVar#} ddmanager (cToNum vid)
           >>= addBDDnullFinalizer
    bthen bdd = unsafePerformIO $
      withBDD bdd $ \bddp ->
        {#call unsafe cudd_bddT#} bddp >>= addBDDfinalizer
    belse bdd = unsafePerformIO $
      withBDD bdd $ \bddp ->
        {#call unsafe cudd_bddE#} bddp >>= addBDDfinalizer

    reduce = cudd_reduce
    satisfy = cudd_satisfy
    support = cudd_support

-------------------------------------------------------------------
-- Implementations.
-------------------------------------------------------------------

withGroup :: Group BDD -> (Ptr BDD -> IO a) -> IO a
withGroup (MkGroup g) = withBDD g

cudd_exists :: Group BDD -> BDD -> BDD
cudd_exists group bdd = unsafePerformIO $ bdd `seq`
  withGroup group $ \groupp -> withBDD bdd $ \bddp ->
    {#call unsafe cudd_bddExistAbstract#} ddmanager bddp groupp
      >>= addBDDfinalizer

cudd_forall :: Group BDD -> BDD -> BDD
cudd_forall group bdd = unsafePerformIO $ bdd `seq`
  withGroup group $ \groupp -> withBDD bdd $ \bddp ->
    {#call unsafe cudd_bddUnivAbstract#} ddmanager bddp groupp
      >>= addBDDfinalizer

cudd_rel_product :: Group BDD -> BDD -> BDD -> BDD
cudd_rel_product group f g = unsafePerformIO $
  withGroup group $ \groupp -> withBDD f $ \fp -> withBDD g $ \gp ->
    {#call unsafe cudd_bddAndAbstract#} ddmanager fp gp groupp
      >>= addBDDfinalizer

-- | FIXME: This function is a bit touchier than you'd hope.
-- The reaons is we use cudd_bddSwapVariables, which in fact swaps variables.
-- This is not exactly a "rename" behaviour.
cudd_rename :: Subst BDD -> BDD -> BDD
cudd_rename (MkSubst subst) f = unsafePerformIO $
  withBDD f $ \fp ->
    allocaArray len $ \arrayx -> allocaArray len $ \arrayx' ->
      do zipWithM_ (pokeSubst arrayx arrayx') subst [0..]
         bddp <- {#call unsafe cudd_bddSwapVariables#} ddmanager fp arrayx arrayx' (fromIntegral len)
         mapM_ (\ (BDD v, BDD v') -> do touchForeignPtr v
                                        touchForeignPtr v') subst
         addBDDfinalizer bddp
    where
      pokeSubst :: Ptr (Ptr BDD) -> Ptr (Ptr BDD) -> (BDD, BDD) -> Int -> IO ()
      pokeSubst arrayx arrayx' (v, v') i =
        do withBDD v  $ pokeElemOff arrayx  i
           withBDD v' $ pokeElemOff arrayx' i

      len = length subst

-- FIXME verify implementation.
cudd_reduce :: BDD -> BDD -> BDD
cudd_reduce f g = unsafePerformIO $
  withBDD f $ \fp -> withBDD g $ \gp ->
    {#call unsafe cudd_bddLICompaction#} ddmanager fp gp
      >>= addBDDfinalizer

-- FIXME verify implementation.
cudd_satisfy :: BDD -> BDD
cudd_satisfy bdd = unsafePerformIO $
  withBDD bdd ({#call unsafe cudd_satone#} ddmanager) >>= addBDDfinalizer

cudd_support :: BDD -> [BDD]
cudd_support bdd = unsafePerformIO $
  do varBitArray <- withBDD bdd ({#call unsafe Cudd_SupportIndex as _cudd_SupportIndex#} ddmanager)
     touchForeignPtr (case bdd of BDD fp -> fp)
     -- The array is as long as the number of variables allocated.
     (_toBDD, fromBDD) <- readIORef bdd_vars
     bdds <- foldM (toBDDs varBitArray) [] (Map.toList fromBDD)
     {#call unsafe cFree#} (castPtr varBitArray)
     return bdds
  where
    toBDDs varBitArray bdds (vid, var) =
      do varInSupport <- peek (advancePtr varBitArray (cToNum vid))
         return $ if varInSupport /= 0
                    then bvar var : bdds
                    else bdds

-------------------------------------------------------------------
-- Operations specific to this BDD binding.
-------------------------------------------------------------------

-- | Dump usage statistics to the given 'Handle'.
stats :: Handle -> IO ()
stats handle =
    do cfile <- handleToCFile handle
       printCFile cfile "CUDD stats\n"
       _ <- {#call unsafe Cudd_PrintInfo as _cudd_PrintInfo#} ddmanager cfile
       printCFile cfile "\nVariable groups\n"
       {#call unsafe cudd_printVarGroups#} ddmanager

----------------------------------------
-- Variable Reordering.
-- FIXME add an off switch
----------------------------------------

{#enum Cudd_ReorderingType as CUDDReorderingMethod {} deriving (Eq, Ord, Show)#}

roMap :: [(ReorderingMethod, CUDDReorderingMethod)]
roMap = [(ReorderSift, CUDD_REORDER_SIFT),
         (ReorderStableWindow3, CUDD_REORDER_WINDOW3)]

-- | Set the dynamic variable ordering heuristic.
dynamicReOrdering :: ReorderingMethod -> IO ()
dynamicReOrdering rom =
    case lookup rom roMap of
      Nothing -> error $ "CUDD.dynamicReOrdering: method not supported: " ++ show rom
      Just brom ->
        {#call unsafe Cudd_AutodynEnable as _cudd_AutodynEnable#} ddmanager (cFromEnum brom) >> return ()

----------------------------------------
-- | Returns the relationship between BDD indices, BDD ids and
-- variable names. This may be useful for discovering what the
-- dynamic reordering is doing.
--
-- The intention of this function is to return
--   @[(position in variable order, immutable variable id, label)]@
-- so that the variable order can be saved.
----------------------------------------

varIndices :: IO [(CInt, CInt, String)]
varIndices = do (toBDD, _fromBDD) <- readIORef bdd_vars
                mapM procVar $ Map.toList toBDD
    where -- procVar :: (String, BDD) -> IO (CUInt, CUInt, String)
          procVar (var, bdd) =
              do -- FIXME CUDD inconsistently uses signed and unsigned ints.
                 vid <- fmap cToNum $
                          withBDD bdd {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#}
                 level <- {#call unsafe Cudd_ReadPerm as _cudd_ReadPerm#} ddmanager vid
                 return (level, vid, var)
{-# NOINLINE varIndices #-}

----------------------------------------
-- BDD Statistics.
----------------------------------------

-- | Determine the size of a BDD.
bddSize :: BDD -> Int
bddSize bdd = unsafePerformIO $
  do size <- withBDD bdd ({#call unsafe Cudd_DagSize as _cudd_DagSize#})
     return $ cToNum size

-- -*- haskell -*-- -----------------------------------------------
-- |
-- Module      :  Data.Boolean.CUDD
-- Copyright   :  (C) 2002-2005, 2009 University of New South Wales, (C) 2009-2011 Peter Gammie
-- License     :  LGPL (see COPYING.LIB for details)
--
-- A binding for CUDD (Fabio Somenzi, University of Colorado).
--
-- Note this library is not thread-safe.
-------------------------------------------------------------------
module Data.Boolean.CUDD
    (
        BDD
    ,	module Data.Boolean

        -- * CUDD-specific functions
--          ,	gc
    ,	stats
    ,	dynamicReOrdering
    ,	varIndices
    ,	bddSize
    ) where

-------------------------------------------------------------------
-- Dependencies.
-------------------------------------------------------------------

#include "cudd_im.h"

import Control.DeepSeq  ( NFData )
import Control.Monad	( foldM, liftM, mapAndUnzipM, zipWithM_ )

import Data.IORef	( IORef, newIORef, readIORef, writeIORef )
import Data.List	( genericLength )
import Data.Maybe	( fromJust, isJust )

import Data.Map         ( Map )
import qualified Data.Map as Map

import Foreign
import Foreign.C

import GHC.ForeignPtr   ( newConcForeignPtr )

import System.IO	( Handle, hIsReadable, hIsWritable )
-- import System.Mem	( performGC )
import System.Posix.IO	( handleToFd )

import Data.Boolean

-------------------------------------------------------------------
-- Extra FFI functions.
-------------------------------------------------------------------

-- | A C file handle.
{#pointer *FILE -> CFile#}

-- | Convert a Haskell Handle into a C FILE *.
-- - FIXME: throw exception on error.
-- - suggested by Simon Marlow.
handleToCFile :: Handle -> IO FILE
handleToCFile h =
    do r <- hIsReadable h
       w <- hIsWritable h
       modestr <- newCString $ mode r w
       fd <- handleToFd h
       {#call unsafe fdopen#} (cToNum fd) modestr
    where mode :: Bool -> Bool -> String
          mode False False = error "Handle not readable or writable!"
          mode False True  = "w"
          mode True  False = "r"
          mode True  True  = "r+" -- FIXME

-- | The Haskell Handle is unusable after calling 'handleToCFile',
-- so provide a neutered "fprintf"-style thing here.
printCFile :: FILE -> String -> IO ()
printCFile file str =
    withCString str ({#call unsafe fprintf_neutered#} file)

--  Close a C FILE *.
-- - FIXME: throw exception on error.
-- closeCFile :: FILE -> IO ()
-- closeCFile cfile = do {#call unsafe fclose#} cfile
--                    return ()

cToNum :: (Num i, Integral e) => e -> i
cToNum  = fromIntegral . toInteger

cFromEnum :: (Integral i, Enum e) => e -> i
cFromEnum  = fromIntegral . fromEnum

-------------------------------------------------------------------
-- Types.
-------------------------------------------------------------------

-- | The BDD manager, which we hide from clients.
{#pointer *DdManager as DDManager newtype#}

-- | The arguments to 'Cudd_Init'.
{#enum CuddSubtableSize {} #}
{#enum CuddCacheSize {} #}

-- | Variable reordering tree options.
{#enum CuddMTRParams {} #}

-- | The abstract type of BDDs.
{#pointer *DdNode as BDD foreign newtype#}

withBDD :: BDD -> (Ptr BDD -> IO a) -> IO a

-- BDDs are just pointers, so there's no work to do when we @deepseq@ them.
instance Control.DeepSeq.NFData BDD

-- Belt-and-suspenders equality checking and ordering.
instance Eq BDD where
    bdd0 == bdd1 = unsafePerformIO $
      withBDD bdd0 $ \bdd0p -> withBDD bdd1 $ \bdd1p ->
        return $ bdd0p == bdd1p

instance Ord BDD where
    bdd0 <= bdd1 = unsafePerformIO $
      withBDD bdd0 $ \bdd0p -> withBDD bdd1 $ \bdd1p ->
        return $ bdd0p == bdd1p || bdd0p < bdd1p

instance Show BDD where
-- Print out the BDD as a sum-of-products.
    showsPrec _ = sop

-------------------------------------------------------------------
-- Administrative functions.
-------------------------------------------------------------------

-- | The BDD manager. This needs to be invoked before any of the
-- following functions... which we arrange for automagically.
ddmanager :: DDManager
ddmanager = unsafePerformIO $
  {#call unsafe Cudd_Init as _cudd_Init #}
    0 0 (cFromEnum UNIQUE_SLOTS) (cFromEnum CACHE_SLOTS) 0
{-# NOINLINE ddmanager #-}

-- | A map to and from BDD variable numbers.
-- FIXME: the second one would be more efficiently Data.IntMap, but we don't use it often.
type VarMap = (Map String BDD, Map CUInt String)

-- | Tracks existing variables.
bdd_vars :: IORef VarMap
bdd_vars = unsafePerformIO $ newIORef (Map.empty, Map.empty)
{-# NOINLINE bdd_vars #-}

-- | Attaches a finalizer to a BDD object.
-- The call to "Cudd_Ref" happens in C to ensure atomicity.
-- Returning objects with initial refcount 0 is a bad design decision.
addBDDfinalizer :: Ptr BDD -> IO BDD
addBDDfinalizer bddp = liftM BDD $ newConcForeignPtr bddp bddf
    where bddf = {#call unsafe Cudd_RecursiveDeref as _cudd_RecursiveDeref#} ddmanager bddp
                   >> return ()
{-# INLINE addBDDfinalizer #-}

-- | Attaches a null finalizer to a 'BDD' object.
-- Used for variables and constants.
addBDDnullFinalizer :: Ptr BDD -> IO BDD
addBDDnullFinalizer bddp = fmap BDD $ newForeignPtr_ bddp
{-# INLINE addBDDnullFinalizer #-}

-- Simulate an "apply" function to simplify atomic refcount incrementing.
{#enum CuddBinOp {} #}

-------------------------------------------------------------------
-- Logical operations.
-------------------------------------------------------------------

-- | Allocate a variable.
newVar :: IO (Ptr BDD) -> String -> IO (Maybe CUInt, BDD)
newVar allocVar label =
      do (toBDD, fromBDD) <- readIORef bdd_vars
         case label `Map.lookup` toBDD of
           Just bdd -> return (Nothing, bdd)
           Nothing ->
             do putStrLn $ "Allocating: " ++ label
                bddp <- allocVar
                vid <- fmap cToNum $
                         {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#} bddp
                --putStrLn $ label ++ " -> " ++ (show (vid, bdd))
                bdd <- addBDDnullFinalizer bddp
                writeIORef bdd_vars ( Map.insert label bdd   toBDD
                                    , Map.insert vid   label fromBDD )
                return (Just vid, bdd)

instance BooleanVariable BDD where
    bvar label = unsafePerformIO $
      fmap snd $ newVar ({#call unsafe Cudd_bddNewVar as _cudd_bddNewVar#} ddmanager)  label

    bvars labels =
      case labels of
        [] -> []
        ls -> unsafePerformIO $
          do (vids, vars) <- mapAndUnzipM (newVar ({#call unsafe Cudd_bddNewVar as _cudd_bddNewVar#} ddmanager)) ls
             if all isJust vids
               then groupVars (fromJust (head vids)) (genericLength vids)
               else putStrLn $ "hBDD-CUDD warning: not grouping variables " ++ show ls
             return vars
      where
        groupVars vid len = makeTreeNode ddmanager vid len (cFromEnum CUDD_MTR_DEFAULT) >> return ()
        makeTreeNode = {#call unsafe Cudd_MakeTreeNode as _cudd_MakeTreeNode#}

    unbvar bdd = unsafePerformIO $ bdd `seq`
                   withBDD bdd $ \bddp ->
                     do vid <- {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#} bddp
                        (_, fromBDD) <- readIORef bdd_vars
                        return $ case cToNum vid `Map.lookup` fromBDD of
                                   Nothing -> "(VID: " ++ show vid ++ ")"
                                   Just v  -> v

instance Boolean BDD where
    true  = bddConstant {#call unsafe Cudd_ReadOne as _cudd_ReadOne#}
    false = bddConstant {#call unsafe Cudd_ReadLogicZero as _cudd_ReadLogicZero#}

    (/\)  = bddBinOp AND
    neg x = unsafePerformIO $ withBDD x $ \xp ->
      {#call unsafe cudd_bddNot#} xp >>= addBDDfinalizer

    nand  = bddBinOp NAND
    (\/)  = bddBinOp OR
    nor   = bddBinOp NOR
    xor   = bddBinOp XOR
    -- (-->) = FIXME ???
    (<->) = bddBinOp XNOR

    -- bITE i t e = unsafePerformIO $
    --   withBDD i $ \ip -> withBDD t $ \tp -> withBDD e $ \ep ->
    --     {#call unsafe cudd_bddIte#} ddmanager ip tp ep
    --       >>= addBDDfinalizer

bddConstant :: (DDManager -> IO (Ptr BDD)) -> BDD
bddConstant f = unsafePerformIO $ f ddmanager >>= addBDDnullFinalizer

bddBinOp :: CuddBinOp -> BDD -> BDD -> BDD
bddBinOp op x y = unsafePerformIO $
  withBDD x $ \xp -> withBDD y $ \yp ->
    {#call unsafe cudd_BinOp#} ddmanager (cFromEnum op) xp yp >>= addBDDfinalizer

instance QBF BDD where
    data Group BDD = MkGroup BDD

    mkGroup = MkGroup . conjoin -- FIXME maybe use Cudd_bddComputeCube
    exists = cudd_exists
    forall = cudd_forall
    rel_product = cudd_rel_product

instance Substitution BDD where
    data Subst BDD = MkSubst [(BDD, BDD)]

    mkSubst = MkSubst
    rename = cudd_rename
    substitute = error "CUDD substitute" -- cudd_substitute

instance BDDOps BDD where
    bif bdd = unsafePerformIO $
      do vid <- withBDD bdd {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#}
         {#call unsafe Cudd_bddIthVar as _cudd_bddIthVar#} ddmanager (cToNum vid)
           >>= addBDDnullFinalizer
    bthen bdd = unsafePerformIO $
      withBDD bdd $ \bddp ->
        {#call unsafe cudd_bddT#} bddp >>= addBDDfinalizer
    belse bdd = unsafePerformIO $
      withBDD bdd $ \bddp ->
        {#call unsafe cudd_bddE#} bddp >>= addBDDfinalizer

    reduce = cudd_reduce
    satisfy = cudd_satisfy
    support = cudd_support

-------------------------------------------------------------------
-- Implementations.
-------------------------------------------------------------------

withGroup :: Group BDD -> (Ptr BDD -> IO a) -> IO a
withGroup (MkGroup g) = withBDD g

cudd_exists :: Group BDD -> BDD -> BDD
cudd_exists group bdd = unsafePerformIO $ bdd `seq`
  withGroup group $ \groupp -> withBDD bdd $ \bddp ->
    {#call unsafe cudd_bddExistAbstract#} ddmanager bddp groupp
      >>= addBDDfinalizer

cudd_forall :: Group BDD -> BDD -> BDD
cudd_forall group bdd = unsafePerformIO $ bdd `seq`
  withGroup group $ \groupp -> withBDD bdd $ \bddp ->
    {#call unsafe cudd_bddUnivAbstract#} ddmanager bddp groupp
      >>= addBDDfinalizer

cudd_rel_product :: Group BDD -> BDD -> BDD -> BDD
cudd_rel_product group f g = unsafePerformIO $
  withGroup group $ \groupp -> withBDD f $ \fp -> withBDD g $ \gp ->
    {#call unsafe cudd_bddAndAbstract#} ddmanager fp gp groupp
      >>= addBDDfinalizer

-- | FIXME: This function is a bit touchier than you'd hope.
-- The reaons is we use cudd_bddSwapVariables, which in fact swaps variables.
-- This is not exactly a "rename" behaviour.
cudd_rename :: Subst BDD -> BDD -> BDD
cudd_rename (MkSubst subst) f = unsafePerformIO $
  withBDD f $ \fp ->
    allocaArray len $ \arrayx -> allocaArray len $ \arrayx' ->
      do zipWithM_ (pokeSubst arrayx arrayx') subst [0..]
         bddp <- {#call unsafe cudd_bddSwapVariables#} ddmanager fp arrayx arrayx' (fromIntegral len)
         mapM_ (\ (BDD v, BDD v') -> do touchForeignPtr v
                                        touchForeignPtr v') subst
         addBDDfinalizer bddp
    where
      pokeSubst :: Ptr (Ptr BDD) -> Ptr (Ptr BDD) -> (BDD, BDD) -> Int -> IO ()
      pokeSubst arrayx arrayx' (v, v') i =
        do withBDD v  $ pokeElemOff arrayx  i
           withBDD v' $ pokeElemOff arrayx' i

      len = length subst

-- FIXME verify implementation.
cudd_reduce :: BDD -> BDD -> BDD
cudd_reduce f g = unsafePerformIO $
  withBDD f $ \fp -> withBDD g $ \gp ->
    {#call unsafe Cudd_bddLICompaction as _cudd_bddLICompaction#} ddmanager fp gp
      >>= addBDDfinalizer

-- FIXME verify implementation.
cudd_satisfy :: BDD -> BDD
cudd_satisfy bdd = unsafePerformIO $
  withBDD bdd ({#call unsafe cudd_satone#} ddmanager) >>= addBDDfinalizer

cudd_support :: BDD -> [BDD]
cudd_support bdd = unsafePerformIO $
  do varBitArray <- withBDD bdd ({#call unsafe Cudd_SupportIndex as _cudd_SupportIndex#} ddmanager)
     -- The array is as long as the number of variables allocated.
     (_toBDD, fromBDD) <- readIORef bdd_vars
     bdds <- foldM (toBDDs varBitArray) [] (Map.toList fromBDD)
     {#call unsafe cFree#} (castPtr varBitArray)
     return bdds
  where
    toBDDs varBitArray bdds (vid, var) =
      do varInSupport <- peek (advancePtr varBitArray (cToNum vid))
         return $ if varInSupport /= 0
                    then bvar var : bdds
                    else bdds

-------------------------------------------------------------------
-- Operations specific to this BDD binding.
-------------------------------------------------------------------

-- | Dump usage statistics to the given 'Handle'.
stats :: Handle -> IO ()
stats handle =
    do cfile <- handleToCFile handle
       printCFile cfile "CUDD stats\n"
       _ <- {#call unsafe Cudd_PrintInfo as _cudd_PrintInfo#} ddmanager cfile
       printCFile cfile "\nVariable groups\n"
       {#call unsafe cudd_printVarGroups#} ddmanager

----------------------------------------
-- Variable Reordering.
-- FIXME add an off switch
----------------------------------------

{#enum Cudd_ReorderingType as CUDDReorderingMethod {} deriving (Eq, Ord, Show)#}

roMap :: [(ReorderingMethod, CUDDReorderingMethod)]
roMap = [(ReorderSift, CUDD_REORDER_SIFT),
         (ReorderStableWindow3, CUDD_REORDER_WINDOW3)]

-- | Set the dynamic variable ordering heuristic.
dynamicReOrdering :: ReorderingMethod -> IO ()
dynamicReOrdering rom =
    case lookup rom roMap of
      Nothing -> error $ "CUDD.dynamicReOrdering: method not supported: " ++ show rom
      Just brom ->
        {#call unsafe Cudd_AutodynEnable as _cudd_AutodynEnable#} ddmanager (cFromEnum brom) >> return ()

----------------------------------------
-- | Returns the relationship between BDD indices, BDD ids and
-- variable names. This may be useful for discovering what the
-- dynamic reordering is doing.
--
-- The intention of this function is to return
--   @[(position in variable order, immutable variable id, label)]@
-- so that the variable order can be saved.
----------------------------------------

varIndices :: IO [(CInt, CInt, String)]
varIndices = do (toBDD, _fromBDD) <- readIORef bdd_vars
                mapM procVar $ Map.toList toBDD
    where -- procVar :: (String, BDD) -> IO (CUInt, CUInt, String)
          procVar (var, bdd) =
              do -- FIXME CUDD inconsistently uses signed and unsigned ints.
                 vid <- fmap cToNum $
                          withBDD bdd {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#}
                 level <- {#call unsafe Cudd_ReadPerm as _cudd_ReadPerm#} ddmanager vid
                 return (level, vid, var)
{-# NOINLINE varIndices #-}

----------------------------------------
-- BDD Statistics.
----------------------------------------

-- | Determine the size of a BDD.
bddSize :: BDD -> Int
bddSize bdd = unsafePerformIO $
  do size <- withBDD bdd ({#call unsafe Cudd_DagSize as _cudd_DagSize#})
     return $ cToNum size


Add function sourceCompletionProviderPopulate

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget SourceCompletionProvider
--
--  Author : Andy Stewart
--
--  Created: 08 Aug 2010
--
--  Copyright (C) 2010 Andy Stewart
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.SourceView.SourceCompletionProvider (
-- * Description
-- | You must implement this interface to provide proposals to 'SourceCompletion'

-- * Types
   SourceCompletionProvider,
   SourceCompletionProviderClass,

-- * Methods
   sourceCompletionProviderGetName,
   sourceCompletionProviderGetIcon,
   sourceCompletionProviderGetInteractiveDelay,
   sourceCompletionProviderGetPriority,
   sourceCompletionProviderGetInfoWidget,
   sourceCompletionProviderPopulate,
   sourceCompletionProviderActivateProposal,
) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GObject	(makeNewGObject)
import System.Glib.Attributes
import System.Glib.Properties
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.SourceView.Signals#}
{#import Graphics.UI.Gtk.SourceView.Types#}

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

-- | Get the name of the provider. This should be a translatable name for display to the user. For
-- example: _("Document word completion provider").
sourceCompletionProviderGetName :: SourceCompletionProviderClass scp => scp
                                -> IO String -- ^ returns  A new string containing the name of the provider.
sourceCompletionProviderGetName scp =
  {#call gtk_source_completion_provider_get_name #}
    (toSourceCompletionProvider scp)
  >>= peekUTFString

-- | Get the icon of the provider.
sourceCompletionProviderGetIcon :: SourceCompletionProviderClass scp => scp
                                -> IO (Maybe Pixbuf)
sourceCompletionProviderGetIcon scp =
  maybeNull (makeNewGObject mkPixbuf) $
  {#call gtk_source_completion_provider_get_icon #}
    (toSourceCompletionProvider scp)

-- | Get the delay in milliseconds before starting interactive completion for this provider. A value of
-- -1 indicates to use the default value as set by 'autoCompleteDelay'.
sourceCompletionProviderGetInteractiveDelay :: SourceCompletionProviderClass scp => scp
                                            -> IO Int -- ^ returns  the interactive delay in milliseconds.
sourceCompletionProviderGetInteractiveDelay scp =
  liftM fromIntegral $
  {#call gtk_source_completion_provider_get_interactive_delay #}
     (toSourceCompletionProvider scp)

-- | Get the provider priority. The priority determines the order in which proposals appear in the
-- completion popup. Higher priorities are sorted before lower priorities. The default priority is 0.
sourceCompletionProviderGetPriority :: SourceCompletionProviderClass scp => scp
                                    -> IO Int -- ^ returns  the provider priority.
sourceCompletionProviderGetPriority scp =
  liftM fromIntegral $
  {#call gtk_source_completion_provider_get_priority #}
    (toSourceCompletionProvider scp)

-- | Get a customized info widget to show extra information of a proposal. This allows for customized
-- widgets on a proposal basis, although in general providers will have the same custom widget for all
-- their proposals and proposal can be ignored.  The implementation of this function is optional. If
-- implemented, 'sourceCompletionProviderUpdateInfo' MUST also be implemented. If not
-- implemented, the default 'sourceCompletionProposalGetInfo' will be used to display extra
-- information about a 'SourceCompletionProposal'.
sourceCompletionProviderGetInfoWidget :: SourceCompletionProviderClass scp => scp
                                      -> SourceCompletionProposal -- ^ @proposal@ The currently selected 'SourceCompletionProposal'
                                     -> IO Widget -- ^ returns  a custom 'Widget' to show extra information about proposal.
sourceCompletionProviderGetInfoWidget scp proposal =
  makeNewObject mkWidget $
  {#call gtk_source_completion_provider_get_info_widget #}
    (toSourceCompletionProvider scp)
    proposal

-- | Populate context with proposals from provider
sourceCompletionProviderPopulate :: SourceCompletionProviderClass scp => scp
                                 -> SourceCompletionContext
                                 -> IO ()
sourceCompletionProviderPopulate scp context =
  {#call gtk_source_completion_provider_populate #}
     (toSourceCompletionProvider scp)
     context

-- | Activate proposal at iter. When this functions returns 'False', the default activation of proposal
-- will take place which replaces the word at iter with the label of proposal.
sourceCompletionProviderActivateProposal :: SourceCompletionProviderClass scp => scp
                                         -> SourceCompletionProposal
                                         -> TextIter
                                         -> IO Bool -- ^ returns  'True' to indicate that the proposal activation has been handled, 'False' otherwise.
sourceCompletionProviderActivateProposal scp proposal iter =
  liftM toBool $
  {#call gtk_source_completion_provider_activate_proposal #}
    (toSourceCompletionProvider scp)
    proposal
    iter

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget SourceCompletionProvider
--
--  Author : Andy Stewart
--
--  Created: 08 Aug 2010
--
--  Copyright (C) 2010 Andy Stewart
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.SourceView.SourceCompletionProvider (
-- * Description
-- | You must implement this interface to provide proposals to 'SourceCompletion'

-- * Types
   SourceCompletionProvider,
   SourceCompletionProviderClass,

-- * Methods
   sourceCompletionProviderGetName,
   sourceCompletionProviderGetIcon,
   sourceCompletionProviderGetInteractiveDelay,
   sourceCompletionProviderGetPriority,
   sourceCompletionProviderGetInfoWidget,
   sourceCompletionProviderActivateProposal,
) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GObject	(makeNewGObject)
import System.Glib.Attributes
import System.Glib.Properties
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.SourceView.Signals#}
{#import Graphics.UI.Gtk.SourceView.Types#}

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

-- | Get the name of the provider. This should be a translatable name for display to the user. For
-- example: _("Document word completion provider").
sourceCompletionProviderGetName :: SourceCompletionProviderClass scp => scp
                                -> IO String -- ^ returns  A new string containing the name of the provider.
sourceCompletionProviderGetName scp =
  {#call gtk_source_completion_provider_get_name #}
    (toSourceCompletionProvider scp)
  >>= peekUTFString

-- | Get the icon of the provider.
sourceCompletionProviderGetIcon :: SourceCompletionProviderClass scp => scp
                                -> IO (Maybe Pixbuf)
sourceCompletionProviderGetIcon scp =
  maybeNull (makeNewGObject mkPixbuf) $
  {#call gtk_source_completion_provider_get_icon #}
    (toSourceCompletionProvider scp)

-- | Get the delay in milliseconds before starting interactive completion for this provider. A value of
-- -1 indicates to use the default value as set by 'autoCompleteDelay'.
sourceCompletionProviderGetInteractiveDelay :: SourceCompletionProviderClass scp => scp
                                            -> IO Int -- ^ returns  the interactive delay in milliseconds.
sourceCompletionProviderGetInteractiveDelay scp =
  liftM fromIntegral $
  {#call gtk_source_completion_provider_get_interactive_delay #}
     (toSourceCompletionProvider scp)

-- | Get the provider priority. The priority determines the order in which proposals appear in the
-- completion popup. Higher priorities are sorted before lower priorities. The default priority is 0.
sourceCompletionProviderGetPriority :: SourceCompletionProviderClass scp => scp
                                    -> IO Int -- ^ returns  the provider priority.
sourceCompletionProviderGetPriority scp =
  liftM fromIntegral $
  {#call gtk_source_completion_provider_get_priority #}
    (toSourceCompletionProvider scp)

-- | Get a customized info widget to show extra information of a proposal. This allows for customized
-- widgets on a proposal basis, although in general providers will have the same custom widget for all
-- their proposals and proposal can be ignored.  The implementation of this function is optional. If
-- implemented, 'sourceCompletionProviderUpdateInfo' MUST also be implemented. If not
-- implemented, the default 'sourceCompletionProposalGetInfo' will be used to display extra
-- information about a 'SourceCompletionProposal'.
sourceCompletionProviderGetInfoWidget :: SourceCompletionProviderClass scp => scp
                                      -> SourceCompletionProposal -- ^ @proposal@ The currently selected 'SourceCompletionProposal'
                                     -> IO Widget -- ^ returns  a custom 'Widget' to show extra information about proposal.
sourceCompletionProviderGetInfoWidget scp proposal =
  makeNewObject mkWidget $
  {#call gtk_source_completion_provider_get_info_widget #}
    (toSourceCompletionProvider scp)
    proposal

-- | Activate proposal at iter. When this functions returns 'False', the default activation of proposal
-- will take place which replaces the word at iter with the label of proposal.
sourceCompletionProviderActivateProposal :: SourceCompletionProviderClass scp => scp
                                         -> SourceCompletionProposal
                                         -> TextIter
                                         -> IO Bool -- ^ returns  'True' to indicate that the proposal activation has been handled, 'False' otherwise.
sourceCompletionProviderActivateProposal scp proposal iter =
  liftM toBool $
  {#call gtk_source_completion_provider_activate_proposal #}
    (toSourceCompletionProvider scp)
    proposal
    iter