Add mutex functions to Gtk and remove the funky threaded intialisation function.

-- -*-haskell-*-
--  GIMP Toolkit (GTK) General
--
--  Author : Axel Simon, Manuel M. T. Chakravarty
--
--  Created: 8 December 1998
--
--  Copyright (C) 2000..2005 Axel Simon, Manuel M. T. Chakravarty
--
--  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.
--
-- TODO
--
-- quitAddDestroy, quitAdd, quitRemove
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- library initialization, main event loop, and events
--
module Graphics.UI.Gtk.General.General (
--  getDefaultLanguage,
  -- * Initialisation
  initGUI,

  -- ** Support for OS threads
  unsafeInitGUIForThreadedRTS,
  postGUISync,
  postGUIAsync,
  threadsEnter,
  threadsLeave,

  -- * Main event loop
  mainGUI,
  mainQuit,

  -- ** Less commonly used event loop functions
  eventsPending,
  mainLevel,
  mainIteration,
  mainIterationDo,

  -- * Grab widgets
  grabAdd,
  grabGetCurrent,
  grabRemove,

  -- * Timeout and idle callbacks
  Priority,
  priorityLow,
  priorityDefaultIdle,
  priorityHighIdle,
  priorityDefault,
  priorityHigh,
  timeoutAdd,
  timeoutAddFull,
  timeoutRemove,
  idleAdd,
  idleRemove,
  inputAdd,
  inputRemove,
  IOCondition,
  HandlerId
  ) where

import System.Environment (getProgName, getArgs)
import Control.Monad      (liftM, mapM, when)
import Control.Concurrent (rtsSupportsBoundThreads, newEmptyMVar,
                           putMVar, takeMVar)
import Data.IORef         (IORef, newIORef, readIORef, writeIORef)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.MainLoop
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.Types#}

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

