add enqueue kernels

add enqueue kernels

-- -----------------------------------------------------------------------------
-- This file is part of Haskell-Opencl.

-- Haskell-Opencl is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.

-- Haskell-Opencl is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.

-- You should have received a copy of the GNU General Public License
-- along with Haskell-Opencl.  If not, see <http://www.gnu.org/licenses/>.
-- -----------------------------------------------------------------------------
{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}
module System.GPU.OpenCL.CommandQueue(
  -- * Types
  CLCommandQueue, CLCommandQueueProperty(..),
  -- * Command Queue Functions
  clCreateCommandQueue, clRetainCommandQueue, clReleaseCommandQueue,
  clGetCommandQueueContext, clGetCommandQueueDevice,
  clGetCommandQueueReferenceCount, clGetCommandQueueProperties,
  clSetCommandQueueProperty,
  -- * Memory Commands
  clEnqueueReadBuffer, clEnqueueWriteBuffer,
  -- * Executing Kernels
  clEnqueueNDRangeKernel, clEnqueueTask,
  -- * Flush and Finish
  clFlush, clFinish
  ) where

-- -----------------------------------------------------------------------------
import Foreign
import Foreign.C.Types
import System.GPU.OpenCL.Types(
  CLint, CLbool, CLuint, CLCommandQueueProperty_, CLCommandQueueInfo_,
  CLError(..), CLCommandQueue, CLDeviceID, CLContext, CLCommandQueueProperty(..),
  CLEvent, CLMem, ErrorCode(..), CLKernel,
  wrapCheckSuccess, wrapPError, wrapGetInfo, getCLValue,
  bitmaskToCommandQueueProperties, bitmaskFromFlags, clSuccess )

#include <CL/cl.h>

-- -----------------------------------------------------------------------------
foreign import ccall "clCreateCommandQueue" raw_clCreateCommandQueue ::
  CLContext -> CLDeviceID -> CLCommandQueueProperty_ -> Ptr CLint -> IO CLCommandQueue
foreign import ccall "clRetainCommandQueue" raw_clRetainCommandQueue ::
  CLCommandQueue -> IO CLint
foreign import ccall "clReleaseCommandQueue" raw_clReleaseCommandQueue ::
  CLCommandQueue -> IO CLint
foreign import ccall "clGetCommandQueueInfo" raw_clGetCommandQueueInfo ::
  CLCommandQueue -> CLCommandQueueInfo_ -> CSize -> Ptr () -> Ptr CSize -> IO CLint
foreign import ccall "clSetCommandQueueProperty" raw_clSetCommandQueueProperty ::
  CLCommandQueue -> CLCommandQueueProperty_ -> CLbool -> Ptr CLCommandQueueProperty_ -> IO CLint
foreign import ccall "clEnqueueReadBuffer" raw_clEnqueueReadBuffer ::
  CLCommandQueue -> CLMem -> CLbool -> CSize -> CSize -> Ptr () -> CLuint -> Ptr CLEvent -> Ptr CLEvent -> IO CLint
foreign import ccall "clEnqueueWriteBuffer" raw_clEnqueueWriteBuffer ::
  CLCommandQueue -> CLMem -> CLbool -> CSize -> CSize -> Ptr () -> CLuint -> Ptr CLEvent -> Ptr CLEvent -> IO CLint
foreign import ccall "clEnqueueNDRangeKernel" raw_clEnqueueNDRangeKernel ::
  CLCommandQueue -> CLKernel -> CLuint -> Ptr CSize -> Ptr CSize -> Ptr CSize -> CLuint -> Ptr CLEvent -> Ptr CLEvent -> IO CLint
foreign import ccall "clEnqueueTask" raw_clEnqueueTask ::
  CLCommandQueue -> CLKernel -> CLuint -> Ptr CLEvent -> Ptr CLEvent -> IO CLint
foreign import ccall "clFlush" raw_clFlush ::
  CLCommandQueue -> IO CLint
foreign import ccall "clFinish" raw_clFinish ::
  CLCommandQueue -> IO CLint

-- -----------------------------------------------------------------------------
{-| Create a command-queue on a specific device.

The OpenCL functions that are submitted to a command-queue are enqueued in the
order the calls are made but can be configured to execute in-order or
out-of-order. The properties argument in clCreateCommandQueue can be used to
specify the execution order.

If the 'CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE' property of a command-queue is
not set, the commands enqueued to a command-queue execute in order. For example,
if an application calls 'clEnqueueNDRangeKernel' to execute kernel A followed by
a 'clEnqueueNDRangeKernel' to execute kernel B, the application can assume that
kernel A finishes first and then kernel B is executed. If the memory objects
output by kernel A are inputs to kernel B then kernel B will see the correct
data in memory objects produced by execution of kernel A. If the
'CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE' property of a commandqueue is set, then
there is no guarantee that kernel A will finish before kernel B starts execution.

Applications can configure the commands enqueued to a command-queue to execute
out-of-order by setting the 'CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE' property of
the command-queue. This can be specified when the command-queue is created or
can be changed dynamically using 'clCreateCommandQueue'. In out-of-order
execution mode there is no guarantee that the enqueued commands will finish
execution in the order they were queued. As there is no guarantee that kernels
will be executed in order, i.e. based on when the 'clEnqueueNDRangeKernel' calls
are made within a command-queue, it is therefore possible that an earlier
'clEnqueueNDRangeKernel' call to execute kernel A identified by event A may
execute and/or finish later than a 'clEnqueueNDRangeKernel' call to execute
kernel B which was called by the application at a later point in time. To
guarantee a specific order of execution of kernels, a wait on a particular event
(in this case event A) can be used. The wait for event A can be specified in the
event_wait_list argument to 'clEnqueueNDRangeKernel' for kernel B.

In addition, a wait for events or a barrier command can be enqueued to the
command-queue. The wait for events command ensures that previously enqueued
commands identified by the list of events to wait for have finished before the
next batch of commands is executed. The barrier command ensures that all
previously enqueued commands in a command-queue have finished execution before
the next batch of commands is executed.

Similarly, commands to read, write, copy or map memory objects that are enqueued
after 'clEnqueueNDRangeKernel', 'clEnqueueTask' or 'clEnqueueNativeKernel'
commands are not guaranteed to wait for kernels scheduled for execution to have
completed (if the 'CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE' property is set). To
ensure correct ordering of commands, the event object returned by
'clEnqueueNDRangeKernel', 'clEnqueueTask' or 'clEnqueueNativeKernel' can be
used to enqueue a wait for event or a barrier command can be enqueued that must
complete before reads or writes to the memory object(s) occur.
-}
clCreateCommandQueue :: CLContext -> CLDeviceID -> [CLCommandQueueProperty]
                     -> IO (Either CLError CLCommandQueue)
clCreateCommandQueue ctx did xs = wrapPError $ \perr -> do
  raw_clCreateCommandQueue ctx did props perr
    where
      props = bitmaskFromFlags xs

-- | Increments the command_queue reference count.
-- 'clCreateCommandQueue' performs an implicit retain. This is very helpful for
-- 3rd party libraries, which typically get a command-queue passed to them by
-- the application. However, it is possible that the application may delete the
-- command-queue without informing the library. Allowing functions to attach to
-- (i.e. retain) and release a command-queue solves the problem of a
-- command-queue being used by a library no longer being valid.
-- Returns 'True' if the function is executed successfully. It returns 'False'
-- if command_queue is not a valid command-queue.
clRetainCommandQueue :: CLCommandQueue -> IO Bool
clRetainCommandQueue = wrapCheckSuccess . raw_clRetainCommandQueue

-- | Decrements the command_queue reference count.
-- After the command_queue reference count becomes zero and all commands queued
-- to command_queue have finished (e.g., kernel executions, memory object
-- updates, etc.), the command-queue is deleted.
-- Returns 'True' if the function is executed successfully. It returns 'False'
-- if command_queue is not a valid command-queue.
clReleaseCommandQueue :: CLCommandQueue -> IO Bool
clReleaseCommandQueue = wrapCheckSuccess . raw_clReleaseCommandQueue

#c
enum CLCommandQueueInfo {
  cL_QUEUE_CONTEXT=CL_QUEUE_CONTEXT,
  cL_QUEUE_DEVICE=CL_QUEUE_DEVICE,
  cL_QUEUE_REFERENCE_COUNT=CL_QUEUE_REFERENCE_COUNT,
  cL_QUEUE_PROPERTIES=CL_QUEUE_PROPERTIES,
  };
