removed debug hPrint

removed debug hPrint

module PGSchedule () where

import Data.Time

import Foreign.C.Types
import Foreign.C.String
import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal.Alloc (free)
import Foreign.Marshal.Array (newArray)
import Data.ByteString.Unsafe (unsafePackCString)
import qualified Data.Text.Encoding as T
import Sigym4.Dimension.CronSchedule
import Sigym4.Dimension

#include "postgres.h"
#include "pgtime.h"
#include "schedule.h"

{#enum PGScheduleError {} deriving (Eq,Show) #}

newtype PGTime = PGTime UTCTime deriving Show

{#pointer * pg_tm as PGTime nocode#}

instance Storable PGTime where
  sizeOf _ = {#sizeof pg_tm #}
  alignment _ = {#alignof pg_tm #}
  peek = fmap PGTime . peekUTCTime
    where
      peekUTCTime p =
        UTCTime <$> peekDay p <*> (timeOfDayToTime <$> peekTimeOfDay p)
      peekDay p = do
        y <- (+1900) . fromIntegral <$> {#get pg_tm->tm_year#} p
        m <- (+1) . fromIntegral <$> {#get pg_tm->tm_mon#} p
        d <- fromIntegral <$> {#get pg_tm->tm_mday#} p
        return (fromGregorian y m d)
      peekTimeOfDay p = do
        h <- fromIntegral <$> {#get pg_tm->tm_hour#} p
        m <- fromIntegral <$> {#get pg_tm->tm_min#} p
        s <- fromIntegral <$> {#get pg_tm->tm_sec#} p
        return (TimeOfDay h m s)

  poke p (PGTime (UTCTime day time)) = do
    let (TimeOfDay h m s) = timeToTimeOfDay time
    {#set pg_tm->tm_sec#} p (round s)
    {#set pg_tm->tm_min#} p (fromIntegral m)
    {#set pg_tm->tm_hour#} p (fromIntegral h)
    let (y,mth,d) = toGregorian day
    {#set pg_tm->tm_mday#} p (fromIntegral d)
    {#set pg_tm->tm_mon#} p (fromIntegral mth - 1)
    {#set pg_tm->tm_year#} p (fromIntegral y - 1900)
    {#set pg_tm->tm_wday#} p 0
    {#set pg_tm->tm_yday#} p 0
    {#set pg_tm->tm_isdst#} p 0
    {#set pg_tm->tm_gmtoff#} p 0
    {#set pg_tm->tm_zone#} p nullPtr --We won't be able to free anything we allocate here so we dont

returnStatus :: PGScheduleError -> IO CInt
returnStatus = return . fromIntegral . fromEnum

pg_schedule_parse :: CString -> IO CInt
pg_schedule_parse s = do
  t <- T.decodeUtf8 <$> unsafePackCString s
  returnStatus $ either (const INVALID_SCHEDULE_FORMAT) (const NO_ERROR) (mkCronSchedule t)
foreign export ccall pg_schedule_parse :: CString -> IO CInt

withSchedule :: CString -> (CronSchedule -> IO PGScheduleError) -> IO CInt
withSchedule s f = do
  t <- T.decodeUtf8 <$> unsafePackCString s
  case mkCronSchedule t of
    Right sched -> fromIntegral . fromEnum <$> f sched
    Left _ -> do
      -- Should not happen since type is 'schedule' so it has already been parsed
      -- properly by pg_schedule_parse
      returnStatus INVALID_SCHEDULE_FORMAT

pg_schedule_contains :: CString -> Ptr PGTime -> Ptr CInt -> IO CInt
pg_schedule_contains s dtPtr resPtr = withSchedule s $ \sched -> do
  PGTime dt <- peek dtPtr
  poke resPtr (if idelem sched dt then 1 else 0)
  pure NO_ERROR
foreign export ccall pg_schedule_contains :: CString -> Ptr PGTime -> Ptr CInt -> IO CInt

pg_schedule_next :: CString -> Ptr PGTime -> Ptr PGTime -> IO CInt
pg_schedule_next s dtPtr resPtr = withSchedule s $ \sched -> do
  PGTime dt <- peek dtPtr
  let result = idsucc sched =<< idfloor sched dt
  maybe (pure NO_RESULT) (\n -> poke resPtr (PGTime (unQ n)) >> pure NO_ERROR) result
foreign export ccall pg_schedule_next :: CString -> Ptr PGTime -> Ptr PGTime -> IO CInt

pg_schedule_previous :: CString -> Ptr PGTime -> Ptr PGTime -> IO CInt
pg_schedule_previous s dtPtr resPtr = withSchedule s $ \sched -> do
  PGTime dt <- peek dtPtr
  let result = idpred sched =<< idceiling sched dt
  maybe (pure NO_RESULT) (\n -> poke resPtr (PGTime (unQ n)) >> pure NO_ERROR) result
foreign export ccall pg_schedule_previous :: CString -> Ptr PGTime -> Ptr PGTime -> IO CInt

pg_schedule_floor :: CString -> Ptr PGTime -> Ptr PGTime -> IO CInt
pg_schedule_floor s dtPtr resPtr = withSchedule s $ \sched -> do
  PGTime dt <- peek dtPtr
  let result = idfloor sched dt
  maybe (pure NO_RESULT) (\n -> poke resPtr (PGTime (unQ n)) >> pure NO_ERROR) result
foreign export ccall pg_schedule_floor :: CString -> Ptr PGTime -> Ptr PGTime -> IO CInt

pg_schedule_ceiling :: CString -> Ptr PGTime -> Ptr PGTime -> IO CInt
pg_schedule_ceiling s dtPtr resPtr = withSchedule s $ \sched -> do
  PGTime dt <- peek dtPtr
  let result = idceiling sched dt
  maybe (pure NO_RESULT) (\n -> poke resPtr (PGTime (unQ n)) >> pure NO_ERROR) result
foreign export ccall pg_schedule_ceiling :: CString -> Ptr PGTime -> Ptr PGTime -> IO CInt

pg_schedule_series :: CString -> Ptr PGTime -> Ptr PGTime -> Ptr (Ptr PGTime) -> Ptr CInt -> IO CInt
pg_schedule_series s fromPtr toPtr resPtr countPtr = withSchedule s $ \sched -> do
  PGTime dtFrom <- peek fromPtr
  PGTime dtTo <- peek toPtr
  let series = map PGTime
             . takeWhile (<= dtTo)
             . map unQ
             $ idenumUp sched dtFrom
  poke resPtr =<< newArray series
  poke countPtr (fromIntegral (length series))
  return NO_ERROR
foreign export ccall pg_schedule_series :: CString -> Ptr PGTime -> Ptr PGTime -> Ptr (Ptr PGTime) -> Ptr CInt -> IO CInt

pg_schedule_free_series :: Ptr PGTime -> IO ()
pg_schedule_free_series = free
foreign export ccall pg_schedule_free_series :: Ptr PGTime -> IO ()

module PGSchedule () where

import Data.Time

import Foreign.C.Types
import Foreign.C.String
import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal.Alloc (free)
import Foreign.Marshal.Array (newArray)
import Data.ByteString.Unsafe (unsafePackCString)
import qualified Data.Text.Encoding as T
import System.IO
import Sigym4.Dimension.CronSchedule
import Sigym4.Dimension

#include "postgres.h"
#include "pgtime.h"
#include "schedule.h"

{#enum PGScheduleError {} deriving (Eq,Show) #}

newtype PGTime = PGTime UTCTime deriving Show

{#pointer * pg_tm as PGTime nocode#}

instance Storable PGTime where
  sizeOf _ = {#sizeof pg_tm #}
  alignment _ = {#alignof pg_tm #}
  peek = fmap PGTime . peekUTCTime
    where
      peekUTCTime p =
        UTCTime <$> peekDay p <*> (timeOfDayToTime <$> peekTimeOfDay p)
      peekDay p = do
        y <- (+1900) . fromIntegral <$> {#get pg_tm->tm_year#} p
        m <- (+1) . fromIntegral <$> {#get pg_tm->tm_mon#} p
        d <- fromIntegral <$> {#get pg_tm->tm_mday#} p
        return (fromGregorian y m d)
      peekTimeOfDay p = do
        h <- fromIntegral <$> {#get pg_tm->tm_hour#} p
        m <- fromIntegral <$> {#get pg_tm->tm_min#} p
        s <- fromIntegral <$> {#get pg_tm->tm_sec#} p
        return (TimeOfDay h m s)

  poke p (PGTime (UTCTime day time)) = do
    let (TimeOfDay h m s) = timeToTimeOfDay time
    {#set pg_tm->tm_sec#} p (round s)
    {#set pg_tm->tm_min#} p (fromIntegral m)
    {#set pg_tm->tm_hour#} p (fromIntegral h)
    let (y,mth,d) = toGregorian day
    {#set pg_tm->tm_mday#} p (fromIntegral d)
    {#set pg_tm->tm_mon#} p (fromIntegral mth - 1)
    {#set pg_tm->tm_year#} p (fromIntegral y - 1900)
    {#set pg_tm->tm_wday#} p 0
    {#set pg_tm->tm_yday#} p 0
    {#set pg_tm->tm_isdst#} p 0
    {#set pg_tm->tm_gmtoff#} p 0
    {#set pg_tm->tm_zone#} p nullPtr --We won't be able to free anything we allocate here so we dont

returnStatus :: PGScheduleError -> IO CInt
returnStatus = return . fromIntegral . fromEnum

pg_schedule_parse :: CString -> IO CInt
pg_schedule_parse s = do
  t <- T.decodeUtf8 <$> unsafePackCString s
  returnStatus $ either (const INVALID_SCHEDULE_FORMAT) (const NO_ERROR) (mkCronSchedule t)
foreign export ccall pg_schedule_parse :: CString -> IO CInt

withSchedule :: CString -> (CronSchedule -> IO PGScheduleError) -> IO CInt
withSchedule s f = do
  t <- T.decodeUtf8 <$> unsafePackCString s
  case mkCronSchedule t of
    Right sched -> fromIntegral . fromEnum <$> f sched
    Left _ -> do
      -- Should not happen since type is 'schedule' so it has already been parsed
      -- properly by pg_schedule_parse
      returnStatus INVALID_SCHEDULE_FORMAT

pg_schedule_contains :: CString -> Ptr PGTime -> Ptr CInt -> IO CInt
pg_schedule_contains s dtPtr resPtr = withSchedule s $ \sched -> do
  PGTime dt <- peek dtPtr
  poke resPtr (if idelem sched dt then 1 else 0)
  pure NO_ERROR
foreign export ccall pg_schedule_contains :: CString -> Ptr PGTime -> Ptr CInt -> IO CInt

pg_schedule_next :: CString -> Ptr PGTime -> Ptr PGTime -> IO CInt
pg_schedule_next s dtPtr resPtr = withSchedule s $ \sched -> do
  PGTime dt <- peek dtPtr
  let result = idsucc sched =<< idfloor sched dt
  maybe (pure NO_RESULT) (\n -> poke resPtr (PGTime (unQ n)) >> pure NO_ERROR) result
foreign export ccall pg_schedule_next :: CString -> Ptr PGTime -> Ptr PGTime -> IO CInt

pg_schedule_previous :: CString -> Ptr PGTime -> Ptr PGTime -> IO CInt
pg_schedule_previous s dtPtr resPtr = withSchedule s $ \sched -> do
  PGTime dt <- peek dtPtr
  let result = idpred sched =<< idceiling sched dt
  maybe (pure NO_RESULT) (\n -> poke resPtr (PGTime (unQ n)) >> pure NO_ERROR) result
foreign export ccall pg_schedule_previous :: CString -> Ptr PGTime -> Ptr PGTime -> IO CInt

pg_schedule_floor :: CString -> Ptr PGTime -> Ptr PGTime -> IO CInt
pg_schedule_floor s dtPtr resPtr = withSchedule s $ \sched -> do
  PGTime dt <- peek dtPtr
  let result = idfloor sched dt
  maybe (pure NO_RESULT) (\n -> poke resPtr (PGTime (unQ n)) >> pure NO_ERROR) result
foreign export ccall pg_schedule_floor :: CString -> Ptr PGTime -> Ptr PGTime -> IO CInt

pg_schedule_ceiling :: CString -> Ptr PGTime -> Ptr PGTime -> IO CInt
pg_schedule_ceiling s dtPtr resPtr = withSchedule s $ \sched -> do
  PGTime dt <- peek dtPtr
  let result = idceiling sched dt
  maybe (pure NO_RESULT) (\n -> poke resPtr (PGTime (unQ n)) >> pure NO_ERROR) result
foreign export ccall pg_schedule_ceiling :: CString -> Ptr PGTime -> Ptr PGTime -> IO CInt

pg_schedule_series :: CString -> Ptr PGTime -> Ptr PGTime -> Ptr (Ptr PGTime) -> Ptr CInt -> IO CInt
pg_schedule_series s fromPtr toPtr resPtr countPtr = withSchedule s $ \sched -> do
  PGTime dtFrom <- peek fromPtr
  PGTime dtTo <- peek toPtr
  let series = map PGTime
             . takeWhile (<= dtTo)
             . map unQ
             $ idenumUp sched dtFrom
  hPrint stderr (dtFrom, dtTo, series)
  poke resPtr =<< newArray series
  poke countPtr (fromIntegral (length series))
  return NO_ERROR
foreign export ccall pg_schedule_series :: CString -> Ptr PGTime -> Ptr PGTime -> Ptr (Ptr PGTime) -> Ptr CInt -> IO CInt

pg_schedule_free_series :: Ptr PGTime -> IO ()
pg_schedule_free_series = free
foreign export ccall pg_schedule_free_series :: Ptr PGTime -> IO ()


[project @ 2005-02-13 16:59:11 by as49] Remove this file which was renamed to Image.chs.pp.

-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget Image
--
--  Author : Axel Simon
--
--  Created: 23 May 2001
--
--  Version $Revision: 1.3 $ from $Date: 2005/02/13 16:25:56 $
--
--  Copyright (C) 2001-2005 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 widget displays an image.
--
--
-- * Because Haskell is not the best language to modify large images directly
--   only functions are bound that allow loading images from disc or by stock
--   names.
--
-- * Another function for extracting the 'Pixbuf' is added for
--   'CellRenderer'.
--
-- TODO
--
-- * Figure out what other functions are useful within Haskell. Maybe we should
--   support loading Pixmaps without exposing them.
--
module Graphics.UI.Gtk.Display.Image (
  Image,
  ImageClass,
  castToImage,
  imageNewFromFile,
  IconSize,
  iconSizeMenu,
  iconSizeSmallToolbar,
  iconSizeLargeToolbar,
  iconSizeButton,
  iconSizeDialog,
  imageNewFromStock,
  imageGetPixbuf,
  imageSetFromPixbuf,
  imageNewFromPixbuf
  ) where

import Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
import System.Glib.GObject		(makeNewGObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Signals#}
import Graphics.UI.Gtk.General.Structs	(IconSize, iconSizeInvalid, iconSizeMenu,
					 iconSizeSmallToolbar, iconSizeLargeToolbar,
					 iconSizeButton, iconSizeDialog)

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

-- methods

-- | Create an image by loading a file.
--
imageNewFromFile :: FilePath -> IO Image
imageNewFromFile path = makeNewObject mkImage $ liftM castPtr $

  withUTFString path {#call unsafe image_new_from_file#}

-- | Create a set of images by specifying a stock
-- object.
--
imageNewFromStock :: String -> IconSize -> IO Image
imageNewFromStock stock ic = withUTFString stock $ \strPtr ->
  makeNewObject mkImage $ liftM castPtr $ {#call unsafe image_new_from_stock#}
  strPtr (fromIntegral ic)

-- | Extract the Pixbuf from the 'Image'.
--
imageGetPixbuf :: Image -> IO Pixbuf
imageGetPixbuf img = makeNewGObject mkPixbuf $ liftM castPtr $
  throwIfNull "Image.imageGetPixbuf: The image contains no Pixbuf object." $
  {#call unsafe image_get_pixbuf#} img

-- | Overwrite the current content of the 'Image' with a new 'Pixbuf'.
--
imageSetFromPixbuf :: Image -> Pixbuf -> IO ()
imageSetFromPixbuf img pb = {#call unsafe gtk_image_set_from_pixbuf#} img pb

-- | Create an 'Image' from a
-- 'Pixbuf'.
--
imageNewFromPixbuf :: Pixbuf -> IO Image
imageNewFromPixbuf pbuf = makeNewObject mkImage $ liftM castPtr $
  {#call unsafe image_new_from_pixbuf#} pbuf


Added support for sharing an OpenGL context with OpenCL.

{- Copyright (c) 2011 Luis Cabellos,

All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of  nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-}
{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, CPP #-}
module Control.Parallel.OpenCL.Context(
  -- * Types
  CLContext, CLContextProperty(..),
  -- * Context Functions
  clCreateContext, clCreateContextFromType, clRetainContext, clReleaseContext,
  clGetContextReferenceCount, clGetContextDevices, clGetContextProperties )
    where

-- -----------------------------------------------------------------------------
import Foreign(
  Ptr, FunPtr, nullPtr, castPtr, alloca, allocaArray, peek, peekArray,
  ptrToIntPtr, intPtrToPtr, withArray )
import Foreign.C.Types( CSize )
import Foreign.C.String( CString, peekCString )
import Foreign.Storable( sizeOf )
import Control.Parallel.OpenCL.Types(
  CLuint, CLint, CLDeviceType_, CLContextInfo_, CLContextProperty_, CLDeviceID,
  CLContext, CLDeviceType, CLPlatformID, bitmaskFromFlags, getCLValue, getEnumCL,
  whenSuccess, wrapCheckSuccess, wrapPError, wrapGetInfo )

#ifdef __APPLE__
#include <OpenCL/opencl.h>
#else
#include <CL/cl.h>
#endif

-- -----------------------------------------------------------------------------
type ContextCallback = CString -> Ptr () -> CSize -> Ptr () -> IO ()
foreign import CALLCONV "wrapper" wrapContextCallback ::
  ContextCallback -> IO (FunPtr ContextCallback)
foreign import CALLCONV "clCreateContext" raw_clCreateContext ::
  Ptr CLContextProperty_ -> CLuint -> Ptr CLDeviceID -> FunPtr ContextCallback ->
  Ptr () -> Ptr CLint -> IO CLContext
foreign import CALLCONV "clCreateContextFromType" raw_clCreateContextFromType ::
  Ptr CLContextProperty_ -> CLDeviceType_ -> FunPtr ContextCallback ->
  Ptr () -> Ptr CLint -> IO CLContext
foreign import CALLCONV "clRetainContext" raw_clRetainContext ::
  CLContext -> IO CLint
foreign import CALLCONV "clReleaseContext" raw_clReleaseContext ::
  CLContext -> IO CLint
foreign import CALLCONV "clGetContextInfo" raw_clGetContextInfo ::
  CLContext -> CLContextInfo_ -> CSize -> Ptr () -> Ptr CSize -> IO CLint

-- -----------------------------------------------------------------------------
#c
enum CLContextProperties {
  cL_CONTEXT_PLATFORM_=CL_CONTEXT_PLATFORM,
#ifdef __APPLE__
  cL_CGL_SHAREGROUP_KHR_=CL_CONTEXT_PROPERTY_USE_CGL_SHAREGROUP_APPLE
#else
  cL_GL_CONTEXT_KHR_=CL_GL_CONTEXT_KHR,
  cL_EGL_DISPLAY_KHR_=CL_EGL_DISPLAY_KHR,
  cL_GLX_DISPLAY_KHR_=CL_GLX_DISPLAY_KHR,
  cL_WGL_HDC_KHR_=CL_WGL_HDC_KHR,
  cL_CGL_SHAREGROUP_KHR_=CL_CGL_SHAREGROUP_KHR
#endif
  };
#endc
{#enum CLContextProperties {upcaseFirstLetter} #}

-- | Specifies a context property name and its corresponding value.
data CLContextProperty = CL_CONTEXT_PLATFORM CLPlatformID
                         -- ^ Specifies the platform to use.
                       | CL_CGL_SHAREGROUP_KHR (Ptr ())
                         -- ^ Specifies the CGL share group to use.
#ifndef __APPLE__
                       | CL_GL_CONTEXT_KHR (Ptr ())
                       | CL_EGL_DISPLAY_KHR (Ptr ())
                       | CL_GLX_DISPLAY_KHR (Ptr ())
                       | CL_WGL_HDC_KHR (Ptr ())
#endif
                       deriving( Show )

packProperty :: CLContextProperty -> [CLContextProperty_]
packProperty (CL_CONTEXT_PLATFORM pid)   = [ getCLValue CL_CONTEXT_PLATFORM_
                                           , fromIntegral . ptrToIntPtr $ pid ]
packProperty (CL_CGL_SHAREGROUP_KHR ptr) = [ getCLValue CL_CGL_SHAREGROUP_KHR_
                                           , fromIntegral . ptrToIntPtr $ ptr ]
#ifndef __APPLE__
packProperty (CL_GL_CONTEXT_KHR ptr)     = [ getCLValue CL_GL_CONTEXT_KHR_
                                           , fromIntegral . ptrToIntPtr $ ptr ]
packProperty (CL_EGL_DISPLAY_KHR ptr)    = [ getCLValue CL_EGL_DISPLAY_KHR_
                                           , fromIntegral . ptrToIntPtr $ ptr ]
packProperty (CL_GLX_DISPLAY_KHR ptr)    = [ getCLValue CL_GLX_DISPLAY_KHR_
                                           , fromIntegral . ptrToIntPtr $ ptr ]
packProperty (CL_WGL_HDC_KHR ptr)        = [ getCLValue CL_WGL_HDC_KHR_
                                           , fromIntegral . ptrToIntPtr $ ptr ]
#endif

packContextProperties :: [CLContextProperty] -> [CLContextProperty_]
packContextProperties [] = [0]
packContextProperties (x:xs) = packProperty x ++ packContextProperties xs

unpackContextProperties :: [CLContextProperty_] -> [CLContextProperty]
unpackContextProperties [] = error "non-exhaustive Context Property list"
unpackContextProperties [x]
  | x == 0 = []
  | otherwise = error "non-exhaustive Context Property list"
unpackContextProperties (x:y:xs) = let ys = unpackContextProperties xs
                                   in case getEnumCL x of
                                     CL_CONTEXT_PLATFORM_
                                       -> CL_CONTEXT_PLATFORM
                                          (intPtrToPtr . fromIntegral $ y) : ys
                                     CL_CGL_SHAREGROUP_KHR_
                                       -> CL_CGL_SHAREGROUP_KHR
                                          (intPtrToPtr . fromIntegral $ y) : ys

-- -----------------------------------------------------------------------------
mkContextCallback :: (String -> IO ()) -> ContextCallback
mkContextCallback f msg _ _ _ = peekCString msg >>= f

-- | Creates an OpenCL context.
-- An OpenCL context is created with one or more devices. Contexts are used by
-- the OpenCL runtime for managing objects such as command-queues, memory,
-- program and kernel objects and for executing kernels on one or more devices
-- specified in the context.
clCreateContext :: [CLContextProperty] -> [CLDeviceID] -> (String -> IO ())
                   -> IO CLContext
clCreateContext [] devs f = withArray devs $ \pdevs ->
  wrapPError $ \perr -> do
    fptr <- wrapContextCallback $ mkContextCallback f
    raw_clCreateContext nullPtr cndevs pdevs fptr nullPtr perr
    where
      cndevs = fromIntegral . length $ devs
clCreateContext props devs f = withArray devs $ \pdevs ->
  wrapPError $ \perr -> do
    fptr <- wrapContextCallback $ mkContextCallback f
    withArray (packContextProperties props) $ \pprops ->
      raw_clCreateContext pprops cndevs pdevs fptr nullPtr perr
    where
      cndevs = fromIntegral . length $ devs

-- | Create an OpenCL context from a device type that identifies the specific
-- device(s) to use.
clCreateContextFromType :: [CLContextProperty] -> [CLDeviceType]
                           -> (String -> IO ()) -> IO CLContext
clCreateContextFromType [] xs f = wrapPError $ \perr -> do
  fptr <- wrapContextCallback $ mkContextCallback f
  raw_clCreateContextFromType nullPtr types fptr nullPtr perr
    where
      types = bitmaskFromFlags xs
clCreateContextFromType props xs f = wrapPError $ \perr -> do
  fptr <- wrapContextCallback $ mkContextCallback f
  withArray (packContextProperties props) $ \pprops ->
    raw_clCreateContextFromType pprops types fptr nullPtr perr
    where
      types = bitmaskFromFlags xs

-- | Increment the context reference count.
-- 'clCreateContext' and 'clCreateContextFromType' perform an implicit retain.
-- This is very helpful for 3rd party libraries, which typically get a context
-- passed to them by the application. However, it is possible that the
-- application may delete the context without informing the library. Allowing
-- functions to attach to (i.e. retain) and release a context solves the
-- problem of a context being used by a library no longer being valid.
-- Returns 'True' if the function is executed successfully, or 'False' if
-- context is not a valid OpenCL context.
clRetainContext :: CLContext -> IO Bool
clRetainContext ctx = wrapCheckSuccess $ raw_clRetainContext ctx

-- | Decrement the context reference count.
-- After the context reference count becomes zero and all the objects attached
-- to context (such as memory objects, command-queues) are released, the
-- context is deleted.
-- Returns 'True' if the function is executed successfully, or 'False' if
-- context is not a valid OpenCL context.
clReleaseContext :: CLContext -> IO Bool
clReleaseContext ctx = wrapCheckSuccess $ raw_clReleaseContext ctx

getContextInfoSize :: CLContext -> CLContextInfo_ -> IO CSize
getContextInfoSize ctx infoid = alloca $ \(value_size :: Ptr CSize) -> do
  whenSuccess (raw_clGetContextInfo ctx infoid 0 nullPtr value_size)
    $ peek value_size

#c
enum CLContextInfo {
  cL_CONTEXT_REFERENCE_COUNT=CL_CONTEXT_REFERENCE_COUNT,
  cL_CONTEXT_DEVICES=CL_CONTEXT_DEVICES,
  cL_CONTEXT_PROPERTIES=CL_CONTEXT_PROPERTIES
  };
#endc
{#enum CLContextInfo {upcaseFirstLetter} #}

-- | Return the context 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.
--
-- This function execute OpenCL clGetContextInfo with 'CL_CONTEXT_REFERENCE_COUNT'.
clGetContextReferenceCount :: CLContext -> IO CLuint
clGetContextReferenceCount ctx =
    wrapGetInfo (\(dat :: Ptr CLuint) ->
        raw_clGetContextInfo ctx infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_CONTEXT_REFERENCE_COUNT
      size = fromIntegral $ sizeOf (0::CLuint)

-- | Return the list of devices in context.
--
-- This function execute OpenCL clGetContextInfo with 'CL_CONTEXT_DEVICES'.
clGetContextDevices :: CLContext -> IO [CLDeviceID]
clGetContextDevices ctx = do
  size <- getContextInfoSize ctx infoid
  let n = (fromIntegral size) `div` elemSize

  allocaArray n $ \(buff :: Ptr CLDeviceID) -> do
    whenSuccess (raw_clGetContextInfo ctx infoid size (castPtr buff) nullPtr)
      $ peekArray n buff
    where
      infoid = getCLValue CL_CONTEXT_DEVICES
      elemSize = sizeOf (nullPtr :: CLDeviceID)

clGetContextProperties :: CLContext -> IO [CLContextProperty]
clGetContextProperties ctx = do
  size <- getContextInfoSize ctx infoid
  let n = (fromIntegral size) `div` elemSize

  if n == 0
    then return []
    else allocaArray n $ \(buff :: Ptr CLContextProperty_) ->
      whenSuccess (raw_clGetContextInfo ctx infoid size (castPtr buff) nullPtr)
        $ fmap unpackContextProperties $ peekArray n buff
    where
      infoid = getCLValue CL_CONTEXT_PROPERTIES
      elemSize = sizeOf (nullPtr :: CLDeviceID)

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

{- Copyright (c) 2011 Luis Cabellos,

All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of  nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-}
{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, CPP #-}
module Control.Parallel.OpenCL.Context(
  -- * Types
  CLContext, CLContextProperty(..),
  -- * Context Functions
  clCreateContext, clCreateContextFromType, clRetainContext, clReleaseContext,
  clGetContextReferenceCount, clGetContextDevices, clGetContextProperties )
    where

-- -----------------------------------------------------------------------------
import Foreign(
  Ptr, FunPtr, nullPtr, castPtr, alloca, allocaArray, peek, peekArray,
  ptrToIntPtr, intPtrToPtr, withArray )
import Foreign.C.Types( CSize )
import Foreign.C.String( CString, peekCString )
import Foreign.Storable( sizeOf )
import Control.Parallel.OpenCL.Types(
  CLuint, CLint, CLDeviceType_, CLContextInfo_, CLContextProperty_, CLDeviceID,
  CLContext, CLDeviceType, CLPlatformID, bitmaskFromFlags, getCLValue, getEnumCL,
  whenSuccess, wrapCheckSuccess, wrapPError, wrapGetInfo )

#ifdef __APPLE__
#include <OpenCL/opencl.h>
#else
#include <CL/cl.h>
#endif

-- -----------------------------------------------------------------------------
type ContextCallback = CString -> Ptr () -> CSize -> Ptr () -> IO ()
foreign import CALLCONV "wrapper" wrapContextCallback ::
  ContextCallback -> IO (FunPtr ContextCallback)
foreign import CALLCONV "clCreateContext" raw_clCreateContext ::
  Ptr CLContextProperty_ -> CLuint -> Ptr CLDeviceID -> FunPtr ContextCallback ->
  Ptr () -> Ptr CLint -> IO CLContext
foreign import CALLCONV "clCreateContextFromType" raw_clCreateContextFromType ::
  Ptr CLContextProperty_ -> CLDeviceType_ -> FunPtr ContextCallback ->
  Ptr () -> Ptr CLint -> IO CLContext
foreign import CALLCONV "clRetainContext" raw_clRetainContext ::
  CLContext -> IO CLint
foreign import CALLCONV "clReleaseContext" raw_clReleaseContext ::
  CLContext -> IO CLint
foreign import CALLCONV "clGetContextInfo" raw_clGetContextInfo ::
  CLContext -> CLContextInfo_ -> CSize -> Ptr () -> Ptr CSize -> IO CLint

-- -----------------------------------------------------------------------------
#c
enum CLContextProperties {
  cL_CONTEXT_PLATFORM_=CL_CONTEXT_PLATFORM,
  };
#endc
{#enum CLContextProperties {upcaseFirstLetter} #}

-- | Specifies a context property name and its corresponding value.
data CLContextProperty = CL_CONTEXT_PLATFORM CLPlatformID
                         -- ^ Specifies the platform to use.
                       deriving( Show )

packContextProperties :: [CLContextProperty] -> [CLContextProperty_]
packContextProperties [] = [0]
packContextProperties (CL_CONTEXT_PLATFORM pid : xs) = getCLValue CL_CONTEXT_PLATFORM_
                                                       : (fromIntegral . ptrToIntPtr $ pid)
                                                       : packContextProperties xs

unpackContextProperties :: [CLContextProperty_] -> [CLContextProperty]
unpackContextProperties [] = error "non-exhaustive Context Property list"
unpackContextProperties [x]
  | x == 0 = []
  | otherwise = error "non-exhaustive Context Property list"
unpackContextProperties (x:y:xs) = let ys = unpackContextProperties xs
                                   in case getEnumCL x of
                                     CL_CONTEXT_PLATFORM_
                                       -> CL_CONTEXT_PLATFORM
                                          (intPtrToPtr . fromIntegral $ y) : ys

-- -----------------------------------------------------------------------------
mkContextCallback :: (String -> IO ()) -> ContextCallback
mkContextCallback f msg _ _ _ = peekCString msg >>= f

-- | Creates an OpenCL context.
-- An OpenCL context is created with one or more devices. Contexts are used by
-- the OpenCL runtime for managing objects such as command-queues, memory,
-- program and kernel objects and for executing kernels on one or more devices
-- specified in the context.
clCreateContext :: [CLContextProperty] -> [CLDeviceID] -> (String -> IO ())
                   -> IO CLContext
clCreateContext [] devs f = withArray devs $ \pdevs ->
  wrapPError $ \perr -> do
    fptr <- wrapContextCallback $ mkContextCallback f
    raw_clCreateContext nullPtr cndevs pdevs fptr nullPtr perr
    where
      cndevs = fromIntegral . length $ devs
clCreateContext props devs f = withArray devs $ \pdevs ->
  wrapPError $ \perr -> do
    fptr <- wrapContextCallback $ mkContextCallback f
    withArray (packContextProperties props) $ \pprops ->
      raw_clCreateContext pprops cndevs pdevs fptr nullPtr perr
    where
      cndevs = fromIntegral . length $ devs

-- | Create an OpenCL context from a device type that identifies the specific
-- device(s) to use.
clCreateContextFromType :: [CLContextProperty] -> [CLDeviceType]
                           -> (String -> IO ()) -> IO CLContext
clCreateContextFromType [] xs f = wrapPError $ \perr -> do
  fptr <- wrapContextCallback $ mkContextCallback f
  raw_clCreateContextFromType nullPtr types fptr nullPtr perr
    where
      types = bitmaskFromFlags xs
clCreateContextFromType props xs f = wrapPError $ \perr -> do
  fptr <- wrapContextCallback $ mkContextCallback f
  withArray (packContextProperties props) $ \pprops ->
    raw_clCreateContextFromType pprops types fptr nullPtr perr
    where
      types = bitmaskFromFlags xs

-- | Increment the context reference count.
-- 'clCreateContext' and 'clCreateContextFromType' perform an implicit retain.
-- This is very helpful for 3rd party libraries, which typically get a context
-- passed to them by the application. However, it is possible that the
-- application may delete the context without informing the library. Allowing
-- functions to attach to (i.e. retain) and release a context solves the
-- problem of a context being used by a library no longer being valid.
-- Returns 'True' if the function is executed successfully, or 'False' if
-- context is not a valid OpenCL context.
clRetainContext :: CLContext -> IO Bool
clRetainContext ctx = wrapCheckSuccess $ raw_clRetainContext ctx

-- | Decrement the context reference count.
-- After the context reference count becomes zero and all the objects attached
-- to context (such as memory objects, command-queues) are released, the
-- context is deleted.
-- Returns 'True' if the function is executed successfully, or 'False' if
-- context is not a valid OpenCL context.
clReleaseContext :: CLContext -> IO Bool
clReleaseContext ctx = wrapCheckSuccess $ raw_clReleaseContext ctx

getContextInfoSize :: CLContext -> CLContextInfo_ -> IO CSize
getContextInfoSize ctx infoid = alloca $ \(value_size :: Ptr CSize) -> do
  whenSuccess (raw_clGetContextInfo ctx infoid 0 nullPtr value_size)
    $ peek value_size

#c
enum CLContextInfo {
  cL_CONTEXT_REFERENCE_COUNT=CL_CONTEXT_REFERENCE_COUNT,
  cL_CONTEXT_DEVICES=CL_CONTEXT_DEVICES,
  cL_CONTEXT_PROPERTIES=CL_CONTEXT_PROPERTIES
  };
#endc
{#enum CLContextInfo {upcaseFirstLetter} #}

-- | Return the context 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.
--
-- This function execute OpenCL clGetContextInfo with 'CL_CONTEXT_REFERENCE_COUNT'.
clGetContextReferenceCount :: CLContext -> IO CLuint
clGetContextReferenceCount ctx =
    wrapGetInfo (\(dat :: Ptr CLuint) ->
        raw_clGetContextInfo ctx infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_CONTEXT_REFERENCE_COUNT
      size = fromIntegral $ sizeOf (0::CLuint)

-- | Return the list of devices in context.
--
-- This function execute OpenCL clGetContextInfo with 'CL_CONTEXT_DEVICES'.
clGetContextDevices :: CLContext -> IO [CLDeviceID]
clGetContextDevices ctx = do
  size <- getContextInfoSize ctx infoid
  let n = (fromIntegral size) `div` elemSize

  allocaArray n $ \(buff :: Ptr CLDeviceID) -> do
    whenSuccess (raw_clGetContextInfo ctx infoid size (castPtr buff) nullPtr)
      $ peekArray n buff
    where
      infoid = getCLValue CL_CONTEXT_DEVICES
      elemSize = sizeOf (nullPtr :: CLDeviceID)

clGetContextProperties :: CLContext -> IO [CLContextProperty]
clGetContextProperties ctx = do
  size <- getContextInfoSize ctx infoid
  let n = (fromIntegral size) `div` elemSize

  if n == 0
    then return []
    else allocaArray n $ \(buff :: Ptr CLContextProperty_) ->
      whenSuccess (raw_clGetContextInfo ctx infoid size (castPtr buff) nullPtr)
        $ fmap unpackContextProperties $ peekArray n buff
    where
      infoid = getCLValue CL_CONTEXT_PROPERTIES
      elemSize = sizeOf (nullPtr :: CLDeviceID)

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


Clean up Git2 module

Clean up Git2 module

module Data.HGit2.Git2 where

import Foreign
import Foreign.C.Types

type CPtr    = Ptr ()
type Ptr2Int = CPtr -> IO CInt

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

#include <git2.h>

module Data.HGit2.Git2 where

import Data.Bits
import Data.Maybe
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO.Unsafe

type CPtr    = Ptr ()
type Ptr2Int = CPtr -> IO CInt