remove deprecated TArg from function parameters

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE EmptyDataDecls           #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GADTs                    #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Exec
-- Copyright : (c) [2009..2011] Trevor L. McDonell
-- License   : BSD
--
-- Kernel execution control for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Exec (

  -- * Kernel Execution
  Fun(Fun), FunParam(..), FunAttribute(..), CacheConfig(..),
  requires, setBlockShape, setSharedSize, setParams, setCacheConfigFun,
  launch, launchKernel, launchKernel'

) where

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

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

-- System
import Foreign
import Foreign.C
import Data.Maybe
import Control.Monad                            (zipWithM_)

#if CUDA_VERSION >= 4000
{-# DEPRECATED setBlockShape, setSharedSize, setParams, launch
      "use launchKernel instead" #-}
#endif

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

-- |
-- A @__global__@ device function
--
newtype Fun = Fun { useFun :: {# type CUfunction #}}

-- |
-- Function attributes
--
{# enum CUfunction_attribute as FunAttribute
    { underscoreToCase
    , MAX_THREADS_PER_BLOCK as MaxKernelThreadsPerBlock
    , MAX as CU_FUNC_ATTRIBUTE_MAX }    -- ignore
    with prefix="CU_FUNC_ATTRIBUTE" deriving (Eq, Show) #}

-- |
-- Cache configuration preference
--
#if CUDA_VERSION < 3000
data CacheConfig
#else
{# enum CUfunc_cache_enum as CacheConfig
    { underscoreToCase }
    with prefix="CU_FUNC_CACHE_PREFER" deriving (Eq, Show) #}
#endif

-- |
-- Kernel function parameters
--
data FunParam where
  IArg :: !Int             -> FunParam
  FArg :: !Float           -> FunParam
  VArg :: Storable a => !a -> FunParam

instance Storable FunParam where
  sizeOf (IArg _)       = sizeOf (undefined :: CUInt)
  sizeOf (FArg _)       = sizeOf (undefined :: CFloat)
  sizeOf (VArg v)       = sizeOf v

  alignment (IArg _)    = alignment (undefined :: CUInt)
  alignment (FArg _)    = alignment (undefined :: CFloat)
  alignment (VArg v)    = alignment v

  poke p (IArg i)       = poke (castPtr p) i
  poke p (FArg f)       = poke (castPtr p) f
  poke p (VArg v)       = poke (castPtr p) v

--------------------------------------------------------------------------------
-- Execution Control
--------------------------------------------------------------------------------

-- |
-- Returns the value of the selected attribute requirement for the given kernel
--
requires :: Fun -> FunAttribute -> IO Int
requires fn att = resultIfOk =<< cuFuncGetAttribute att fn

{# fun unsafe cuFuncGetAttribute
  { alloca-   `Int'          peekIntConv*
  , cFromEnum `FunAttribute'
  , useFun    `Fun'                       } -> `Status' cToEnum #}

-- |
-- Specify the @(x,y,z)@ dimensions of the thread blocks that are created when
-- the given kernel function is launched.
--
setBlockShape :: Fun -> (Int,Int,Int) -> IO ()
setBlockShape fn (x,y,z) = nothingIfOk =<< cuFuncSetBlockShape fn x y z

{# fun unsafe cuFuncSetBlockShape
  { useFun `Fun'
  ,        `Int'
  ,        `Int'
  ,        `Int' } -> `Status' cToEnum #}

-- |
-- Set the number of bytes of dynamic shared memory to be available to each
-- thread block when the function is launched
--
setSharedSize :: Fun -> Integer -> IO ()
setSharedSize fn bytes = nothingIfOk =<< cuFuncSetSharedSize fn bytes

{# fun unsafe cuFuncSetSharedSize
  { useFun   `Fun'
  , cIntConv `Integer' } -> `Status' cToEnum #}

-- |
-- On devices where the L1 cache and shared memory use the same hardware
-- resources, this sets the preferred cache configuration for the given device
-- function. This is only a preference; the driver is free to choose a different
-- configuration as required to execute the function.
--
-- Switching between configuration modes may insert a device-side
-- synchronisation point for streamed kernel launches.
--
setCacheConfigFun :: Fun -> CacheConfig -> IO ()
#if CUDA_VERSION < 3000
setCacheConfigFun _  _    = requireSDK 3.0 "setCacheConfigFun"
#else
setCacheConfigFun fn pref = nothingIfOk =<< cuFuncSetCacheConfig fn pref

{# fun unsafe cuFuncSetCacheConfig
  { useFun    `Fun'
  , cFromEnum `CacheConfig' } -> `Status' cToEnum #}
#endif

-- |
-- Invoke the kernel on a size @(w,h)@ grid of blocks. Each block contains the
-- number of threads specified by a previous call to 'setBlockShape'. The launch
-- may also be associated with a specific 'Stream'.
--
launch :: Fun -> (Int,Int) -> Maybe Stream -> IO ()
launch fn (w,h) mst =
  nothingIfOk =<< case mst of
    Nothing -> cuLaunchGridAsync fn w h (Stream nullPtr)
    Just st -> cuLaunchGridAsync fn w h st

{# fun unsafe cuLaunchGridAsync
  { useFun    `Fun'
  ,           `Int'
  ,           `Int'
  , useStream `Stream' } -> `Status' cToEnum #}

-- |
-- Invoke a kernel on a @(gx * gy * gz)@ grid of blocks, where each block
-- contains @(tx * ty * tz)@ threads and has access to a given number of bytes
-- of shared memory. The launch may also be associated with a specific 'Stream'.
--
-- In 'launchKernel', the number of kernel parameters and their offsets and
-- sizes do not need to be specified, as this information is retrieved directly
-- from the kernel's image. This requires the kernel to have been compiled with
-- toolchain version 3.2 or later.
--
-- The alternative 'launchKernel'' will pass the arguments in directly,
-- requiring the application to know the size and alignment/padding of each
-- kernel parameter.
--
launchKernel, launchKernel'
    :: Fun                      -- ^ function to execute
    -> (Int,Int,Int)            -- ^ block grid dimension
    -> (Int,Int,Int)            -- ^ thread block shape
    -> Int                      -- ^ shared memory (bytes)
    -> Maybe Stream             -- ^ (optional) stream to execute in
    -> [FunParam]               -- ^ list of function parameters
    -> IO ()
#if CUDA_VERSION >= 4000
launchKernel fn (gx,gy,gz) (tx,ty,tz) sm mst args
  = (=<<) nothingIfOk
  $ withMany withFP args
  $ \pa -> withArray pa
  $ \pp -> cuLaunchKernel fn gx gy gz tx ty tz sm st pp nullPtr
  where
    st = fromMaybe (Stream nullPtr) mst

    withFP :: FunParam -> (Ptr FunParam -> IO b) -> IO b
    withFP p f = case p of
      IArg v -> with' v (f . castPtr)
      FArg v -> with' v (f . castPtr)
      VArg v -> with' v (f . castPtr)

    -- can't use the standard 'with' because 'alloca' will pass an undefined
    -- dummy argument when determining 'sizeOf' and 'alignment', but sometimes
    -- instances in Accelerate need to evaluate this argument.
    --
    with' :: Storable a => a -> (Ptr a -> IO b) -> IO b
    with' val f =
      allocaBytes (sizeOf val) $ \ptr -> do
        poke ptr val
        f ptr

launchKernel' fn (gx,gy,gz) (tx,ty,tz) sm mst args
  = (=<<) nothingIfOk
  $ with bytes
  $ \pb -> withArray' args
  $ \pa -> withArray0 nullPtr [buffer, castPtr pa, size, castPtr pb]
  $ \pp -> cuLaunchKernel fn gx gy gz tx ty tz sm st nullPtr pp
  where
    buffer      = wordPtrToPtr 0x01     -- CU_LAUNCH_PARAM_BUFFER_POINTER
    size        = wordPtrToPtr 0x02     -- CU_LAUNCH_PARAM_BUFFER_SIZE
    bytes       = foldl (\a x -> a + sizeOf x) 0 args
    st          = fromMaybe (Stream nullPtr) mst

    -- can't use the standard 'withArray' because 'mallocArray' will pass
    -- 'undefined' to 'sizeOf' when determining how many bytes to allocate, but
    -- our Storable instance for FunParam needs to dispatch on each constructor,
    -- hence evaluating the undefined.
    --
    withArray' vals f =
      allocaBytes bytes $ \ptr -> do
        pokeArray ptr vals
        f ptr

{# fun unsafe cuLaunchKernel
  { useFun    `Fun'
  ,           `Int', `Int', `Int'
  ,           `Int', `Int', `Int'
  ,           `Int'
  , useStream `Stream'
  , castPtr   `Ptr (Ptr FunParam)'
  , castPtr   `Ptr (Ptr ())'       } -> `Status' cToEnum #}

#else
launchKernel fn (gx,gy,_) (tx,ty,tz) sm mst args = do
  setParams     fn args
  setSharedSize fn (toInteger sm)
  setBlockShape fn (tx,ty,tz)
  launch        fn (gx,gy) mst

launchKernel' = launchKernel
#endif

--------------------------------------------------------------------------------
-- Kernel function parameters
--------------------------------------------------------------------------------

-- |
-- Set the parameters that will specified next time the kernel is invoked
--
setParams :: Fun -> [FunParam] -> IO ()
setParams fn prs = do
  zipWithM_ (set fn) offsets prs
  nothingIfOk =<< cuParamSetSize fn (last offsets)
  where
    offsets = scanl (\a b -> a + size b) 0 prs

    size (IArg _)    = sizeOf (undefined :: CUInt)
    size (FArg _)    = sizeOf (undefined :: CFloat)
    size (VArg v)    = sizeOf v

    set f o (IArg v) = nothingIfOk =<< cuParamSeti f o v
    set f o (FArg v) = nothingIfOk =<< cuParamSetf f o v
    set f o (VArg v) = with v $ \p -> (nothingIfOk =<< cuParamSetv f o p (sizeOf v))

{# fun unsafe cuParamSetSize
  { useFun `Fun'
  ,        `Int' } -> `Status' cToEnum #}

{# fun unsafe cuParamSeti
  { useFun `Fun'
  ,        `Int'
  ,        `Int' } -> `Status' cToEnum #}

{# fun unsafe cuParamSetf
  { useFun `Fun'
  ,        `Int'
  ,        `Float' } -> `Status' cToEnum #}

{# fun unsafe cuParamSetv
  `Storable a' =>
  { useFun  `Fun'
  ,         `Int'
  , castPtr `Ptr a'
  ,         `Int'   } -> `Status' cToEnum #}

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE EmptyDataDecls           #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GADTs                    #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Exec
-- Copyright : (c) [2009..2011] Trevor L. McDonell
-- License   : BSD
--
-- Kernel execution control for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Exec (

  -- * Kernel Execution
  Fun(Fun), FunParam(..), FunAttribute(..), CacheConfig(..),
  requires, setBlockShape, setSharedSize, setParams, setCacheConfigFun,
  launch, launchKernel, launchKernel'

) where

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

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

-- System
import Foreign
import Foreign.C
import Data.Maybe
import Control.Monad                            (zipWithM_)

#if CUDA_VERSION >= 3020
{-# DEPRECATED TArg "as of CUDA version 3.2" #-}
#endif
#if CUDA_VERSION >= 4000
{-# DEPRECATED setBlockShape, setSharedSize, setParams, launch
      "use launchKernel instead" #-}
#endif

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

-- |
-- A @__global__@ device function
--
newtype Fun = Fun { useFun :: {# type CUfunction #}}

-- |
-- Function attributes
--
{# enum CUfunction_attribute as FunAttribute
    { underscoreToCase
    , MAX_THREADS_PER_BLOCK as MaxKernelThreadsPerBlock
    , MAX as CU_FUNC_ATTRIBUTE_MAX }    -- ignore
    with prefix="CU_FUNC_ATTRIBUTE" deriving (Eq, Show) #}

-- |
-- Cache configuration preference
--
#if CUDA_VERSION < 3000
data CacheConfig
#else
{# enum CUfunc_cache_enum as CacheConfig
    { underscoreToCase }
    with prefix="CU_FUNC_CACHE_PREFER" deriving (Eq, Show) #}
#endif

-- |
-- Kernel function parameters
--
data FunParam where
  IArg :: !Int             -> FunParam
  FArg :: !Float           -> FunParam
  TArg :: !Texture         -> FunParam
  VArg :: Storable a => !a -> FunParam

instance Storable FunParam where
  sizeOf (IArg _)       = sizeOf (undefined :: CUInt)
  sizeOf (FArg _)       = sizeOf (undefined :: CFloat)
  sizeOf (VArg v)       = sizeOf v
  sizeOf (TArg _)       = 0

  alignment (IArg _)    = alignment (undefined :: CUInt)
  alignment (FArg _)    = alignment (undefined :: CFloat)
  alignment (VArg v)    = alignment v
  alignment (TArg _)    = 0

  poke p (IArg i)       = poke (castPtr p) i
  poke p (FArg f)       = poke (castPtr p) f
  poke p (VArg v)       = poke (castPtr p) v
  poke _ (TArg _)       = return ()

--------------------------------------------------------------------------------
-- Execution Control
--------------------------------------------------------------------------------

-- |
-- Returns the value of the selected attribute requirement for the given kernel
--
requires :: Fun -> FunAttribute -> IO Int
requires fn att = resultIfOk =<< cuFuncGetAttribute att fn

{# fun unsafe cuFuncGetAttribute
  { alloca-   `Int'          peekIntConv*
  , cFromEnum `FunAttribute'
  , useFun    `Fun'                       } -> `Status' cToEnum #}

-- |
-- Specify the @(x,y,z)@ dimensions of the thread blocks that are created when
-- the given kernel function is launched.
--
setBlockShape :: Fun -> (Int,Int,Int) -> IO ()
setBlockShape fn (x,y,z) = nothingIfOk =<< cuFuncSetBlockShape fn x y z

{# fun unsafe cuFuncSetBlockShape
  { useFun `Fun'
  ,        `Int'
  ,        `Int'
  ,        `Int' } -> `Status' cToEnum #}

-- |
-- Set the number of bytes of dynamic shared memory to be available to each
-- thread block when the function is launched
--
setSharedSize :: Fun -> Integer -> IO ()
setSharedSize fn bytes = nothingIfOk =<< cuFuncSetSharedSize fn bytes

{# fun unsafe cuFuncSetSharedSize
  { useFun   `Fun'
  , cIntConv `Integer' } -> `Status' cToEnum #}

-- |
-- On devices where the L1 cache and shared memory use the same hardware
-- resources, this sets the preferred cache configuration for the given device
-- function. This is only a preference; the driver is free to choose a different
-- configuration as required to execute the function.
--
-- Switching between configuration modes may insert a device-side
-- synchronisation point for streamed kernel launches.
--
setCacheConfigFun :: Fun -> CacheConfig -> IO ()
#if CUDA_VERSION < 3000
setCacheConfigFun _  _    = requireSDK 3.0 "setCacheConfigFun"
#else
setCacheConfigFun fn pref = nothingIfOk =<< cuFuncSetCacheConfig fn pref

{# fun unsafe cuFuncSetCacheConfig
  { useFun    `Fun'
  , cFromEnum `CacheConfig' } -> `Status' cToEnum #}
#endif

-- |
-- Invoke the kernel on a size @(w,h)@ grid of blocks. Each block contains the
-- number of threads specified by a previous call to 'setBlockShape'. The launch
-- may also be associated with a specific 'Stream'.
--
launch :: Fun -> (Int,Int) -> Maybe Stream -> IO ()
launch fn (w,h) mst =
  nothingIfOk =<< case mst of
    Nothing -> cuLaunchGridAsync fn w h (Stream nullPtr)
    Just st -> cuLaunchGridAsync fn w h st

{# fun unsafe cuLaunchGridAsync
  { useFun    `Fun'
  ,           `Int'
  ,           `Int'
  , useStream `Stream' } -> `Status' cToEnum #}

-- |
-- Invoke a kernel on a @(gx * gy * gz)@ grid of blocks, where each block
-- contains @(tx * ty * tz)@ threads and has access to a given number of bytes
-- of shared memory. The launch may also be associated with a specific 'Stream'.
--
-- In 'launchKernel', the number of kernel parameters and their offsets and
-- sizes do not need to be specified, as this information is retrieved directly
-- from the kernel's image. This requires the kernel to have been compiled with
-- toolchain version 3.2 or later.
--
-- The alternative 'launchKernel'' will pass the arguments in directly,
-- requiring the application to know the size and alignment/padding of each
-- kernel parameter.
--
launchKernel, launchKernel'
    :: Fun                      -- ^ function to execute
    -> (Int,Int,Int)            -- ^ block grid dimension
    -> (Int,Int,Int)            -- ^ thread block shape
    -> Int                      -- ^ shared memory (bytes)
    -> Maybe Stream             -- ^ (optional) stream to execute in
    -> [FunParam]               -- ^ list of function parameters
    -> IO ()
#if CUDA_VERSION >= 4000
launchKernel fn (gx,gy,gz) (tx,ty,tz) sm mst args
  = (=<<) nothingIfOk
  $ withMany withFP args
  $ \pa -> withArray pa
  $ \pp -> cuLaunchKernel fn gx gy gz tx ty tz sm st pp nullPtr
  where
    st = fromMaybe (Stream nullPtr) mst

    withFP :: FunParam -> (Ptr FunParam -> IO b) -> IO b
    withFP p f = case p of
      IArg v -> with' v (f . castPtr)
      FArg v -> with' v (f . castPtr)
      VArg v -> with' v (f . castPtr)
      TArg _ -> error "launchKernel: TArg is deprecated"

    -- can't use the standard 'with' because 'alloca' will pass an undefined
    -- dummy argument when determining 'sizeOf' and 'alignment', but sometimes
    -- instances in Accelerate need to evaluate this argument.
    --
    with' :: Storable a => a -> (Ptr a -> IO b) -> IO b
    with' val f =
      allocaBytes (sizeOf val) $ \ptr -> do
        poke ptr val
        f ptr

launchKernel' fn (gx,gy,gz) (tx,ty,tz) sm mst args
  = (=<<) nothingIfOk
  $ with bytes
  $ \pb -> withArray' args
  $ \pa -> withArray0 nullPtr [buffer, castPtr pa, size, castPtr pb]
  $ \pp -> cuLaunchKernel fn gx gy gz tx ty tz sm st nullPtr pp
  where
    buffer      = wordPtrToPtr 0x01     -- CU_LAUNCH_PARAM_BUFFER_POINTER
    size        = wordPtrToPtr 0x02     -- CU_LAUNCH_PARAM_BUFFER_SIZE
    bytes       = foldl (\a x -> a + sizeOf x) 0 args
    st          = fromMaybe (Stream nullPtr) mst

    -- can't use the standard 'withArray' because 'mallocArray' will pass
    -- 'undefined' to 'sizeOf' when determining how many bytes to allocate, but
    -- our Storable instance for FunParam needs to dispatch on each constructor,
    -- hence evaluating the undefined.
    --
    withArray' vals f =
      allocaBytes bytes $ \ptr -> do
        pokeArray ptr vals
        f ptr

{# fun unsafe cuLaunchKernel
  { useFun    `Fun'
  ,           `Int', `Int', `Int'
  ,           `Int', `Int', `Int'
  ,           `Int'
  , useStream `Stream'
  , castPtr   `Ptr (Ptr FunParam)'
  , castPtr   `Ptr (Ptr ())'       } -> `Status' cToEnum #}

#else
launchKernel fn (gx,gy,_) (tx,ty,tz) sm mst args = do
  setParams     fn args
  setSharedSize fn (toInteger sm)
  setBlockShape fn (tx,ty,tz)
  launch        fn (gx,gy) mst

launchKernel' = launchKernel
#endif

--------------------------------------------------------------------------------
-- Kernel function parameters
--------------------------------------------------------------------------------

-- |
-- Set the parameters that will specified next time the kernel is invoked
--
setParams :: Fun -> [FunParam] -> IO ()
setParams fn prs = do
  zipWithM_ (set fn) offsets prs
  nothingIfOk =<< cuParamSetSize fn (last offsets)
  where
    offsets = scanl (\a b -> a + size b) 0 prs

    size (IArg _)    = sizeOf (undefined :: CUInt)
    size (FArg _)    = sizeOf (undefined :: CFloat)
    size (TArg _)    = 0
    size (VArg v)    = sizeOf v

    set f o (IArg v) = nothingIfOk =<< cuParamSeti f o v
    set f o (FArg v) = nothingIfOk =<< cuParamSetf f o v
    set f _ (TArg v) = nothingIfOk =<< cuParamSetTexRef f (-1) v
    set f o (VArg v) = with v $ \p -> (nothingIfOk =<< cuParamSetv f o p (sizeOf v))

{# fun unsafe cuParamSetSize
  { useFun `Fun'
  ,        `Int' } -> `Status' cToEnum #}

{# fun unsafe cuParamSeti
  { useFun `Fun'
  ,        `Int'
  ,        `Int' } -> `Status' cToEnum #}

{# fun unsafe cuParamSetf
  { useFun `Fun'
  ,        `Int'
  ,        `Float' } -> `Status' cToEnum #}

{# fun unsafe cuParamSetv
  `Storable a' =>
  { useFun  `Fun'
  ,         `Int'
  , castPtr `Ptr a'
  ,         `Int'   } -> `Status' cToEnum #}

{# fun unsafe cuParamSetTexRef
  { useFun     `Fun'
  ,            `Int'    -- must be CU_PARAM_TR_DEFAULT (-1)
  , useTexture `Texture' } -> `Status' cToEnum #}


remove constants from types

remove constants from types

-- -----------------------------------------------------------------------------
-- 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/>.
-- -----------------------------------------------------------------------------
module System.GPU.OpenCL.Types(
  ErrorCode(..), CLbool, CLint, CLuint, CLulong, CLPlatformInfo_, CLMem,
  CLProgram, CLEvent,
  CLDeviceType_, CLDeviceInfo_, CLContextInfo_, CLDeviceFPConfig(..),
  CLDeviceMemCacheType(..), CLDeviceExecCapability(..), CLDeviceLocalMemType(..),
  CLPlatformID, CLDeviceID, CLContext, CLCommandQueue, CLContextProperty_,
  CLDeviceType(..), CLCommandQueueProperty(..), CLCommandQueueInfo_,
  CLEventInfo_, CLProfilingInfo_, CLCommandType(..), CLCommandType_,
  CLCommandExecutionStatus(..), CLProfilingInfo(..), getProfilingInfoValue,
  CLCommandQueueProperty_, getDeviceTypeValue, getDeviceLocalMemType,
  getDeviceMemCacheType, getCommandType, getCommandExecutionStatus,
  bitmaskToDeviceTypes, bitmaskFromDeviceTypes, bitmaskToCommandQueueProperties,
  bitmaskFromCommandQueueProperties, bitmaskToFPConfig, bitmaskToExecCapability )
       where

-- -----------------------------------------------------------------------------
import Foreign( Ptr )
import Foreign.C.Types
import Data.List( foldl' )
import Data.Bits( Bits, shiftL, (.|.), (.&.) )

#include <CL/cl.h>

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

type CLPlatformID = {#type cl_platform_id#}
type CLDeviceID = {#type cl_device_id#}
type CLContext = {#type cl_context#}
type CLCommandQueue = {#type cl_command_queue#}
type CLMem = {#type cl_mem#}
type CLEvent = {#type cl_event#}
type CLProgram = {#type cl_program#}

type CLint = {#type cl_int#}
type CLuint = {#type cl_uint#}
type CLulong = {#type cl_ulong#}
type CLbool = {#type cl_bool#}

type CLPlatformInfo_ = {#type cl_platform_info#}
type CLDeviceType_ = {#type cl_device_type#}
type CLDeviceInfo_ = {#type cl_device_info#}
type CLDeviceFPConfig_ = {#type cl_device_fp_config#}
type CLDeviceMemCacheType_ = {#type cl_device_mem_cache_type#}
type CLDeviceLocalMemType_ = {#type cl_device_local_mem_type#}
type CLDeviceExecCapability_ = {#type cl_device_exec_capabilities#}
type CLContextInfo_ = {#type cl_context_info#}
type CLContextProperty_ = {#type cl_context_properties#}
type CLCommandQueueInfo_ = {#type cl_command_queue_info#}
type CLCommandQueueProperty_ = {#type cl_command_queue_properties#}
type CLEventInfo_ = {#type cl_event_info#}
type CLProfilingInfo_ = {#type cl_profiling_info#}
type CLCommandType_ = {#type cl_command_type#}

newtype ErrorCode = ErrorCode CInt deriving( Eq )

-- -----------------------------------------------------------------------------
#c
enum CLDeviceType {
CLDEVICE_TYPE_CPU=CL_DEVICE_TYPE_CPU,
CLDEVICE_TYPE_GPU=CL_DEVICE_TYPE_GPU,
CLDEVICE_TYPE_ACCELERATOR=CL_DEVICE_TYPE_ACCELERATOR,
CLDEVICE_TYPE_DEFAULT=CL_DEVICE_TYPE_DEFAULT,
CLDEVICE_TYPE_ALL=CL_DEVICE_TYPE_ALL
  };
#endc

{-|
 * 'CLDEVICE_TYPE_CPU', An OpenCL device that is the host processor. The host processor runs the OpenCL implementations and is a single or multi-core CPU.

 * 'CLDEVICE_TYPE_GPU', An OpenCL device that is a GPU. By this we mean that the device can also be used to accelerate a 3D API such as OpenGL or DirectX.

 * 'CLDEVICE_TYPE_ACCELERATOR', Dedicated OpenCL accelerators (for example the IBM CELL Blade). These devices communicate with the host processor using a peripheral interconnect such as PCIe.

 * 'CLDEVICE_TYPE_DEFAULT', The default OpenCL device in the system.

 * 'CLDEVICE_TYPE_ALL', All OpenCL devices available in the system.
-}
{#enum CLDeviceType {} deriving( Show ) #}

getDeviceTypeValue :: CLDeviceType -> CLDeviceType_
getDeviceTypeValue = fromIntegral . fromEnum

#c
enum CLCommandQueueProperty {
  CLQUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE=CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE,
  CLQUEUE_PROFILING_ENABLE=CL_QUEUE_PROFILING_ENABLE
  };
#endc

{-|
 * 'CLQUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE', Determines whether the commands
queued in the command-queue are executed in-order or out-of-order. If set, the
commands in the command-queue are executed out-of-order. Otherwise, commands are
executed in-order.

 * 'CLQUEUE_PROFILING_ENABLE', Enable or disable profiling of commands in the
command-queue. If set, the profiling of commands is enabled. Otherwise profiling
of commands is disabled. See 'clGetEventProfilingInfo' for more information.
-}
{#enum CLCommandQueueProperty {} deriving( Show, Bounded, Eq, Ord ) #}

#c
enum CLDeviceFPConfig {
  CLFP_DENORM=CL_FP_DENORM, CLFP_INF_NAN=CL_FP_INF_NAN,
  CLFP_ROUND_TO_NEAREST=CL_FP_ROUND_TO_NEAREST,
  CLFP_ROUND_TO_ZERO=CL_FP_ROUND_TO_ZERO,
  CLFP_ROUND_TO_INF=CL_FP_ROUND_TO_INF, CLFP_FMA=CL_FP_FMA,
  };
#endc

{-|
 * 'CLFP_DENORM', denorms are supported.

 * 'CLFP_INF_NAN', INF and NaNs are supported.

 * 'CLFP_ROUND_TO_NEAREST', round to nearest even rounding mode supported.

 * 'CLFP_ROUND_TO_ZERO', round to zero rounding mode supported.

 * 'CLFP_ROUND_TO_INF', round to +ve and -ve infinity rounding modes supported.

 * 'CLFP_FMA', IEEE754-2008 fused multiply-add is supported.
-}
{#enum CLDeviceFPConfig {} deriving( Show, Bounded, Eq, Ord ) #}

#c
enum CLDeviceExecCapability {
  CLEXEC_KERNEL=CL_EXEC_KERNEL,
  CLEXEC_NATIVE_KERNEL=CL_EXEC_NATIVE_KERNEL
  };
#endc

{-|
 * 'CLEXEC_KERNEL', The OpenCL device can execute OpenCL kernels.

 * 'CLEXEC_NATIVE_KERNEL', The OpenCL device can execute native kernels.
-}
{#enum CLDeviceExecCapability {} deriving( Show, Bounded, Eq, Ord ) #}

#c
enum CLDeviceMemCacheType {
  CLNONE=CL_NONE,CLREAD_ONLY_CACHE=CL_READ_ONLY_CACHE,
  CLREAD_WRITE_CACHE=CL_READ_WRITE_CACHE
  };
#endc

{#enum CLDeviceMemCacheType {} deriving( Show ) #}

getDeviceMemCacheType :: CLDeviceMemCacheType_ -> Maybe CLDeviceMemCacheType
getDeviceMemCacheType = Just . toEnum . fromIntegral

#c
enum CLDeviceLocalMemType {
  CLLOCAL=CL_LOCAL, CLGLOBAL=CL_GLOBAL
  };
#endc

{#enum CLDeviceLocalMemType {} deriving( Show ) #}

getDeviceLocalMemType :: CLDeviceLocalMemType_ -> Maybe CLDeviceLocalMemType
getDeviceLocalMemType = Just . toEnum . fromIntegral

#c
enum CLCommandType {
  CLCOMMAND_NDRANGE_KERNEL=CL_COMMAND_NDRANGE_KERNEL,
  CLCOMMAND_TASK=CL_COMMAND_TASK ,
  CLCOMMAND_NATIVE_KERNEL=CL_COMMAND_NATIVE_KERNEL,
  CLCOMMAND_READ_BUFFER=CL_COMMAND_READ_BUFFER,
  CLCOMMAND_WRITE_BUFFER=CL_COMMAND_WRITE_BUFFER,
  CLCOMMAND_COPY_BUFFER=CL_COMMAND_COPY_BUFFER,
  CLCOMMAND_READ_IMAGE=CL_COMMAND_READ_IMAGE,
  CLCOMMAND_WRITE_IMAGE=CL_COMMAND_WRITE_IMAGE,
  CLCOMMAND_COPY_IMAGE=CL_COMMAND_COPY_IMAGE,
  CLCOMMAND_COPY_BUFFER_TO_IMAGE=CL_COMMAND_COPY_BUFFER_TO_IMAGE,
  CLCOMMAND_COPY_IMAGE_TO_BUFFER=CL_COMMAND_COPY_IMAGE_TO_BUFFER,
  CLCOMMAND_MAP_BUFFER=CL_COMMAND_MAP_BUFFER,
  CLCOMMAND_MAP_IMAGE=CL_COMMAND_MAP_IMAGE,
  CLCOMMAND_UNMAP_MEM_OBJECT=CL_COMMAND_UNMAP_MEM_OBJECT,
  CLCOMMAND_MARKER=CL_COMMAND_MARKER,
  CLCOMMAND_ACQUIRE_GL_OBJECTS=CL_COMMAND_ACQUIRE_GL_OBJECTS,
  CLCOMMAND_RELEASE_GL_OBJECTS=CL_COMMAND_RELEASE_GL_OBJECTS
  };
#endc

-- | Command associated with an event.
{#enum CLCommandType {} deriving( Show ) #}

getCommandType :: CLCommandType_ -> Maybe CLCommandType
getCommandType = Just . toEnum . fromIntegral

#c
enum CLCommandExecutionStatus {
  CLQUEUED=CL_QUEUED, CLSUBMITTED=CL_SUBMITTED, CLRUNNING=CL_RUNNING,
  CLCOMPLETE=CL_COMPLETE, CLEXEC_ERROR= -1
  };
#endc

{-|
 * 'CLQUEUED', command has been enqueued in the command-queue.

 * 'CLSUBMITTED', enqueued command has been submitted by the host to the
device associated with the command-queue.

 * 'CLRUNNING', device is currently executing this command.

 * 'CLCOMPLETE', the command has completed.

 * 'CLEXEC_ERROR', command was abnormally terminated.
-}
{#enum CLCommandExecutionStatus {} deriving( Show ) #}

getCommandExecutionStatus :: CLint -> Maybe CLCommandExecutionStatus
getCommandExecutionStatus n
  | n < 0 = Just CLEXEC_ERROR
  | otherwise = Just . toEnum . fromIntegral $ n

#c
enum CLProfilingInfo {
  CLPROFILING_COMMAND_QUEUED=CL_PROFILING_COMMAND_QUEUED,
  CLPROFILING_COMMAND_SUBMIT=CL_PROFILING_COMMAND_SUBMIT,
  CLPROFILING_COMMAND_START=CL_PROFILING_COMMAND_START,
  CLPROFILING_COMMAND_END=CL_PROFILING_COMMAND_END
  };
#endc

{-| Specifies the profiling data.

 * 'CLPROFILING_COMMAND_QUEUED', A 64-bit value that describes the current
device time counter in nanoseconds when the command identified by event is
enqueued in a command-queue by the host.

 * 'CLPROFILING_COMMAND_SUBMIT', A 64-bit value that describes the current
device time counter in nanoseconds when the command identified by event that has
been enqueued is submitted by the host to the device associated with the
commandqueue.

 * 'CLPROFILING_COMMAND_START',	 A 64-bit value that describes the current
device time counter in nanoseconds when the command identified by event starts
execution on the device.

 * 'CLPROFILING_COMMAND_END', A 64-bit value that describes the current device
time counter in nanoseconds when the command identified by event has finished
execution on the device.
-}
{#enum CLProfilingInfo {} deriving( Show ) #}

getProfilingInfoValue :: CLProfilingInfo -> CLProfilingInfo_
getProfilingInfoValue = fromIntegral . fromEnum

-- -----------------------------------------------------------------------------
binaryFlags :: (Ord b, Enum b, Bounded b) => b -> [b]
binaryFlags m = map toEnum . takeWhile (<= (fromEnum m)) $ [1 `shiftL` n | n <- [0..]]

testMask :: Bits b => b -> b -> Bool
testMask mask v = (v .&. mask) == v

bitmaskToDeviceTypes :: CLDeviceType_ -> [CLDeviceType]
bitmaskToDeviceTypes mask = filter (testMask mask . fromIntegral . fromEnum) $ [CLDEVICE_TYPE_CPU,CLDEVICE_TYPE_GPU,CLDEVICE_TYPE_ACCELERATOR,CLDEVICE_TYPE_DEFAULT,CLDEVICE_TYPE_ALL]

bitmaskFromDeviceTypes :: [CLDeviceType] -> CLDeviceType_
bitmaskFromDeviceTypes = foldl' (.|.) 0 . map (fromIntegral . fromEnum)

bitmaskToCommandQueueProperties :: CLCommandQueueProperty_ -> [CLCommandQueueProperty]
bitmaskToCommandQueueProperties mask = filter (testMask mask . fromIntegral . fromEnum) $ binaryFlags maxBound

bitmaskFromCommandQueueProperties :: [CLCommandQueueProperty] -> CLCommandQueueProperty_
bitmaskFromCommandQueueProperties = foldl' (.|.) 0 . map (fromIntegral.fromEnum)

bitmaskToFPConfig :: CLDeviceFPConfig_ -> [CLDeviceFPConfig]
bitmaskToFPConfig mask = filter (testMask mask . fromIntegral . fromEnum) $ binaryFlags maxBound

bitmaskToExecCapability :: CLDeviceExecCapability_ -> [CLDeviceExecCapability]
bitmaskToExecCapability mask = filter (testMask mask . fromIntegral . fromEnum) $ binaryFlags maxBound

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

-- -----------------------------------------------------------------------------
-- 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/>.
-- -----------------------------------------------------------------------------
module System.GPU.OpenCL.Types(
  ErrorCode(..), CLbool, CLint, CLuint, CLulong, CLPlatformInfo_, CLMem,
  CLProgram, CLEvent,
  CLDeviceType_, CLDeviceInfo_, CLContextInfo_, CLDeviceFPConfig(..),
  CLDeviceMemCacheType(..), CLDeviceExecCapability(..), CLDeviceLocalMemType(..),
  CLPlatformID, CLDeviceID, CLContext, CLCommandQueue, CLContextProperty_,
  CLDeviceType(..), CLCommandQueueProperty(..), CLCommandQueueInfo_,
  CLEventInfo_, CLProfilingInfo_, CLCommandType, CLCommandType_,
  CLCommandExecutionStatus(..), CLProfilingInfo(..), getProfilingInfoValue,
  CLCommandQueueProperty_, getDeviceTypeValue, getDeviceLocalMemType,
  getDeviceMemCacheType, getCommandType, getCommandExecutionStatus,
  bitmaskToDeviceTypes, bitmaskFromDeviceTypes, bitmaskToCommandQueueProperties,
  bitmaskFromCommandQueueProperties, bitmaskToFPConfig, bitmaskToExecCapability )
       where

-- -----------------------------------------------------------------------------
import Foreign( Ptr )
import Foreign.C.Types
import Data.Maybe( fromMaybe, mapMaybe )
import Data.List( foldl' )
import Data.Bits( shiftL, complement, (.|.) )
import System.GPU.OpenCL.Util( testMask )

#include <CL/cl.h>

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

type CLPlatformID = {#type cl_platform_id#}
type CLDeviceID = {#type cl_device_id#}
type CLContext = {#type cl_context#}
type CLCommandQueue = {#type cl_command_queue#}
type CLMem = {#type cl_mem#}
type CLEvent = {#type cl_event#}
type CLProgram = {#type cl_program#}

type CLint = {#type cl_int#}
type CLuint = {#type cl_uint#}
type CLulong = {#type cl_ulong#}
type CLbool = {#type cl_bool#}

type CLPlatformInfo_ = {#type cl_platform_info#}
type CLDeviceType_ = {#type cl_device_type#}
type CLDeviceInfo_ = {#type cl_device_info#}
type CLDeviceFPConfig_ = {#type cl_device_fp_config#}
type CLDeviceMemCacheType_ = {#type cl_device_mem_cache_type#}
type CLDeviceLocalMemType_ = {#type cl_device_local_mem_type#}
type CLDeviceExecCapability_ = {#type cl_device_exec_capabilities#}
type CLContextInfo_ = {#type cl_context_info#}
type CLContextProperty_ = {#type cl_context_properties#}
type CLCommandQueueInfo_ = {#type cl_command_queue_info#}
type CLCommandQueueProperty_ = {#type cl_command_queue_properties#}
type CLEventInfo_ = {#type cl_event_info#}
type CLProfilingInfo_ = {#type cl_profiling_info#}
type CLCommandType_ = {#type cl_command_type#}

newtype ErrorCode = ErrorCode CInt deriving( Eq )

-- -----------------------------------------------------------------------------
data CLDeviceType = CL_DEVICE_TYPE_CPU
                    -- ^ An OpenCL device that is the host processor. The host
                    -- processor runs the OpenCL implementations and is a single
                    -- or multi-core CPU.
                  | CL_DEVICE_TYPE_GPU
                    -- ^ An OpenCL device that is a GPU. By this we mean that
                    -- the device can also be used to accelerate a 3D API such
                    -- as OpenGL or DirectX.
                  | CL_DEVICE_TYPE_ACCELERATOR
                    -- ^ Dedicated OpenCL accelerators (for example the IBM CELL
                    -- Blade). These devices communicate with the host processor
                    -- using a peripheral interconnect such as PCIe.
                  | CL_DEVICE_TYPE_DEFAULT
                    -- ^ The default OpenCL device in the system.
                  | CL_DEVICE_TYPE_ALL
                    -- ^ All OpenCL devices available in the system.
                  deriving( Eq, Show )

deviceTypeValues :: [(CLDeviceType,CLDeviceType_)]
deviceTypeValues = [
  (CL_DEVICE_TYPE_CPU, 1 `shiftL` 1), (CL_DEVICE_TYPE_GPU, 1 `shiftL` 2),
  (CL_DEVICE_TYPE_ACCELERATOR, 1 `shiftL` 3), (CL_DEVICE_TYPE_DEFAULT, 1 `shiftL` 0),
  (CL_DEVICE_TYPE_ALL, complement 0) ]
getDeviceTypeValue :: CLDeviceType -> CLDeviceType_
getDeviceTypeValue info = fromMaybe 0 (lookup info deviceTypeValues)

data CLCommandQueueProperty = CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE
                              -- ^ Determines whether the commands queued in the
                              -- command-queue are executed in-order or
                              -- out-of-order. If set, the commands in the
                              -- command-queue are executed out-of-order.
                              -- Otherwise, commands are executed in-order.
                            | CL_QUEUE_PROFILING_ENABLE
                              -- ^ Enable or disable profiling of commands in
                              -- the command-queue. If set, the profiling of
                              -- commands is enabled. Otherwise profiling of
                              -- commands is disabled. See
                              -- 'clGetEventProfilingInfo' for more information.
                              deriving( Eq, Show )

commandQueueProperties :: [(CLCommandQueueProperty,CLCommandQueueProperty_)]
commandQueueProperties = [
  (CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE, 1 `shiftL` 0),
  (CL_QUEUE_PROFILING_ENABLE, 1 `shiftL` 1)]

data CLDeviceFPConfig = CL_FP_DENORM -- ^ denorms are supported.
                      | CL_FP_INF_NAN -- ^ INF and NaNs are supported.
                      | CL_FP_ROUND_TO_NEAREST
                        -- ^ round to nearest even rounding mode supported.
                      | CL_FP_ROUND_TO_ZERO
                        -- ^ round to zero rounding mode supported.
                      | CL_FP_ROUND_TO_INF
                        -- ^ round to +ve and -ve infinity rounding modes
                        -- supported.
                      | CL_FP_FMA
                        -- ^ IEEE754-2008 fused multiply-add is supported.
                        deriving( Show )

deviceFPValues :: [(CLDeviceFPConfig,CLDeviceFPConfig_)]
deviceFPValues = [
  (CL_FP_DENORM, 1 `shiftL` 0), (CL_FP_INF_NAN, 1 `shiftL` 1),
  (CL_FP_ROUND_TO_NEAREST, 1 `shiftL` 2), (CL_FP_ROUND_TO_ZERO, 1 `shiftL` 3),
  (CL_FP_ROUND_TO_INF, 1 `shiftL` 4), (CL_FP_FMA, 1 `shiftL` 5)]

data CLDeviceExecCapability = CL_EXEC_KERNEL
                              -- ^ The OpenCL device can execute OpenCL kernels.
                            | CL_EXEC_NATIVE_KERNEL
                              -- ^ The OpenCL device can execute native kernels.
                              deriving( Show )

deviceExecValues :: [(CLDeviceExecCapability,CLDeviceExecCapability_)]
deviceExecValues = [
  (CL_EXEC_KERNEL, 1 `shiftL` 0), (CL_EXEC_NATIVE_KERNEL, 1 `shiftL` 1)]

data CLDeviceMemCacheType = CL_NONE | CL_READ_ONLY_CACHE | CL_READ_WRITE_CACHE
                          deriving( Show )
deviceMemCacheTypes :: [(CLDeviceMemCacheType_,CLDeviceMemCacheType)]
deviceMemCacheTypes = [
  (0x0,CL_NONE), (0x1,CL_READ_ONLY_CACHE),(0x2,CL_READ_WRITE_CACHE)]
getDeviceMemCacheType :: CLDeviceMemCacheType_ -> Maybe CLDeviceMemCacheType
getDeviceMemCacheType val = lookup val deviceMemCacheTypes

data CLDeviceLocalMemType = CL_LOCAL | CL_GLOBAL deriving( Show )

deviceLocalMemTypes :: [(CLDeviceLocalMemType_,CLDeviceLocalMemType)]
deviceLocalMemTypes = [(0x1,CL_LOCAL), (0x2,CL_GLOBAL)]
getDeviceLocalMemType :: CLDeviceLocalMemType_ -> Maybe CLDeviceLocalMemType
getDeviceLocalMemType val = lookup val deviceLocalMemTypes

data CLCommandType = CL_COMMAND_NDRANGE_KERNEL | CL_COMMAND_TASK
                   | CL_COMMAND_NATIVE_KERNEL | CL_COMMAND_READ_BUFFER
                   | CL_COMMAND_WRITE_BUFFER | CL_COMMAND_COPY_BUFFER
                   | CL_COMMAND_READ_IMAGE | CL_COMMAND_WRITE_IMAGE
                   | CL_COMMAND_COPY_IMAGE | CL_COMMAND_COPY_BUFFER_TO_IMAGE
                   | CL_COMMAND_COPY_IMAGE_TO_BUFFER | CL_COMMAND_MAP_BUFFER
                   | CL_COMMAND_MAP_IMAGE | CL_COMMAND_UNMAP_MEM_OBJECT
                   | CL_COMMAND_MARKER | CL_COMMAND_ACQUIRE_GL_OBJECTS
                   | CL_COMMAND_RELEASE_GL_OBJECTS
                   deriving( Show )

commandTypes :: [(CLCommandType_, CLCommandType)]
commandTypes = [(0x11F0,CL_COMMAND_NDRANGE_KERNEL),(0x11F1,CL_COMMAND_TASK),
                (0x11F2,CL_COMMAND_NATIVE_KERNEL),(0x11F3,CL_COMMAND_READ_BUFFER),
                (0x11F4,CL_COMMAND_WRITE_BUFFER),(0x11F5,CL_COMMAND_COPY_BUFFER),
                (0x11F6,CL_COMMAND_READ_IMAGE),(0x11F7,CL_COMMAND_WRITE_IMAGE),
                (0x11F8,CL_COMMAND_COPY_IMAGE),(0x11F9,CL_COMMAND_COPY_IMAGE_TO_BUFFER),
                (0x11FA,CL_COMMAND_COPY_BUFFER_TO_IMAGE),(0x11FB,CL_COMMAND_MAP_BUFFER),
                (0x11FC,CL_COMMAND_MAP_IMAGE),(0x11FD,CL_COMMAND_UNMAP_MEM_OBJECT),
                (0x11FE,CL_COMMAND_MARKER),(0x11FF,CL_COMMAND_ACQUIRE_GL_OBJECTS),
                (0x1200,CL_COMMAND_RELEASE_GL_OBJECTS)]
getCommandType :: CLCommandType_ -> Maybe CLCommandType
getCommandType = (`lookup` commandTypes)

data CLCommandExecutionStatus = CL_QUEUED
                                -- ^ command has been enqueued in the command-queue
                              | CL_SUBMITTED
                                -- ^ enqueued command has been submitted by the
                                -- host to the device associated with the
                                -- command-queue
                              | CL_RUNNING
                                -- ^ device is currently executing this command
                              | CL_COMPLETE -- ^ the command has completed
                              | CL_EXEC_ERROR
                                -- ^ command was abnormally terminated

commandExecutionStatus :: [(CLint, CLCommandExecutionStatus)]
commandExecutionStatus = [(0x0,CL_COMPLETE),(0x1,CL_RUNNING),
                          (0x2,CL_SUBMITTED),(0x3,CL_QUEUED)]
getCommandExecutionStatus :: CLint -> Maybe CLCommandExecutionStatus
getCommandExecutionStatus n
  | n < 0 = Just CL_EXEC_ERROR
  | otherwise = lookup n commandExecutionStatus

#c
enum CLProfilingInfo {
  CLPROFILING_COMMAND_QUEUED = CL_PROFILING_COMMAND_QUEUED,
  CLPROFILING_COMMAND_SUBMIT = CL_PROFILING_COMMAND_SUBMIT,
  CLPROFILING_COMMAND_START = CL_PROFILING_COMMAND_START,
  CLPROFILING_COMMAND_END = CL_PROFILING_COMMAND_END
  };
#endc

{-| Specifies the profiling data.

 * 'CLPROFILING_COMMAND_QUEUED', A 64-bit value that describes the current
device time counter in nanoseconds when the command identified by event is
enqueued in a command-queue by the host.

 * 'CLPROFILING_COMMAND_SUBMIT', A 64-bit value that describes the current
device time counter in nanoseconds when the command identified by event that has
been enqueued is submitted by the host to the device associated with the
commandqueue.

 * 'CLPROFILING_COMMAND_START',	 A 64-bit value that describes the current
device time counter in nanoseconds when the command identified by event starts
execution on the device.

 * 'CLPROFILING_COMMAND_END', A 64-bit value that describes the current device
time counter in nanoseconds when the command identified by event has finished
execution on the device.
-}
{#enum CLProfilingInfo {}#}

getProfilingInfoValue :: CLProfilingInfo -> CLProfilingInfo_
getProfilingInfoValue = fromIntegral . fromEnum

-- -----------------------------------------------------------------------------
bitmaskToDeviceTypes :: CLDeviceType_ -> [CLDeviceType]
bitmaskToDeviceTypes mask = map fst . filter (testMask mask) $ deviceTypeValues

bitmaskFromDeviceTypes :: [CLDeviceType] -> CLDeviceType_
bitmaskFromDeviceTypes = foldl' (.|.) 0 . mapMaybe (`lookup` deviceTypeValues)

bitmaskToCommandQueueProperties :: CLCommandQueueProperty_ -> [CLCommandQueueProperty]
bitmaskToCommandQueueProperties mask = map fst . filter (testMask mask) $ commandQueueProperties

bitmaskFromCommandQueueProperties :: [CLCommandQueueProperty] -> CLCommandQueueProperty_
bitmaskFromCommandQueueProperties = foldl' (.|.) 0 . mapMaybe (`lookup` commandQueueProperties)

bitmaskToFPConfig :: CLDeviceFPConfig_ -> [CLDeviceFPConfig]
bitmaskToFPConfig mask = map fst . filter (testMask mask) $ deviceFPValues

bitmaskToExecCapability :: CLDeviceExecCapability_ -> [CLDeviceExecCapability]
bitmaskToExecCapability mask = map fst . filter (testMask mask) $ deviceExecValues

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


[project @ 2002-07-17 16:07:50 by juhp]

[project @ 2002-07-17 16:07:50 by juhp]

Export timeoutAdd, timeoutRemove, idleAdd, idleRemove and HandlerId.

darcs-hash:20020717160750-f332a-d66284029be7e8fc11e82e36184f5143524410e1.gz

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry General initialization@
--
--  Author : Manuel M. T. Chakravarty
--  Created: 8 December 1998
--
--  Version $Revision: 1.4 $ from $Date: 2002/07/17 16:07:50 $
--
--  Copyright (c) [2000..2002] Axel Simon
--
--  This file 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 2 of the License, or
--  (at your option) any later version.
--
--  This file 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.
--
-- @description@ --------------------------------------------------------------
--
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------
--
--  * quitAddDestroy, quitAdd, quitRemove, inputAdd, inputRemove
--
{-# OPTIONS -optc-include gtk/gtk.h #-}
module General(
  setLocale,
--  getDefaultLanguage,
  init,
  eventsPending,
  main,
  mainLevel,
  mainQuit,
  mainIteration,
  grabAdd,
  grabGetCurrent,
  grabRemove,
  mkDestructor,
  DestroyNotify,
  timeoutAdd,
  timeoutRemove,
  idleAdd,
  idleRemove,
  HandlerId
  ) where

import Prelude
       hiding   (init)
import System   (getProgName, getArgs, ExitCode(ExitSuccess, ExitFailure))
import Monad	(liftM, mapM)
import Foreign
import UTFCForeign
import IOExts	(newIORef, readIORef, writeIORef)
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Enums    (InputCondition(..))

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

-- @method setLocale@ Ensure that the current locale is read.
--
setLocale :: IO String
setLocale  = do
  strPtr <- {#call unsafe set_locale#}
  str <- peekCString strPtr
  destruct strPtr
  return str

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

-- @method init@ initialize GTK+
--
-- * extracts all GTK+ specific arguments from the given options list
--
init :: Maybe (String, [String]) -> IO (String, [String])
init Nothing = do
  prog <- getProgName
  args <- getArgs
  init $ Just (prog, args)
init (Just (prog, args)) = do
  let allArgs = (prog:args)
      argc    = length allArgs
  withMany withCString allArgs $ \addrs  ->
    withArray	       addrs   $ \argv ->
    withObject	       argv    $ \argvp ->
    withObject	       argc    $ \argcp ->
    do
--      {#call unsafe init#} argcp argvp
      {#call unsafe init#} (castPtr argcp) (castPtr argvp)
      argc'   <- peek argcp
      argv'   <- peek argvp
      addrs'  <- peekArray argc' argv'
      _:args' <- mapM peekCString addrs'  -- drop the program name
      return (prog, args')

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

-- @method main@ GTK+'s main event loop
--
main :: IO ()
main  = {#call main#}

-- @method mainLevel@ Inquire the main level
--
mainLevel :: IO Int
mainLevel  = liftM (toEnum.fromEnum) {#call unsafe main_level#}

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

-- @method mainIteration@ process events
--
mainIteration :: IO Bool
mainIteration  = liftM toBool {#call main_iteration#}

-- @method mainIterationDo@ process events
--
mainIterationDo :: Bool -> IO Bool
mainIterationDo blocking =
  liftM toBool $ {#call main_iteration_do#} (fromBool blocking)

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

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

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

{#pointer Function#}

foreign export dynamic mkHandler :: IO {#type gint#} -> IO Function

{#pointer DestroyNotify#}

foreign export dynamic mkDestructor :: IO () -> IO DestroyNotify

type HandlerId = {#type guint#}

-- Turn a function into a function pointer and a destructor pointer.
--
makeCallback :: IO {#type gint#} -> IO (Function, DestroyNotify)
makeCallback fun = do
  funPtr <- mkHandler fun
  dRef <- newIORef nullFunPtr
  dPtr <- mkDestructor $ do
    freeHaskellFunPtr funPtr
    dPtr <- readIORef dRef
    freeHaskellFunPtr dPtr
  writeIORef dRef dPtr
  return (funPtr, dPtr)

-- @method timeoutAdd@ Register a function that is to be called after
-- @ref arg interval@ ms have been elapsed.
--
-- * If the function returns False it will be removed.
--
timeoutAdd :: IO Bool -> Int -> IO HandlerId
timeoutAdd fun msec = do
  (funPtr, dPtr) <- makeCallback (liftM fromBool fun)
  {#call unsafe timeout_add_full#} (fromIntegral msec) funPtr nullFunPtr
    nullPtr dPtr

-- @method timeoutRemove@ Remove a previously added timeout handler by its
-- @ref type TimeoutId@.
--
timeoutRemove :: HandlerId -> IO ()
timeoutRemove  = {#call unsafe timeout_remove#}

-- @method idleAdd@ Add a callback that is called whenever the system is idle.
--
-- * A priority can be specified.
--
idleAdd :: IO Bool -> Int -> IO HandlerId
idleAdd fun pri = do
  (funPtr, dPtr) <- makeCallback (liftM fromBool fun)
  {#call unsafe idle_add_full#} (fromIntegral pri) funPtr nullFunPtr
    nullPtr dPtr

-- @method idleRemove@ Remove a previously added idle handler by its
-- @ref arg TimeoutId@.
--
idleRemove :: HandlerId -> IO ()
idleRemove  = {#call unsafe idle_remove#}

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry General initialization@
--
--  Author : Manuel M. T. Chakravarty
--  Created: 8 December 1998
--
--  Version $Revision: 1.3 $ from $Date: 2002/07/08 09:13:09 $
--
--  Copyright (c) [2000..2002] Axel Simon
--
--  This file 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 2 of the License, or
--  (at your option) any later version.
--
--  This file 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.
--
-- @description@ --------------------------------------------------------------
--
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------
--
--  * quitAddDestroy, quitAdd, quitRemove, timeoutAdd, timeoutRemove, idleAdd,
--    idleRemove, inputAdd, inputRemove
--
{-# OPTIONS -optc-include gtk/gtk.h #-}
module General(
  setLocale,
--  getDefaultLanguage,
  init,
  eventsPending,
  main,
  mainLevel,
  mainQuit,
  mainIteration,
  grabAdd,
  grabGetCurrent,
  grabRemove,
  mkDestructor,
  DestroyNotify
  ) where

import Prelude
       hiding   (init)
import System   (getProgName, getArgs, ExitCode(ExitSuccess, ExitFailure))
import Monad	(liftM, mapM)
import Foreign
import UTFCForeign
import IOExts	(newIORef, readIORef, writeIORef)
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Enums    (InputCondition(..))

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

-- @method setLocale@ Ensure that the current locale is read.
--
setLocale :: IO String
setLocale  = do
  strPtr <- {#call unsafe set_locale#}
  str <- peekCString strPtr
  destruct strPtr
  return str

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

-- @method init@ initialize GTK+
--
-- * extracts all GTK+ specific arguments from the given options list
--
init :: Maybe (String, [String]) -> IO (String, [String])
init Nothing = do
  prog <- getProgName
  args <- getArgs
  init $ Just (prog, args)
init (Just (prog, args)) = do
  let allArgs = (prog:args)
      argc    = length allArgs
  withMany withCString allArgs $ \addrs  ->
    withArray	       addrs   $ \argv ->
    withObject	       argv    $ \argvp ->
    withObject	       argc    $ \argcp ->
    do
--      {#call unsafe init#} argcp argvp
      {#call unsafe init#} (castPtr argcp) (castPtr argvp)
      argc'   <- peek argcp
      argv'   <- peek argvp
      addrs'  <- peekArray argc' argv'
      _:args' <- mapM peekCString addrs'  -- drop the program name
      return (prog, args')

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

-- @method main@ GTK+'s main event loop
--
main :: IO ()
main  = {#call main#}

-- @method mainLevel@ Inquire the main level
--
mainLevel :: IO Int
mainLevel  = liftM (toEnum.fromEnum) {#call unsafe main_level#}

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

-- @method mainIteration@ process events
--
mainIteration :: IO Bool
mainIteration  = liftM toBool {#call main_iteration#}

-- @method mainIterationDo@ process events
--
mainIterationDo :: Bool -> IO Bool
mainIterationDo blocking =
  liftM toBool $ {#call main_iteration_do#} (fromBool blocking)

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

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

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

{#pointer Function#}

foreign export dynamic mkHandler :: IO {#type gint#} -> IO Function

{#pointer DestroyNotify#}

foreign export dynamic mkDestructor :: IO () -> IO DestroyNotify

type HandlerId = {#type guint#}

-- Turn a function into a function pointer and a destructor pointer.
--
makeCallback :: IO {#type gint#} -> IO (Function, DestroyNotify)
makeCallback fun = do
  funPtr <- mkHandler fun
  dRef <- newIORef nullFunPtr
  dPtr <- mkDestructor $ do
    freeHaskellFunPtr funPtr
    dPtr <- readIORef dRef
    freeHaskellFunPtr dPtr
  writeIORef dRef dPtr
  return (funPtr, dPtr)

-- @method timeoutAdd@ Register a function that is to be called after
-- @ref arg interval@ ms have been elapsed.
--
-- * If the function returns False it will be removed.
--
timeoutAdd :: IO Bool -> Int -> IO HandlerId
timeoutAdd fun msec = do
  (funPtr, dPtr) <- makeCallback (liftM fromBool fun)
  {#call unsafe timeout_add_full#} (fromIntegral msec) funPtr nullFunPtr
    nullPtr dPtr

-- @method timeoutRemove@ Remove a previously added timeout handler by its
-- @ref type TimeoutId@.
--
timeoutRemove :: HandlerId -> IO ()
timeoutRemove  = {#call unsafe timeout_remove#}

-- @method idleAdd@ Add a callback that is called whenever the system is idle.
--
-- * A priority can be specified.
--
idleAdd :: IO Bool -> Int -> IO HandlerId
idleAdd fun pri = do
  (funPtr, dPtr) <- makeCallback (liftM fromBool fun)
  {#call unsafe idle_add_full#} (fromIntegral pri) funPtr nullFunPtr
    nullPtr dPtr

-- @method idleRemove@ Remove a previously added idle handler by its
-- @ref arg TimeoutId@.
--
idleRemove :: HandlerId -> IO ()
idleRemove  = {#call unsafe idle_remove#}


Updated XCore architecture header

Updated XCore architecture header

{-# LANGUAGE ForeignFunctionInterface #-}
{-|
Module      : Hapstone.Internal.XCore
Description : XCore architecture header ported using C2HS + some boilerplate
Copyright   : (c) Inokentiy Babushkin, 2016
License     : BSD3
Maintainer  : Inokentiy Babushkin <inokentiy.babushkin@googlemail.com>
Stability   : experimental

This module contains XCore specific datatypes and their respective Storable
instances. Most of the types are used internally and can be looked up here.
Some of them are currently unused, as the headers only define them as symbolic
constants whose type is never used explicitly, which poses a problem for a
memory-safe port to the Haskell language, this is about to get fixed in a
future version.

Apart from that, because the module is generated using C2HS, some of the
documentation is misplaced or rendered incorrectly, so if in doubt, read the
source file.
-}
module Hapstone.Internal.XCore where

#include <capstone/xcore.h>

{#context lib = "capstone"#}

import Foreign
import Foreign.C.Types

-- | operand type for instruction's operands
{#enum xcore_op_type as XCoreOpType {underscoreToCase}
    deriving (Show, Eq, Bounded)#}

-- | XCore registers
{#enum xcore_reg as XCoreReg {underscoreToCase}
    deriving (Show, Eq, Bounded)#}

-- | memory access operands
-- associated with 'XcoreOpMem' operand type
data XCoreOpMemStruct = XCoreOpMemStruct
    { base :: Word8 -- ^ base register
    , index :: Word8 -- ^ index register
    , disp :: Int32 -- ^ displacement/offset value
    , direct :: Int32 -- ^ +1: forward, -1: backward
    } deriving (Show, Eq)

instance Storable XCoreOpMemStruct where
    sizeOf _ = {#sizeof xcore_op_mem#}
    alignment _ = {#alignof xcore_op_mem#}
    peek p = XCoreOpMemStruct
        <$> (fromIntegral <$> {#get xcore_op_mem->base#} p)
        <*> (fromIntegral <$> {#get xcore_op_mem->index#} p)
        <*> (fromIntegral <$> {#get xcore_op_mem->disp#} p)
        <*> (fromIntegral <$> {#get xcore_op_mem->direct#} p)
    poke p (XCoreOpMemStruct b i disp dir) = do
        {#set xcore_op_mem->base#} p (fromIntegral b)
        {#set xcore_op_mem->index#} p (fromIntegral i)
        {#set xcore_op_mem->disp#} p (fromIntegral disp)
        {#set xcore_op_mem->direct#} p (fromIntegral dir)

-- | instruction operand
data CsXCoreOp
    = Reg XCoreReg -- ^ register value for 'XcoreOpReg' operands
    | Imm Int32 -- ^ immediate value for 'XcoreOpImm' operands
    | Mem XCoreOpMemStruct -- ^ base/index/disp/direct value for 'XcoreOpMem'
                           -- operands
    | Undefined -- ^ invalid operand value, for 'XcoreOpInvalid' operand
    deriving (Show, Eq)

instance Storable CsXCoreOp where
    sizeOf _ = 16
    alignment _ = 4
    peek p = do
        t <- fromIntegral <$> {#get cs_xcore_op->type#} p
        let bP = plusPtr p 4
        case toEnum t of
          XcoreOpReg -> (Reg . toEnum . fromIntegral) <$> (peek bP :: IO Int32)
          XcoreOpImm -> Imm <$> peek bP
          XcoreOpMem -> Mem <$> peek bP
          _ -> return Undefined
    poke p op = do
        let bP = plusPtr p 4
            setType = {#set cs_xcore_op->type#} p . fromIntegral . fromEnum
        case op of
          Reg r -> do poke bP (fromIntegral $ fromEnum r :: Int32)
                      setType XcoreOpReg
          Imm i -> poke bP i >> setType XcoreOpImm
          Mem m -> poke bP m >> setType XcoreOpMem
          _ -> setType XcoreOpInvalid

-- | instruction datatype
newtype CsXCore = CsXCore [CsXCoreOp] -- ^ operand list of this instruction,
                                      -- *MUST* have <= 8 operands, else you'll
                                      -- get a runtime error when you
                                      -- (implicitly) try to write it to memory
                                      -- via it's Storable instance
    deriving (Show, Eq)

instance Storable CsXCore where
    sizeOf _ = 132
    alignment _ = 4
    peek p = do
        num <- fromIntegral <$> {#get cs_xcore->op_count#} p
        CsXCore <$> peekArray num (plusPtr p {#offsetof cs_xcore.operands#})
    poke p (CsXCore o) = do
        {#set cs_xcore->op_count#} p (fromIntegral $ length o)
        if length o > 8
           then error "operands overflew 8 elements"
           else pokeArray (plusPtr p {#offsetof cs_xcore->operands#}) o

-- | XCore instructions
{#enum xcore_insn as XCoreInsn {underscoreToCase}
    deriving (Show, Eq, Bounded)#}
-- | XCore instruction groups
{#enum xcore_insn_group as XCoreInsnGroup {underscoreToCase}
    deriving (Show, Eq, Bounded)#}

{-# LANGUAGE ForeignFunctionInterface #-}
{-|
Module      : Hapstone.Internal.XCore
Description : XCore architecture header ported using C2HS + some boilerplate
Copyright   : (c) Inokentiy Babushkin, 2016
License     : BSD3
Maintainer  : Inokentiy Babushkin <inokentiy.babushkin@googlemail.com>
Stability   : experimental

This module contains XCore specific datatypes and their respective Storable
instances. Most of the types are used internally and can be looked up here.
Some of them are currently unused, as the headers only define them as symbolic
constants whose type is never used explicitly, which poses a problem for a
memory-safe port to the Haskell language, this is about to get fixed in a
future version.

Apart from that, because the module is generated using C2HS, some of the
documentation is misplaced or rendered incorrectly, so if in doubt, read the
source file.
-}
module Hapstone.Internal.XCore where

#include <capstone/xcore.h>

{#context lib = "capstone"#}

import Foreign
import Foreign.C.Types

-- | operand type for instruction's operands
{#enum xcore_op_type as XCoreOpType {underscoreToCase}
    deriving (Show, Eq, Bounded)#}

-- | memory access operands
-- associated with 'XcoreOpMem' operand type
data XCoreOpMemStruct = XCoreOpMemStruct
    { base :: Word8 -- ^ base register
    , index :: Word8 -- ^ index register
    , disp :: Int32 -- ^ displacement/offset value
    , direct :: Int32 -- ^ +1: forward, -1: backward
    } deriving (Show, Eq)

instance Storable XCoreOpMemStruct where
    sizeOf _ = {#sizeof xcore_op_mem#}
    alignment _ = {#alignof xcore_op_mem#}
    peek p = XCoreOpMemStruct
        <$> (fromIntegral <$> {#get xcore_op_mem->base#} p)
        <*> (fromIntegral <$> {#get xcore_op_mem->index#} p)
        <*> (fromIntegral <$> {#get xcore_op_mem->disp#} p)
        <*> (fromIntegral <$> {#get xcore_op_mem->direct#} p)
    poke p (XCoreOpMemStruct b i disp dir) = do
        {#set xcore_op_mem->base#} p (fromIntegral b)
        {#set xcore_op_mem->index#} p (fromIntegral i)
        {#set xcore_op_mem->disp#} p (fromIntegral disp)
        {#set xcore_op_mem->direct#} p (fromIntegral dir)

-- | instruction operand
data CsXCoreOp
    = Reg Word32 -- ^ register value for 'XcoreOpReg' operands
    | Imm Int32 -- ^ immediate value for 'XcoreOpImm' operands
    | Mem XCoreOpMemStruct -- ^ base/index/disp/direct value for 'XcoreOpMem'
                           -- operands
    | Undefined -- ^ invalid operand value, for 'XcoreOpInvalid' operand
    deriving (Show, Eq)

instance Storable CsXCoreOp where
    sizeOf _ = 16
    alignment _ = 4
    peek p = do
        t <- fromIntegral <$> {#get cs_xcore_op->type#} p
        let bP = plusPtr p 4
        case toEnum t of
          XcoreOpReg -> Reg <$> peek bP
          XcoreOpImm -> Imm <$> peek bP
          XcoreOpMem -> Mem <$> peek bP
          _ -> return Undefined
    poke p op = do
        let bP = plusPtr p 4
            setType = {#set cs_xcore_op->type#} p . fromIntegral . fromEnum
        case op of
          Reg r -> poke bP r >> setType XcoreOpReg
          Imm i -> poke bP i >> setType XcoreOpImm
          Mem m -> poke bP m >> setType XcoreOpMem
          _ -> setType XcoreOpInvalid

-- | instruction datatype
newtype CsXCore = CsXCore [CsXCoreOp] -- ^ operand list of this instruction,
                                      -- *MUST* have <= 8 operands, else you'll
                                      -- get a runtime error when you
                                      -- (implicitly) try to write it to memory
                                      -- via it's Storable instance
    deriving (Show, Eq)

instance Storable CsXCore where
    sizeOf _ = 132
    alignment _ = 4
    peek p = do
        num <- fromIntegral <$> {#get cs_xcore->op_count#} p
        CsXCore <$> peekArray num (plusPtr p {#offsetof cs_xcore.operands#})
    poke p (CsXCore o) = do
        {#set cs_xcore->op_count#} p (fromIntegral $ length o)
        if length o > 8
           then error "operands overflew 8 elements"
           else pokeArray (plusPtr p {#offsetof cs_xcore->operands#}) o

-- | XCore registers
{#enum xcore_reg as XCoreReg {underscoreToCase}
    deriving (Show, Eq, Bounded)#}
-- | XCore instructions
{#enum xcore_insn as XCoreInsn {underscoreToCase}
    deriving (Show, Eq, Bounded)#}
-- | XCore instruction groups
{#enum xcore_insn_group as XCoreInsnGroup {underscoreToCase}
    deriving (Show, Eq, Bounded)#}


Implement pageRectangleNew

Implement pageRectangleNew

{-# LANGUAGE CPP, DeriveDataTypeable #-}
--  GIMP Toolkit (GTK) Binding for Haskell: binding to poppler -*-haskell-*-
--
--  Author : Andy Stewart
--  Created: 18-Jun-2010
--
--  Copyright (c) 2010 Andy Stewart
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 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.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  POPPLER, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original POPPLER documentation.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module Graphics.UI.Gtk.Poppler.Page (
-- * Types
    Cairo,
    PopplerRectangle (..),
    PopplerColor (..),
    ImageMapping,
    PageTransition,
    LinkMapping,
    FormFieldMapping,

-- * Enums
    SelectionStyle (..),

-- * Methods
    pageRender,
    -- pageRenderToPixbuf,
    pageGetSize,
    pageGetIndex,
    pageGetThumbnail,
    pageGetThumbnailSize,
    pageRenderToPs,
    pageFindText,
    pageGetText,
    pageGetDuration,
    pageGetTransition,
    pageGetLinkMapping,
    pageGetImageMapping,
    pageGetFormFieldMapping,
    pageGetSelectionRegion,
    pageRenderSelection,
    pageAddAnnot,
    pageRemoveAnnot,
    pageRectangleNew
    -- pageRenderSelectionToPixbuf,
    ) where

import Control.Monad
import Data.Typeable
import System.Glib.FFI
import System.Glib.Flags
import System.Glib.GError
import System.Glib.GObject
import System.Glib.GList
import System.Glib.UTFString
import Graphics.UI.Gtk.Poppler.Enums
import Graphics.UI.Gtk.Abstract.Widget (Rectangle (..), Color (..))
{#import Graphics.UI.GtkInternals#}
{#import Graphics.Rendering.Cairo.Types#}
{#import Graphics.UI.Gtk.Poppler.Types#}
import Graphics.UI.Gtk.Poppler.Structs
import Control.Monad.Reader (ReaderT(runReaderT), ask, MonadIO, liftIO)
import Graphics.Rendering.Cairo.Internal (Render(..), bracketR)

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

-- | Render the page to the given cairo context. This function is for rendering a page that will be
-- displayed. If you want to render a page that will be printed use 'pageRenderForPrinting'
-- instead
pageRender :: PageClass page => page
 -> Render ()
pageRender page =
  ask >>= \ x -> liftIO ({#call poppler_page_render #} (toPage page) x)

-- | First scale the document to match the specified pixels per point, then render the rectangle given by
-- the upper left corner at (@srcX@, @srcY@) and @srcWidth@ and @srcHeight@. This function is for rendering
-- a page that will be displayed. If you want to render a page that will be printed use
-- 'pageRenderToPixbufForPrinting' instead
{- pageRenderToPixbuf :: PageClass page => page
 -> Rectangle -- ^ @rect@      rectangle to render
 -> Double -- ^ @scale@      scale specified as pixels per point
 -> Int -- ^ @rotation@   rotate the document by the specified degree
 -> Pixbuf -- ^ @pixbuf@     pixbuf to render into
 -> IO ()
pageRenderToPixbuf page (Rectangle x y width height) scale rotation pixbuf =
  {#call poppler_page_render_to_pixbuf #}
    (toPage page)
    (fromIntegral x)
    (fromIntegral y)
    (fromIntegral width)
    (fromIntegral height)
    (realToFrac scale)
    (fromIntegral rotation)
    pixbuf
-}

-- | Gets the size of page at the current scale and rotation.
pageGetSize :: PageClass page => page
 -> IO (Double, Double)
pageGetSize page =
  alloca $ \ widthPtr ->
  alloca $ \ heightPtr -> do
      {#call poppler_page_get_size #}
        (toPage page)
        widthPtr
        heightPtr
      width <- peek widthPtr
      height <- peek heightPtr
      return (realToFrac width, realToFrac height)

-- | Returns the index of page
pageGetIndex :: PageClass page => page
 -> IO Int  -- ^ returns index value of page
pageGetIndex page =
  liftM fromIntegral $
  {#call poppler_page_get_index #} (toPage page)

-- | Get the embedded thumbnail for the specified page. If the document doesn't have an embedded
-- thumbnail for the page, this function returns 'Nothing'.
pageGetThumbnail :: PageClass page => page
 -> IO (Maybe Surface) -- ^ returns the tumbnail as a @cairoSurfaceT@ or 'Nothing' if the document doesn't have a thumbnail for this page.
pageGetThumbnail page = do
  surfacePtr <- {#call poppler_page_get_thumbnail #} (toPage page)
  if surfacePtr == nullPtr
     then return Nothing
     else liftM Just (mkSurface surfacePtr)

-- | Returns 'True' if page has a thumbnail associated with it. It also fills in width and height with the
-- width and height of the thumbnail. The values of width and height are not changed if no appropriate
-- thumbnail exists.
pageGetThumbnailSize :: PageClass page => page
 -> IO (Maybe (Int, Int))
pageGetThumbnailSize page =
  alloca $ \ widthPtr ->
  alloca $ \ heightPtr -> do
    success <- liftM toBool $
                {#call poppler_page_get_thumbnail_size #}
                  (toPage page)
                  widthPtr
                  heightPtr
    if success
       then do
         width  <- peek widthPtr
         height <- peek heightPtr
         return $ Just (fromIntegral width, fromIntegral height)
       else return Nothing

-- | Render the page on a postscript file
pageRenderToPs :: (PageClass page, PSFileClass psFile) => page -> psFile -> IO ()
pageRenderToPs page psFile =
  {#call poppler_page_render_to_ps #} (toPage page) (toPSFile psFile)

-- | A GList of rectangles for each occurance of the text on the page. The coordinates are in PDF points.
pageFindText :: PageClass page => page
 -> String  -- ^ @text@    the text to search for (UTF-8 encoded)
 -> IO [PopplerRectangle]
pageFindText page text =
  withUTFString text $ \ textPtr -> do
    glistPtr <- {#call poppler_page_find_text #} (toPage page) textPtr
    list <- fromGList glistPtr
    mapM peekPopplerRectangle list

-- | Retrieves the contents of the specified selection as text.
pageGetText :: PageClass page => page -> IO String  -- ^ returns selection string
pageGetText page =
  {#call poppler_page_get_text #} (toPage page)
  >>= peekUTFString

-- | Returns the duration of page
pageGetDuration :: PageClass page => page
 -> IO Double  -- ^ returns duration in seconds of page or -1.
pageGetDuration page =
  liftM realToFrac $
  {#call poppler_page_get_duration #} (toPage page)

-- | Returns the transition effect of page
pageGetTransition :: PageClass page => page
 -> IO (Maybe PageTransition) -- ^ returns a 'PageTransition' or 'Nothing'.
pageGetTransition page = do
  ptr <- {#call poppler_page_get_transition #} (toPage page)
  if ptr == nullPtr
     then return Nothing
     else liftM Just $ makeNewPageTransition (castPtr ptr)

{#pointer *PageTransition foreign newtype #}

makeNewPageTransition :: Ptr PageTransition -> IO PageTransition
makeNewPageTransition rPtr = do
  transition <- newForeignPtr rPtr page_transition_free
  return (PageTransition transition)

foreign import ccall unsafe "&poppler_page_transition_free"
  page_transition_free :: FinalizerPtr PageTransition

-- | Returns a list of 'LinkMapping' items that map from a location on page to a 'Action'.
pageGetLinkMapping :: PageClass page => page
 -> IO [LinkMapping]
pageGetLinkMapping page = do
  glistPtr <- {#call poppler_page_get_link_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewLinkMapping list
  {#call unsafe poppler_page_free_link_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *LinkMapping foreign newtype #}

makeNewLinkMapping :: Ptr LinkMapping -> IO LinkMapping
makeNewLinkMapping rPtr = do
  linkMapping <- newForeignPtr rPtr poppler_link_mapping_free
  return (LinkMapping linkMapping)

foreign import ccall unsafe "&poppler_link_mapping_free"
  poppler_link_mapping_free :: FinalizerPtr LinkMapping

-- | Returns a list of 'ImageMapping' items that map from a location on page to a 'Action'.
pageGetImageMapping :: PageClass page => page
 -> IO [ImageMapping]
pageGetImageMapping page = do
  glistPtr <- {#call poppler_page_get_image_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewImageMapping list
  {#call unsafe poppler_page_free_image_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *ImageMapping foreign newtype #}

makeNewImageMapping :: Ptr ImageMapping -> IO ImageMapping
makeNewImageMapping rPtr = do
  imageMapping <- newForeignPtr rPtr poppler_image_mapping_free
  return (ImageMapping imageMapping)

foreign import ccall unsafe "&poppler_image_mapping_free"
  poppler_image_mapping_free :: FinalizerPtr ImageMapping

-- | Returns a list of 'FormFieldMapping' items that map from a location on page to a 'Action'.
pageGetFormFieldMapping :: PageClass page => page
 -> IO [FormFieldMapping]
pageGetFormFieldMapping page = do
  glistPtr <- {#call poppler_page_get_form_field_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewFormFieldMapping list
  {#call unsafe poppler_page_free_image_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *FormFieldMapping foreign newtype #}

makeNewFormFieldMapping :: Ptr FormFieldMapping -> IO FormFieldMapping
makeNewFormFieldMapping rPtr = do
  formFieldMapping <- newForeignPtr rPtr poppler_form_field_mapping_free
  return (FormFieldMapping formFieldMapping)

foreign import ccall unsafe "&poppler_form_field_mapping_free"
  poppler_form_field_mapping_free :: FinalizerPtr FormFieldMapping

-- | Returns a region containing the area that would be rendered by 'pageRenderSelection' or
-- 'pageRenderSelectionToPixbuf' as a GList of PopplerRectangle.
pageGetSelectionRegion :: PageClass page => page
 -> Double -- ^ @scale@     scale specified as pixels per point
 -> SelectionStyle -- ^ @style@     a 'SelectionStyle'
 -> PopplerRectangle -- ^ @selection@ start and end point of selection as a rectangle
 -> IO [PopplerRectangle]
pageGetSelectionRegion page scale style selection =
  with selection $ \ selectionPtr -> do
    glistPtr <- {#call poppler_page_get_selection_region #}
                 (toPage page)
                 (realToFrac scale)
                 ((fromIntegral . fromEnum) style)
                 (castPtr selectionPtr)
    list <- fromGList glistPtr
    rectangles <- mapM peekPopplerRectangle list
    {#call unsafe poppler_page_selection_region_free #} (castPtr glistPtr)
    return rectangles

-- | Render the selection specified by selection for page to the given cairo context. The selection will
-- be rendered, using @glyphColor@ for the glyphs and @backgroundColor@ for the selection background.
--
-- If non-'Nothing', @oldSelection@ specifies the selection that is already rendered to cairo, in which case
-- this function will (some day) only render the changed part of the selection.
pageRenderSelection :: PageClass page => page
 -> PopplerRectangle -- ^ @selection@        start and end point of selection as a rectangle
 -> PopplerRectangle -- ^ @oldSelection@    previous selection
 -> SelectionStyle -- ^ @style@            a 'SelectionStyle'
 -> PopplerColor -- ^ @glyphColor@      color to use for drawing glyphs
 -> PopplerColor -- ^ @backgroundColor@ color to use for the selection background
 -> Render ()
pageRenderSelection page selection oldSelection style glyphColor backgroundColor = do
  cairo <- ask
  liftIO $
         with selection $ \ selectionPtr ->
         with oldSelection $ \ oldSelectionPtr ->
         with glyphColor $ \ glyphColorPtr ->
         with backgroundColor $ \ backgroundColorPtr ->
              {#call poppler_page_render_selection #}
                  (toPage page)
                  cairo
                  (castPtr selectionPtr)
                  (castPtr oldSelectionPtr)
                  ((fromIntegral . fromEnum) style)
                  (castPtr glyphColorPtr)
                  (castPtr backgroundColorPtr)

pageAddAnnot :: (PageClass page, AnnotClass annot) => page -> annot -> IO ()
pageAddAnnot page annot =
  {# call poppler_page_add_annot #} (toPage page) (toAnnot annot)

pageRemoveAnnot :: (PageClass page, AnnotClass annot) => page -> annot -> IO ()
pageRemoveAnnot page annot =
  {# call poppler_page_remove_annot #} (toPage page) (toAnnot annot)

pageRectangleNew :: IO PopplerRectangle
pageRectangleNew =
  (peekPopplerRectangle . castPtr) =<< {# call poppler_rectangle_new #}

-- | Render the selection specified by selection for page into pixbuf. The selection will be rendered at
-- scale, using @glyphColor@ for the glyphs and @backgroundColor@ for the selection background.
--
-- If non-'Nothing', @oldSelection@ specifies the selection that is already rendered in pixbuf, in which case
-- this function will (some day) only render the changed part of the selection.
{-
pageRenderSelectionToPixbuf :: PageClass page => page
 -> Double -- ^ @scale@            scale specified as pixels per point
 -> Int -- ^ @rotation@         rotate the document by the specified degree
 -> Pixbuf -- ^ @pixbuf@           pixbuf to render to
 -> PopplerRectangle -- ^ @selection@        start and end point of selection as a rectangle
 -> PopplerRectangle -- ^ @oldSelection@    previous selection
 -> SelectionStyle -- ^ @style@            a 'SelectionStyle'
 -> Color -- ^ @glyphColor@      color to use for drawing glyphs
 -> Color -- ^ @backgroundColor@ color to use for the selection background
 -> IO ()
pageRenderSelectionToPixbuf page scale rotation pixbuf selection oldSelection style glyphColor backgroundColor =
  with selection $ \ selectionPtr ->
  with oldSelection $ \ oldSelectionPtr ->
  with glyphColor $ \ glyphColorPtr ->
  with backgroundColor $ \ backgroundColorPtr ->
      {#call poppler_page_render_selection_to_pixbuf #}
        (toPage page)
        (realToFrac scale)
        (fromIntegral rotation)
        pixbuf
        (castPtr selectionPtr)
        (castPtr oldSelectionPtr)
        ((fromIntegral . fromEnum) style)
        (castPtr glyphColorPtr)
        (castPtr backgroundColorPtr)
-}

{-# LANGUAGE CPP, DeriveDataTypeable #-}
--  GIMP Toolkit (GTK) Binding for Haskell: binding to poppler -*-haskell-*-
--
--  Author : Andy Stewart
--  Created: 18-Jun-2010
--
--  Copyright (c) 2010 Andy Stewart
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 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.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  POPPLER, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original POPPLER documentation.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module Graphics.UI.Gtk.Poppler.Page (
-- * Types
    Cairo,
    PopplerRectangle (..),
    PopplerColor (..),
    ImageMapping,
    PageTransition,
    LinkMapping,
    FormFieldMapping,

-- * Enums
    SelectionStyle (..),

-- * Methods
    pageRender,
    -- pageRenderToPixbuf,
    pageGetSize,
    pageGetIndex,
    pageGetThumbnail,
    pageGetThumbnailSize,
    pageRenderToPs,
    pageFindText,
    pageGetText,
    pageGetDuration,
    pageGetTransition,
    pageGetLinkMapping,
    pageGetImageMapping,
    pageGetFormFieldMapping,
    pageGetSelectionRegion,
    pageRenderSelection,
    pageAddAnnot,
    pageRemoveAnnot
    -- pageRenderSelectionToPixbuf,
    ) where

import Control.Monad
import Data.Typeable
import System.Glib.FFI
import System.Glib.Flags
import System.Glib.GError
import System.Glib.GObject
import System.Glib.GList
import System.Glib.UTFString
import Graphics.UI.Gtk.Poppler.Enums
import Graphics.UI.Gtk.Abstract.Widget (Rectangle (..), Color (..))
{#import Graphics.UI.GtkInternals#}
{#import Graphics.Rendering.Cairo.Types#}
{#import Graphics.UI.Gtk.Poppler.Types#}
import Graphics.UI.Gtk.Poppler.Structs
import Control.Monad.Reader (ReaderT(runReaderT), ask, MonadIO, liftIO)
import Graphics.Rendering.Cairo.Internal (Render(..), bracketR)

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

-- | Render the page to the given cairo context. This function is for rendering a page that will be
-- displayed. If you want to render a page that will be printed use 'pageRenderForPrinting'
-- instead
pageRender :: PageClass page => page
 -> Render ()
pageRender page =
  ask >>= \ x -> liftIO ({#call poppler_page_render #} (toPage page) x)

-- | First scale the document to match the specified pixels per point, then render the rectangle given by
-- the upper left corner at (@srcX@, @srcY@) and @srcWidth@ and @srcHeight@. This function is for rendering
-- a page that will be displayed. If you want to render a page that will be printed use
-- 'pageRenderToPixbufForPrinting' instead
{- pageRenderToPixbuf :: PageClass page => page
 -> Rectangle -- ^ @rect@      rectangle to render
 -> Double -- ^ @scale@      scale specified as pixels per point
 -> Int -- ^ @rotation@   rotate the document by the specified degree
 -> Pixbuf -- ^ @pixbuf@     pixbuf to render into
 -> IO ()
pageRenderToPixbuf page (Rectangle x y width height) scale rotation pixbuf =
  {#call poppler_page_render_to_pixbuf #}
    (toPage page)
    (fromIntegral x)
    (fromIntegral y)
    (fromIntegral width)
    (fromIntegral height)
    (realToFrac scale)
    (fromIntegral rotation)
    pixbuf
-}

-- | Gets the size of page at the current scale and rotation.
pageGetSize :: PageClass page => page
 -> IO (Double, Double)
pageGetSize page =
  alloca $ \ widthPtr ->
  alloca $ \ heightPtr -> do
      {#call poppler_page_get_size #}
        (toPage page)
        widthPtr
        heightPtr
      width <- peek widthPtr
      height <- peek heightPtr
      return (realToFrac width, realToFrac height)

-- | Returns the index of page
pageGetIndex :: PageClass page => page
 -> IO Int  -- ^ returns index value of page
pageGetIndex page =
  liftM fromIntegral $
  {#call poppler_page_get_index #} (toPage page)

-- | Get the embedded thumbnail for the specified page. If the document doesn't have an embedded
-- thumbnail for the page, this function returns 'Nothing'.
pageGetThumbnail :: PageClass page => page
 -> IO (Maybe Surface) -- ^ returns the tumbnail as a @cairoSurfaceT@ or 'Nothing' if the document doesn't have a thumbnail for this page.
pageGetThumbnail page = do
  surfacePtr <- {#call poppler_page_get_thumbnail #} (toPage page)
  if surfacePtr == nullPtr
     then return Nothing
     else liftM Just (mkSurface surfacePtr)

-- | Returns 'True' if page has a thumbnail associated with it. It also fills in width and height with the
-- width and height of the thumbnail. The values of width and height are not changed if no appropriate
-- thumbnail exists.
pageGetThumbnailSize :: PageClass page => page
 -> IO (Maybe (Int, Int))
pageGetThumbnailSize page =
  alloca $ \ widthPtr ->
  alloca $ \ heightPtr -> do
    success <- liftM toBool $
                {#call poppler_page_get_thumbnail_size #}
                  (toPage page)
                  widthPtr
                  heightPtr
    if success
       then do
         width  <- peek widthPtr
         height <- peek heightPtr
         return $ Just (fromIntegral width, fromIntegral height)
       else return Nothing

-- | Render the page on a postscript file
pageRenderToPs :: (PageClass page, PSFileClass psFile) => page -> psFile -> IO ()
pageRenderToPs page psFile =
  {#call poppler_page_render_to_ps #} (toPage page) (toPSFile psFile)

-- | A GList of rectangles for each occurance of the text on the page. The coordinates are in PDF points.
pageFindText :: PageClass page => page
 -> String  -- ^ @text@    the text to search for (UTF-8 encoded)
 -> IO [PopplerRectangle]
pageFindText page text =
  withUTFString text $ \ textPtr -> do
    glistPtr <- {#call poppler_page_find_text #} (toPage page) textPtr
    list <- fromGList glistPtr
    mapM peekPopplerRectangle list

-- | Retrieves the contents of the specified selection as text.
pageGetText :: PageClass page => page -> IO String  -- ^ returns selection string
pageGetText page =
  {#call poppler_page_get_text #} (toPage page)
  >>= peekUTFString

-- | Returns the duration of page
pageGetDuration :: PageClass page => page
 -> IO Double  -- ^ returns duration in seconds of page or -1.
pageGetDuration page =
  liftM realToFrac $
  {#call poppler_page_get_duration #} (toPage page)

-- | Returns the transition effect of page
pageGetTransition :: PageClass page => page
 -> IO (Maybe PageTransition) -- ^ returns a 'PageTransition' or 'Nothing'.
pageGetTransition page = do
  ptr <- {#call poppler_page_get_transition #} (toPage page)
  if ptr == nullPtr
     then return Nothing
     else liftM Just $ makeNewPageTransition (castPtr ptr)

{#pointer *PageTransition foreign newtype #}

makeNewPageTransition :: Ptr PageTransition -> IO PageTransition
makeNewPageTransition rPtr = do
  transition <- newForeignPtr rPtr page_transition_free
  return (PageTransition transition)

foreign import ccall unsafe "&poppler_page_transition_free"
  page_transition_free :: FinalizerPtr PageTransition

-- | Returns a list of 'LinkMapping' items that map from a location on page to a 'Action'.
pageGetLinkMapping :: PageClass page => page
 -> IO [LinkMapping]
pageGetLinkMapping page = do
  glistPtr <- {#call poppler_page_get_link_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewLinkMapping list
  {#call unsafe poppler_page_free_link_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *LinkMapping foreign newtype #}

makeNewLinkMapping :: Ptr LinkMapping -> IO LinkMapping
makeNewLinkMapping rPtr = do
  linkMapping <- newForeignPtr rPtr poppler_link_mapping_free
  return (LinkMapping linkMapping)

foreign import ccall unsafe "&poppler_link_mapping_free"
  poppler_link_mapping_free :: FinalizerPtr LinkMapping

-- | Returns a list of 'ImageMapping' items that map from a location on page to a 'Action'.
pageGetImageMapping :: PageClass page => page
 -> IO [ImageMapping]
pageGetImageMapping page = do
  glistPtr <- {#call poppler_page_get_image_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewImageMapping list
  {#call unsafe poppler_page_free_image_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *ImageMapping foreign newtype #}

makeNewImageMapping :: Ptr ImageMapping -> IO ImageMapping
makeNewImageMapping rPtr = do
  imageMapping <- newForeignPtr rPtr poppler_image_mapping_free
  return (ImageMapping imageMapping)

foreign import ccall unsafe "&poppler_image_mapping_free"
  poppler_image_mapping_free :: FinalizerPtr ImageMapping

-- | Returns a list of 'FormFieldMapping' items that map from a location on page to a 'Action'.
pageGetFormFieldMapping :: PageClass page => page
 -> IO [FormFieldMapping]
pageGetFormFieldMapping page = do
  glistPtr <- {#call poppler_page_get_form_field_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewFormFieldMapping list
  {#call unsafe poppler_page_free_image_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *FormFieldMapping foreign newtype #}

makeNewFormFieldMapping :: Ptr FormFieldMapping -> IO FormFieldMapping
makeNewFormFieldMapping rPtr = do
  formFieldMapping <- newForeignPtr rPtr poppler_form_field_mapping_free
  return (FormFieldMapping formFieldMapping)

foreign import ccall unsafe "&poppler_form_field_mapping_free"
  poppler_form_field_mapping_free :: FinalizerPtr FormFieldMapping

-- | Returns a region containing the area that would be rendered by 'pageRenderSelection' or
-- 'pageRenderSelectionToPixbuf' as a GList of PopplerRectangle.
pageGetSelectionRegion :: PageClass page => page
 -> Double -- ^ @scale@     scale specified as pixels per point
 -> SelectionStyle -- ^ @style@     a 'SelectionStyle'
 -> PopplerRectangle -- ^ @selection@ start and end point of selection as a rectangle
 -> IO [PopplerRectangle]
pageGetSelectionRegion page scale style selection =
  with selection $ \ selectionPtr -> do
    glistPtr <- {#call poppler_page_get_selection_region #}
                 (toPage page)
                 (realToFrac scale)
                 ((fromIntegral . fromEnum) style)
                 (castPtr selectionPtr)
    list <- fromGList glistPtr
    rectangles <- mapM peekPopplerRectangle list
    {#call unsafe poppler_page_selection_region_free #} (castPtr glistPtr)
    return rectangles

-- | Render the selection specified by selection for page to the given cairo context. The selection will
-- be rendered, using @glyphColor@ for the glyphs and @backgroundColor@ for the selection background.
--
-- If non-'Nothing', @oldSelection@ specifies the selection that is already rendered to cairo, in which case
-- this function will (some day) only render the changed part of the selection.
pageRenderSelection :: PageClass page => page
 -> PopplerRectangle -- ^ @selection@        start and end point of selection as a rectangle
 -> PopplerRectangle -- ^ @oldSelection@    previous selection
 -> SelectionStyle -- ^ @style@            a 'SelectionStyle'
 -> PopplerColor -- ^ @glyphColor@      color to use for drawing glyphs
 -> PopplerColor -- ^ @backgroundColor@ color to use for the selection background
 -> Render ()
pageRenderSelection page selection oldSelection style glyphColor backgroundColor = do
  cairo <- ask
  liftIO $
         with selection $ \ selectionPtr ->
         with oldSelection $ \ oldSelectionPtr ->
         with glyphColor $ \ glyphColorPtr ->
         with backgroundColor $ \ backgroundColorPtr ->
              {#call poppler_page_render_selection #}
                  (toPage page)
                  cairo
                  (castPtr selectionPtr)
                  (castPtr oldSelectionPtr)
                  ((fromIntegral . fromEnum) style)
                  (castPtr glyphColorPtr)
                  (castPtr backgroundColorPtr)

pageAddAnnot :: (PageClass page, AnnotClass annot) => page -> annot -> IO ()
pageAddAnnot page annot =
  {# call poppler_page_add_annot #} (toPage page) (toAnnot annot)

pageRemoveAnnot :: (PageClass page, AnnotClass annot) => page -> annot -> IO ()
pageRemoveAnnot page annot =
  {# call poppler_page_remove_annot #} (toPage page) (toAnnot annot)

-- | Render the selection specified by selection for page into pixbuf. The selection will be rendered at
-- scale, using @glyphColor@ for the glyphs and @backgroundColor@ for the selection background.
--
-- If non-'Nothing', @oldSelection@ specifies the selection that is already rendered in pixbuf, in which case
-- this function will (some day) only render the changed part of the selection.
{-
pageRenderSelectionToPixbuf :: PageClass page => page
 -> Double -- ^ @scale@            scale specified as pixels per point
 -> Int -- ^ @rotation@         rotate the document by the specified degree
 -> Pixbuf -- ^ @pixbuf@           pixbuf to render to
 -> PopplerRectangle -- ^ @selection@        start and end point of selection as a rectangle
 -> PopplerRectangle -- ^ @oldSelection@    previous selection
 -> SelectionStyle -- ^ @style@            a 'SelectionStyle'
 -> Color -- ^ @glyphColor@      color to use for drawing glyphs
 -> Color -- ^ @backgroundColor@ color to use for the selection background
 -> IO ()
pageRenderSelectionToPixbuf page scale rotation pixbuf selection oldSelection style glyphColor backgroundColor =
  with selection $ \ selectionPtr ->
  with oldSelection $ \ oldSelectionPtr ->
  with glyphColor $ \ glyphColorPtr ->
  with backgroundColor $ \ backgroundColorPtr ->
      {#call poppler_page_render_selection_to_pixbuf #}
        (toPage page)
        (realToFrac scale)
        (fromIntegral rotation)
        pixbuf
        (castPtr selectionPtr)
        (castPtr oldSelectionPtr)
        ((fromIntegral . fromEnum) style)
        (castPtr glyphColorPtr)
        (castPtr backgroundColorPtr)
-}