#endc
{#enum CLCommandQueueInfo {upcaseFirstLetter} #}

-- | Return the context specified when the command-queue is created.
clGetCommandQueueContext :: CLCommandQueue -> IO (Either CLError CLContext)
clGetCommandQueueContext cq = wrapGetInfo (\(dat :: Ptr CLContext)
                                           -> raw_clGetCommandQueueInfo cq infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_QUEUE_CONTEXT
      size = fromIntegral $ sizeOf (nullPtr::CLContext)

-- | Return the device specified when the command-queue is created.
clGetCommandQueueDevice :: CLCommandQueue -> IO (Either CLError CLDeviceID)
clGetCommandQueueDevice cq = wrapGetInfo (\(dat :: Ptr CLDeviceID)
                                           -> raw_clGetCommandQueueInfo cq infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_QUEUE_DEVICE
      size = fromIntegral $ sizeOf (nullPtr::CLDeviceID)

-- | Return the command-queue reference count.
-- The reference count returned should be considered immediately stale. It is
-- unsuitable for general use in applications. This feature is provided for
-- identifying memory leaks.
clGetCommandQueueReferenceCount :: CLCommandQueue -> IO (Either CLError CLuint)
clGetCommandQueueReferenceCount cq = wrapGetInfo (\(dat :: Ptr CLuint)
                                           -> raw_clGetCommandQueueInfo cq infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_QUEUE_REFERENCE_COUNT
      size = fromIntegral $ sizeOf (0::CLuint)

-- | Return the currently specified properties for the command-queue. These
-- properties are specified by the properties argument in 'clCreateCommandQueue'
-- , and can be changed by 'clSetCommandQueueProperty'.
clGetCommandQueueProperties :: CLCommandQueue -> IO (Either CLError [CLCommandQueueProperty])
clGetCommandQueueProperties cq = wrapGetInfo (\(dat :: Ptr CLCommandQueueProperty_)
                                           -> raw_clGetCommandQueueInfo cq infoid size (castPtr dat)) bitmaskToCommandQueueProperties
    where
      infoid = getCLValue CL_QUEUE_PROPERTIES
      size = fromIntegral $ sizeOf (0::CLCommandQueueProperty_)

-- | Enable or disable the properties of a command-queue.
-- Returns the command-queue properties before they were changed by
-- 'clSetCommandQueueProperty'.
-- As specified for 'clCreateCommandQueue', the
-- 'CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE' command-queue property determines
-- whether the commands in a command-queue are executed in-order or
-- out-of-order. Changing this command-queue property will cause the OpenCL
-- implementation to block until all previously queued commands in command_queue
-- have completed. This can be an expensive operation and therefore changes to
-- the 'CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE' property should be only done
-- when absolutely necessary.
--
-- It is possible that a device(s) becomes unavailable after a context and
-- command-queues that use this device(s) have been created and commands have
-- been queued to command-queues. In this case the behavior of OpenCL API calls
-- that use this context (and command-queues) are considered to be
-- implementation-defined. The user callback function, if specified when the
-- context is created, can be used to record appropriate information
-- when the device becomes unavailable.
clSetCommandQueueProperty :: CLCommandQueue -> [CLCommandQueueProperty] -> Bool
                          -> IO [CLCommandQueueProperty]
clSetCommandQueueProperty cq xs val = alloca $ \(dat :: Ptr CLCommandQueueProperty_) -> do
  errcode <- fmap ErrorCode $ raw_clSetCommandQueueProperty cq props (fromBool val) dat
  if errcode == clSuccess
    then fmap bitmaskToCommandQueueProperties $ peek dat
    else return []
    where
      props = bitmaskFromFlags xs

-- -----------------------------------------------------------------------------
clEnqueue :: (CLuint -> Ptr CLEvent -> Ptr CLEvent -> IO CLint) -> [CLEvent] -> IO (Either CLError CLEvent)
clEnqueue f [] = alloca $ \event -> do
  errcode <- f 0 nullPtr event
  if errcode == (fromIntegral . fromEnum $ CL_SUCCESS )
    then fmap Right $ peek event
    else return . Left . toEnum . fromIntegral $ errcode
clEnqueue f events = allocaArray nevents $ \pevents -> do
  pokeArray pevents events
  alloca $ \event -> do
    errcode <- f cnevents pevents event
    if errcode == (fromIntegral . fromEnum $ CL_SUCCESS )
      then fmap Right $ peek event
      else return . Left . toEnum . fromIntegral $ errcode
    where
      nevents = length events
      cnevents = fromIntegral nevents

-- -----------------------------------------------------------------------------
{-| Enqueue commands to read from a buffer object to host memory. Calling
clEnqueueReadBuffer to read a region of the buffer object with the ptr argument
value set to host_ptr + offset, where host_ptr is a pointer to the memory region
specified when the buffer object being read is created with
'CL_MEM_USE_HOST_PTR', must meet the following requirements in order to avoid
undefined behavior:

 * All commands that use this buffer object have finished execution before the
read command begins execution

 * The buffer object is not mapped

 * The buffer object is not used by any command-queue until the read command has
finished execution Errors

'clEnqueueReadBuffer' returns the event if the function is executed
successfully. Otherwise, it returns one of the following errors:

 * 'CL_INVALID_COMMAND_QUEUE' if command_queue is not a valid command-queue.

 * 'CL_INVALID_CONTEXT' if the context associated with command_queue and buffer
are not the same or if the context associated with command_queue and events in
event_wait_list are not the same.

 * 'CL_INVALID_MEM_OBJECT' if buffer is not a valid buffer object.

 * 'CL_INVALID_VALUE' if the region being read specified by (offset, cb) is out
of bounds or if ptr is a NULL value.

 * 'CL_INVALID_EVENT_WAIT_LIST' if event_wait_list is NULL and
num_events_in_wait_list greater than 0, or event_wait_list is not NULL and
num_events_in_wait_list is 0, or if event objects in event_wait_list are not
valid events.

 * 'CL_MEM_OBJECT_ALLOCATION_FAILURE' if there is a failure to allocate memory
for data store associated with buffer.

 * 'CL_OUT_OF_HOST_MEMORY' if there is a failure to allocate resources required
by the OpenCL implementation on the host.
-}
clEnqueueReadBuffer :: CLCommandQueue -> CLMem -> Bool -> CSize -> CSize
                       -> Ptr () -> [CLEvent] -> IO (Either CLError CLEvent)
clEnqueueReadBuffer cq mem check off size dat = clEnqueue (raw_clEnqueueReadBuffer cq mem (fromBool check) off size dat)

{-| Enqueue commands to write to a buffer object from host memory.Calling
clEnqueueWriteBuffer to update the latest bits in a region of the buffer object
with the ptr argument value set to host_ptr + offset, where host_ptr is a
pointer to the memory region specified when the buffer object being written is
created with 'CL_MEM_USE_HOST_PTR', must meet the following requirements in
order to avoid undefined behavior:

 * The host memory region given by (host_ptr + offset, cb) contains the latest
bits when the enqueued write command begins execution.

 * The buffer object is not mapped.

 * The buffer object is not used by any command-queue until the write command
has finished execution.

'clEnqueueWriteBuffer' returns the Event if the function is executed
successfully. Otherwise, it returns one of the following errors:

 * 'CL_INVALID_COMMAND_QUEUE' if command_queue is not a valid command-queue.

 * 'CL_INVALID_CONTEXT' if the context associated with command_queue and buffer
are not the same or if the context associated with command_queue and events in
event_wait_list are not the same.

 * 'CL_INVALID_MEM_OBJECT' if buffer is not a valid buffer object.

 * 'CL_INVALID_VALUE' if the region being written specified by (offset, cb) is
out of bounds or if ptr is a NULL value.

 * 'CL_INVALID_EVENT_WAIT_LIST' if event_wait_list is NULL and
num_events_in_wait_list greater than 0, or event_wait_list is not NULL and
num_events_in_wait_list is 0, or if event objects in event_wait_list are not
valid events.

 * 'CL_MEM_OBJECT_ALLOCATION_FAILURE' if there is a failure to allocate memory
for data store associated with buffer.

 * 'CL_OUT_OF_HOST_MEMORY' if there is a failure to allocate resources required
by the OpenCL implementation on the host.
-}
clEnqueueWriteBuffer :: CLCommandQueue -> CLMem -> Bool -> CSize -> CSize
                       -> Ptr () -> [CLEvent] -> IO (Either CLError CLEvent)
clEnqueueWriteBuffer cq mem check off size dat = clEnqueue (raw_clEnqueueWriteBuffer cq mem (fromBool check) off size dat)

-- -----------------------------------------------------------------------------
clEnqueueNDRangeKernel :: CLCommandQueue -> CLKernel -> [CSize] -> [CSize] -> [CLEvent] -> IO (Either CLError CLEvent)
clEnqueueNDRangeKernel cq krn gws lws events = withArray gws $ \pgws -> withArray lws $ \plws -> do
  clEnqueue (raw_clEnqueueNDRangeKernel cq krn num nullPtr pgws plws) events
    where
      num = fromIntegral $ length gws

{-| Enqueues a command to execute a kernel on a device. The kernel is executed
using a single work-item.

'clEnqueueTask' is equivalent to calling 'clEnqueueNDRangeKernel' with work_dim
= 1, global_work_offset = [], global_work_size[0] set to 1, and
local_work_size[0] set to 1.

Returns the evens if the kernel execution was successfully queued, or one of the
errors below:

 * 'CL_INVALID_PROGRAM_EXECUTABLE' if there is no successfully built program
executable available for device associated with command_queue.

 * 'CL_INVALID_COMMAND_QUEUE if' command_queue is not a valid command-queue.

 * 'CL_INVALID_KERNEL' if kernel is not a valid kernel object.

 * 'CL_INVALID_CONTEXT' if context associated with command_queue and kernel is
not the same or if the context associated with command_queue and events in
event_wait_list are not the same.

 * 'CL_INVALID_KERNEL_ARGS' if the kernel argument values have not been specified.

 * 'CL_INVALID_WORK_GROUP_SIZE' if a work-group size is specified for kernel
using the __attribute__((reqd_work_group_size(X, Y, Z))) qualifier in program
source and is not (1, 1, 1).

 * 'CL_OUT_OF_RESOURCES' if there is a failure to queue the execution instance
of kernel on the command-queue because of insufficient resources needed to
execute the kernel.

 * 'CL_MEM_OBJECT_ALLOCATION_FAILURE' if there is a failure to allocate memory
for data store associated with image or buffer objects specified as arguments to
kernel.

 * 'CL_OUT_OF_HOST_MEMORY' if there is a failure to allocate resources required
by the OpenCL implementation on the host.
-}
clEnqueueTask :: CLCommandQueue -> CLKernel -> [CLEvent] -> IO (Either CLError CLEvent)
clEnqueueTask cq krn = clEnqueue (raw_clEnqueueTask cq krn)

-- -----------------------------------------------------------------------------
-- | Issues all previously queued OpenCL commands in a command-queue to the
-- device associated with the command-queue.
-- 'clFlush' only guarantees that all queued commands to command_queue get
-- issued to the appropriate device. There is no guarantee that they will be
-- complete after 'clFlush' returns.
--
-- 'clFlush' returns 'True' if the function call was executed successfully. It
-- returns 'False' if command_queue is not a valid command-queue or if there is
-- a failure to allocate resources required by the OpenCL implementation on the
-- host.
--
-- Any blocking commands queued in a command-queue such as 'clEnqueueReadImage'
-- or 'clEnqueueReadBuffer' with blocking_read set to 'True',
-- 'clEnqueueWriteImage' or 'clEnqueueWriteBuffer' with blocking_write set to
-- 'True', 'clEnqueueMapImage' or 'clEnqueueMapBuffer' with blocking_map set to
-- 'True' or 'clWaitForEvents' perform an implicit flush of the command-queue.
--
-- To use event objects that refer to commands enqueued in a command-queue as
-- event objects to wait on by commands enqueued in a different command-queue,
-- the application must call a 'clFlush' or any blocking commands that perform
-- an implicit flush of the command-queue where the commands that refer to these
-- event objects are enqueued.
clFlush :: CLCommandQueue -> IO Bool
clFlush = wrapCheckSuccess . raw_clFlush

-- | Blocks until all previously queued OpenCL commands in a command-queue are
-- issued to the associated device and have completed.
-- 'clFinish' does not return until all queued commands in command_queue have
-- been processed and completed. 'clFinish' is also a synchronization point.
--
-- 'clFinish' returns 'True' if the function call was executed successfully. It
-- returns 'False' if command_queue is not a valid command-queue or if there is
-- a failure to allocate resources required by the OpenCL implementation on the
-- host.
clFinish :: CLCommandQueue -> IO Bool
clFinish = wrapCheckSuccess . raw_clFinish

-- -----------------------------------------------------------------------------

-- -----------------------------------------------------------------------------
-- This file is part of Haskell-Opencl.

-- Haskell-Opencl is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.

-- Haskell-Opencl is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.

-- You should have received a copy of the GNU General Public License
-- along with Haskell-Opencl.  If not, see <http://www.gnu.org/licenses/>.
-- -----------------------------------------------------------------------------
{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}
module System.GPU.OpenCL.CommandQueue(
  -- * Types
  CLCommandQueue, CLCommandQueueProperty(..),
  -- * Command Queue Functions
  clCreateCommandQueue, clRetainCommandQueue, clReleaseCommandQueue,
  clGetCommandQueueContext, clGetCommandQueueDevice,
  clGetCommandQueueReferenceCount, clGetCommandQueueProperties,
  clSetCommandQueueProperty,
  -- * Memory Commands
  clEnqueueReadBuffer, clEnqueueWriteBuffer,
  -- * Executing Kernels
  -- * Flush and Finish
  clFlush, clFinish
  ) where

-- -----------------------------------------------------------------------------
import Foreign
import Foreign.C.Types
import System.GPU.OpenCL.Types(
  CLint, CLbool, CLuint, CLCommandQueueProperty_, CLCommandQueueInfo_,
  CLError(..), CLCommandQueue, CLDeviceID, CLContext, CLCommandQueueProperty(..),
  CLEvent, CLMem, ErrorCode(..),
  wrapCheckSuccess, wrapPError, wrapGetInfo, getCLValue,
  bitmaskToCommandQueueProperties, bitmaskFromFlags, clSuccess )

#include <CL/cl.h>

-- -----------------------------------------------------------------------------
foreign import ccall "clCreateCommandQueue" raw_clCreateCommandQueue ::
  CLContext -> CLDeviceID -> CLCommandQueueProperty_ -> Ptr CLint -> IO CLCommandQueue
foreign import ccall "clRetainCommandQueue" raw_clRetainCommandQueue ::
  CLCommandQueue -> IO CLint
foreign import ccall "clReleaseCommandQueue" raw_clReleaseCommandQueue ::
  CLCommandQueue -> IO CLint
foreign import ccall "clGetCommandQueueInfo" raw_clGetCommandQueueInfo ::
  CLCommandQueue -> CLCommandQueueInfo_ -> CSize -> Ptr () -> Ptr CSize -> IO CLint
foreign import ccall "clSetCommandQueueProperty" raw_clSetCommandQueueProperty ::
  CLCommandQueue -> CLCommandQueueProperty_ -> CLbool -> Ptr CLCommandQueueProperty_ -> IO CLint
foreign import ccall "clEnqueueReadBuffer" raw_clEnqueueReadBuffer ::
  CLCommandQueue -> CLMem -> CLbool -> CSize -> CSize -> Ptr () -> CLuint -> Ptr CLEvent -> Ptr CLEvent -> IO CLint
foreign import ccall "clEnqueueWriteBuffer" raw_clEnqueueWriteBuffer ::
  CLCommandQueue -> CLMem -> CLbool -> CSize -> CSize -> Ptr () -> CLuint -> Ptr CLEvent -> Ptr CLEvent -> IO CLint
foreign import ccall "clFlush" raw_clFlush ::
  CLCommandQueue -> IO CLint
foreign import ccall "clFinish" raw_clFinish ::
  CLCommandQueue -> IO CLint

-- -----------------------------------------------------------------------------
{-| Create a command-queue on a specific device.

The OpenCL functions that are submitted to a command-queue are enqueued in the
order the calls are made but can be configured to execute in-order or
out-of-order. The properties argument in clCreateCommandQueue can be used to
specify the execution order.

If the 'CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE' property of a command-queue is
not set, the commands enqueued to a command-queue execute in order. For example,
if an application calls 'clEnqueueNDRangeKernel' to execute kernel A followed by
a 'clEnqueueNDRangeKernel' to execute kernel B, the application can assume that
kernel A finishes first and then kernel B is executed. If the memory objects
output by kernel A are inputs to kernel B then kernel B will see the correct
data in memory objects produced by execution of kernel A. If the
'CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE' property of a commandqueue is set, then
there is no guarantee that kernel A will finish before kernel B starts execution.

Applications can configure the commands enqueued to a command-queue to execute
out-of-order by setting the 'CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE' property of
the command-queue. This can be specified when the command-queue is created or
can be changed dynamically using 'clCreateCommandQueue'. In out-of-order
execution mode there is no guarantee that the enqueued commands will finish
execution in the order they were queued. As there is no guarantee that kernels
will be executed in order, i.e. based on when the 'clEnqueueNDRangeKernel' calls
are made within a command-queue, it is therefore possible that an earlier
'clEnqueueNDRangeKernel' call to execute kernel A identified by event A may
execute and/or finish later than a 'clEnqueueNDRangeKernel' call to execute
kernel B which was called by the application at a later point in time. To
guarantee a specific order of execution of kernels, a wait on a particular event
(in this case event A) can be used. The wait for event A can be specified in the
event_wait_list argument to 'clEnqueueNDRangeKernel' for kernel B.

In addition, a wait for events or a barrier command can be enqueued to the
command-queue. The wait for events command ensures that previously enqueued
commands identified by the list of events to wait for have finished before the
next batch of commands is executed. The barrier command ensures that all
previously enqueued commands in a command-queue have finished execution before
the next batch of commands is executed.

Similarly, commands to read, write, copy or map memory objects that are enqueued
after 'clEnqueueNDRangeKernel', 'clEnqueueTask' or 'clEnqueueNativeKernel'
commands are not guaranteed to wait for kernels scheduled for execution to have
completed (if the 'CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE' property is set). To
ensure correct ordering of commands, the event object returned by
'clEnqueueNDRangeKernel', 'clEnqueueTask' or 'clEnqueueNativeKernel' can be
used to enqueue a wait for event or a barrier command can be enqueued that must
complete before reads or writes to the memory object(s) occur.
-}
clCreateCommandQueue :: CLContext -> CLDeviceID -> [CLCommandQueueProperty]
                     -> IO (Either CLError CLCommandQueue)
clCreateCommandQueue ctx did xs = wrapPError $ \perr -> do
  raw_clCreateCommandQueue ctx did props perr
    where
      props = bitmaskFromFlags xs

-- | Increments the command_queue reference count.
-- 'clCreateCommandQueue' performs an implicit retain. This is very helpful for
-- 3rd party libraries, which typically get a command-queue passed to them by
-- the application. However, it is possible that the application may delete the
-- command-queue without informing the library. Allowing functions to attach to
-- (i.e. retain) and release a command-queue solves the problem of a
-- command-queue being used by a library no longer being valid.
-- Returns 'True' if the function is executed successfully. It returns 'False'
-- if command_queue is not a valid command-queue.
clRetainCommandQueue :: CLCommandQueue -> IO Bool
clRetainCommandQueue = wrapCheckSuccess . raw_clRetainCommandQueue

-- | Decrements the command_queue reference count.
-- After the command_queue reference count becomes zero and all commands queued
-- to command_queue have finished (e.g., kernel executions, memory object
-- updates, etc.), the command-queue is deleted.
-- Returns 'True' if the function is executed successfully. It returns 'False'
-- if command_queue is not a valid command-queue.
clReleaseCommandQueue :: CLCommandQueue -> IO Bool
clReleaseCommandQueue = wrapCheckSuccess . raw_clReleaseCommandQueue

#c
enum CLCommandQueueInfo {
  cL_QUEUE_CONTEXT=CL_QUEUE_CONTEXT,
  cL_QUEUE_DEVICE=CL_QUEUE_DEVICE,
  cL_QUEUE_REFERENCE_COUNT=CL_QUEUE_REFERENCE_COUNT,
  cL_QUEUE_PROPERTIES=CL_QUEUE_PROPERTIES,
  };
#endc
{#enum CLCommandQueueInfo {upcaseFirstLetter} #}

-- | Return the context specified when the command-queue is created.
clGetCommandQueueContext :: CLCommandQueue -> IO (Either CLError CLContext)
clGetCommandQueueContext cq = wrapGetInfo (\(dat :: Ptr CLContext)
                                           -> raw_clGetCommandQueueInfo cq infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_QUEUE_CONTEXT
      size = fromIntegral $ sizeOf (nullPtr::CLContext)

-- | Return the device specified when the command-queue is created.
clGetCommandQueueDevice :: CLCommandQueue -> IO (Either CLError CLDeviceID)
clGetCommandQueueDevice cq = wrapGetInfo (\(dat :: Ptr CLDeviceID)
                                           -> raw_clGetCommandQueueInfo cq infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_QUEUE_DEVICE
      size = fromIntegral $ sizeOf (nullPtr::CLDeviceID)

-- | Return the command-queue reference count.
-- The reference count returned should be considered immediately stale. It is
-- unsuitable for general use in applications. This feature is provided for
-- identifying memory leaks.
clGetCommandQueueReferenceCount :: CLCommandQueue -> IO (Either CLError CLuint)
clGetCommandQueueReferenceCount cq = wrapGetInfo (\(dat :: Ptr CLuint)
                                           -> raw_clGetCommandQueueInfo cq infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_QUEUE_REFERENCE_COUNT
      size = fromIntegral $ sizeOf (0::CLuint)

-- | Return the currently specified properties for the command-queue. These
-- properties are specified by the properties argument in 'clCreateCommandQueue'
-- , and can be changed by 'clSetCommandQueueProperty'.
clGetCommandQueueProperties :: CLCommandQueue -> IO (Either CLError [CLCommandQueueProperty])
clGetCommandQueueProperties cq = wrapGetInfo (\(dat :: Ptr CLCommandQueueProperty_)
                                           -> raw_clGetCommandQueueInfo cq infoid size (castPtr dat)) bitmaskToCommandQueueProperties
    where
      infoid = getCLValue CL_QUEUE_PROPERTIES
      size = fromIntegral $ sizeOf (0::CLCommandQueueProperty_)

-- | Enable or disable the properties of a command-queue.
-- Returns the command-queue properties before they were changed by
-- 'clSetCommandQueueProperty'.
-- As specified for 'clCreateCommandQueue', the
-- 'CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE' command-queue property determines
-- whether the commands in a command-queue are executed in-order or
-- out-of-order. Changing this command-queue property will cause the OpenCL
-- implementation to block until all previously queued commands in command_queue
-- have completed. This can be an expensive operation and therefore changes to
-- the 'CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE' property should be only done
-- when absolutely necessary.
--
-- It is possible that a device(s) becomes unavailable after a context and
-- command-queues that use this device(s) have been created and commands have
-- been queued to command-queues. In this case the behavior of OpenCL API calls
-- that use this context (and command-queues) are considered to be
-- implementation-defined. The user callback function, if specified when the
-- context is created, can be used to record appropriate information
-- when the device becomes unavailable.
clSetCommandQueueProperty :: CLCommandQueue -> [CLCommandQueueProperty] -> Bool
                          -> IO [CLCommandQueueProperty]
clSetCommandQueueProperty cq xs val = alloca $ \(dat :: Ptr CLCommandQueueProperty_) -> do
  errcode <- fmap ErrorCode $ raw_clSetCommandQueueProperty cq props (fromBool val) dat
  if errcode == clSuccess
    then fmap bitmaskToCommandQueueProperties $ peek dat
    else return []
    where
      props = bitmaskFromFlags xs

-- -----------------------------------------------------------------------------
{-| Enqueue commands to read from a buffer object to host memory. Calling
clEnqueueReadBuffer to read a region of the buffer object with the ptr argument
value set to host_ptr + offset, where host_ptr is a pointer to the memory region
specified when the buffer object being read is created with
'CL_MEM_USE_HOST_PTR', must meet the following requirements in order to avoid
undefined behavior:

 * All commands that use this buffer object have finished execution before the
read command begins execution

 * The buffer object is not mapped

 * The buffer object is not used by any command-queue until the read command has
finished execution Errors

'clEnqueueReadBuffer' returns the event if the function is executed
successfully. Otherwise, it returns one of the following errors:

 * 'CL_INVALID_COMMAND_QUEUE' if command_queue is not a valid command-queue.

 * 'CL_INVALID_CONTEXT' if the context associated with command_queue and buffer
are not the same or if the context associated with command_queue and events in
event_wait_list are not the same.

 * 'CL_INVALID_MEM_OBJECT' if buffer is not a valid buffer object.

 * 'CL_INVALID_VALUE' if the region being read specified by (offset, cb) is out
of bounds or if ptr is a NULL value.

 * 'CL_INVALID_EVENT_WAIT_LIST' if event_wait_list is NULL and
num_events_in_wait_list greater than 0, or event_wait_list is not NULL and
num_events_in_wait_list is 0, or if event objects in event_wait_list are not
valid events.

 * 'CL_MEM_OBJECT_ALLOCATION_FAILURE' if there is a failure to allocate memory
for data store associated with buffer.

 * 'CL_OUT_OF_HOST_MEMORY' if there is a failure to allocate resources required
by the OpenCL implementation on the host.
-}
clEnqueueReadBuffer :: CLCommandQueue -> CLMem -> Bool -> CSize -> CSize
                       -> Ptr () -> [CLEvent] -> IO (Either CLError CLEvent)
clEnqueueReadBuffer cq mem check off size dat [] = alloca $ \event -> do
  errcode <- raw_clEnqueueReadBuffer cq mem (fromBool check) off size dat 0 nullPtr event
  if errcode == (fromIntegral . fromEnum $ CL_SUCCESS )
    then fmap Right $ peek event
    else return . Left . toEnum . fromIntegral $ errcode
clEnqueueReadBuffer cq mem check off size dat events = allocaArray nevents $ \pevents -> do
  pokeArray pevents events
  alloca $ \event -> do
    errcode <- raw_clEnqueueReadBuffer cq mem (fromBool check) off size dat cnevents pevents event
    if errcode == (fromIntegral . fromEnum $ CL_SUCCESS )
      then fmap Right $ peek event
      else return . Left . toEnum . fromIntegral $ errcode
    where
      nevents = length events
      cnevents = fromIntegral nevents

{-| Enqueue commands to write to a buffer object from host memory.Calling
clEnqueueWriteBuffer to update the latest bits in a region of the buffer object
with the ptr argument value set to host_ptr + offset, where host_ptr is a
pointer to the memory region specified when the buffer object being written is
created with 'CL_MEM_USE_HOST_PTR', must meet the following requirements in
order to avoid undefined behavior:

 * The host memory region given by (host_ptr + offset, cb) contains the latest
bits when the enqueued write command begins execution.

 * The buffer object is not mapped.

 * The buffer object is not used by any command-queue until the write command
has finished execution.

'clEnqueueWriteBuffer' returns the Event if the function is executed
successfully. Otherwise, it returns one of the following errors:

 * 'CL_INVALID_COMMAND_QUEUE' if command_queue is not a valid command-queue.

 * 'CL_INVALID_CONTEXT' if the context associated with command_queue and buffer
are not the same or if the context associated with command_queue and events in
event_wait_list are not the same.

 * 'CL_INVALID_MEM_OBJECT' if buffer is not a valid buffer object.

 * 'CL_INVALID_VALUE' if the region being written specified by (offset, cb) is
out of bounds or if ptr is a NULL value.

 * 'CL_INVALID_EVENT_WAIT_LIST' if event_wait_list is NULL and
num_events_in_wait_list greater than 0, or event_wait_list is not NULL and
num_events_in_wait_list is 0, or if event objects in event_wait_list are not
valid events.

 * 'CL_MEM_OBJECT_ALLOCATION_FAILURE' if there is a failure to allocate memory
for data store associated with buffer.

 * 'CL_OUT_OF_HOST_MEMORY' if there is a failure to allocate resources required
by the OpenCL implementation on the host.
-}
clEnqueueWriteBuffer :: CLCommandQueue -> CLMem -> Bool -> CSize -> CSize
                       -> Ptr () -> [CLEvent] -> IO (Either CLError CLEvent)
clEnqueueWriteBuffer cq mem check off size dat [] = alloca $ \event -> do
  errcode <- raw_clEnqueueWriteBuffer cq mem (fromBool check) off size dat 0 nullPtr event
  if errcode == (fromIntegral . fromEnum $ CL_SUCCESS )
    then fmap Right $ peek event
    else return . Left . toEnum . fromIntegral $ errcode
clEnqueueWriteBuffer cq mem check off size dat events = allocaArray nevents $ \pevents -> do
  pokeArray pevents events
  alloca $ \event -> do
    errcode <- raw_clEnqueueWriteBuffer cq mem (fromBool check) off size dat cnevents pevents event
    if errcode == (fromIntegral . fromEnum $ CL_SUCCESS )
      then fmap Right $ peek event
      else return . Left . toEnum . fromIntegral $ errcode
    where
      nevents = length events
      cnevents = fromIntegral nevents

-- -----------------------------------------------------------------------------
-- | Issues all previously queued OpenCL commands in a command-queue to the
-- device associated with the command-queue.
-- 'clFlush' only guarantees that all queued commands to command_queue get
-- issued to the appropriate device. There is no guarantee that they will be
-- complete after 'clFlush' returns.
--
-- 'clFlush' returns 'True' if the function call was executed successfully. It
-- returns 'False' if command_queue is not a valid command-queue or if there is
-- a failure to allocate resources required by the OpenCL implementation on the
-- host.
--
-- Any blocking commands queued in a command-queue such as 'clEnqueueReadImage'
-- or 'clEnqueueReadBuffer' with blocking_read set to 'True',
-- 'clEnqueueWriteImage' or 'clEnqueueWriteBuffer' with blocking_write set to
-- 'True', 'clEnqueueMapImage' or 'clEnqueueMapBuffer' with blocking_map set to
-- 'True' or 'clWaitForEvents' perform an implicit flush of the command-queue.
--
-- To use event objects that refer to commands enqueued in a command-queue as
-- event objects to wait on by commands enqueued in a different command-queue,
-- the application must call a 'clFlush' or any blocking commands that perform
-- an implicit flush of the command-queue where the commands that refer to these
-- event objects are enqueued.
clFlush :: CLCommandQueue -> IO Bool
clFlush = wrapCheckSuccess . raw_clFlush

-- | Blocks until all previously queued OpenCL commands in a command-queue are
-- issued to the associated device and have completed.
-- 'clFinish' does not return until all queued commands in command_queue have
-- been processed and completed. 'clFinish' is also a synchronization point.
--
-- 'clFinish' returns 'True' if the function call was executed successfully. It
-- returns 'False' if command_queue is not a valid command-queue or if there is
-- a failure to allocate resources required by the OpenCL implementation on the
-- host.
clFinish :: CLCommandQueue -> IO Bool
clFinish = wrapCheckSuccess . raw_clFinish

-- -----------------------------------------------------------------------------


`createVideoWriter` takes `codec:String` of length four and passes it to C `wrapCreateVideoWriter` (fix: previously was hardcoded to send a malformed `int fourcc` value)

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns, CPP#-}
#include "cvWrapLEO.h"
module CV.Video where
{#import CV.Image#}

import Data.Char (ord)
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import Foreign.C.Types
import Foreign.C.String
import System.IO.Unsafe
import Utils.Stream

-- NOTE: For some reason, this module fails to work with ghci for me

{#pointer *CvCapture as Capture foreign newtype#}

foreign import ccall "& wrapReleaseCapture" releaseCapture :: FinalizerPtr Capture

{#pointer *CvVideoWriter as VideoWriter foreign newtype#}

foreign import ccall "& wrapReleaseVideoWriter" releaseVideoWriter :: FinalizerPtr VideoWriter
-- NOTE: This use of foreignPtr is quite likely to cause trouble by retaining
--       videos longer than necessary.

type VideoStream c d = Stream IO (Image c d)

streamFromVideo cap   = dropS 1 $ streamFromVideo' (undefined) cap
streamFromVideo' p cap = Value $ do
                         x <- getFrame cap
                         case x of
                            Just f -> return (p,(streamFromVideo' f cap))
                            Nothing -> return (p,Terminated)

captureFromFile fn = withCString fn $ \cfn -> do
                      ptr <- {#call cvCreateFileCapture#} cfn
                      fptr <- newForeignPtr releaseCapture ptr
                      return . Capture $ fptr

captureFromCam int = do
                      ptr <- {#call cvCreateCameraCapture#} (fromIntegral int)
                      if  ptr==nullPtr
                        then
                          return Nothing
                        else do
                          fptr <- newForeignPtr releaseCapture ptr
                          return . Just . Capture $ fptr

dropFrame cap = withCapture cap $ \ccap -> {#call cvGrabFrame#} ccap >> return ()

getFrame :: Capture -> IO (Maybe (Image RGB D32))
getFrame cap = withCapture cap $ \ccap -> do
                p_frame <- {#call cvQueryFrame#} ccap
                if p_frame==nullPtr then return Nothing
                                    else creatingImage (ensure32F p_frame) >>= return . Just
                    -- NOTE: This works because Image module has generated wrappers for ensure32F

#c
enum CapProp {
      CAP_PROP_POS_MSEC       =  CV_CAP_PROP_POS_MSEC
    , CAP_PROP_POS_FRAMES     =  CV_CAP_PROP_POS_FRAMES
    , CAP_PROP_POS_AVI_RATIO  =  CV_CAP_PROP_POS_AVI_RATIO
    , CAP_PROP_FRAME_WIDTH    =  CV_CAP_PROP_FRAME_WIDTH
    , CAP_PROP_FRAME_HEIGHT   =  CV_CAP_PROP_FRAME_HEIGHT
    , CAP_PROP_FPS            =  CV_CAP_PROP_FPS
    , CAP_PROP_FOURCC         =  CV_CAP_PROP_FOURCC
    , CAP_PROP_FRAME_COUNT    =  CV_CAP_PROP_FRAME_COUNT
    , CAP_PROP_FORMAT         =  CV_CAP_PROP_FORMAT
    , CAP_PROP_MODE           =  CV_CAP_PROP_MODE
    , CAP_PROP_BRIGHTNESS     =  CV_CAP_PROP_BRIGHTNESS
    , CAP_PROP_CONTRAST       =  CV_CAP_PROP_CONTRAST
    , CAP_PROP_SATURATION     =  CV_CAP_PROP_SATURATION
    , CAP_PROP_HUE            =  CV_CAP_PROP_HUE
    , CAP_PROP_GAIN           =  CV_CAP_PROP_GAIN
    , CAP_PROP_EXPOSURE       =  CV_CAP_PROP_EXPOSURE
    , CAP_PROP_CONVERT_RGB    =  CV_CAP_PROP_CONVERT_RGB
    , CAP_PROP_RECTIFICATION  =  CV_CAP_PROP_RECTIFICATION
    , CAP_PROP_MONOCROME      =  CV_CAP_PROP_MONOCROME
};
#endc

{#enum CapProp {}#}

fromProp = fromIntegral . fromEnum

getCapProp cap prop = withCapture cap $ \ccap ->
                         {#call cvGetCaptureProperty#}
                           ccap (fromProp prop) >>= return . realToFrac

getFrameRate cap = unsafePerformIO $
                      withCapture cap $ \ccap ->
                         {#call cvGetCaptureProperty#}
                           ccap (fromProp CAP_PROP_FPS) >>= return . realToFrac

getFrameSize cap = unsafePerformIO $
                      withCapture cap $ \ccap -> do
                         w <- {#call cvGetCaptureProperty#} ccap (fromProp CAP_PROP_FRAME_WIDTH)
                                >>= return . round
                         h <- {#call cvGetCaptureProperty#} ccap (fromProp CAP_PROP_FRAME_HEIGHT)
                                >>= return . round
                         return (w,h)

setCapProp cap prop val = withCapture cap $ \ccap ->
                         {#call cvSetCaptureProperty#}
                           ccap (fromProp prop) (realToFrac val)

numberOfFrames cap = unsafePerformIO $
                      withCapture cap $ \ccap ->
                         {#call cvGetCaptureProperty#}
                           ccap (fromProp CAP_PROP_FRAME_COUNT)
                            >>= return . floor

frameNumber cap = unsafePerformIO $
                      withCapture cap $ \ccap ->
                         {#call cvGetCaptureProperty#}
                          ccap (fromProp CAP_PROP_POS_FRAMES) >>= return . floor

-- Video Writing

createVideoWriter filename codec framerate frameSize =
    withCString filename $ \cfilename -> do
        ptr <- {#call wrapCreateVideoWriter#} cfilename
                                              cc1 cc2 cc3 cc4
                                              framerate w h 0
        if ptr == nullPtr then error "Could not create video writer" else return ()
        fptr <- newForeignPtr releaseVideoWriter ptr
        return . VideoWriter $ fptr
  where
    (fromIntegral -> w, fromIntegral -> h) = frameSize
    [cc1, cc2, cc3, cc4]
        | 4 == length codec = fmap (fromIntegral . ord) codec
        | otherwise = error "Video writer codec must be a four-character string, eg. \"MPEG\""

writeFrame :: VideoWriter -> Image RGB D32 -> IO ()
writeFrame writer img = withVideoWriter writer $ \cwriter ->
                         withImage img    $ \cimg ->
                          {#call cvWriteFrame #} cwriter cimg >> return ()

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns, CPP#-}
#include "cvWrapLEO.h"
module CV.Video where
{#import CV.Image#}

import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import Foreign.C.Types
import Foreign.C.String
import System.IO.Unsafe
import Utils.Stream

-- NOTE: For some reason, this module fails to work with ghci for me

{#pointer *CvCapture as Capture foreign newtype#}

foreign import ccall "& wrapReleaseCapture" releaseCapture :: FinalizerPtr Capture

{#pointer *CvVideoWriter as VideoWriter foreign newtype#}

foreign import ccall "& wrapReleaseVideoWriter" releaseVideoWriter :: FinalizerPtr VideoWriter
-- NOTE: This use of foreignPtr is quite likely to cause trouble by retaining
--       videos longer than necessary.

type VideoStream c d = Stream IO (Image c d)

streamFromVideo cap   = dropS 1 $ streamFromVideo' (undefined) cap
streamFromVideo' p cap = Value $ do
                         x <- getFrame cap
                         case x of
                            Just f -> return (p,(streamFromVideo' f cap))
                            Nothing -> return (p,Terminated)

captureFromFile fn = withCString fn $ \cfn -> do
                      ptr <- {#call cvCreateFileCapture#} cfn
                      fptr <- newForeignPtr releaseCapture ptr
                      return . Capture $ fptr

captureFromCam int = do
                      ptr <- {#call cvCreateCameraCapture#} (fromIntegral int)
                      if  ptr==nullPtr
                        then
                          return Nothing
                        else do
                          fptr <- newForeignPtr releaseCapture ptr
                          return . Just . Capture $ fptr

dropFrame cap = withCapture cap $ \ccap -> {#call cvGrabFrame#} ccap >> return ()

getFrame :: Capture -> IO (Maybe (Image RGB D32))
getFrame cap = withCapture cap $ \ccap -> do
                p_frame <- {#call cvQueryFrame#} ccap
                if p_frame==nullPtr then return Nothing
                                    else creatingImage (ensure32F p_frame) >>= return . Just
                    -- NOTE: This works because Image module has generated wrappers for ensure32F

#c
enum CapProp {
      CAP_PROP_POS_MSEC       =  CV_CAP_PROP_POS_MSEC
    , CAP_PROP_POS_FRAMES     =  CV_CAP_PROP_POS_FRAMES
    , CAP_PROP_POS_AVI_RATIO  =  CV_CAP_PROP_POS_AVI_RATIO
    , CAP_PROP_FRAME_WIDTH    =  CV_CAP_PROP_FRAME_WIDTH
    , CAP_PROP_FRAME_HEIGHT   =  CV_CAP_PROP_FRAME_HEIGHT
    , CAP_PROP_FPS            =  CV_CAP_PROP_FPS
    , CAP_PROP_FOURCC         =  CV_CAP_PROP_FOURCC
    , CAP_PROP_FRAME_COUNT    =  CV_CAP_PROP_FRAME_COUNT
    , CAP_PROP_FORMAT         =  CV_CAP_PROP_FORMAT
    , CAP_PROP_MODE           =  CV_CAP_PROP_MODE
    , CAP_PROP_BRIGHTNESS     =  CV_CAP_PROP_BRIGHTNESS
    , CAP_PROP_CONTRAST       =  CV_CAP_PROP_CONTRAST
    , CAP_PROP_SATURATION     =  CV_CAP_PROP_SATURATION
    , CAP_PROP_HUE            =  CV_CAP_PROP_HUE
    , CAP_PROP_GAIN           =  CV_CAP_PROP_GAIN
    , CAP_PROP_EXPOSURE       =  CV_CAP_PROP_EXPOSURE
    , CAP_PROP_CONVERT_RGB    =  CV_CAP_PROP_CONVERT_RGB
    , CAP_PROP_RECTIFICATION  =  CV_CAP_PROP_RECTIFICATION
    , CAP_PROP_MONOCROME      =  CV_CAP_PROP_MONOCROME
};
#endc

{#enum CapProp {}#}

fromProp = fromIntegral . fromEnum

getCapProp cap prop = withCapture cap $ \ccap ->
                         {#call cvGetCaptureProperty#}
                           ccap (fromProp prop) >>= return . realToFrac

getFrameRate cap = unsafePerformIO $
                      withCapture cap $ \ccap ->
                         {#call cvGetCaptureProperty#}
                           ccap (fromProp CAP_PROP_FPS) >>= return . realToFrac

getFrameSize cap = unsafePerformIO $
                      withCapture cap $ \ccap -> do
                         w <- {#call cvGetCaptureProperty#} ccap (fromProp CAP_PROP_FRAME_WIDTH)
                                >>= return . round
                         h <- {#call cvGetCaptureProperty#} ccap (fromProp CAP_PROP_FRAME_HEIGHT)
                                >>= return . round
                         return (w,h)

setCapProp cap prop val = withCapture cap $ \ccap ->
                         {#call cvSetCaptureProperty#}
                           ccap (fromProp prop) (realToFrac val)

numberOfFrames cap = unsafePerformIO $
                      withCapture cap $ \ccap ->
                         {#call cvGetCaptureProperty#}
                           ccap (fromProp CAP_PROP_FRAME_COUNT)
                            >>= return . floor

frameNumber cap = unsafePerformIO $
                      withCapture cap $ \ccap ->
                         {#call cvGetCaptureProperty#}
                          ccap (fromProp CAP_PROP_POS_FRAMES) >>= return . floor

-- Video Writing

data Codec = MPG4 deriving (Eq,Show)

createVideoWriter filename codec framerate frameSize =
    withCString filename $ \cfilename -> do
        ptr <- {#call wrapCreateVideoWriter#} cfilename fourcc
                                              framerate w h 0
        if ptr == nullPtr then error "Could not create video writer" else return ()
        fptr <- newForeignPtr releaseVideoWriter ptr
        return . VideoWriter $ fptr
  where
    (fromIntegral -> w, fromIntegral -> h) = frameSize
    fourcc | codec == MPG4 = 0x4d504734 -- This is so wrong..

writeFrame :: VideoWriter -> Image RGB D32 -> IO ()
writeFrame writer img = withVideoWriter writer $ \cwriter ->
                         withImage img    $ \cimg ->
                          {#call cvWriteFrame #} cwriter cimg >> return ()


regexdispatcher: small simplification

regexdispatcher: small simplification

--
-- @file
--
-- @brief Key Haskell bindings
--
-- @copyright BSD License (see LICENSE.md or https://www.libelektra.org)
--
module Elektra.Key (
  Key (..), Namespace (..), ElektraKeyVarargs (KeyMetaName, KeyBinary, KeyComment, KeyOwner),
  keyNew, keyNewWithValue, keyNewWithFlagsAndValue,
  keyDup, keyCopy, keyClear,
  keyIncRef, keyDecRef, keyGetRef,
  keyName, keyGetNameSize, keySetName, keyAddName,
  keyUnescapedName, keyGetUnescapedNameSize,
  keyGetFullNameSize, keyGetFullName,
  keyBaseName, keyGetBaseName, keyGetBaseNameSize, keyAddBaseName, keySetBaseName, keyDeleteBaseName,
  keyGetNamespace,
  keyString, keyGetValueSize, keySetString, keySet,
  keyRewindMeta, keyNextMeta, keyCurrentMeta,
  keyCopyMeta, keyCopyAllMeta, keyGetMeta, keySetMeta, keyListMeta,
  keyCmp, keyNeedSync,
  keyIsBelow, keyIsDirectBelow,
  keyRel, keyIsInactive, keyIsBinary, keyIsString, keyPtrNull,
  ifKey, withKey, whenKey,
  tmpRef
) where

#include <kdb.h>
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Ptr (castPtr, nullPtr)
import Foreign.ForeignPtr (FinalizerPtr (..), withForeignPtr, addForeignPtrFinalizer)
import System.IO.Unsafe (unsafePerformIO)
import Data.Maybe (isJust, fromJust)
import Control.Monad (liftM)
import Data.Bool (bool)

{#context lib="libelektra" #}

-- ***
-- TYPE DEFINITIONS
-- ***

{#pointer *Key foreign newtype #}

{#typedef size_t Int#}
{#typedef ssize_t Int #}

{#enum KEY_NS_NONE as Namespace { underscoreToCase } deriving (Show, Eq) #}
{#enum KEY_NAME as ElektraKeyVarargs { underscoreToCase } deriving (Show, Eq) #}

data KeyNew = KeyNew { knKeyName :: Maybe String
                     , knKeyValue :: Maybe String
                     , knMeta :: [(String, String)]
                     , knKeySize :: Maybe Int
                     , knFlags :: [ElektraKeyVarargs]
                     } deriving (Show)

-- ***
-- KEY CREATION / DELETION / COPPY METHODS
-- ***

keyPtrNull :: Key -> IO Bool
keyPtrNull (Key ptr) = withForeignPtr ptr (return . (== nullPtr))

-- as we use haskell's reference counting here, increase the number by one
-- so it gets deleted properly when haskell calls the finalizer
keyNew :: String -> IO Key
keyNew name = keyNewRaw name KeyEnd >>= addFinalizer
keyNewWithValue :: String -> String -> IO Key
keyNewWithValue name value = keyNewRawWithValue name KeyValue value KeyEnd >>= addFinalizer
keyNewWithFlagsAndValue :: String -> ElektraKeyVarargs -> String -> IO Key
keyNewWithFlagsAndValue name flags value = keyNewRawWithFlagsAndValue name KeyFlags flags KeyValue value KeyEnd >>= addFinalizer
{#fun unsafe variadic keyNew[keyswitch_t] as keyNewRaw {`String', `ElektraKeyVarargs'} -> `Key' #}
{#fun unsafe variadic keyNew[keyswitch_t, const char *, keyswitch_t]
  as keyNewRawWithValue {`String', `ElektraKeyVarargs', `String', `ElektraKeyVarargs'} -> `Key' #}
{#fun unsafe variadic keyNew[keyswitch_t, keyswitch_t, keyswitch_t, const char *, keyswitch_t]
  as keyNewRawWithFlagsAndValue
    {`String', `ElektraKeyVarargs', `ElektraKeyVarargs', `ElektraKeyVarargs', `String', `ElektraKeyVarargs'}
    -> `Key' #}
keyDup :: Key -> IO Key
keyDup k = keyDupRaw k >>= addFinalizer
{#fun unsafe keyDup as keyDupRaw {`Key'} -> `Key' #}
{#fun unsafe keyCopy {`Key', `Key'} -> `Int' #}
{#fun unsafe keyClear {`Key'} -> `Int' #}
{#fun unsafe keyIncRef {`Key'} -> `Int' #}
{#fun unsafe keyDecRef {`Key'} -> `Int' #}
{#fun unsafe keyGetRef {`Key'} -> `Int' #}

-- ***
-- KEY NAME MANIPULATION METHODS
-- ***

{#fun unsafe keyName {`Key'} -> `String' #}
keyGetName = keyName
{#fun unsafe keyGetNameSize {`Key'} -> `Int' #}
keyUnescapedName :: Key -> IO String
keyUnescapedName key = do
  size <- keyGetUnescapedNameSize key
  withKey key $ (\cKey -> do
    result <- {#call unsafe keyUnescapedName as keyUnescapedNameRaw #} cKey
    C2HSImp.peekCStringLen (castPtr result, size))
{#fun unsafe keyGetUnescapedNameSize {`Key'} -> `Int' #}
{#fun unsafe keySetName {`Key', `String'} -> `Int' #}
keyGetFullName :: (Key) -> IO String
keyGetFullName key = do
  size <- keyGetFullNameSize key
  withKey key $ \cKey ->
    allocaBytes size (\result -> do
      {#call unsafe keyGetFullName as keyGetFullNameRaw #} cKey result size
      C2HSImp.peekCString result)
{#fun unsafe keyGetFullNameSize {`Key'} -> `Int' #}
{#fun unsafe keyBaseName {`Key'} -> `String' #}
keyGetBaseName :: Key -> IO String
keyGetBaseName = keyBaseName
{#fun unsafe keyGetBaseNameSize {`Key'} -> `Int' #}
{#fun unsafe keyAddBaseName {`Key', `String'} -> `Int' #}
{#fun unsafe keyAddName {`Key', `String'} -> `Int' #}
keySetBaseName :: Key -> String -> IO Int
keySetBaseName key baseName = keySetBaseNameRaw key (Just baseName)
keyDeleteBaseName :: Key -> IO Int
keyDeleteBaseName key = keySetBaseNameRaw key Nothing
keySetBaseNameRaw :: Key -> Maybe String -> IO Int
keySetBaseNameRaw key baseName = do
  withKey key $ \cKey -> if (isJust baseName)
    then C2HSImp.withCString (fromJust baseName) $ \cValue -> call cKey cValue
    else call cKey nullPtr
  where call cKey cValue = {#call unsafe keySetBaseName as keySetBaseNameRaw' #} cKey cValue
{#fun unsafe keyGetNamespace {`Key'} -> `Namespace' #}

-- ***
-- KEY VALUE MANIPULATION METHODS
-- ***

-- we don't handle binary data currently
-- {#fun unsafe keyValue {`Key'} -> `PPtr' #}
{#fun unsafe keyString {`Key'} -> `String' #}
{#fun unsafe keyGetValueSize {`Key'} -> `Int' #}
keySet :: Show a => Key -> a -> IO Int
keySet key = keySetString key . show
{#fun unsafe keySetString {`Key', `String'} -> `Int' #}

-- ***
-- KEY META MANIPULATION METHODS
-- ***

{#fun unsafe keyRewindMeta {`Key'} -> `Int' #}
{#fun unsafe keyNextMeta as keyNextMeta {`Key'} -> `Key' #}
{#fun unsafe keyCurrentMeta as keyCurrentMeta {`Key'} -> `Key' #}
{#fun unsafe keyCopyMeta {`Key', `Key', `String'} -> `Int' #}
{#fun unsafe keyCopyAllMeta {`Key', `Key'} -> `Int' #}
{#fun unsafe keyGetMeta as keyGetMeta {`Key', `String'} -> `Key' #}
{#fun unsafe keySetMeta {`Key', `String', `String'} -> `Int' #}
keyListMeta :: Key -> IO [Key]
keyListMeta key = keyRewindMeta key >> listMeta []
  where
    listMeta res = do
      cur <- keyNextMeta key
      isNull <- keyPtrNull cur
      if isNull then return res else liftM (cur :) (listMeta res)

-- ***
-- KEY TESTING METHODS
-- ***

{#fun unsafe keyCmp {`Key', `Key'} -> `Int' #}
{#fun unsafe keyNeedSync {`Key'} -> `Int' #}
{#fun unsafe keyIsBelow {`Key', `Key'} -> `Int' #}
{#fun unsafe keyIsDirectBelow {`Key', `Key'} -> `Int' #}
{#fun unsafe keyRel {`Key', `Key'} -> `Int' #}
{#fun unsafe keyIsInactive {`Key'} -> `Int' #}
{#fun unsafe keyIsBinary {`Key'} -> `Int' #}
{#fun unsafe keyIsString {`Key'} -> `Int' #}

-- ***
-- COMMON HASKELL TYPE CLASSES
-- unsafePerformIO should be ok here, as those functions don't alter the key's state
-- ***

instance Show Key where
  show key = unsafePerformIO $ do
    name <- keyName key
    value <- keyString key
    ref <- keyGetRef key
    return $ name ++ " " ++ value ++ " " ++ (show ref)

instance Eq Key where
  key1 == key2 = unsafePerformIO $ fmap (== 0) $ keyCmp key1 key2

-- ***
-- ADDITIONAL HELPERS USEFUL IN HASKELL
-- ***

addFinalizer :: Key -> IO Key
addFinalizer (Key a) = addForeignPtrFinalizer keyDel a >> return (Key a)

ifKey :: IO a -> (Key -> IO a) -> Key -> IO a
ifKey f t k = keyPtrNull k >>= bool (t k) f

whenKey :: (Key -> IO ()) -> Key -> IO ()
whenKey w k = ifKey (return ()) w k

-- Temporarily increases the reference counter so e.g. a keyset will not take ownership so
-- Haskell's finalizer can run successfully afterwards
tmpRef :: Key -> IO Key
tmpRef k@(Key a) = keyIncRef k >> addForeignPtrFinalizer keyDecRefPtr a >> return (Key a)

foreign import ccall unsafe "Elektra/Key.chs.h &keyDel"
  keyDel :: C2HSImp.FunPtr ((C2HSImp.Ptr (Key)) -> (IO ()))

foreign import ccall unsafe "Elektra/Key.chs.h &keyDecRef"
  keyDecRefPtr :: C2HSImp.FunPtr ((C2HSImp.Ptr (Key)) -> (IO ()))

--
-- @file
--
-- @brief Key Haskell bindings
--
-- @copyright BSD License (see LICENSE.md or https://www.libelektra.org)
--
module Elektra.Key (
  Key (..), Namespace (..), ElektraKeyVarargs (KeyMetaName, KeyBinary, KeyComment, KeyOwner),
  keyNew, keyNewWithValue, keyNewWithFlagsAndValue,
  keyDup, keyCopy, keyClear,
  keyIncRef, keyDecRef, keyGetRef,
  keyName, keyGetNameSize, keySetName, keyAddName,
  keyUnescapedName, keyGetUnescapedNameSize,
  keyGetFullNameSize, keyGetFullName,
  keyBaseName, keyGetBaseName, keyGetBaseNameSize, keyAddBaseName, keySetBaseName, keyDeleteBaseName,
  keyGetNamespace,
  keyString, keyGetValueSize, keySetString, keySet,
  keyRewindMeta, keyNextMeta, keyCurrentMeta,
  keyCopyMeta, keyCopyAllMeta, keyGetMeta, keySetMeta, keyListMeta,
  keyCmp, keyNeedSync,
  keyIsBelow, keyIsDirectBelow,
  keyRel, keyIsInactive, keyIsBinary, keyIsString, keyPtrNull,
  ifKey, withKey, whenKey,
  tmpRef
) where

#include <kdb.h>
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Ptr (castPtr, nullPtr)
import Foreign.ForeignPtr (FinalizerPtr (..), withForeignPtr, addForeignPtrFinalizer)
import System.IO.Unsafe (unsafePerformIO)
import Data.Maybe (isJust, fromJust)
import Control.Monad (liftM, join)
import Data.Bool (bool)

{#context lib="libelektra" #}

-- ***
-- TYPE DEFINITIONS
-- ***

{#pointer *Key foreign newtype #}

{#typedef size_t Int#}
{#typedef ssize_t Int #}

{#enum KEY_NS_NONE as Namespace { underscoreToCase } deriving (Show, Eq) #}
{#enum KEY_NAME as ElektraKeyVarargs { underscoreToCase } deriving (Show, Eq) #}

data KeyNew = KeyNew { knKeyName :: Maybe String
                     , knKeyValue :: Maybe String
                     , knMeta :: [(String, String)]
                     , knKeySize :: Maybe Int
                     , knFlags :: [ElektraKeyVarargs]
                     } deriving (Show)

-- ***
-- KEY CREATION / DELETION / COPPY METHODS
-- ***

keyPtrNull :: Key -> IO Bool
keyPtrNull (Key ptr) = withForeignPtr ptr (return . (== nullPtr))

-- as we use haskell's reference counting here, increase the number by one
-- so it gets deleted properly when haskell calls the finalizer
keyNew :: String -> IO Key
keyNew name = keyNewRaw name KeyEnd >>= addFinalizer
keyNewWithValue :: String -> String -> IO Key
keyNewWithValue name value = keyNewRawWithValue name KeyValue value KeyEnd >>= addFinalizer
keyNewWithFlagsAndValue :: String -> ElektraKeyVarargs -> String -> IO Key
keyNewWithFlagsAndValue name flags value = keyNewRawWithFlagsAndValue name KeyFlags flags KeyValue value KeyEnd >>= addFinalizer
{#fun unsafe variadic keyNew[keyswitch_t] as keyNewRaw {`String', `ElektraKeyVarargs'} -> `Key' #}
{#fun unsafe variadic keyNew[keyswitch_t, const char *, keyswitch_t]
  as keyNewRawWithValue {`String', `ElektraKeyVarargs', `String', `ElektraKeyVarargs'} -> `Key' #}
{#fun unsafe variadic keyNew[keyswitch_t, keyswitch_t, keyswitch_t, const char *, keyswitch_t]
  as keyNewRawWithFlagsAndValue
    {`String', `ElektraKeyVarargs', `ElektraKeyVarargs', `ElektraKeyVarargs', `String', `ElektraKeyVarargs'}
    -> `Key' #}
keyDup :: Key -> IO Key
keyDup k = keyDupRaw k >>= addFinalizer
{#fun unsafe keyDup as keyDupRaw {`Key'} -> `Key' #}
{#fun unsafe keyCopy {`Key', `Key'} -> `Int' #}
{#fun unsafe keyClear {`Key'} -> `Int' #}
{#fun unsafe keyIncRef {`Key'} -> `Int' #}
{#fun unsafe keyDecRef {`Key'} -> `Int' #}
{#fun unsafe keyGetRef {`Key'} -> `Int' #}

-- ***
-- KEY NAME MANIPULATION METHODS
-- ***

{#fun unsafe keyName {`Key'} -> `String' #}
keyGetName = keyName
{#fun unsafe keyGetNameSize {`Key'} -> `Int' #}
keyUnescapedName :: Key -> IO String
keyUnescapedName key = do
  size <- keyGetUnescapedNameSize key
  withKey key $ (\cKey -> do
    result <- {#call unsafe keyUnescapedName as keyUnescapedNameRaw #} cKey
    C2HSImp.peekCStringLen (castPtr result, size))
{#fun unsafe keyGetUnescapedNameSize {`Key'} -> `Int' #}
{#fun unsafe keySetName {`Key', `String'} -> `Int' #}
keyGetFullName :: (Key) -> IO String
keyGetFullName key = do
  size <- keyGetFullNameSize key
  withKey key $ \cKey ->
    allocaBytes size (\result -> do
      {#call unsafe keyGetFullName as keyGetFullNameRaw #} cKey result size
      C2HSImp.peekCString result)
{#fun unsafe keyGetFullNameSize {`Key'} -> `Int' #}
{#fun unsafe keyBaseName {`Key'} -> `String' #}
keyGetBaseName :: Key -> IO String
keyGetBaseName = keyBaseName
{#fun unsafe keyGetBaseNameSize {`Key'} -> `Int' #}
{#fun unsafe keyAddBaseName {`Key', `String'} -> `Int' #}
{#fun unsafe keyAddName {`Key', `String'} -> `Int' #}
keySetBaseName :: Key -> String -> IO Int
keySetBaseName key baseName = keySetBaseNameRaw key (Just baseName)
keyDeleteBaseName :: Key -> IO Int
keyDeleteBaseName key = keySetBaseNameRaw key Nothing
keySetBaseNameRaw :: Key -> Maybe String -> IO Int
keySetBaseNameRaw key baseName = do
  withKey key $ \cKey -> if (isJust baseName)
    then C2HSImp.withCString (fromJust baseName) $ \cValue -> call cKey cValue
    else call cKey nullPtr
  where call cKey cValue = {#call unsafe keySetBaseName as keySetBaseNameRaw' #} cKey cValue
{#fun unsafe keyGetNamespace {`Key'} -> `Namespace' #}

-- ***
-- KEY VALUE MANIPULATION METHODS
-- ***

-- we don't handle binary data currently
-- {#fun unsafe keyValue {`Key'} -> `PPtr' #}
{#fun unsafe keyString {`Key'} -> `String' #}
{#fun unsafe keyGetValueSize {`Key'} -> `Int' #}
keySet :: Show a => Key -> a -> IO Int
keySet key = keySetString key . show
{#fun unsafe keySetString {`Key', `String'} -> `Int' #}

-- ***
-- KEY META MANIPULATION METHODS
-- ***

{#fun unsafe keyRewindMeta {`Key'} -> `Int' #}
{#fun unsafe keyNextMeta as keyNextMeta {`Key'} -> `Key' #}
{#fun unsafe keyCurrentMeta as keyCurrentMeta {`Key'} -> `Key' #}
{#fun unsafe keyCopyMeta {`Key', `Key', `String'} -> `Int' #}
{#fun unsafe keyCopyAllMeta {`Key', `Key'} -> `Int' #}
{#fun unsafe keyGetMeta as keyGetMeta {`Key', `String'} -> `Key' #}
{#fun unsafe keySetMeta {`Key', `String', `String'} -> `Int' #}
keyListMeta :: Key -> IO [Key]
keyListMeta key = keyRewindMeta key >> listMeta []
  where
    listMeta res = do
      cur <- keyNextMeta key
      isNull <- keyPtrNull cur
      if isNull then return res else liftM (cur :) (listMeta res)

-- ***
-- KEY TESTING METHODS
-- ***

{#fun unsafe keyCmp {`Key', `Key'} -> `Int' #}
{#fun unsafe keyNeedSync {`Key'} -> `Int' #}
{#fun unsafe keyIsBelow {`Key', `Key'} -> `Int' #}
{#fun unsafe keyIsDirectBelow {`Key', `Key'} -> `Int' #}
{#fun unsafe keyRel {`Key', `Key'} -> `Int' #}
{#fun unsafe keyIsInactive {`Key'} -> `Int' #}
{#fun unsafe keyIsBinary {`Key'} -> `Int' #}
{#fun unsafe keyIsString {`Key'} -> `Int' #}

-- ***
-- COMMON HASKELL TYPE CLASSES
-- unsafePerformIO should be ok here, as those functions don't alter the key's state
-- ***

instance Show Key where
  show key = unsafePerformIO $ do
    name <- keyName key
    value <- keyString key
    ref <- keyGetRef key
    return $ name ++ " " ++ value ++ " " ++ (show ref)

instance Eq Key where
  key1 == key2 = unsafePerformIO $ fmap (== 0) $ keyCmp key1 key2

-- ***
-- ADDITIONAL HELPERS USEFUL IN HASKELL
-- ***

addFinalizer :: Key -> IO Key
addFinalizer (Key a) = addForeignPtrFinalizer keyDel a >> return (Key a)

ifKey :: IO a -> (Key -> IO a) -> Key -> IO a
ifKey f t k = join $ bool (t k) f <$> keyPtrNull k

whenKey :: (Key -> IO ()) -> Key -> IO ()
whenKey w k = ifKey (return ()) w k

-- Temporarily increases the reference counter so e.g. a keyset will not take ownership so
-- Haskell's finalizer can run successfully afterwards
tmpRef :: Key -> IO Key
tmpRef k@(Key a) = keyIncRef k >> addForeignPtrFinalizer keyDecRefPtr a >> return (Key a)

foreign import ccall unsafe "Elektra/Key.chs.h &keyDel"
  keyDel :: C2HSImp.FunPtr ((C2HSImp.Ptr (Key)) -> (IO ()))

foreign import ccall unsafe "Elektra/Key.chs.h &keyDecRef"
  keyDecRefPtr :: C2HSImp.FunPtr ((C2HSImp.Ptr (Key)) -> (IO ()))


export the record constructors, useful for `choose'

Ignore-this: bc06b33f525749eeb33ab6d5cf2fb1a

darcs-hash:20090911024325-115f9-4ce6986a8febf209a345c936bb8863460cd62e84.gz

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Marshal
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- Device management routines
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Device
  (
    ComputeMode(..),
    DeviceFlags(..),
    DeviceProperties(..),

    -- ** Device management
    choose,
    get,
    count,
    props,
    set,
    setFlags,
    setOrder
  )
  where

import Foreign
import Foreign.C

import Foreign.CUDA.Error
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Internal.Offsets

#include "cbits/stubs.h"
#include <cuda_runtime_api.h>
{# context lib="cudart" #}

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

{# pointer *cudaDeviceProp as ^ foreign -> DeviceProperties nocode #}

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

-- |
-- Device execution flags
--
{# enum cudaDeviceFlags as DeviceFlags { }
    with prefix="cudaDeviceFlag" deriving (Eq, Show) #}

-- |
-- The properties of a compute device
--
data DeviceProperties = DeviceProperties
  {
    deviceName               :: String,         -- ^ Identifier
    computeCapability        :: Double,         -- ^ 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
    maxThreadsPerBlock       :: Int,            -- ^ Max number of threads per block
    maxThreadsDim            :: (Int,Int,Int),  -- ^ Max size of each dimension of a block
    maxGridSize              :: (Int,Int,Int),  -- ^ Max size of each dimension of a grid
    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
    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)

instance Storable DeviceProperties where
    sizeOf _    = {#sizeof cudaDeviceProp#}
    alignment _ = alignment (undefined :: Ptr ())

    peek p      = do
        gm <- cIntConv     `fmap` {#get cudaDeviceProp.totalGlobalMem#} p
        sm <- cIntConv     `fmap` {#get cudaDeviceProp.sharedMemPerBlock#} p
        rb <- cIntConv     `fmap` {#get cudaDeviceProp.regsPerBlock#} p
        ws <- cIntConv     `fmap` {#get cudaDeviceProp.warpSize#} p
        mp <- cIntConv     `fmap` {#get cudaDeviceProp.memPitch#} p
        tb <- cIntConv     `fmap` {#get cudaDeviceProp.maxThreadsPerBlock#} p
        cl <- cIntConv     `fmap` {#get cudaDeviceProp.clockRate#} p
        cm <- cIntConv     `fmap` {#get cudaDeviceProp.totalConstMem#} p
        v1 <- fromIntegral `fmap` {#get cudaDeviceProp.major#} p
        v2 <- fromIntegral `fmap` {#get cudaDeviceProp.minor#} p
        ta <- cIntConv     `fmap` {#get cudaDeviceProp.textureAlignment#} p
        ov <- cToBool      `fmap` {#get cudaDeviceProp.deviceOverlap#} p
        pc <- cIntConv     `fmap` {#get cudaDeviceProp.multiProcessorCount#} p
        ke <- cToBool      `fmap` {#get cudaDeviceProp.kernelExecTimeoutEnabled#} p
        tg <- cToBool      `fmap` {#get cudaDeviceProp.integrated#} p
        hm <- cToBool      `fmap` {#get cudaDeviceProp.canMapHostMemory#} p
        md <- cToEnum      `fmap` {#get cudaDeviceProp.computeMode#} p

        --
        -- C->Haskell returns the wrong type when accessing static arrays in
        -- structs, returning the dereferenced element but with a Ptr type. Work
        -- around this with manual pointer arithmetic...
        --
        n            <- peekCString (p `plusPtr` devNameOffset)
        (t1:t2:t3:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxThreadDimOffset :: Ptr CInt)
        (g1:g2:g3:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxGridSizeOffset  :: Ptr CInt)

        return DeviceProperties
            {
              deviceName               = n,
              computeCapability        = v1 + v2 / max 10 (10^ ((ceiling . logBase 10) v2 :: Int)),
              totalGlobalMem           = gm,
              totalConstMem            = cm,
              sharedMemPerBlock        = sm,
              regsPerBlock             = rb,
              warpSize                 = ws,
              maxThreadsPerBlock       = tb,
              maxThreadsDim            = (t1,t2,t3),
              maxGridSize              = (g1,g2,g3),
              clockRate                = cl,
              multiProcessorCount      = pc,
              memPitch                 = mp,
              textureAlignment         = ta,
              computeMode              = md,
              deviceOverlap            = ov,
              kernelExecTimeoutEnabled = ke,
              integrated               = tg,
              canMapHostMemory         = hm
            }

--------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------

-- |
-- Select the compute device which best matches the given criteria
--
choose     :: DeviceProperties -> IO (Either String Int)
choose dev =  resultIfOk `fmap` cudaChooseDevice dev

{# fun unsafe cudaChooseDevice
    { alloca-      `Int'              peekIntConv* ,
      withDevProp* `DeviceProperties'              } -> `Status' cToEnum #}
    where
        withDevProp = with

-- |
-- Returns which device is currently being used
--
get :: IO (Either String Int)
get =  resultIfOk `fmap` cudaGetDevice

{# fun unsafe cudaGetDevice
    { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}

-- |
-- Returns the number of devices available for execution, with compute
-- capability >= 1.0
--
count :: IO (Either String Int)
count =  resultIfOk `fmap` cudaGetDeviceCount

{# fun unsafe cudaGetDeviceCount
    { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}

-- |
-- Return information about the selected compute device
--
props   :: Int -> IO (Either String DeviceProperties)
props n =  resultIfOk `fmap` cudaGetDeviceProperties n

{# fun unsafe cudaGetDeviceProperties
    { alloca- `DeviceProperties' peek* ,
              `Int'                    } -> `Status' cToEnum #}

-- |
-- Set device to be used for GPU execution
--
set   :: Int -> IO (Maybe String)
set n =  nothingIfOk `fmap` cudaSetDevice n

{# fun unsafe cudaSetDevice
    { `Int' } -> `Status' cToEnum #}

-- |
-- Set flags to be used for device executions
--
setFlags   :: [DeviceFlags] -> IO (Maybe String)
setFlags f =  nothingIfOk `fmap` cudaSetDeviceFlags (combineBitMasks f)

{# fun unsafe cudaSetDeviceFlags
    { `Int' } -> `Status' cToEnum #}

-- |
-- Set list of devices for CUDA execution in priority order
--
setOrder   :: [Int] -> IO (Maybe String)
setOrder l =  nothingIfOk `fmap` cudaSetValidDevices l (length l)

{# fun unsafe cudaSetValidDevices
    { withArrayIntConv* `[Int]' ,
                        `Int'   } -> `Status' cToEnum #}
    where
        withArrayIntConv = withArray . map cIntConv

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Marshal
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- Device management routines
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Device
  (
    ComputeMode,
    DeviceFlags,
    DeviceProperties(..),

    -- ** Device management
    choose,
    get,
    count,
    props,
    set,
    setFlags,
    setOrder
  )
  where

import Foreign
import Foreign.C

import Foreign.CUDA.Error
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Internal.Offsets

#include "cbits/stubs.h"
#include <cuda_runtime_api.h>
{# context lib="cudart" #}

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

{# pointer *cudaDeviceProp as ^ foreign -> DeviceProperties nocode #}

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

-- |
-- Device execution flags
--
{# enum cudaDeviceFlags as DeviceFlags { }
    with prefix="cudaDeviceFlag" deriving (Eq, Show) #}

-- |
-- The properties of a compute device
--
data DeviceProperties = DeviceProperties
  {
    deviceName               :: String,         -- ^ Identifier
    computeCapability        :: Double,         -- ^ 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
    maxThreadsPerBlock       :: Int,            -- ^ Max number of threads per block
    maxThreadsDim            :: (Int,Int,Int),  -- ^ Max size of each dimension of a block
    maxGridSize              :: (Int,Int,Int),  -- ^ Max size of each dimension of a grid
    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
    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)

instance Storable DeviceProperties where
    sizeOf _    = {#sizeof cudaDeviceProp#}
    alignment _ = alignment (undefined :: Ptr ())

    peek p      = do
        gm <- cIntConv     `fmap` {#get cudaDeviceProp.totalGlobalMem#} p
        sm <- cIntConv     `fmap` {#get cudaDeviceProp.sharedMemPerBlock#} p
        rb <- cIntConv     `fmap` {#get cudaDeviceProp.regsPerBlock#} p
        ws <- cIntConv     `fmap` {#get cudaDeviceProp.warpSize#} p
        mp <- cIntConv     `fmap` {#get cudaDeviceProp.memPitch#} p
        tb <- cIntConv     `fmap` {#get cudaDeviceProp.maxThreadsPerBlock#} p
        cl <- cIntConv     `fmap` {#get cudaDeviceProp.clockRate#} p
        cm <- cIntConv     `fmap` {#get cudaDeviceProp.totalConstMem#} p
        v1 <- fromIntegral `fmap` {#get cudaDeviceProp.major#} p
        v2 <- fromIntegral `fmap` {#get cudaDeviceProp.minor#} p
        ta <- cIntConv     `fmap` {#get cudaDeviceProp.textureAlignment#} p
        ov <- cToBool      `fmap` {#get cudaDeviceProp.deviceOverlap#} p
        pc <- cIntConv     `fmap` {#get cudaDeviceProp.multiProcessorCount#} p
        ke <- cToBool      `fmap` {#get cudaDeviceProp.kernelExecTimeoutEnabled#} p
        tg <- cToBool      `fmap` {#get cudaDeviceProp.integrated#} p
        hm <- cToBool      `fmap` {#get cudaDeviceProp.canMapHostMemory#} p
        md <- cToEnum      `fmap` {#get cudaDeviceProp.computeMode#} p

        --
        -- C->Haskell returns the wrong type when accessing static arrays in
        -- structs, returning the dereferenced element but with a Ptr type. Work
        -- around this with manual pointer arithmetic...
        --
        n            <- peekCString (p `plusPtr` devNameOffset)
        (t1:t2:t3:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxThreadDimOffset :: Ptr CInt)
        (g1:g2:g3:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxGridSizeOffset  :: Ptr CInt)

        return DeviceProperties
            {
              deviceName               = n,
              computeCapability        = v1 + v2 / max 10 (10^ ((ceiling . logBase 10) v2 :: Int)),
              totalGlobalMem           = gm,
              totalConstMem            = cm,
              sharedMemPerBlock        = sm,
              regsPerBlock             = rb,
              warpSize                 = ws,
              maxThreadsPerBlock       = tb,
              maxThreadsDim            = (t1,t2,t3),
              maxGridSize              = (g1,g2,g3),
              clockRate                = cl,
              multiProcessorCount      = pc,
              memPitch                 = mp,
              textureAlignment         = ta,
              computeMode              = md,
              deviceOverlap            = ov,
              kernelExecTimeoutEnabled = ke,
              integrated               = tg,
              canMapHostMemory         = hm
            }

--------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------

-- |
-- Select the compute device which best matches the given criteria
--
choose     :: DeviceProperties -> IO (Either String Int)
choose dev =  resultIfOk `fmap` cudaChooseDevice dev

{# fun unsafe cudaChooseDevice
    { alloca-      `Int'              peekIntConv* ,
      withDevProp* `DeviceProperties'              } -> `Status' cToEnum #}
    where
        withDevProp = with

-- |
-- Returns which device is currently being used
--
get :: IO (Either String Int)
get =  resultIfOk `fmap` cudaGetDevice

{# fun unsafe cudaGetDevice
    { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}

-- |
-- Returns the number of devices available for execution, with compute
-- capability >= 1.0
--
count :: IO (Either String Int)
count =  resultIfOk `fmap` cudaGetDeviceCount

{# fun unsafe cudaGetDeviceCount
    { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}

-- |
-- Return information about the selected compute device
--
props   :: Int -> IO (Either String DeviceProperties)
props n =  resultIfOk `fmap` cudaGetDeviceProperties n

{# fun unsafe cudaGetDeviceProperties
    { alloca- `DeviceProperties' peek* ,
              `Int'                    } -> `Status' cToEnum #}

-- |
-- Set device to be used for GPU execution
--
set   :: Int -> IO (Maybe String)
set n =  nothingIfOk `fmap` cudaSetDevice n

{# fun unsafe cudaSetDevice
    { `Int' } -> `Status' cToEnum #}

-- |
-- Set flags to be used for device executions
--
setFlags   :: [DeviceFlags] -> IO (Maybe String)
setFlags f =  nothingIfOk `fmap` cudaSetDeviceFlags (combineBitMasks f)

{# fun unsafe cudaSetDeviceFlags
    { `Int' } -> `Status' cToEnum #}

-- |
-- Set list of devices for CUDA execution in priority order
--
setOrder   :: [Int] -> IO (Maybe String)
setOrder l =  nothingIfOk `fmap` cudaSetValidDevices l (length l)

{# fun unsafe cudaSetValidDevices
    { withArrayIntConv* `[Int]' ,
                        `Int'   } -> `Status' cToEnum #}
    where
        withArrayIntConv = withArray . map cIntConv