{-
-- | Retreive the current language.
-- * This function returns a String which's pointer can be used later on for
--   comarisions.
--
--getDefaultLanguage :: IO String
--getDefaultLanguage = do
--  strPtr <- {#call unsafe get_default_language#}
--  str <- peekUTFString strPtr
--  destruct strPtr
--  return str
-}

unsafeInitGUIForThreadedRTS = initGUI

-- We compile this module using -#includ"gtk/wingtk.h" to bypass the win32 abi
-- check however we do not compile users programs with this header so if
-- initGUI was ever inlined in a users program, then that program would not
-- bypass the abi check and would fail on startup. So to stop that we must
-- prevent initGUI from being inlined.
{-# NOINLINE initGUI #-}
-- | Initialize the GUI.
--
-- This must be called before any other function in the Gtk2Hs library.
--
-- This function initializes the GUI toolkit and parses all Gtk
-- specific arguments. The remaining arguments are returned. If the
-- initialization of the toolkit fails for whatever reason, an exception
-- is thrown.
--
-- * Throws: @error \"Cannot initialize GUI.\"@
--
--
-- * If you want to use Gtk2Hs and in a multi-threaded application then it is your obligation
--   to ensure that all calls to Gtk+ happen on a single OS thread.
--   If you want to make calls to Gtk2Hs functions from a Haskell thread other
--   than the one that calls this functions and 'mainGUI' then you will have to
--   \'post\' your GUI actions to the main GUI thread. You can do this using
--   'postGUISync' or 'postGUIAsync'. See also 'threadsEnter'.
--
initGUI :: IO [String]
initGUI = do
  when rtsSupportsBoundThreads initialiseGThreads
  threadsEnter
  prog <- getProgName
  args <- getArgs
  let allArgs = (prog:args)
  withMany withUTFString allArgs $ \addrs  ->
    withArrayLen       addrs   $ \argc argv ->
    with	       argv    $ \argvp ->
    with	       argc    $ \argcp -> do
      res <- {#call unsafe init_check#} (castPtr argcp) (castPtr argvp)
      if (toBool res) then do
        argc'   <- peek argcp
        argv'   <- peek argvp
        _:addrs'  <- peekArray argc' argv'  -- drop the program name
        mapM peekUTFString addrs'
        else error "Cannot initialize GUI."

-- g_thread_init aborts the whole program if it's called more than once so
-- we've got to keep track of whether or not we've called it already. Sigh.
--
foreign import ccall "hsgthread.h gtk2hs_threads_initialise"
  initialiseGThreads :: IO ()

-- | Post an action to be run in the main GUI thread.
--
-- The current thread blocks until the action completes and the result is
-- returned.
--
postGUISync :: IO a -> IO a
postGUISync action = do
  resultVar <- newEmptyMVar
  idleAdd (action >>= putMVar resultVar >> return False) priorityDefault
  takeMVar resultVar

-- | Post an action to be run in the main GUI thread.
--
-- The current thread continues and does not wait for the result of the
-- action.
--
postGUIAsync :: IO () -> IO ()
postGUIAsync action = do
  idleAdd (action >> return False) priorityDefault
  return ()

-- | Acquired the global Gtk lock.
--
-- * During normal operation, this lock is held by the thread from which all
--   interaction with Gtk is performed. When calling 'mainGUI', the thread will
--   release this global lock before it waits for user interaction. During this
--   time it is, in principle, possible to use a different OS thread (any other
--   Haskell thread that is bound to the Gtk OS thread will be blocked anyway)
--   to interact with Gtk by explicitly acquiring the lock, calling Gtk functions
--   and releasing the lock. However, the Gtk functions that are called from this
--   different thread may not trigger any calls to the OS since this will
--   lead to a crash on Windows (the Win32 API can only be used from a single
--   thread). Since it is very hard to tell which function only interacts on
--   Gtk data structures and which function call actual OS functions, it
--   is best not to use this feature at all. A better way to perform updates
--   in the background is to spawn a Haskell thread and to perform the update
--   to Gtk widgets using 'postGUIAsync' or 'postGUISync'. These will execute
--   their arguments from the main loop, that is, from the OS thread of Gtk,
--   thereby ensuring that any Gtk and OS function can be called.
--
{#fun unsafe gdk_threads_enter as threadsEnter {} -> `()' #}

-- | Release the global Gtk lock.
--
-- * The use of this function is not recommended. See 'threadsEnter'.
--
{#fun unsafe gdk_threads_leave as threadsLeave {} -> `()' #}

-- | Inquire the number of events pending on the event queue
--
eventsPending :: IO Int
eventsPending  = liftM fromIntegral {#call unsafe events_pending#}

-- | Run the Gtk+ main event loop.
--
mainGUI :: IO ()
mainGUI  = {#call main#}

-- | Inquire the main loop level.
--
-- * Callbacks that take more time to process can call 'mainIteration' to keep
-- the GUI responsive. Each time the main loop is restarted this way, the main
-- loop counter is increased. This function returns this counter.
--
mainLevel :: IO Int
mainLevel  = liftM (toEnum.fromEnum) {#call unsafe main_level#}

-- | Exit the main event loop.
--
mainQuit :: IO ()
mainQuit  = {#call main_quit#}

-- | Process an event, block if necessary.
--
-- * Returns @True@ if 'mainQuit' was called while processing the event.
--
mainIteration :: IO Bool
mainIteration  = liftM toBool {#call main_iteration#}

-- | Process a single event.
--
-- * Called with @True@, this function behaves as 'mainIteration' in that it
-- waits until an event is available for processing. It will return
-- immediately, if passed @False@.
--
-- * Returns @True@ if the 'mainQuit' was called while processing the event.
--
mainIterationDo :: Bool -> IO Bool
mainIterationDo blocking =
  liftM toBool $ {#call main_iteration_do#} (fromBool blocking)

-- | add a grab widget
--
grabAdd :: WidgetClass wd => wd -> IO ()
grabAdd  = {#call grab_add#} . toWidget

-- | inquire current grab widget
--
grabGetCurrent :: IO (Maybe Widget)
grabGetCurrent  = do
  wPtr <- {#call grab_get_current#}
  if (wPtr==nullPtr) then return Nothing else
    liftM Just $ makeNewObject mkWidget (return wPtr)

-- | remove a grab widget
--
grabRemove :: WidgetClass w => w -> IO ()
grabRemove  = {#call grab_remove#} . toWidget

-- -*-haskell-*-
--  GIMP Toolkit (GTK) General
--
--  Author : Axel Simon, Manuel M. T. Chakravarty
--
--  Created: 8 December 1998
--
--  Copyright (C) 2000..2005 Axel Simon, Manuel M. T. Chakravarty
--
--  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.
--
-- TODO
--
-- quitAddDestroy, quitAdd, quitRemove
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- library initialization, main event loop, and events
--
module Graphics.UI.Gtk.General.General (
--  getDefaultLanguage,
  -- * Initialisation
  initGUI,

  -- ** Support for OS threads
  unsafeInitGUIForThreadedRTS,
  postGUISync,
  postGUIAsync,

  -- * Main event loop
  mainGUI,
  mainQuit,

  -- ** Less commonly used event loop functions
  eventsPending,
  mainLevel,
  mainIteration,
  mainIterationDo,

  -- * Grab widgets
  grabAdd,
  grabGetCurrent,
  grabRemove,

  -- * Timeout and idle callbacks
  Priority,
  priorityLow,
  priorityDefaultIdle,
  priorityHighIdle,
  priorityDefault,
  priorityHigh,
  timeoutAdd,
  timeoutAddFull,
  timeoutRemove,
  idleAdd,
  idleRemove,
  inputAdd,
  inputRemove,
  IOCondition,
  HandlerId
  ) where

import System.Environment (getProgName, getArgs)
import Control.Monad      (liftM, mapM, when)
import Control.Concurrent (rtsSupportsBoundThreads, newEmptyMVar,
                           putMVar, takeMVar)
import Data.IORef         (IORef, newIORef, readIORef, writeIORef)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.MainLoop
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.Types#}

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

{-
-- | Retreive the current language.
-- * This function returns a String which's pointer can be used later on for
--   comarisions.
--
--getDefaultLanguage :: IO String
--getDefaultLanguage = do
--  strPtr <- {#call unsafe get_default_language#}
--  str <- peekUTFString strPtr
--  destruct strPtr
--  return str
-}

-- We compile this module using -#includ"gtk/wingtk.h" to bypass the win32 abi
-- check however we do not compile users programs with this header so if
-- initGUI was ever inlined in a users program, then that program would not
-- bypass the abi check and would fail on startup. So to stop that we must
-- prevent initGUI from being inlined.
{-# NOINLINE initGUI #-}
-- | Initialize the GUI.
--
-- This must be called before any other function in the Gtk2Hs library.
--
-- This function initializes the GUI toolkit and parses all Gtk
-- specific arguments. The remaining arguments are returned. If the
-- initialization of the toolkit fails for whatever reason, an exception
-- is thrown.
--
-- * Throws: @error \"Cannot initialize GUI.\"@
--
initGUI :: IO [String]
initGUI = do
  name <- getProgName
  when (rtsSupportsBoundThreads && name /= "<interactive>") $ fail $ "\n" ++
    "initGUI: Gtk+ is single threaded and so cannot safely be used from\n" ++
    "multiple Haskell threads when using GHC's threaded RTS. You can\n" ++
    "avoid this error by relinking your program without using the\n" ++
    "'-threaded' flag. If you have to use the threaded RTS and are\n" ++
    "absolutely sure that you only ever call Gtk+ from a single OS\n" ++
    "thread then you can use the function: unsafeInitGUIForThreadedRTS\n"

  unsafeInitGUIForThreadedRTS

{-# NOINLINE unsafeInitGUIForThreadedRTS #-}
-- | Same as initGUI except that it prints no warning when used with GHC's
-- threaded RTS.
--
-- If you want to use Gtk2Hs and the threaded RTS then it is your obligation
-- to ensure that all calls to Gtk+ happen on a single OS thread.
-- If you want to make calls to Gtk2Hs functions from a Haskell thread other
-- than the one that calls this functions and 'mainGUI' then you will have to
-- \'post\' your GUI actions to the main GUI thread. You can do this using
-- 'postGUISync' or 'postGUIAsync'.
--
unsafeInitGUIForThreadedRTS :: IO [String]
unsafeInitGUIForThreadedRTS = do
  when rtsSupportsBoundThreads initialiseGThreads
  prog <- getProgName
  args <- getArgs
  let allArgs = (prog:args)
  withMany withUTFString allArgs $ \addrs  ->
    withArrayLen       addrs   $ \argc argv ->
    with	       argv    $ \argvp ->
    with	       argc    $ \argcp -> do
      res <- {#call unsafe init_check#} (castPtr argcp) (castPtr argvp)
      if (toBool res) then do
        argc'   <- peek argcp
        argv'   <- peek argvp
        _:addrs'  <- peekArray argc' argv'  -- drop the program name
        mapM peekUTFString addrs'
        else error "Cannot initialize GUI."

-- g_thread_init aborts the whole program if it's called more than once so
-- we've got to keep track of whether or not we've called it already. Sigh.
--
foreign import ccall "hsgthread.h gtk2hs_threads_initialise"
  initialiseGThreads :: IO ()

-- | Post an action to be run in the main GUI thread.
--
-- The current thread blocks until the action completes and the result is
-- returned.
--
postGUISync :: IO a -> IO a
postGUISync action = do
  resultVar <- newEmptyMVar
  idleAdd (action >>= putMVar resultVar >> return False) priorityDefault
  takeMVar resultVar

-- | Post an action to be run in the main GUI thread.
--
-- The current thread continues and does not wait for the result of the
-- action.
--
postGUIAsync :: IO () -> IO ()
postGUIAsync action = do
  idleAdd (action >> return False) priorityDefault
  return ()

-- | Inquire the number of events pending on the event queue
--
eventsPending :: IO Int
eventsPending  = liftM fromIntegral {#call unsafe events_pending#}

-- | Run the Gtk+ main event loop.
--
mainGUI :: IO ()
mainGUI  = {#call main#}

-- | Inquire the main loop level.
--
-- * Callbacks that take more time to process can call 'mainIteration' to keep
-- the GUI responsive. Each time the main loop is restarted this way, the main
-- loop counter is increased. This function returns this counter.
--
mainLevel :: IO Int
mainLevel  = liftM (toEnum.fromEnum) {#call unsafe main_level#}

-- | Exit the main event loop.
--
mainQuit :: IO ()
mainQuit  = {#call main_quit#}

-- | Process an event, block if necessary.
--
-- * Returns @True@ if 'mainQuit' was called while processing the event.
--
mainIteration :: IO Bool
mainIteration  = liftM toBool {#call main_iteration#}

-- | Process a single event.
--
-- * Called with @True@, this function behaves as 'mainIteration' in that it
-- waits until an event is available for processing. It will return
-- immediately, if passed @False@.
--
-- * Returns @True@ if the 'mainQuit' was called while processing the event.
--
mainIterationDo :: Bool -> IO Bool
mainIterationDo blocking =
  liftM toBool $ {#call main_iteration_do#} (fromBool blocking)

-- | add a grab widget
--
grabAdd :: WidgetClass wd => wd -> IO ()
grabAdd  = {#call grab_add#} . toWidget

-- | inquire current grab widget
--
grabGetCurrent :: IO (Maybe Widget)
grabGetCurrent  = do
  wPtr <- {#call grab_get_current#}
  if (wPtr==nullPtr) then return Nothing else
    liftM Just $ makeNewObject mkWidget (return wPtr)

-- | remove a grab widget
--
grabRemove :: WidgetClass w => w -> IO ()
grabRemove  = {#call grab_remove#} . toWidget


fix display of NVVM UserError

fix display of NVVM UserError

{-# LANGUAGE DeriveDataTypeable       #-}
{-# LANGUAGE ForeignFunctionInterface #-}
-- Copyright (c) 2012-2014 NVIDIA Corporation.  All rights reserved.
--
-- Permission is hereby granted, free of charge, to any person obtaining a copy
-- of this software and associated documentation files (the "Software"), to deal
-- in the Software without restriction, including without limitation the rights
-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:
--
-- The above copyright notice and this permission notice shall be included in
-- all copies or substantial portions of the Software.
--
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-- SOFTWARE.
-- |
-- Module      : Foreign.LibNVVM.Error
-- Copyright   : NVIDIA Corporation
-- License     : MIT
--
-- Maintainer  : Sean Lee <selee@nvidia.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
module Foreign.LibNVVM.Error (

  -- * Error code
  Status(..), NVVMException(..),
  nvvmError, describe,

  -- * Helper functions
  resultIfOk, nothingIfOk,

) where

import Control.Exception
import Data.Typeable
import System.IO.Unsafe
import Foreign.C
import Foreign.Ptr
import Foreign.LibNVVM.Internal

#include "cbits/stubs.h"
{# context lib = "nvvm" #}

-- |
-- The type 'Status' is an enumeration whose values represent the status of the
-- last libNVVM operation.
--
{# enum nvvmResult as Status
    { underscoreToCase
    , NVVM_SUCCESS as Success
    }
    with prefix="NVVM_ERROR" deriving (Eq, Show) #}

-- | An NVVM Exception
--
data NVVMException
  = ExitCode  Status
  | UserError String
  deriving Typeable

instance Exception NVVMException

instance Show NVVMException where
  showsPrec n (ExitCode s)  = showsPrec n ("NVVM Exception: " ++ describe s)
  showsPrec _ (UserError s) = showString s

-- | Raise an 'NVVMException' in the IO monad
--
nvvmError :: String -> IO a
nvvmError s = throwIO (UserError s)

-- Helper function
-- ---------------

-- | Get the message string for a given NVVM result code
--
{# fun pure unsafe nvvmGetErrorString as describe
    { cFromEnum `Status' } -> `String' #}

-- |
-- Return the results of a function on successful execution, otherwise throw an
-- exception with an error string associated with the return code
--
{-# INLINE resultIfOk #-}
resultIfOk :: (Status, a) -> IO a
resultIfOk (status, result) =
    case status of
        Success -> return  result
        _       -> throwIO (ExitCode status)

-- |
-- Throw an exception with an error string associated with an unsuccessful
-- return code, otherwise return unit.
--
{-# INLINE nothingIfOk #-}
nothingIfOk :: Status -> IO ()
nothingIfOk status =
    case status of
        Success -> return  ()
        _       -> throwIO (ExitCode status)

{-# LANGUAGE DeriveDataTypeable       #-}
{-# LANGUAGE ForeignFunctionInterface #-}
-- Copyright (c) 2012-2014 NVIDIA Corporation.  All rights reserved.
--
-- Permission is hereby granted, free of charge, to any person obtaining a copy
-- of this software and associated documentation files (the "Software"), to deal
-- in the Software without restriction, including without limitation the rights
-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:
--
-- The above copyright notice and this permission notice shall be included in
-- all copies or substantial portions of the Software.
--
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-- SOFTWARE.
-- |
-- Module      : Foreign.LibNVVM.Error
-- Copyright   : NVIDIA Corporation
-- License     : MIT
--
-- Maintainer  : Sean Lee <selee@nvidia.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
module Foreign.LibNVVM.Error (

  -- * Error code
  Status(..), NVVMException(..),
  nvvmError, describe,

  -- * Helper functions
  resultIfOk, nothingIfOk,

) where

import Control.Exception
import Data.Typeable
import System.IO.Unsafe
import Foreign.C
import Foreign.Ptr
import Foreign.LibNVVM.Internal

#include "cbits/stubs.h"
{# context lib = "nvvm" #}

-- |
-- The type 'Status' is an enumeration whose values represent the status of the
-- last libNVVM operation.
--
{# enum nvvmResult as Status
    { underscoreToCase
    , NVVM_SUCCESS as Success
    }
    with prefix="NVVM_ERROR" deriving (Eq, Show) #}

-- | An NVVM Exception
--
data NVVMException
  = ExitCode  Status
  | UserError String
  deriving Typeable

instance Exception NVVMException

instance Show NVVMException where
  showsPrec n (ExitCode s)  = showsPrec n ("NVVM Exception: " ++ describe s)
  showsPrec n (UserError s) = showsPrec n s

-- | Raise an 'NVVMException' in the IO monad
--
nvvmError :: String -> IO a
nvvmError s = throwIO (UserError s)

-- Helper function
-- ---------------

-- | Get the message string for a given NVVM result code
--
{# fun pure unsafe nvvmGetErrorString as describe
    { cFromEnum `Status' } -> `String' #}

-- |
-- Return the results of a function on successful execution, otherwise throw an
-- exception with an error string associated with the return code
--
{-# INLINE resultIfOk #-}
resultIfOk :: (Status, a) -> IO a
resultIfOk (status, result) =
    case status of
        Success -> return  result
        _       -> throwIO (ExitCode status)

-- |
-- Throw an exception with an error string associated with an unsuccessful
-- return code, otherwise return unit.
--
{-# INLINE nothingIfOk #-}
nothingIfOk :: Status -> IO ()
nothingIfOk status =
    case status of
        Success -> return  ()
        _       -> throwIO (ExitCode status)


fix: store Tag in TAG field (was stored to SOURCE)

{-# LANGUAGE ForeignFunctionInterface #-}

#include <mpi.h>

module Control.Parallel.MPI.Status (Status (..), StatusPtr) where

import C2HS
import Control.Monad (liftM)
import Control.Applicative ((<$>), (<*>))

{# context prefix = "MPI" #}

data Status =
   Status
   { status_source :: Int
   , status_tag :: Int
   , status_error :: Int
   , status_count :: Int
   , status_cancelled :: Int
   }
   deriving (Eq, Ord, Show)

{#pointer *Status as StatusPtr -> Status #}

instance Storable Status where
  sizeOf _ = {#sizeof MPI_Status #}
  alignment _ = 4
  peek p = Status
    <$> liftM cIntConv ({#get MPI_Status->MPI_SOURCE #} p)
    <*> liftM cIntConv ({#get MPI_Status->MPI_TAG #} p)
    <*> liftM cIntConv ({#get MPI_Status->MPI_ERROR #} p)
    <*> liftM cIntConv ({#get MPI_Status->_count #} p)
    <*> liftM cIntConv ({#get MPI_Status->_cancelled #} p)
  poke p x = do
    {#set MPI_Status.MPI_SOURCE #} p (cIntConv $ status_source x)
    {#set MPI_Status.MPI_TAG #} p (cIntConv $ status_tag x)
    {#set MPI_Status.MPI_ERROR #} p (cIntConv $ status_error x)
    {#set MPI_Status._count #} p (cIntConv $ status_count x)
    {#set MPI_Status._cancelled #} p (cIntConv $ status_cancelled x)

{-# LANGUAGE ForeignFunctionInterface #-}

#include <mpi.h>

module Control.Parallel.MPI.Status (Status (..), StatusPtr) where

import C2HS
import Control.Monad (liftM)
import Control.Applicative ((<$>), (<*>))

{# context prefix = "MPI" #}

data Status =
   Status
   { status_source :: Int
   , status_tag :: Int
   , status_error :: Int
   , status_count :: Int
   , status_cancelled :: Int
   }
   deriving (Eq, Ord, Show)

{#pointer *Status as StatusPtr -> Status #}

instance Storable Status where
  sizeOf _ = {#sizeof MPI_Status #}
  alignment _ = 4
  peek p = Status
    <$> liftM cIntConv ({#get MPI_Status->MPI_SOURCE #} p)
    <*> liftM cIntConv ({#get MPI_Status->MPI_TAG #} p)
    <*> liftM cIntConv ({#get MPI_Status->MPI_ERROR #} p)
    <*> liftM cIntConv ({#get MPI_Status->_count #} p)
    <*> liftM cIntConv ({#get MPI_Status->_cancelled #} p)
  poke p x = do
    {#set MPI_Status.MPI_SOURCE #} p (cIntConv $ status_source x)
    {#set MPI_Status.MPI_SOURCE #} p (cIntConv $ status_tag x)
    {#set MPI_Status.MPI_ERROR #} p (cIntConv $ status_error x)
    {#set MPI_Status._count #} p (cIntConv $ status_count x)
    {#set MPI_Status._cancelled #} p (cIntConv $ status_cancelled x)


Refactoring

Refactoring

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}

#include <git2/config.h>

module Data.HGit2.Config where

import Data.HGit2.Git2
import Data.HGit2.Errors
import Foreign
import Foreign.C

newtype Config = Config CPtr

-- | Locate the path to the global configuration file
--
-- The user or global configuration file is usually located in
-- `$HOME/.gitconfig`.
--
-- This method will try to guess the full path to that file, if the file
-- exists. The returned path may be used on any `git_config` call to load the
-- global configuration file.
findGlobalConfig :: IO (Maybe String)
findGlobalConfig = alloca $ \pth -> do
  res <- {#call git_config_find_global#} pth
  if res == 0
    then fmap Just $ peekCString pth
    else return Nothing

-- | Open the global configuration file
openGlobalConfig :: IO (Either GitError Config)
openGlobalConfig = alloca $ \conf -> do
  res <- {#call git_config_open_global#} conf
  retEither res $ fmap (Right . Config) $ peek conf

{-
/**
 * Create a configuration file backend for ondisk files
 *
 * These are the normal `.gitconfig` files that Core Git
 * processes. Note that you first have to add this file to a
 * configuration object before you can query it for configuration
 * variables.
 *
 * @param out the new backend
 * @param path where the config file is located
 */
GIT_EXTERN(int) git_config_file__ondisk(struct git_config_file **out, const char *path);

/**
 * Allocate a new configuration object
 *
 * This object is empty, so you have to add a file to it before you
 * can do anything with it.
 *
 * @param out pointer to the new configuration
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_new(git_config **out);

/**
 * Add a generic config file instance to an existing config
 *
 * Note that the configuration object will free the file
 * automatically.
 *
 * Further queries on this config object will access each
 * of the config file instances in order (instances with
 * a higher priority will be accessed first).
 *
 * @param cfg the configuration to add the file to
 * @param file the configuration file (backend) to add
 * @param priority the priority the backend should have
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_add_file(git_config *cfg, git_config_file *file, int priority);

/**
 * Add an on-disk config file instance to an existing config
 *
 * The on-disk file pointed at by `path` will be opened and
 * parsed; it's expected to be a native Git config file following
 * the default Git config syntax (see man git-config).
 *
 * Note that the configuration object will free the file
 * automatically.
 *
 * Further queries on this config object will access each
 * of the config file instances in order (instances with
 * a higher priority will be accessed first).
 *
 * @param cfg the configuration to add the file to
 * @param path path to the configuration file (backend) to add
 * @param priority the priority the backend should have
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_add_file_ondisk(git_config *cfg, const char *path, int priority);

/**
 * Create a new config instance containing a single on-disk file
 *
 * This method is a simple utility wrapper for the following sequence
 * of calls:
 *	- git_config_new
 *	- git_config_add_file_ondisk
 *
 * @param cfg The configuration instance to create
 * @param path Path to the on-disk file to open
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_open_ondisk(git_config **cfg, const char *path);

/**
 * Free the configuration and its associated memory and files
 *
 * @param cfg the configuration to free
 */
GIT_EXTERN(void) git_config_free(git_config *cfg);

/**
 * Get the value of an integer config variable.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param out pointer to the variable where the value should be stored
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_get_int(git_config *cfg, const char *name, int *out);

/**
 * Get the value of a long integer config variable.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param out pointer to the variable where the value should be stored
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_get_long(git_config *cfg, const char *name, long int *out);

/**
 * Get the value of a boolean config variable.
 *
 * This function uses the usual C convention of 0 being false and
 * anything else true.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param out pointer to the variable where the value should be stored
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_get_bool(git_config *cfg, const char *name, int *out);
-}

-- | Get the value of a string config variable.
-- The string is owned by the variable and should not be freed by the user.
configString :: Config -> String -> IO (Either GitError String)
configString (Config c) vn = alloca $ \out -> do
  vn' <- newCString vn
  res <- {#call git_config_get_string#} c vn' out
  retEither res $ fmap Right $ peekCString =<< peek out

-- | Set the value of an integer config variable.
setConfigInt :: Config -> String -> Int -> IO (Maybe GitError)
setConfigInt conf vn val =
  mConfig {#call git_config_set_int#} conf vn (fromIntegral val)

-- | Set the value of a long integer config variable.
setConfigInteger :: Config -> String -> Integer -> IO (Maybe GitError)
setConfigInteger conf vn val =
  mConfig {#call git_config_set_long#} conf vn (fromIntegral val)

-- | Set the value of a boolean config variable.
setConfigBool :: Config -> String -> Bool -> IO (Maybe GitError)
setConfigBool conf vn val =
  mConfig {#call git_config_set_bool#} conf vn (fromBool val)

-- | Set the value of a string config variable.
setConfigString :: Config -> String -> String -> IO (Maybe GitError)
setConfigString conf vn val =
  mConfig {#call git_config_set_string#} conf vn =<< newCString val

-- | Delete a config variable
delConfig :: Config -> String -> IO (Maybe GitError)
delConfig (Config c) vn = do
  str <- newCString vn
  retMaybe =<< {#call git_config_delete#} c str

mConfig :: (CPtr -> CString -> t -> IO CInt) -> Config -> String -> t
        -> IO (Maybe GitError)
mConfig call (Config c) vn val = do
  str <- newCString vn
  retMaybe =<< call c str val

-- TODO: foreachConfig :: Config ->
{-
/**
 * Perform an operation on each config variable.
 *
 * The callback receives the normalized name and value of each variable
 * in the config backend, and the data pointer passed to this function.
 * As soon as one of the callback functions returns something other than 0,
 * this function returns that value.
 *
 * @param cfg where to get the variables from
 * @param callback the function to call on each variable
 * @param payload the data to pass to the callback
 * @return GIT_SUCCESS or the return value of the callback which didn't return 0
 */
GIT_EXTERN(int) git_config_foreach(
	git_config *cfg,
	int (*callback)(const char *var_name, const char *value, void *payload),
	void *payload);
-}

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}

#include <git2/config.h>

module Data.HGit2.Config where

import Data.HGit2.Git2
import Data.HGit2.Errors
import Foreign
import Foreign.C

newtype Config = Config CPtr

-- | Locate the path to the global configuration file
--
-- The user or global configuration file is usually located in
-- `$HOME/.gitconfig`.
--
-- This method will try to guess the full path to that file, if the file
-- exists. The returned path may be used on any `git_config` call to load the
-- global configuration file.
findGlobalConfig :: IO (Maybe String)
findGlobalConfig = alloca $ \pth -> do
  res <- {#call git_config_find_global#} pth
  if res == 0
    then fmap Just $ peekCString pth
    else return Nothing

-- | Open the global configuration file
openGlobalConfig :: IO (Either GitError Config)
openGlobalConfig = alloca $ \conf -> do
  res <- {#call git_config_open_global#} conf
  retEither res $ fmap (Right . Config) $ peek conf

{-
/**
 * Create a configuration file backend for ondisk files
 *
 * These are the normal `.gitconfig` files that Core Git
 * processes. Note that you first have to add this file to a
 * configuration object before you can query it for configuration
 * variables.
 *
 * @param out the new backend
 * @param path where the config file is located
 */
GIT_EXTERN(int) git_config_file__ondisk(struct git_config_file **out, const char *path);

/**
 * Allocate a new configuration object
 *
 * This object is empty, so you have to add a file to it before you
 * can do anything with it.
 *
 * @param out pointer to the new configuration
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_new(git_config **out);

/**
 * Add a generic config file instance to an existing config
 *
 * Note that the configuration object will free the file
 * automatically.
 *
 * Further queries on this config object will access each
 * of the config file instances in order (instances with
 * a higher priority will be accessed first).
 *
 * @param cfg the configuration to add the file to
 * @param file the configuration file (backend) to add
 * @param priority the priority the backend should have
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_add_file(git_config *cfg, git_config_file *file, int priority);

/**
 * Add an on-disk config file instance to an existing config
 *
 * The on-disk file pointed at by `path` will be opened and
 * parsed; it's expected to be a native Git config file following
 * the default Git config syntax (see man git-config).
 *
 * Note that the configuration object will free the file
 * automatically.
 *
 * Further queries on this config object will access each
 * of the config file instances in order (instances with
 * a higher priority will be accessed first).
 *
 * @param cfg the configuration to add the file to
 * @param path path to the configuration file (backend) to add
 * @param priority the priority the backend should have
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_add_file_ondisk(git_config *cfg, const char *path, int priority);

/**
 * Create a new config instance containing a single on-disk file
 *
 * This method is a simple utility wrapper for the following sequence
 * of calls:
 *	- git_config_new
 *	- git_config_add_file_ondisk
 *
 * @param cfg The configuration instance to create
 * @param path Path to the on-disk file to open
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_open_ondisk(git_config **cfg, const char *path);

/**
 * Free the configuration and its associated memory and files
 *
 * @param cfg the configuration to free
 */
GIT_EXTERN(void) git_config_free(git_config *cfg);

/**
 * Get the value of an integer config variable.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param out pointer to the variable where the value should be stored
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_get_int(git_config *cfg, const char *name, int *out);

/**
 * Get the value of a long integer config variable.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param out pointer to the variable where the value should be stored
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_get_long(git_config *cfg, const char *name, long int *out);

/**
 * Get the value of a boolean config variable.
 *
 * This function uses the usual C convention of 0 being false and
 * anything else true.
 *
 * @param cfg where to look for the variable
 * @param name the variable's name
 * @param out pointer to the variable where the value should be stored
 * @return GIT_SUCCESS on success; error code otherwise
 */
GIT_EXTERN(int) git_config_get_bool(git_config *cfg, const char *name, int *out);
-}

-- | Get the value of a string config variable.
-- The string is owned by the variable and should not be freed by the user.
configString :: Config -> String -> IO (Either GitError String)
configString (Config c) vn = alloca $ \out -> do
  vn' <- newCString vn
  res <- {#call git_config_get_string#} c vn' out
  retEither res $ fmap Right $ peekCString =<< peek out

-- | Set the value of an integer config variable.
setConfigInt :: Config -> String -> Int -> IO (Maybe GitError)
setConfigInt (Config c) vn val = do
  str <- newCString vn
  retMaybe =<< {#call git_config_set_int#} c str (fromIntegral val)

-- | Set the value of a long integer config variable.
setConfigInteger :: Config -> String -> Integer -> IO (Maybe GitError)
setConfigInteger (Config c) vn val = do
  str <- newCString vn
  retMaybe =<< {#call git_config_set_long#} c str (fromIntegral val)

-- | Set the value of a boolean config variable.
setConfigBool :: Config -> String -> Bool -> IO (Maybe GitError)
setConfigBool (Config c) vn val = do
  str <- newCString vn
  retMaybe =<< {#call git_config_set_bool#} c str (fromBool val)

-- | Set the value of a string config variable.
setConfigString :: Config -> String -> String -> IO (Maybe GitError)
setConfigString (Config c) vn val = do
  str <- newCString vn
  vl' <- newCString val
  retMaybe =<< {#call git_config_set_string#} c str vl'

-- | Delete a config variable
delConfig :: Config -> String -> IO (Maybe GitError)
delConfig (Config c) vn = do
  str <- newCString vn
  retMaybe =<< {#call git_config_delete#} c str

-- TODO: foreachConfig :: Config ->
{-
/**
 * Perform an operation on each config variable.
 *
 * The callback receives the normalized name and value of each variable
 * in the config backend, and the data pointer passed to this function.
 * As soon as one of the callback functions returns something other than 0,
 * this function returns that value.
 *
 * @param cfg where to get the variables from
 * @param callback the function to call on each variable
 * @param payload the data to pass to the callback
 * @return GIT_SUCCESS or the return value of the callback which didn't return 0
 */
GIT_EXTERN(int) git_config_foreach(
	git_config *cfg,
	int (*callback)(const char *var_name, const char *value, void *payload),
	void *payload);
-}


fix for 7.8.4

fix for 7.8.4

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

#include "bindings.h"

module GDAL.Internal.OGR (
    DataSource
  , DataSourceH
  , SQLDialect (..)
  , ApproxOK (..)
  , Layer
  , LayerH (..)
  , RODataSource
  , RWDataSource
  , ROLayer
  , RWLayer
  , Driver

  , openReadOnly
  , openReadWrite
  , create
  , createMem
  , canCreateMultipleGeometryFields

  , datasourceName
  , executeSQL

  , createLayer
  , getLayer
  , getLayerByName

  , getSpatialFilter
  , setSpatialFilter

  , layerCount
  , layerName
  , layerFeatureDef

  , registerAll
  , cleanupAll

  , withLockedLayerPtr
  , withLockedLayerPtrs
  , unDataSource
  , unLayer
  , withLockedDataSourcePtr
) where

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

import Data.Text (Text)
import qualified Data.Vector as V

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

import Foreign.C.String (CString, peekCString, withCString)
import Foreign.C.Types (CInt(..), CChar(..))
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.Marshal.Utils (toBool)

import Foreign.Storable (Storable)

import System.IO.Unsafe (unsafePerformIO)

{#import GDAL.Internal.OSR#}
{#import GDAL.Internal.OGRGeometry#}
{#import GDAL.Internal.OGRFeature#}
{#import GDAL.Internal.OGRError#}
{#import GDAL.Internal.CPLString#}
import GDAL.Internal.CPLError hiding (None)
import GDAL.Internal.CPLConv (cplFree)
import GDAL.Internal.Util
import GDAL.Internal.Types

#include "ogr_api.h"

{#fun RegisterAll as ^ {} -> `()'  #}
{#fun CleanupAll  as ^ {} -> `()'  #}

{#pointer OGRSFDriverH as DriverH newtype#}
deriving instance Eq DriverH

nullDriverH :: DriverH
nullDriverH = DriverH nullPtr

{#pointer DataSourceH newtype#}
newtype DataSource s (t::AccessMode) = DataSource (Mutex, DataSourceH)

deriving instance Eq DataSourceH

nullDataSourceH :: DataSourceH
nullDataSourceH = DataSourceH nullPtr

unDataSource :: DataSource s t -> DataSourceH
unDataSource (DataSource (_,p)) = p

type RODataSource s = DataSource s ReadOnly
type RWDataSource s = DataSource s ReadWrite

withLockedDataSourcePtr
  :: DataSource s t -> (DataSourceH -> IO b) -> IO b
withLockedDataSourcePtr (DataSource (m,p)) f = withMutex m (f p)

{#pointer LayerH newtype#}

deriving instance Storable LayerH
deriving instance Eq LayerH

nullLayerH :: LayerH
nullLayerH = LayerH nullPtr

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

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

lMutex :: Layer s t a -> Mutex
lMutex (Layer (m,_)) = m

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

withLockedLayerPtrs
  :: [Layer s t a] -> ([LayerH] -> IO b) -> IO b
withLockedLayerPtrs ls f
  = withMutexes (map lMutex ls) (f (map unLayer ls))

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

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

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

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

openWithMode :: OGRAccess -> String -> GDAL s (DataSource s t)
openWithMode m p = do
  ptr <- liftIO $ withCString p $ \p' ->
           throwIfError "open" ({#call OGROpen as ^#} p' (fromEnumC m) nullPtr)
  newDataSourceHandle ptr `catch` (\NullDataSource ->
    throwM (GDALException CE_Failure OpenFailed "OGROpen returned a NULL ptr"))

newDataSourceHandle :: DataSourceH -> GDAL s (DataSource s t)
newDataSourceHandle p
  | p==nullDataSourceH = throwBindingException NullDataSource
  | otherwise          = do
      registerFinalizer (void ({#call unsafe ReleaseDataSource as ^#} p))
      m <- liftIO newMutex
      return $ DataSource (m,p)

type Driver = String

create :: Driver -> String -> OptionList -> GDAL s (RWDataSource s)
create driverName name options = newDataSourceHandle <=<
  liftIO $ throwIfError "create" $ do
    pDr <- driverByName driverName
    withCString name $ \pName ->
      withOptionList options $ {#call OGR_Dr_CreateDataSource as ^#} pDr pName

createMem :: OptionList -> GDAL s (RWDataSource s)
createMem = create "Memory" ""

driverByName :: String -> IO DriverH
driverByName name = withCString name $ \pName -> do
  drv <- {#call unsafe GetDriverByName as ^#} pName
  if drv == nullDriverH
    then throwBindingException (UnknownDriver name)
    else return drv

{#enum define ApproxOK
  { TRUE as ApproxOK
  , FALSE as StrictOK
  } deriving (Eq, Show) #}

createLayer
  :: RWDataSource s -> FeatureDef -> ApproxOK -> OptionList
  -> GDAL s (RWLayer s a)
createLayer ds FeatureDef{..} approxOk options = liftIO $
  useAsEncodedCString fdName $ \pName ->
  withMaybeSpatialReference (gfdSrs fdGeom) $ \pSrs ->
  withOptionList extendedOptions $ \pOpts ->
  throwIfError "createLayer" $ do
    fpL <- {#call OGR_DS_CreateLayer as ^#} pDs pName pSrs gType pOpts >>=
              newLayerHandle ds NullLayer
    withLockedLayerPtr fpL $ \pL -> do
      V.forM_ fdFields $ \f -> withFieldDefnH f $ \pFld ->
        {#call unsafe OGR_L_CreateField as ^#} pL pFld iApproxOk
      when (not (V.null fdGeoms)) $
        if supportsMultiGeomFields pL
          then
#if MULTI_GEOM_FIELDS
            V.forM_ fdGeoms $ \f -> withGeomFieldDefnH f $ \pGFld ->
              {#call OGR_L_CreateGeomField as ^#} pL pGFld iApproxOk
#else
            error "should never reach here"
#endif
          else throwBindingException CantCreateMultipleGeomFields
      return fpL
  where
    supportsMultiGeomFields pL =
      layerHasCapability pL CreateGeomField &&
      dataSourceHasCapability pDs CreateGeomFieldAfterCreateLayer
    iApproxOk = fromEnumC approxOk
    pDs   = unDataSource ds
    gType = fromEnumC (gfdType fdGeom)
    extendedOptions
      | gfdName fdGeom /= "" = ("GEOMETRY_NAME", gfdName fdGeom):options
      | otherwise            = options

canCreateMultipleGeometryFields :: Bool
canCreateMultipleGeometryFields =
#if MULTI_GEOM_FIELDS
  True
#else
  False
#endif

getLayer :: Int -> DataSource s t -> GDAL s (Layer s t a)
getLayer layer ds = liftIO $
  newLayerHandle ds (InvalidLayerIndex layer) <=<
    throwIfError "getLayer" $ {#call OGR_DS_GetLayer as ^#} dsH lyr
  where
    dsH = unDataSource ds
    lyr = fromIntegral layer

getLayerByName :: Text -> DataSource s t -> GDAL s (Layer s t a)
getLayerByName layer ds = liftIO $ useAsEncodedCString layer $
  newLayerHandle ds (InvalidLayerName layer) <=<
    throwIfError "getLayerByName" .
      {#call OGR_DS_GetLayerByName as ^#} (unDataSource ds)

-- | GDAL < 1.11 only supports 1 geometry field and associates it the layer
layerGeomFieldDef :: LayerH -> IO GeomFieldDef
layerGeomFieldDef p =
  GeomFieldDef
    <$> ({#call unsafe OGR_L_GetGeometryColumn as ^#} p >>= peekEncodedCString)
    <*> liftM toEnumC ({#call unsafe OGR_L_GetGeomType	as ^#} p)
    <*> ({#call unsafe OGR_L_GetSpatialRef as ^#} p >>=
          maybeNewSpatialRefBorrowedHandle)

newLayerHandle
  :: DataSource s t -> OGRException -> LayerH -> IO (Layer s t a)
newLayerHandle (DataSource (m,_)) exc p
  | p==nullLayerH = throwBindingException exc
  | otherwise     = return (Layer (m,p))

layerCount :: DataSource s t -> GDAL s Int
layerCount = liftM fromIntegral
           . liftIO . {#call unsafe OGR_DS_GetLayerCount as ^#} . unDataSource

datasourceName :: DataSource s t -> GDAL s String
datasourceName =
  liftIO . (peekCString <=< {#call unsafe OGR_DS_GetName as ^#} . unDataSource)

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 -> Text -> Maybe Geometry -> RODataSource s
  -> GDAL s (ROLayer s a)
executeSQL dialect query mSpatialFilter ds@(DataSource (m,dsP)) = do
  p <- catchJust selectExc execute (throwBindingException . SQLQueryError)
  when (p==nullLayerH) $ throwBindingException NullLayer
  registerFinalizer ({#call unsafe OGR_DS_ReleaseResultSet as ^#} dsP p)
  return (Layer (m, p))
  where
    selectExc GDALException{..} | gdalErrNum==AppDefined = Just gdalErrMsg
    selectExc _                                          = Nothing
    execute = liftIO $
      throwIfError "executeSQL" $
      withLockedDataSourcePtr ds $ \dsPtr ->
      withMaybeGeometry mSpatialFilter $ \sFilter ->
      withSQLDialect dialect $ \sDialect ->
      useAsEncodedCString query $ \sQuery ->
        {#call OGR_DS_ExecuteSQL as ^#} dsPtr sQuery sFilter sDialect

layerName :: Layer s t a -> GDAL s Text
layerName =
  liftIO . (peekEncodedCString <=< {#call unsafe OGR_L_GetName as ^#} . unLayer)

layerFeatureDef :: Layer s t a -> GDAL s FeatureDef
layerFeatureDef l = liftIO $ do
  let pL = unLayer l
  gfd <- layerGeomFieldDef pL
  featureDefFromHandle gfd =<< {#call unsafe OGR_L_GetLayerDefn as ^#} pL

getSpatialFilter :: Layer s t a -> GDAL s (Maybe Geometry)
getSpatialFilter l = liftIO $ withLockedLayerPtr l $ \lPtr -> do
  p <- {#call unsafe OGR_L_GetSpatialFilter as ^#} lPtr
  if p == nullPtr
    then return Nothing
    else liftM Just (cloneGeometry p)

setSpatialFilter :: Layer s t a -> Geometry -> GDAL s ()
setSpatialFilter l g = liftIO $
  withLockedLayerPtr l $ \lPtr -> withGeometry g$ \gPtr ->
    {#call unsafe OGR_L_SetSpatialFilter as ^#} lPtr gPtr

data LayerCapability
  = RandomRead
  | SequentialWrite
  | RandomWrite
  | FastSpatialFilter
  | FastFeatureCount
  | FastGetExtent
  | CreateField
  | DeleteField
  | ReorderFields
  | AlterFieldDefn
  | Transactions
  | DeleteFeature
  | FastSetNextByIndex
  | StringsAsUTF8
  | IgnoreFields
  | CreateGeomField
  deriving (Eq, Show, Enum, Bounded)

layerHasCapability :: LayerH -> LayerCapability -> Bool
layerHasCapability l c = unsafePerformIO $ do
  withCString (show c)
    (liftM toBool . {#call unsafe OGR_L_TestCapability as ^#} l)

data DataSourceCapability
  = CreateLayer
  | DeleteLayer
  | CreateGeomFieldAfterCreateLayer
  deriving (Eq, Show, Enum, Bounded)

dataSourceHasCapability :: DataSourceH -> DataSourceCapability -> Bool
dataSourceHasCapability d c = unsafePerformIO $ do
  withCString (show c)
    (liftM toBool . {#call unsafe OGR_DS_TestCapability as ^#} d)

data DriverCapability
  = CreateDataSource
  | DeleteDataSource
  deriving (Eq, Show, Enum, Bounded)

driverHasCapability :: DriverH -> DriverCapability -> Bool
driverHasCapability d c = unsafePerformIO $ do
  withCString (show c)
    (liftM toBool . {#call unsafe OGR_Dr_TestCapability as ^#} d)

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

#include "bindings.h"

module GDAL.Internal.OGR (
    DataSource
  , DataSourceH
  , SQLDialect (..)
  , ApproxOK (..)
  , Layer
  , LayerH (..)
  , RODataSource
  , RWDataSource
  , ROLayer
  , RWLayer
  , Driver

  , openReadOnly
  , openReadWrite
  , create
  , createMem
  , canCreateMultipleGeometryFields

  , datasourceName
  , executeSQL

  , createLayer
  , getLayer
  , getLayerByName

  , getSpatialFilter
  , setSpatialFilter

  , layerCount
  , layerName
  , layerFeatureDef

  , registerAll
  , cleanupAll

  , withLockedLayerPtr
  , withLockedLayerPtrs
  , unDataSource
  , unLayer
  , withLockedDataSourcePtr
) where

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

import Data.Text (Text)
import qualified Data.Vector as V

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

import Foreign.C.String (CString, peekCString, withCString)
import Foreign.C.Types (CInt(..), CChar(..))
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.Marshal.Utils (toBool)

import Foreign.Storable (Storable)

import System.IO.Unsafe (unsafePerformIO)

{#import GDAL.Internal.OSR#}
{#import GDAL.Internal.OGRGeometry#}
{#import GDAL.Internal.OGRFeature#}
{#import GDAL.Internal.OGRError#}
{#import GDAL.Internal.CPLString#}
import GDAL.Internal.CPLError hiding (None)
import GDAL.Internal.CPLConv (cplFree)
import GDAL.Internal.Util
import GDAL.Internal.Types

#include "ogr_api.h"

{#fun RegisterAll as ^ {} -> `()'  #}
{#fun CleanupAll  as ^ {} -> `()'  #}

{#pointer OGRSFDriverH as DriverH newtype#}
deriving instance Eq DriverH

nullDriverH :: DriverH
nullDriverH = DriverH nullPtr

{#pointer DataSourceH newtype#}
newtype DataSource s (t::AccessMode) = DataSource (Mutex, DataSourceH)

deriving instance Eq DataSourceH

nullDataSourceH :: DataSourceH
nullDataSourceH = DataSourceH nullPtr

unDataSource :: DataSource s t -> DataSourceH
unDataSource (DataSource (_,p)) = p

type RODataSource s = DataSource s ReadOnly
type RWDataSource s = DataSource s ReadWrite

withLockedDataSourcePtr
  :: DataSource s t -> (DataSourceH -> IO b) -> IO b
withLockedDataSourcePtr (DataSource (m,p)) f = withMutex m (f p)

{#pointer LayerH newtype#}

deriving instance Storable LayerH
deriving instance Eq LayerH

nullLayerH :: LayerH
nullLayerH = LayerH nullPtr

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

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

lMutex :: Layer s t a -> Mutex
lMutex (Layer (m,_)) = m

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

withLockedLayerPtrs
  :: [Layer s t a] -> ([LayerH] -> IO b) -> IO b
withLockedLayerPtrs ls f
  = withMutexes (map lMutex ls) (f (map unLayer ls))

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

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

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

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

openWithMode :: OGRAccess -> String -> GDAL s (DataSource s t)
openWithMode m p = do
  ptr <- liftIO $ withCString p $ \p' ->
           throwIfError "open" ({#call OGROpen as ^#} p' (fromEnumC m) nullPtr)
  newDataSourceHandle ptr `catch` (\NullDataSource ->
    throwM (GDALException CE_Failure OpenFailed "OGROpen returned a NULL ptr"))

newDataSourceHandle :: DataSourceH -> GDAL s (DataSource s t)
newDataSourceHandle p
  | p==nullDataSourceH = throwBindingException NullDataSource
  | otherwise          = do
      registerFinalizer (void ({#call unsafe ReleaseDataSource as ^#} p))
      m <- liftIO newMutex
      return $ DataSource (m,p)

type Driver = String

create :: Driver -> String -> OptionList -> GDAL s (RWDataSource s)
create driverName name options = newDataSourceHandle <=<
  liftIO $ throwIfError "create" $ do
    pDr <- driverByName driverName
    withCString name $ \pName ->
      withOptionList options $ {#call OGR_Dr_CreateDataSource as ^#} pDr pName

createMem :: OptionList -> GDAL s (RWDataSource s)
createMem = create "Memory" ""

driverByName :: String -> IO DriverH
driverByName name = withCString name $ \pName -> do
  drv <- {#call unsafe GetDriverByName as ^#} pName
  if drv == nullDriverH
    then throwBindingException (UnknownDriver name)
    else return drv

{#enum define ApproxOK
  { TRUE as ApproxOK
  , FALSE as StrictOK
  } deriving (Eq, Show) #}

createLayer
  :: RWDataSource s -> FeatureDef -> ApproxOK -> OptionList
  -> GDAL s (RWLayer s a)
createLayer ds FeatureDef{..} approxOk options = liftIO $
  useAsEncodedCString fdName $ \pName ->
  withMaybeSpatialReference (gfdSrs fdGeom) $ \pSrs ->
  withOptionList extendedOptions $ \pOpts ->
  throwIfError "createLayer" $ do
    fpL <- {#call OGR_DS_CreateLayer as ^#} pDs pName pSrs gType pOpts >>=
              newLayerHandle ds NullLayer
    withLockedLayerPtr fpL $ \pL -> do
      V.forM_ fdFields $ \f -> withFieldDefnH f $ \pFld ->
        {#call unsafe OGR_L_CreateField as ^#} pL pFld iApproxOk
      when (not (V.null fdGeoms)) $
        if supportsMultiGeomFields pL
          then
#if MULTI_GEOM_FIELDS
            V.forM_ fdGeoms $ \f -> withGeomFieldDefnH f $ \pGFld ->
              {#call OGR_L_CreateGeomField as ^#} pL pGFld iApproxOk
#else
            error "should never reach here"
#endif
          else throwBindingException CantCreateMultipleGeomFields
      return fpL
  where
    supportsMultiGeomFields pL =
      layerHasCapability pL CreateGeomField &&
      dataSourceHasCapability pDs CreateGeomFieldAfterCreateLayer
    iApproxOk = fromEnumC approxOk
    pDs   = unDataSource ds
    gType = fromEnumC (gfdType fdGeom)
    extendedOptions
      | gfdName fdGeom /= "" = ("GEOMETRY_NAME", gfdName fdGeom):options
      | otherwise            = options

canCreateMultipleGeometryFields :: Bool
canCreateMultipleGeometryFields =
#if MULTI_GEOM_FIELDS
  True
#else
  False
#endif

getLayer :: Int -> DataSource s t -> GDAL s (Layer s t a)
getLayer layer ds = liftIO $
  newLayerHandle ds (InvalidLayerIndex layer) <=<
    throwIfError "getLayer" $ {#call OGR_DS_GetLayer as ^#} dsH lyr
  where
    dsH = unDataSource ds
    lyr = fromIntegral layer

getLayerByName :: Text -> DataSource s t -> GDAL s (Layer s t a)
getLayerByName layer ds = liftIO $ useAsEncodedCString layer $
  newLayerHandle ds (InvalidLayerName layer) <=<
    throwIfError "getLayerByName" .
      {#call OGR_DS_GetLayerByName as ^#} (unDataSource ds)

-- | GDAL < 1.11 only supports 1 geometry field and associates it the layer
layerGeomFieldDef :: LayerH -> IO GeomFieldDef
layerGeomFieldDef p =
  GeomFieldDef
    <$> ({#call unsafe OGR_L_GetGeometryColumn as ^#} p >>= peekEncodedCString)
    <*> liftM toEnumC ({#call unsafe OGR_L_GetGeomType	as ^#} p)
    <*> ({#call unsafe OGR_L_GetSpatialRef as ^#} p >>=
          maybeNewSpatialRefBorrowedHandle)

newLayerHandle
  :: DataSource s t -> OGRException -> LayerH -> IO (Layer s t a)
newLayerHandle (DataSource (m,_)) exc p
  | p==nullLayerH = throwBindingException exc
  | otherwise     = return (Layer (m,p))

layerCount :: DataSource s t -> GDAL s Int
layerCount = liftM fromIntegral
           . liftIO . {#call unsafe OGR_DS_GetLayerCount as ^#} . unDataSource

datasourceName :: DataSource s t -> GDAL s String
datasourceName =
  liftIO . (peekCString <=< {#call unsafe OGR_DS_GetName as ^#} . unDataSource)

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 -> Text -> Maybe Geometry -> RODataSource s
  -> GDAL s (ROLayer s a)
executeSQL dialect query mSpatialFilter ds@(DataSource (m,dsP)) = do
  p <- catchJust selectExc execute (throwBindingException . SQLQueryError)
  when (p==nullLayerH) $ throwBindingException NullLayer
  registerFinalizer ({#call unsafe OGR_DS_ReleaseResultSet as ^#} dsP p)
  return (Layer (m, p))
  where
    selectExc GDALException{..} | gdalErrNum==AppDefined = Just gdalErrMsg
    selectExc _                                          = Nothing
    execute = liftIO $
      throwIfError "executeSQL" $
      withLockedDataSourcePtr ds $ \dsPtr ->
      withMaybeGeometry mSpatialFilter $ \sFilter ->
      withSQLDialect dialect $ \sDialect ->
      useAsEncodedCString query $ \sQuery ->
        {#call OGR_DS_ExecuteSQL as ^#} dsPtr sQuery sFilter sDialect

layerName :: Layer s t a -> GDAL s Text
layerName =
  liftIO . (peekEncodedCString <=< {#call unsafe OGR_L_GetName as ^#} . unLayer)

layerFeatureDef :: Layer s t a -> GDAL s FeatureDef
layerFeatureDef l = liftIO $ do
  let pL = unLayer l
  gfd <- layerGeomFieldDef pL
  featureDefFromHandle gfd =<< {#call unsafe OGR_L_GetLayerDefn as ^#} pL

getSpatialFilter :: Layer s t a -> GDAL s (Maybe Geometry)
getSpatialFilter l = liftIO $ withLockedLayerPtr l $ \lPtr -> do
  p <- {#call unsafe OGR_L_GetSpatialFilter as ^#} lPtr
  if p == nullPtr
    then return Nothing
    else liftM Just (cloneGeometry p)

setSpatialFilter :: Layer s t a -> Geometry -> GDAL s ()
setSpatialFilter l g = liftIO $
  withLockedLayerPtr l $ \lPtr -> withGeometry g$ \gPtr ->
    {#call unsafe OGR_L_SetSpatialFilter as ^#} lPtr gPtr

data LayerCapability
  = RandomRead
  | SequentialWrite
  | RandomWrite
  | FastSpatialFilter
  | FastFeatureCount
  | FastGetExtent
  | CreateField
  | DeleteField
  | ReorderFields
  | AlterFieldDefn
  | Transactions
  | DeleteFeature
  | FastSetNextByIndex
  | StringsAsUTF8
  | IgnoreFields
  | CreateGeomField
  deriving (Eq, Show, Enum, Bounded)

layerHasCapability :: LayerH -> LayerCapability -> Bool
layerHasCapability l c = unsafePerformIO $ do
  withCString (show c)
    (liftM toBool . {#call unsafe OGR_L_TestCapability as ^#} l)

data DataSourceCapability
  = CreateLayer
  | DeleteLayer
  | CreateGeomFieldAfterCreateLayer
  deriving (Eq, Show, Enum, Bounded)

dataSourceHasCapability :: DataSourceH -> DataSourceCapability -> Bool
dataSourceHasCapability d c = unsafePerformIO $ do
  withCString (show c)
    (liftM toBool . {#call unsafe OGR_DS_TestCapability as ^#} d)

data DriverCapability
  = CreateDataSource
  | DeleteDataSource
  deriving (Eq, Show, Enum, Bounded)

driverHasCapability :: DriverH -> DriverCapability -> Bool
driverHasCapability d c = unsafePerformIO $ do
  withCString (show c)
    (liftM toBool . {#call unsafe OGR_Dr_TestCapability as ^#} d)


occupancy calculator magic values for compute 2.1 devices

Ignore-this: 84ad2a849d2b3ff2942554bea700013f

darcs-hash:20110209211713-dcabc-6577e11113cbe33bc12fa16193ab485f195740e8.gz

--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Analysis.Device
-- Copyright : (c) [2009..2010] Trevor L. McDonell
-- License   : BSD
--
-- Common device functions
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Analysis.Device
  (
    Compute, ComputeMode(..),
    DeviceProperties(..), DeviceResources(..), Allocation(..),
    resources
  )
  where

#include <cuda.h>

import Data.Int
import Data.Maybe

-- |
-- The compute mode the device is currently in
--
{# enum CUcomputemode as ComputeMode
    { underscoreToCase }
    with prefix="CU_COMPUTEMODE" deriving (Eq, Show) #}

-- |
-- GPU compute capability
--
type Compute = Double

-- |
-- The properties of a compute device
--
data DeviceProperties = DeviceProperties
  {
    deviceName               :: String,         -- ^ Identifier
    computeCapability        :: Compute,        -- ^ Supported compute capability
    totalGlobalMem           :: Int64,          -- ^ Available global memory on the device in bytes
    totalConstMem            :: Int64,          -- ^ Available constant memory on the device in bytes
    sharedMemPerBlock        :: Int64,          -- ^ Available shared memory per block in bytes
    regsPerBlock             :: Int,            -- ^ 32-bit registers per block
    warpSize                 :: Int,            -- ^ Warp size in threads (SIMD width)
    maxThreadsPerBlock       :: Int,            -- ^ Max number of threads per block
    maxBlockSize             :: (Int,Int,Int),  -- ^ Max size of each dimension of a block
    maxGridSize              :: (Int,Int,Int),  -- ^ Max size of each dimension of a grid
#if CUDA_VERSION >= 3000
    maxTextureDim1D          :: Int,            -- ^ Maximum texture dimensions
    maxTextureDim2D          :: (Int,Int),
    maxTextureDim3D          :: (Int,Int,Int),
#endif
    clockRate                :: Int,            -- ^ Clock frequency in kilohertz
    multiProcessorCount      :: Int,            -- ^ Number of multiprocessors on the device
    memPitch                 :: Int64,          -- ^ Max pitch in bytes allowed by memory copies
    textureAlignment         :: Int64,          -- ^ Alignment requirement for textures
    computeMode              :: ComputeMode,
    deviceOverlap            :: Bool,           -- ^ Device can concurrently copy memory and execute a kernel
#if CUDA_VERSION >= 3000
    concurrentKernels        :: Bool,           -- ^ Device can possibly execute multiple kernels concurrently
    eccEnabled               :: Bool,           -- ^ Device supports and has enabled error correction
#endif
    kernelExecTimeoutEnabled :: Bool,           -- ^ Whether there is a runtime limit on kernels
    integrated               :: Bool,           -- ^ As opposed to discrete
    canMapHostMemory         :: Bool            -- ^ Device can use pinned memory
  }
  deriving (Show)

-- GPU Hardware Resources
--
data Allocation      = Warp | Block
data DeviceResources = DeviceResources
  {
    threadsPerWarp     :: Int,          -- ^ Warp size
    threadsPerMP       :: Int,          -- ^ Maximum number of in-flight threads on a multiprocessor
    threadBlocksPerMP  :: Int,          -- ^ Maximum number of thread blocks resident on a multiprocessor
    warpsPerMP         :: Int,          -- ^ Maximum number of in-flight warps per multiprocessor
    sharedMemPerMP     :: Int,          -- ^ Total amount of shared memory per multiprocessor (bytes)
    sharedMemAllocUnit :: Int,          -- ^ Shared memory allocation unit size (bytes)
    regFileSize        :: Int,          -- ^ Total number of registers in a multiprocessor
    regAllocUnit       :: Int,          -- ^ Register allocation unit size
    regAllocWarp       :: Int,          -- ^ Register allocation granularity for warps
    allocation         :: Allocation    -- ^ How multiprocessor resources are divided
  }

-- |
-- Extract some additional hardware resource limitations for a given device
-- TLM: default to highest compute capability, when no specific data available?
--
resources :: DeviceProperties -> DeviceResources
resources dev = fromMaybe err (lookup compute gpuData)
  where
    compute = computeCapability dev
    err     = error $  "No data for device: "
                    ++ shows (deviceName dev) " (compute " ++ shows compute ")"

    gpuData =
      [(1.0, DeviceResources 32  768 8 24 16384 512  8192 256 2 Block)
      ,(1.1, DeviceResources 32  768 8 24 16384 512  8192 256 2 Block)
      ,(1.2, DeviceResources 32 1024 8 32 16384 512 16384 512 2 Block)
      ,(1.3, DeviceResources 32 1024 8 32 16384 512 16384 512 2 Block)
      ,(2.0, DeviceResources 32 1536 8 48 49152 128 32768  64 1 Warp)
      ,(2.1, DeviceResources 32 1536 8 48 49152 128 32768  64 1 Warp)
      ]

--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Analysis.Device
-- Copyright : (c) [2009..2010] Trevor L. McDonell
-- License   : BSD
--
-- Common device functions
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Analysis.Device
  (
    Compute, ComputeMode(..),
    DeviceProperties(..), DeviceResources(..), Allocation(..),
    resources
  )
  where

#include <cuda.h>

import Data.Int
import Data.Maybe

-- |
-- The compute mode the device is currently in
--
{# enum CUcomputemode as ComputeMode
    { underscoreToCase }
    with prefix="CU_COMPUTEMODE" deriving (Eq, Show) #}

-- |
-- GPU compute capability
--
type Compute = Double

-- |
-- The properties of a compute device
--
data DeviceProperties = DeviceProperties
  {
    deviceName               :: String,         -- ^ Identifier
    computeCapability        :: Compute,        -- ^ Supported compute capability
    totalGlobalMem           :: Int64,          -- ^ Available global memory on the device in bytes
    totalConstMem            :: Int64,          -- ^ Available constant memory on the device in bytes
    sharedMemPerBlock        :: Int64,          -- ^ Available shared memory per block in bytes
    regsPerBlock             :: Int,            -- ^ 32-bit registers per block
    warpSize                 :: Int,            -- ^ Warp size in threads (SIMD width)
    maxThreadsPerBlock       :: Int,            -- ^ Max number of threads per block
    maxBlockSize             :: (Int,Int,Int),  -- ^ Max size of each dimension of a block
    maxGridSize              :: (Int,Int,Int),  -- ^ Max size of each dimension of a grid
#if CUDA_VERSION >= 3000
    maxTextureDim1D          :: Int,            -- ^ Maximum texture dimensions
    maxTextureDim2D          :: (Int,Int),
    maxTextureDim3D          :: (Int,Int,Int),
#endif
    clockRate                :: Int,            -- ^ Clock frequency in kilohertz
    multiProcessorCount      :: Int,            -- ^ Number of multiprocessors on the device
    memPitch                 :: Int64,          -- ^ Max pitch in bytes allowed by memory copies
    textureAlignment         :: Int64,          -- ^ Alignment requirement for textures
    computeMode              :: ComputeMode,
    deviceOverlap            :: Bool,           -- ^ Device can concurrently copy memory and execute a kernel
#if CUDA_VERSION >= 3000
    concurrentKernels        :: Bool,           -- ^ Device can possibly execute multiple kernels concurrently
    eccEnabled               :: Bool,           -- ^ Device supports and has enabled error correction
#endif
    kernelExecTimeoutEnabled :: Bool,           -- ^ Whether there is a runtime limit on kernels
    integrated               :: Bool,           -- ^ As opposed to discrete
    canMapHostMemory         :: Bool            -- ^ Device can use pinned memory
  }
  deriving (Show)

-- GPU Hardware Resources
--
data Allocation      = Warp | Block
data DeviceResources = DeviceResources
  {
    threadsPerWarp     :: Int,          -- ^ Warp size
    threadsPerMP       :: Int,          -- ^ Maximum number of in-flight threads on a multiprocessor
    threadBlocksPerMP  :: Int,          -- ^ Maximum number of thread blocks resident on a multiprocessor
    warpsPerMP         :: Int,          -- ^ Maximum number of in-flight warps per multiprocessor
    sharedMemPerMP     :: Int,          -- ^ Total amount of shared memory per multiprocessor (bytes)
    sharedMemAllocUnit :: Int,          -- ^ Shared memory allocation unit size (bytes)
    regFileSize        :: Int,          -- ^ Total number of registers in a multiprocessor
    regAllocUnit       :: Int,          -- ^ Register allocation unit size
    regAllocWarp       :: Int,          -- ^ Register allocation granularity for warps
    allocation         :: Allocation    -- ^ How multiprocessor resources are divided
  }

-- |
-- Extract some additional hardware resource limitations for a given device
--
resources :: DeviceProperties -> DeviceResources
resources dev = fromMaybe err (lookup compute gpuData)
  where
    compute = computeCapability dev
    err     = error $  "No data for device: "
                    ++ shows (deviceName dev) " (compute " ++ shows compute ")"

    gpuData =
      [(1.0, DeviceResources 32  768 8 24 16384 512  8192 256 2 Block)
      ,(1.1, DeviceResources 32  768 8 24 16384 512  8192 256 2 Block)
      ,(1.2, DeviceResources 32 1024 8 32 16384 512 16384 512 2 Block)
      ,(1.3, DeviceResources 32 1024 8 32 16384 512 16384 512 2 Block)
      ,(2.0, DeviceResources 32 1536 8 48 49152 128 32768  64 1 Warp)
      ]


Don't bind attributes we don't understand.

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GValueTypes
--
--  Author : Axel Simon
--
--  Created: 1 June 2001
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- This is used by the implementation of properties and by the
-- 'Graphics.UI.Gtk.TreeList.TreeModel' and
-- related modules.
--
module System.Glib.GValueTypes (
  valueSetUInt,
  valueGetUInt,
  valueSetInt,
  valueGetInt,
  valueSetUInt64,
  valueGetUInt64,
  valueSetInt64,
  valueGetInt64,
  valueSetBool,
  valueGetBool,
  valueSetPointer,
  valueGetPointer,
  valueSetFloat,
  valueGetFloat,
  valueSetDouble,
  valueGetDouble,
  valueSetEnum,
  valueGetEnum,
  valueSetFlags,
  valueGetFlags,
  valueSetString,
  valueGetString,
  valueSetMaybeString,
  valueGetMaybeString,
  valueSetBoxed,
  valueGetBoxed,
  valueSetGObject,
  valueGetGObject,
  valueSetMaybeGObject,
  valueGetMaybeGObject,
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.Flags
import System.Glib.UTFString
{#import System.Glib.GValue#}		(GValue(GValue))
import System.Glib.GObject

{# context lib="glib" prefix="g" #}

valueSetUInt :: GValue -> Word -> IO ()
valueSetUInt gvalue value =
  {# call unsafe value_set_uint #} gvalue (fromIntegral value)

valueGetUInt :: GValue -> IO Word
valueGetUInt gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_uint #} gvalue

valueSetInt :: GValue -> Int -> IO ()
valueSetInt gvalue value =
  {# call unsafe value_set_int #} gvalue (fromIntegral value)

valueGetInt :: GValue -> IO Int
valueGetInt gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_int #} gvalue

valueSetUInt64 :: GValue -> Word64 -> IO ()
valueSetUInt64 gvalue value =
  {# call unsafe value_set_uint64 #} gvalue (fromIntegral value)

valueGetUInt64 :: GValue -> IO Word64
valueGetUInt64 gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_uint64 #} gvalue

valueSetInt64 :: GValue -> Int64 -> IO ()
valueSetInt64 gvalue value =
  {# call unsafe value_set_int64 #} gvalue (fromIntegral value)

valueGetInt64 :: GValue -> IO Int64
valueGetInt64 gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_int64 #} gvalue

valueSetBool :: GValue -> Bool -> IO ()
valueSetBool gvalue value =
  {# call unsafe value_set_boolean #} gvalue (fromBool value)

valueGetBool :: GValue -> IO Bool
valueGetBool gvalue =
  liftM toBool $
  {# call  unsafe value_get_boolean #} gvalue

-- These functions should probably never be used as they are dangerous.
--
valueSetPointer :: GValue -> (Ptr ()) -> IO ()
valueSetPointer gvalue value =
  {# call unsafe value_set_pointer #} gvalue value

valueGetPointer :: GValue -> IO (Ptr ())
valueGetPointer gvalue =
  {# call unsafe value_get_pointer #} gvalue

valueSetFloat :: GValue -> Float -> IO ()
valueSetFloat gvalue value =
  {# call unsafe value_set_float #} gvalue (realToFrac value)

valueGetFloat :: GValue -> IO Float
valueGetFloat gvalue =
  liftM realToFrac $
  {# call unsafe value_get_float #} gvalue

valueSetDouble :: GValue -> Double -> IO ()
valueSetDouble gvalue value =
  {# call unsafe value_set_double #} gvalue (realToFrac value)

valueGetDouble :: GValue -> IO Double
valueGetDouble gvalue =
  liftM realToFrac $
  {# call unsafe value_get_double #} gvalue

valueSetEnum :: Enum enum => GValue -> enum -> IO ()
valueSetEnum gvalue value =
  {# call unsafe value_set_enum #} gvalue (fromIntegral $ fromEnum value)

valueGetEnum :: Enum enum => GValue -> IO enum
valueGetEnum gvalue =
  liftM (toEnum . fromIntegral) $
  {# call unsafe value_get_enum #} gvalue

valueSetFlags :: Flags flag => GValue -> [flag] -> IO ()
valueSetFlags gvalue value =
  {# call unsafe value_set_flags #} gvalue (fromIntegral $ fromFlags value)

valueGetFlags :: Flags flag => GValue -> IO [flag]
valueGetFlags gvalue =
  liftM (toFlags . fromIntegral) $
  {# call unsafe value_get_flags #} gvalue

valueSetString :: GValue -> String -> IO ()
valueSetString gvalue str =
  withUTFString str $ \strPtr ->
  {# call unsafe value_set_string #} gvalue strPtr

valueGetString :: GValue -> IO String
valueGetString gvalue = do
  strPtr <- {# call unsafe value_get_string #} gvalue
  if strPtr == nullPtr
    then return ""
    else peekUTFString strPtr

valueSetMaybeString :: GValue -> Maybe String -> IO ()
valueSetMaybeString gvalue (Just str) =
  withUTFString str $ \strPtr ->
  {# call unsafe value_set_string #} gvalue strPtr

valueSetMaybeString gvalue Nothing =
  {# call unsafe value_set_static_string #} gvalue nullPtr

valueGetMaybeString :: GValue -> IO (Maybe String)
valueGetMaybeString gvalue =
  {# call unsafe value_get_string #} gvalue
  >>= maybePeek peekUTFString

valueSetBoxed :: (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GValue -> boxed -> IO ()
valueSetBoxed with gvalue boxed =
  with boxed $ \boxedPtr -> do
  {# call unsafe g_value_set_boxed #} gvalue (castPtr boxedPtr)

valueGetBoxed :: (Ptr boxed -> IO boxed) -> GValue -> IO boxed
valueGetBoxed peek gvalue =
  {# call unsafe g_value_get_boxed #} gvalue >>= peek . castPtr

-- for some weird reason the API says that gv is a gpointer, not a GObject
--
valueSetGObject :: GObjectClass gobj => GValue -> gobj -> IO ()
valueSetGObject gvalue obj =
  withForeignPtr ((unGObject.toGObject) obj) $ \objPtr ->
    {# call unsafe g_value_set_object #} gvalue (castPtr objPtr)

-- Unsafe because it performs an unchecked downcast. Only for internal use.
--
valueGetGObject :: GObjectClass gobj => GValue -> IO gobj
valueGetGObject gvalue =
  liftM unsafeCastGObject $
  makeNewGObject mkGObject $
  throwIfNull "GValue.valueGetObject: extracting invalid object" $
  liftM castPtr $
  {# call unsafe value_get_object #} gvalue

valueSetMaybeGObject :: GObjectClass gobj => GValue -> (Maybe gobj) -> IO ()
valueSetMaybeGObject gvalue (Just obj) = valueSetGObject gvalue obj
valueSetMaybeGObject gvalue Nothing =
    {# call unsafe g_value_set_object #} gvalue nullPtr

valueGetMaybeGObject :: GObjectClass gobj => GValue -> IO (Maybe gobj)
valueGetMaybeGObject gvalue =
  liftM (liftM unsafeCastGObject) $
  maybeNull (makeNewGObject mkGObject) $
  liftM castPtr $
  {# call unsafe value_get_object #} gvalue

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GValueTypes
--
--  Author : Axel Simon
--
--  Created: 1 June 2001
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- This is used by the implementation of properties and by the
-- 'Graphics.UI.Gtk.TreeList.TreeModel' and
-- related modules.
--
module System.Glib.GValueTypes (
  valueSetUInt,
  valueGetUInt,
  valueSetInt,
  valueGetInt,
  valueSetUInt64,
  valueGetUInt64,
  valueSetInt64,
  valueGetInt64,
  valueSetUChar,
  valueGetUChar,
  valueSetChar,
  valueGetChar,
  valueSetBool,
  valueGetBool,
  valueSetPointer,
  valueGetPointer,
  valueSetFloat,
  valueGetFloat,
  valueSetDouble,
  valueGetDouble,
  valueSetEnum,
  valueGetEnum,
  valueSetFlags,
  valueGetFlags,
  valueSetString,
  valueGetString,
  valueSetMaybeString,
  valueGetMaybeString,
  valueSetBoxed,
  valueGetBoxed,
  valueSetGObject,
  valueGetGObject,
  valueSetMaybeGObject,
  valueGetMaybeGObject,
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.Flags
import System.Glib.UTFString
{#import System.Glib.GValue#}		(GValue(GValue))
import System.Glib.GObject

{# context lib="glib" prefix="g" #}

valueSetUInt :: GValue -> Word -> IO ()
valueSetUInt gvalue value =
  {# call unsafe value_set_uint #} gvalue (fromIntegral value)

valueGetUInt :: GValue -> IO Word
valueGetUInt gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_uint #} gvalue

valueSetInt :: GValue -> Int -> IO ()
valueSetInt gvalue value =
  {# call unsafe value_set_int #} gvalue (fromIntegral value)

valueGetInt :: GValue -> IO Int
valueGetInt gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_int #} gvalue

valueSetUInt64 :: GValue -> Word64 -> IO ()
valueSetUInt64 gvalue value =
  {# call unsafe value_set_uint64 #} gvalue (fromIntegral value)

valueGetUInt64 :: GValue -> IO Word64
valueGetUInt64 gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_uint64 #} gvalue

valueSetInt64 :: GValue -> Int64 -> IO ()
valueSetInt64 gvalue value =
  {# call unsafe value_set_int64 #} gvalue (fromIntegral value)

valueGetInt64 :: GValue -> IO Int64
valueGetInt64 gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_int64 #} gvalue

valueSetUChar :: GValue -> Word8 -> IO ()
valueSetUChar gvalue value =
  {# call unsafe value_set_uchar #} gvalue (fromIntegral value)

valueGetUChar :: GValue -> IO Word8
valueGetUChar gvalue =
  liftM fromIntegral $ {# call unsafe value_get_uchar #} gvalue

--these belong somewhere else, are in new c2hs's C2HS module
cToEnum :: (Integral i, Enum e) => i -> e
cToEnum  = toEnum . fromIntegral

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

--valueSetChar :: GValue -> {#type gchar#} -> IO ()
valueSetChar :: GValue -> Char -> IO ()
valueSetChar gvalue value =
  {# call unsafe value_set_char #} gvalue (cFromEnum value)

--valueGetChar :: GValue -> IO {#type gchar#}
valueGetChar :: GValue -> IO Char
valueGetChar gvalue =
  liftM cToEnum $ {# call unsafe value_get_char #} gvalue

valueSetBool :: GValue -> Bool -> IO ()
valueSetBool gvalue value =
  {# call unsafe value_set_boolean #} gvalue (fromBool value)

valueGetBool :: GValue -> IO Bool
valueGetBool gvalue =
  liftM toBool $
  {# call  unsafe value_get_boolean #} gvalue

-- These functions should probably never be used as they are dangerous.
--
valueSetPointer :: GValue -> (Ptr ()) -> IO ()
valueSetPointer gvalue value =
  {# call unsafe value_set_pointer #} gvalue value

valueGetPointer :: GValue -> IO (Ptr ())
valueGetPointer gvalue =
  {# call unsafe value_get_pointer #} gvalue

valueSetFloat :: GValue -> Float -> IO ()
valueSetFloat gvalue value =
  {# call unsafe value_set_float #} gvalue (realToFrac value)

valueGetFloat :: GValue -> IO Float
valueGetFloat gvalue =
  liftM realToFrac $
  {# call unsafe value_get_float #} gvalue

valueSetDouble :: GValue -> Double -> IO ()
valueSetDouble gvalue value =
  {# call unsafe value_set_double #} gvalue (realToFrac value)

valueGetDouble :: GValue -> IO Double
valueGetDouble gvalue =
  liftM realToFrac $
  {# call unsafe value_get_double #} gvalue

valueSetEnum :: Enum enum => GValue -> enum -> IO ()
valueSetEnum gvalue value =
  {# call unsafe value_set_enum #} gvalue (fromIntegral $ fromEnum value)

valueGetEnum :: Enum enum => GValue -> IO enum
valueGetEnum gvalue =
  liftM (toEnum . fromIntegral) $
  {# call unsafe value_get_enum #} gvalue

valueSetFlags :: Flags flag => GValue -> [flag] -> IO ()
valueSetFlags gvalue value =
  {# call unsafe value_set_flags #} gvalue (fromIntegral $ fromFlags value)

valueGetFlags :: Flags flag => GValue -> IO [flag]
valueGetFlags gvalue =
  liftM (toFlags . fromIntegral) $
  {# call unsafe value_get_flags #} gvalue

valueSetString :: GValue -> String -> IO ()
valueSetString gvalue str =
  withUTFString str $ \strPtr ->
  {# call unsafe value_set_string #} gvalue strPtr

valueGetString :: GValue -> IO String
valueGetString gvalue = do
  strPtr <- {# call unsafe value_get_string #} gvalue
  if strPtr == nullPtr
    then return ""
    else peekUTFString strPtr

valueSetMaybeString :: GValue -> Maybe String -> IO ()
valueSetMaybeString gvalue (Just str) =
  withUTFString str $ \strPtr ->
  {# call unsafe value_set_string #} gvalue strPtr

valueSetMaybeString gvalue Nothing =
  {# call unsafe value_set_static_string #} gvalue nullPtr

valueGetMaybeString :: GValue -> IO (Maybe String)
valueGetMaybeString gvalue =
  {# call unsafe value_get_string #} gvalue
  >>= maybePeek peekUTFString

valueSetBoxed :: (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GValue -> boxed -> IO ()
valueSetBoxed with gvalue boxed =
  with boxed $ \boxedPtr -> do
  {# call unsafe g_value_set_boxed #} gvalue (castPtr boxedPtr)

valueGetBoxed :: (Ptr boxed -> IO boxed) -> GValue -> IO boxed
valueGetBoxed peek gvalue =
  {# call unsafe g_value_get_boxed #} gvalue >>= peek . castPtr

-- for some weird reason the API says that gv is a gpointer, not a GObject
--
valueSetGObject :: GObjectClass gobj => GValue -> gobj -> IO ()
valueSetGObject gvalue obj =
  withForeignPtr ((unGObject.toGObject) obj) $ \objPtr ->
    {# call unsafe g_value_set_object #} gvalue (castPtr objPtr)

-- Unsafe because it performs an unchecked downcast. Only for internal use.
--
valueGetGObject :: GObjectClass gobj => GValue -> IO gobj
valueGetGObject gvalue =
  liftM unsafeCastGObject $
  makeNewGObject mkGObject $
  throwIfNull "GValue.valueGetObject: extracting invalid object" $
  liftM castPtr $
  {# call unsafe value_get_object #} gvalue

valueSetMaybeGObject :: GObjectClass gobj => GValue -> (Maybe gobj) -> IO ()
valueSetMaybeGObject gvalue (Just obj) = valueSetGObject gvalue obj
valueSetMaybeGObject gvalue Nothing =
    {# call unsafe g_value_set_object #} gvalue nullPtr

valueGetMaybeGObject :: GObjectClass gobj => GValue -> IO (Maybe gobj)
valueGetMaybeGObject gvalue =
  liftM (liftM unsafeCastGObject) $
  maybeNull (makeNewGObject mkGObject) $
  liftM castPtr $
  {# call unsafe value_get_object #} gvalue