gnomevfs: add function S.G.V.Volume.volumeUnmount

--  GIMP Toolkit (GTK) Binding for Haskell: binding to libgnomevfs -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  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/>.
--
--  GnomeVFS, 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 GnomeVFS documentation,
--  Copyright (c) 2001 Seth Nickell <snickell@stanford.edu>. The
--  documentation is covered by the GNU Free Documentation License,
--  version 1.2.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module System.Gnome.VFS.Volume (

-- * Types
  -- | An abstraction for a mounted filesystem or network location.
  Volume,
  VolumeClass,
  VolumeID,
  -- | Safely cast an object to a 'Volume'.
  castToVolume,

-- * Volume Operations
  volumeCompare,
  volumeEject,
  volumeGetActivationURI,
  volumeGetDevicePath,
  volumeGetDeviceType,
  volumeGetDisplayName,
  volumeGetDrive,
  volumeGetFilesystemType,
  volumeGetHalUDI,
  volumeGetIcon,
  volumeGetID,
  volumeGetVolumeType,
  volumeHandlesTrash,
  volumeIsMounted,
  volumeIsReadOnly,
  volumeIsUserVisible,
  volumeUnmount

  ) where

import Control.Exception
import Control.Monad (liftM)
import System.Glib.UTFString
import System.Glib.FFI
{#import System.Gnome.VFS.Marshal#}
{#import System.Gnome.VFS.Types#}

{# context lib = "gnomevfs" prefix = "gnome_vfs" #}

-- | Compares two 'Volume' objects @a@ and @b@. Two 'Volume'
--   objects referring to different volumes are guaranteed to not
--   return 'EQ' when comparing them. If they refer to the same volume 'EQ'
--   is returned.
--
--   The resulting gint should be used to determine the order in which
--   @a@ and @b@ are displayed in graphical user interfaces.
--
--   The comparison algorithm first of all peeks the device type of
--   @a@ and @b@, they will be sorted in the following order:
--
--     * Magnetic and opto-magnetic volumes (ZIP, floppy)
--
--     * Optical volumes (CD, DVD)
--
--     * External volumes (USB sticks, music players)
--
--     * Mounted hard disks
--
--     * Network mounts
--
--     * Other volumes
--
--   Afterwards, the display name of @a@ and @b@ is compared using a
--   locale-sensitive sorting algorithm.
--
--   If two volumes have the same display name, their unique ID is
--   compared which can be queried using 'volumeGetID'.
volumeCompare :: (VolumeClass volume1, VolumeClass volume2)
              => volume1
              -> volume2
              -> IO Ordering
volumeCompare a b =
    do result <- liftM fromIntegral $ {# call volume_compare #} (castToVolume a) (castToVolume b)
       let ordering | result < 0 = LT
                    | result > 0 = GT
                    | otherwise  = EQ
       return ordering

-- Requests ejection of a 'Volume'.
--
-- Before the unmount operation is executed, the
-- 'Volume' object's @pre-unmount@ signal is emitted.
--
-- If the volume is a mount point, i.e. its type is
-- 'VolumeTypeMountpoint', it is unmounted, and if it refers to a
-- disk, it is also ejected.
--
-- If the volume is a special VFS mount, i.e. its type is
-- 'VolumeTypeMount', it is ejected.
--
-- If the volume is a connected server, it is removed from the list of
-- connected servers.
--
-- Otherwise, no further action is done.
volumeEject   :: VolumeClass volume
              => volume                  -- ^ @volume@ - the volume to eject
              -> VolumeOpSuccessCallback -- ^ @successCallback@ - the
                                         --   callback to call once
                                         --   the operation has
                                         --   completed successfully
              -> VolumeOpFailureCallback -- ^ @failureCallback@ - the
                                         --   callback to call if the
                                         --   operation fails
              -> IO ()
volumeEject volume successCallback failureCallback =
    do cCallback <- volumeOpCallbackMarshal successCallback failureCallback
       {# call volume_eject #} (castToVolume volume) cCallback $ castFunPtrToPtr cCallback

marshalString cAction volume =
    cAction (castToVolume volume) >>= readUTFString
marshalMaybeString cAction volume =
    cAction (castToVolume volume) >>= maybePeek readUTFString

-- | Returns the activation URI of @volume@.
--
--   The returned URI usually refers to a valid location. You can
--   check the validity of the location by calling 'uriFromString'
--   with the URI, and checking whether the return value is not
--   'Nothing'.
volumeGetActivationURI  :: VolumeClass volume
                        => volume     -- ^ @volume@ - the volume to query
                        -> IO TextURI -- ^ the volume's activation URI.
volumeGetActivationURI =
    marshalString {# call volume_get_activation_uri #}

-- | Returns the device path of a 'Volume' object.
--
--   For HAL volumes, this returns the value of the volume's
--   @block.device@ key. For UNIX mounts, it returns the @mntent@'s
--   @mnt_fsname@ entry.
--
--   Otherwise, it returns 'Nothing'.
volumeGetDevicePath     :: VolumeClass volume =>
                           volume    -- ^ @volume@ - the volume object to query
                        -> IO String -- ^ the volume's device path
volumeGetDevicePath =
    marshalString {# call volume_get_device_path #}

-- | Returns the 'DeviceType' of a 'Volume' object.
volumeGetDeviceType     :: VolumeClass volume =>
                           volume        -- ^ @volume@ - the volume object to query
                        -> IO DeviceType -- the volume's device type
volumeGetDeviceType volume =
    liftM cToEnum $ {# call volume_get_device_type #} (castToVolume volume)

-- | Returns the display name of a 'Volume' object.
volumeGetDisplayName    :: VolumeClass volume =>
                           volume    -- ^ @volume@ - the volume object to query
                        -> IO String -- ^ the volume's display name
volumeGetDisplayName =
    marshalString {# call volume_get_display_name #}

-- | Returns the 'Drive' that @volume@ is on.
volumeGetDrive          :: VolumeClass volume =>
                           volume   -- ^ @volume@ - the volume object to query
                        -> IO Drive -- ^ the containing drive
volumeGetDrive volume =
    {# call volume_get_drive #} (castToVolume volume) >>= newDrive

-- | Returns a string describing the file system on @volume@, or
--   'Nothing' if no information on the underlying file system is
--   available.
--
--   The file system may be used to provide special functionality that
--   depends on the file system type, for instance to determine
--   whether trashing is supported (cf. 'volumeHandlesTrash').
--
--   For HAL mounts, this returns the value of the @\"volume.fstype\"@
--   key, for traditional UNIX mounts it is set to the mntent's
--   mnt_type key, for connected servers, 'Nothing' is returned.
volumeGetFilesystemType :: VolumeClass volume =>
                           volume            -- ^ @volume@ - the
                                             -- volume object to query
                        -> IO (Maybe String) -- ^ a string describing
                                             -- the filesystem type,
                                             -- or 'Nothing' if no
                                             -- information is
                                             -- available
volumeGetFilesystemType =
    marshalMaybeString {# call volume_get_filesystem_type #}

-- | Returns the HAL UDI of a 'Volume' object.
--
--   For HAL volumes, this matches the value of the @info.udi@ key,
--   for other volumes it is 'Nothing'.
volumeGetHalUDI :: VolumeClass volume =>
                   volume            -- ^ @volume@ - the volume object to query
                -> IO (Maybe String) -- ^ the volume's HAL UDI
volumeGetHalUDI =
    marshalMaybeString {# call volume_get_hal_udi #}

-- | Returns the icon filename for a 'Volume' object.
volumeGetIcon :: VolumeClass volume =>
                 volume      -- ^ @volume@ - a volume object
              -> IO FilePath -- ^ the icon that should be used for this volume
volumeGetIcon =
    marshalString {# call volume_get_icon #}

-- | Returns a unique identifier for a 'Volume' object.
volumeGetID :: VolumeClass volume =>
               volume      -- ^ @volume@ - a volume object
            -> IO VolumeID -- ^ a unique identifier for the volume
volumeGetID volume =
    {# call volume_get_id #} (castToVolume volume)

-- | Returns the volume type of @volume@.
volumeGetVolumeType     :: VolumeClass volume =>
                           volume        -- ^ @volume@ - the volume object to query
                        -> IO VolumeType -- ^ the volume's volume type
volumeGetVolumeType volume =
    liftM cToEnum $ {# call volume_get_volume_type #} (castToVolume volume)

marshalBool cAction volume =
    liftM toBool $ cAction (castToVolume volume)

-- | Returns whether the file system on a volume supports trashing of
--   files.
--
--   If the volume has an AutoFS file system (i.e.,
--   'volumeGetDeviceType' returns 'DeviceTypeAutofs'), or if the
--   volume is mounted read-only (i.e., 'volumeIsReadOnly' returns
--   'True'), it is assumed to not support trashing of files.
--
--   Otherwise, if the volume provides file system information, it is
--   determined whether the file system supports trashing of
--   files.
volumeHandlesTrash      :: VolumeClass volume =>
                           volume  -- ^ @volume@ -
                        -> IO Bool -- ^ 'True' if the volume handles trash, otherwise 'False'
volumeHandlesTrash =
    marshalBool {# call volume_handles_trash #}

-- | Returns whether the file system on a volume is currently mounted.
--
--   For HAL volumes, this reflects the value of the
--   @\"volume.is_mounted\"@ key, for traditional UNIX mounts and
--   connected servers, 'True' is returned, because their existence
--   implies that they are mounted.
volumeIsMounted         :: VolumeClass volume =>
                           volume  -- ^ @volume@ -
                        -> IO Bool -- ^ 'True' if the volume is mounted, otherwise 'False'
volumeIsMounted =
    marshalBool {# call volume_is_mounted #}

-- | Returns whether the file system on a volume is read-only.
--
--   For HAL volumes, the @\"volume.is_mounted_read_only\"@ key is
--   authoritative, for traditional UNIX mounts it returns TRUE if the
--   mount was done with the @\"ro\"@ option. For servers, 'False' is
--   returned.
volumeIsReadOnly        :: VolumeClass volume =>
                           volume  -- ^ @volume@ -
                        -> IO Bool -- ^ 'True' if the volume is read-only, otherwise 'False'
volumeIsReadOnly =
    marshalBool {# call volume_is_read_only #}

-- | Returns a 'Bool' for whether a volume is user-visible. This should
--   be used by applications to determine whether the volume should be
--   listed in user interfaces listing available volumes.
volumeIsUserVisible     :: VolumeClass volume =>
                           volume  -- @volume@ -
                        -> IO Bool -- ^ 'True' if the volume is user visible, otherwise 'False'
volumeIsUserVisible =
    marshalBool {# call volume_is_user_visible #}

-- Requests unmount of a 'Volume'.
--
-- Note that 'volumeUnmount' may also unvoke 'volumeEject', if
-- @volume@ signals that it should be ejected when it is unmounted.
-- This may be true for CD-ROMs, USB sticks, and other devices,
-- depending on the backend providing the volume.
volumeUnmount :: VolumeClass volume
              => volume                  -- ^ @volume@ - the volume to eject
              -> VolumeOpSuccessCallback -- ^ @successCallback@ - the
                                         --   callback to call once
                                         --   the operation has
                                         --   completed successfully
              -> VolumeOpFailureCallback -- ^ @failureCallback@ - the
                                         --   callback to call if the
                                         --   operation fails
              -> IO ()
volumeUnmount volume successCallback failureCallback =
    do cCallback <- volumeOpCallbackMarshal successCallback failureCallback
       {# call volume_unmount #} (castToVolume volume) cCallback $ castFunPtrToPtr cCallback

--  GIMP Toolkit (GTK) Binding for Haskell: binding to libgnomevfs -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  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/>.
--
--  GnomeVFS, 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 GnomeVFS documentation,
--  Copyright (c) 2001 Seth Nickell <snickell@stanford.edu>. The
--  documentation is covered by the GNU Free Documentation License,
--  version 1.2.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module System.Gnome.VFS.Volume (

-- * Types
  -- | An abstraction for a mounted filesystem or network location.
  Volume,
  VolumeClass,
  VolumeID,
  -- | Safely cast an object to a 'Volume'.
  castToVolume,

-- * Volume Operations
  volumeCompare,
  volumeEject,
  volumeGetActivationURI,
  volumeGetDevicePath,
  volumeGetDeviceType,
  volumeGetDisplayName,
  volumeGetDrive,
  volumeGetFilesystemType,
  volumeGetHalUDI,
  volumeGetIcon,
  volumeGetID,
  volumeGetVolumeType,
  volumeHandlesTrash,
  volumeIsMounted,
  volumeIsReadOnly,
  volumeIsUserVisible

  ) where

import Control.Exception
import Control.Monad (liftM)
import System.Glib.UTFString
import System.Glib.FFI
{#import System.Gnome.VFS.Marshal#}
{#import System.Gnome.VFS.Types#}

{# context lib = "gnomevfs" prefix = "gnome_vfs" #}

-- | Compares two 'Volume' objects @a@ and @b@. Two 'Volume'
--   objects referring to different volumes are guaranteed to not
--   return 'EQ' when comparing them. If they refer to the same volume 'EQ'
--   is returned.
--
--   The resulting gint should be used to determine the order in which
--   @a@ and @b@ are displayed in graphical user interfaces.
--
--   The comparison algorithm first of all peeks the device type of
--   @a@ and @b@, they will be sorted in the following order:
--
--     * Magnetic and opto-magnetic volumes (ZIP, floppy)
--
--     * Optical volumes (CD, DVD)
--
--     * External volumes (USB sticks, music players)
--
--     * Mounted hard disks
--
--     * Network mounts
--
--     * Other volumes
--
--   Afterwards, the display name of @a@ and @b@ is compared using a
--   locale-sensitive sorting algorithm.
--
--   If two volumes have the same display name, their unique ID is
--   compared which can be queried using 'volumeGetID'.
volumeCompare :: (VolumeClass volume1, VolumeClass volume2)
              => volume1
              -> volume2
              -> IO Ordering
volumeCompare a b =
    do result <- liftM fromIntegral $ {# call volume_compare #} (castToVolume a) (castToVolume b)
       let ordering | result < 0 = LT
                    | result > 0 = GT
                    | otherwise  = EQ
       return ordering

-- Requests ejection of a 'Volume'.
--
-- Before the unmount operation is executed, the
-- 'Volume' object's @pre-unmount@ signal is emitted.
--
-- If the volume is a mount point, i.e. its type is
-- 'VolumeTypeMountpoint', it is unmounted, and if it refers to a
-- disk, it is also ejected.
--
-- If the volume is a special VFS mount, i.e. its type is
-- 'VolumeTypeMount', it is ejected.
--
-- If the volume is a connected server, it is removed from the list of
-- connected servers.
--
-- Otherwise, no further action is done.
volumeEject   :: VolumeClass volume
              => volume                  -- ^ @volume@ - the volume to eject
              -> VolumeOpSuccessCallback -- ^ @successCallback@ - the
                                         --   callback to call once
                                         --   the operation has
                                         --   completed successfully
              -> VolumeOpFailureCallback -- ^ @failureCallback@ - the
                                         --   callback to call if the
                                         --   operation fails
              -> IO ()
volumeEject volume successCallback failureCallback =
    do cCallback <- volumeOpCallbackMarshal successCallback failureCallback
       {# call volume_eject #} (castToVolume volume) cCallback $ castFunPtrToPtr cCallback

marshalString cAction volume =
    cAction (castToVolume volume) >>= readUTFString
marshalMaybeString cAction volume =
    cAction (castToVolume volume) >>= maybePeek readUTFString

-- | Returns the activation URI of @volume@.
--
--   The returned URI usually refers to a valid location. You can
--   check the validity of the location by calling 'uriFromString'
--   with the URI, and checking whether the return value is not
--   'Nothing'.
volumeGetActivationURI  :: VolumeClass volume
                        => volume     -- ^ @volume@ - the volume to query
                        -> IO TextURI -- ^ the volume's activation URI.
volumeGetActivationURI =
    marshalString {# call volume_get_activation_uri #}

-- | Returns the device path of a 'Volume' object.
--
--   For HAL volumes, this returns the value of the volume's
--   @block.device@ key. For UNIX mounts, it returns the @mntent@'s
--   @mnt_fsname@ entry.
--
--   Otherwise, it returns 'Nothing'.
volumeGetDevicePath     :: VolumeClass volume =>
                           volume    -- ^ @volume@ - the volume object to query
                        -> IO String -- ^ the volume's device path
volumeGetDevicePath =
    marshalString {# call volume_get_device_path #}

-- | Returns the 'DeviceType' of a 'Volume' object.
volumeGetDeviceType     :: VolumeClass volume =>
                           volume        -- ^ @volume@ - the volume object to query
                        -> IO DeviceType -- the volume's device type
volumeGetDeviceType volume =
    liftM cToEnum $ {# call volume_get_device_type #} (castToVolume volume)

-- | Returns the display name of a 'Volume' object.
volumeGetDisplayName    :: VolumeClass volume =>
                           volume    -- ^ @volume@ - the volume object to query
                        -> IO String -- ^ the volume's display name
volumeGetDisplayName =
    marshalString {# call volume_get_display_name #}

-- | Returns the 'Drive' that @volume@ is on.
volumeGetDrive          :: VolumeClass volume =>
                           volume   -- ^ @volume@ - the volume object to query
                        -> IO Drive -- ^ the containing drive
volumeGetDrive volume =
    {# call volume_get_drive #} (castToVolume volume) >>= newDrive

-- | Returns a string describing the file system on @volume@, or
--   'Nothing' if no information on the underlying file system is
--   available.
--
--   The file system may be used to provide special functionality that
--   depends on the file system type, for instance to determine
--   whether trashing is supported (cf. 'volumeHandlesTrash').
--
--   For HAL mounts, this returns the value of the @\"volume.fstype\"@
--   key, for traditional UNIX mounts it is set to the mntent's
--   mnt_type key, for connected servers, 'Nothing' is returned.
volumeGetFilesystemType :: VolumeClass volume =>
                           volume            -- ^ @volume@ - the
                                             -- volume object to query
                        -> IO (Maybe String) -- ^ a string describing
                                             -- the filesystem type,
                                             -- or 'Nothing' if no
                                             -- information is
                                             -- available
volumeGetFilesystemType =
    marshalMaybeString {# call volume_get_filesystem_type #}

-- | Returns the HAL UDI of a 'Volume' object.
--
--   For HAL volumes, this matches the value of the @info.udi@ key,
--   for other volumes it is 'Nothing'.
volumeGetHalUDI :: VolumeClass volume =>
                   volume            -- ^ @volume@ - the volume object to query
                -> IO (Maybe String) -- ^ the volume's HAL UDI
volumeGetHalUDI =
    marshalMaybeString {# call volume_get_hal_udi #}

-- | Returns the icon filename for a 'Volume' object.
volumeGetIcon :: VolumeClass volume =>
                 volume      -- ^ @volume@ - a volume object
              -> IO FilePath -- ^ the icon that should be used for this volume
volumeGetIcon =
    marshalString {# call volume_get_icon #}

-- | Returns a unique identifier for a 'Volume' object.
volumeGetID :: VolumeClass volume =>
               volume      -- ^ @volume@ - a volume object
            -> IO VolumeID -- ^ a unique identifier for the volume
volumeGetID volume =
    {# call volume_get_id #} (castToVolume volume)

-- | Returns the volume type of @volume@.
volumeGetVolumeType     :: VolumeClass volume =>
                           volume        -- ^ @volume@ - the volume object to query
                        -> IO VolumeType -- ^ the volume's volume type
volumeGetVolumeType volume =
    liftM cToEnum $ {# call volume_get_volume_type #} (castToVolume volume)

marshalBool cAction volume =
    liftM toBool $ cAction (castToVolume volume)

-- | Returns whether the file system on a volume supports trashing of
--   files.
--
--   If the volume has an AutoFS file system (i.e.,
--   'volumeGetDeviceType' returns 'DeviceTypeAutofs'), or if the
--   volume is mounted read-only (i.e., 'volumeIsReadOnly' returns
--   'True'), it is assumed to not support trashing of files.
--
--   Otherwise, if the volume provides file system information, it is
--   determined whether the file system supports trashing of
--   files.
volumeHandlesTrash      :: VolumeClass volume =>
                           volume  -- ^ @volume@ -
                        -> IO Bool -- ^ 'True' if the volume handles trash, otherwise 'False'
volumeHandlesTrash =
    marshalBool {# call volume_handles_trash #}

-- | Returns whether the file system on a volume is currently mounted.
--
--   For HAL volumes, this reflects the value of the
--   @\"volume.is_mounted\"@ key, for traditional UNIX mounts and
--   connected servers, 'True' is returned, because their existence
--   implies that they are mounted.
volumeIsMounted         :: VolumeClass volume =>
                           volume  -- ^ @volume@ -
                        -> IO Bool -- ^ 'True' if the volume is mounted, otherwise 'False'
volumeIsMounted =
    marshalBool {# call volume_is_mounted #}

-- | Returns whether the file system on a volume is read-only.
--
--   For HAL volumes, the @\"volume.is_mounted_read_only\"@ key is
--   authoritative, for traditional UNIX mounts it returns TRUE if the
--   mount was done with the @\"ro\"@ option. For servers, 'False' is
--   returned.
volumeIsReadOnly        :: VolumeClass volume =>
                           volume  -- ^ @volume@ -
                        -> IO Bool -- ^ 'True' if the volume is read-only, otherwise 'False'
volumeIsReadOnly =
    marshalBool {# call volume_is_read_only #}

-- | Returns a 'Bool' for whether a volume is user-visible. This should
--   be used by applications to determine whether the volume should be
--   listed in user interfaces listing available volumes.
volumeIsUserVisible     :: VolumeClass volume =>
                           volume  -- @volume@ -
                        -> IO Bool -- ^ 'True' if the volume is user visible, otherwise 'False'
volumeIsUserVisible =
    marshalBool {# call volume_is_user_visible #}


add image format data

add image format data

{- Copyright (c) 2011 Luis Cabellos,

All rights reserved.

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

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

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

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

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-}
{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, CPP #-}
module Control.Parallel.OpenCL.Memory(
  -- * Types
  CLMem, CLSampler, CLMemFlag(..), CLMemObjectType(..), CLAddressingMode(..),
  CLFilterMode(..), CLImageFormat(..),
  -- * Memory Functions
  clCreateBuffer, clRetainMemObject, clReleaseMemObject, clGetMemType,
  clGetMemFlags, clGetMemSize, clGetMemHostPtr, clGetMemMapCount,
  clGetMemReferenceCount, clGetMemContext,
  -- * Sampler Functions
  clCreateSampler, clRetainSampler, clReleaseSampler, clGetSamplerReferenceCount,
  clGetSamplerContext, clGetSamplerAddressingMode, clGetSamplerFilterMode,
  clGetSamplerNormalizedCoords
  ) where

-- -----------------------------------------------------------------------------
import Foreign
import Foreign.C.Types
import Control.Parallel.OpenCL.Types(
  CLMem, CLContext, CLSampler, CLint, CLuint, CLbool, CLMemFlags_,
  CLMemInfo_, CLAddressingMode_, CLFilterMode_, CLSamplerInfo_,
  CLAddressingMode(..), CLFilterMode(..), CLMemFlag(..), CLMemObjectType_,
  CLMemObjectType(..),
  wrapPError, wrapCheckSuccess, wrapGetInfo, getEnumCL, bitmaskFromFlags,
  bitmaskToMemFlags, getCLValue )

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

-- -----------------------------------------------------------------------------
foreign import CALLCONV "clCreateBuffer" raw_clCreateBuffer ::
  CLContext -> CLMemFlags_ -> CSize -> Ptr () -> Ptr CLint -> IO CLMem
--foreign import CALLCONV "clCreateImage2D" raw_clCreateImage2D ::
--  CLContext -> CLMemFlags_ -> CLImageFormat_p -> CSize -> CSize -> CSize
--  -> Ptr () -> Ptr CLint -> IO CLMem
--foreign import CALLCONV "clCreateImage3D" raw_clCreateImage3D ::
--  CLContext -> CLMemFlags_-> CLImageFormat_p -> CSize -> CSize -> CSize -> CSize
--  -> CSize -> Ptr () -> Ptr CLint -> IO CLMem
foreign import CALLCONV "clRetainMemObject" raw_clRetainMemObject ::
  CLMem -> IO CLint
foreign import CALLCONV "clReleaseMemObject" raw_clReleaseMemObject ::
  CLMem -> IO CLint
--foreign import CALLCONV "clGetSupportedImageFormats" raw_clGetSupportedImageFormats ::
--  CLContext -> CLMemFlags_ -> CLMemObjectType_ -> CLuint -> CLImageFormat_p
--  -> Ptr CLuint -> IO CLint
foreign import CALLCONV "clGetMemObjectInfo" raw_clGetMemObjectInfo ::
  CLMem -> CLMemInfo_ -> CSize -> Ptr () -> Ptr CSize -> IO CLint
--foreign import CALLCONV "clGetImageInfo" raw_clGetImageInfo ::
--  CLMem -> CLImageInfo_ -> CSize -> Ptr () -> Ptr CSize -> IO CLint
foreign import CALLCONV "clCreateSampler" raw_clCreateSampler ::
  CLContext -> CLbool -> CLAddressingMode_ -> CLFilterMode_ -> Ptr CLint -> IO CLSampler
foreign import CALLCONV "clRetainSampler" raw_clRetainSampler ::
  CLSampler -> IO CLint
foreign import CALLCONV "clReleaseSampler" raw_clReleaseSampler ::
  CLSampler -> IO CLint
foreign import CALLCONV "clGetSamplerInfo" raw_clGetSamplerInfo ::
  CLSampler -> CLSamplerInfo_ -> CSize -> Ptr () -> Ptr CSize -> IO CLint

-- -----------------------------------------------------------------------------
{-| Creates a buffer object. Returns a valid non-zero buffer object if the
buffer object is created successfully. Otherwise, it throws the 'CLError':

 * 'CL_INVALID_CONTEXT' if context is not a valid context.

 * 'CL_INVALID_VALUE' if values specified in flags are not valid.

 * 'CL_INVALID_BUFFER_SIZE' if size is 0 or is greater than
'clDeviceMaxMemAllocSize' value for all devices in context.

 * 'CL_INVALID_HOST_PTR' if host_ptr is NULL and 'CL_MEM_USE_HOST_PTR' or
'CL_MEM_COPY_HOST_PTR' are set in flags or if host_ptr is not NULL but
'CL_MEM_COPY_HOST_PTR' or 'CL_MEM_USE_HOST_PTR' are not set in flags.

 * 'CL_MEM_OBJECT_ALLOCATION_FAILURE' if there is a failure to allocate memory
for buffer object.

 * 'CL_OUT_OF_HOST_MEMORY' if there is a failure to allocate resources required
by the OpenCL implementation on the host.
-}
clCreateBuffer :: Integral a => CLContext -> [CLMemFlag] -> (a, Ptr ()) -> IO CLMem
clCreateBuffer ctx xs (sbuff,buff) = wrapPError $ \perr -> do
  raw_clCreateBuffer ctx flags (fromIntegral sbuff) buff perr
    where
      flags = bitmaskFromFlags xs

-- | Increments the memory object reference count. returns 'True' if the
-- function is executed successfully. After the memobj reference count becomes
-- zero and commands queued for execution on a command-queue(s) that use memobj
-- have finished, the memory object is deleted. It returns 'False' if memobj is
-- not a valid memory object.
clRetainMemObject :: CLMem -> IO Bool
clRetainMemObject mem = wrapCheckSuccess $ raw_clRetainMemObject mem

-- | Decrements the memory object reference count. After the memobj reference
-- count becomes zero and commands queued for execution on a command-queue(s)
-- that use memobj have finished, the memory object is deleted. Returns 'True'
-- if the function is executed successfully. It returns 'False' if memobj is not
-- a valid memory object.
clReleaseMemObject :: CLMem -> IO Bool
clReleaseMemObject mem = wrapCheckSuccess $ raw_clReleaseMemObject mem

#c
enum CLChannelOrder {
  cL_R=CL_R,
  cL_A=CL_A,
  cL_INTENSITY=CL_INTENSITY,
  cL_LUMINANCE=CL_LUMINANCE,
  cL_RG=CL_RG,
  cL_RA=CL_RA,
  cL_RGB=CL_RGB,
  cL_RGBA=CL_RGBA,
  cL_ARGB=CL_ARGB,
  cL_BGRA=CL_BGRA,
  };
#endc
{-| Specifies the number of channels and the channel layout i.e. the memory
layout in which channels are stored in the image. Valid values are described in
the table below.

 * 'CL_R', 'CL_A'.

 * 'CL_INTENSITY', This format can only be used if channel data type =
'CL_UNORM_INT8', 'CL_UNORM_INT16', 'CL_SNORM_INT8', 'CL_SNORM_INT16',
'CL_HALF_FLOAT', or 'CL_FLOAT'.

 * 'CL_LUMINANCE', This format can only be used if channel data type =
'CL_UNORM_INT8', 'CL_UNORM_INT16', 'CL_SNORM_INT8', 'CL_SNORM_INT16',
'CL_HALF_FLOAT', or 'CL_FLOAT'.

 * 'CL_RG', 'CL_RA'.

 * 'CL_RGB', This format can only be used if channel data type =
'CL_UNORM_SHORT_565', 'CL_UNORM_SHORT_555' or 'CL_UNORM_INT101010'.

 * 'CL_RGBA'.

 * 'CL_ARGB', 'CL_BGRA'. This format can only be used if channel data type =
'CL_UNORM_INT8', 'CL_SNORM_INT8', 'CL_SIGNED_INT8' or 'CL_UNSIGNED_INT8'.
-}
{#enum CLChannelOrder {upcaseFirstLetter} #}

#c
enum CLChannelType {
  cL_SNORM_INT8=CL_SNORM_INT8,
  cL_SNORM_INT16=CL_SNORM_INT16,
  cL_UNORM_INT8=CL_UNORM_INT8,
  cL_UNORM_INT16=CL_UNORM_INT16,
  cL_UNORM_SHORT_565=CL_UNORM_SHORT_565,
  cL_UNORM_SHORT_555=CL_UNORM_SHORT_555,
  cL_UNORM_INT_101010=CL_UNORM_INT_101010,
  cL_SIGNED_INT8=CL_SIGNED_INT8,
  cL_SIGNED_INT16=CL_SIGNED_INT16,
  cL_SIGNED_INT32=CL_SIGNED_INT32,
  cL_UNSIGNED_INT8=CL_UNSIGNED_INT8,
  cL_UNSIGNED_INT16=CL_UNSIGNED_INT16,
  cL_UNSIGNED_INT32=CL_UNSIGNED_INT32,
  cL_HALF_FLOAT=CL_HALF_FLOAT,
  cL_FLOAT=CL_FLOAT,
  };
#endc
{-| Describes the size of the channel data type. The number of bits per element
determined by the image_channel_data_type and image_channel_order must be a
power of two. The list of supported values is described in the table below.

 * 'CL_SNORM_INT8', Each channel component is a normalized signed 8-bit integer
value.

 * 'CL_SNORM_INT16', Each channel component is a normalized signed 16-bit
integer value.

 * 'CL_UNORM_INT8', Each channel component is a normalized unsigned 8-bit
integer value.

 * 'CL_UNORM_INT16', Each channel component is a normalized unsigned 16-bit
integer value.

 * 'CL_UNORM_SHORT_565', Represents a normalized 5-6-5 3-channel RGB image. The
channel order must be 'CL_RGB'.

 * 'CL_UNORM_SHORT_555', Represents a normalized x-5-5-5 4-channel xRGB
image. The channel order must be 'CL_RGB'.

 * 'CL_UNORM_INT_101010', Represents a normalized x-10-10-10 4-channel xRGB
image. The channel order must be 'CL_RGB'.

 * 'CL_SIGNED_INT8', Each channel component is an unnormalized signed 8-bit
integer value.

 * 'CL_SIGNED_INT16', Each channel component is an unnormalized signed 16-bit
integer value.

 * 'CL_SIGNED_INT32', Each channel component is an unnormalized signed 32-bit
integer value.

 * 'CL_UNSIGNED_INT8', Each channel component is an unnormalized unsigned 8-bit
integer value.

 * 'CL_UNSIGNED_INT16', Each channel component is an unnormalized unsigned
16-bit integer value.

 * 'CL_UNSIGNED_INT32', Each channel component is an unnormalized unsigned
32-bit integer value.

 * 'CL_HALF_FLOAT', Each channel component is a 16-bit half-float value.

 * 'CL_FLOAT', Each channel component is a single precision floating-point
value.
-}
{#enum CLChannelType {upcaseFirstLetter} #}

data CLImageFormat = CLImageFormat
                     { image_channel_order :: ! CLChannelOrder
                     , image_channel_data_type :: ! CLChannelType }

#c
enum CLMemInfo {
  cL_MEM_TYPE=CL_MEM_TYPE,
  cL_MEM_FLAGS=CL_MEM_FLAGS,
  cL_MEM_SIZE=CL_MEM_SIZE,
  cL_MEM_HOST_PTR=CL_MEM_HOST_PTR,
  cL_MEM_MAP_COUNT=CL_MEM_MAP_COUNT,
  cL_MEM_REFERENCE_COUNT=CL_MEM_REFERENCE_COUNT,
  cL_MEM_CONTEXT=CL_MEM_CONTEXT,
  };
#endc
{#enum CLMemInfo {upcaseFirstLetter} #}

-- | Returns the mem object type.
--
-- This function execute OpenCL clGetMemObjectInfo with 'CL_MEM_TYPE'.
clGetMemType :: CLMem -> IO CLMemObjectType
clGetMemType mem =
    wrapGetInfo (\(dat :: Ptr CLMemObjectType_) ->
        raw_clGetMemObjectInfo mem infoid size (castPtr dat)) getEnumCL
    where
      infoid = getCLValue CL_MEM_TYPE
      size = fromIntegral $ sizeOf (0::CLMemObjectType_)

-- | Return the flags argument value specified when memobj was created.
--
-- This function execute OpenCL clGetMemObjectInfo with 'CL_MEM_FLAGS'.
clGetMemFlags :: CLMem -> IO [CLMemFlag]
clGetMemFlags mem =
    wrapGetInfo (\(dat :: Ptr CLMemFlags_)->
        raw_clGetMemObjectInfo mem infoid size (castPtr dat)) bitmaskToMemFlags
    where
      infoid = getCLValue CL_MEM_FLAGS
      size = fromIntegral $ sizeOf (0::CLMemFlags_)

-- | Return actual size of memobj in bytes.
--
-- This function execute OpenCL clGetMemObjectInfo with 'CL_MEM_SIZE'.
clGetMemSize :: CLMem -> IO CSize
clGetMemSize mem =
    wrapGetInfo (\(dat :: Ptr CSize)->
        raw_clGetMemObjectInfo mem infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_MEM_SIZE
      size = fromIntegral $ sizeOf (0::CSize)

-- | Return the host_ptr argument value specified when memobj is created.
--
-- This function execute OpenCL clGetMemObjectInfo with 'CL_MEM_HOST_PTR'.
clGetMemHostPtr :: CLMem -> IO (Ptr ())
clGetMemHostPtr mem =
    wrapGetInfo (\(dat :: Ptr (Ptr ()))->
        raw_clGetMemObjectInfo mem infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_MEM_HOST_PTR
      size = fromIntegral $ sizeOf (nullPtr::Ptr ())

-- | Map count. The map count returned should be considered immediately
-- stale. It is unsuitable for general use in applications. This feature is
-- provided for debugging.
--
-- This function execute OpenCL clGetMemObjectInfo with 'CL_MEM_MAP_COUNT'.
clGetMemMapCount :: CLMem -> IO CLuint
clGetMemMapCount mem =
    wrapGetInfo (\(dat :: Ptr CLuint)->
        raw_clGetMemObjectInfo mem infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_MEM_MAP_COUNT
      size = fromIntegral $ sizeOf (0 :: CLuint)

-- | Return memobj reference count. The reference count returned should be
-- considered immediately stale. It is unsuitable for general use in
-- applications. This feature is provided for identifying memory leaks.
--
-- This function execute OpenCL clGetMemObjectInfo with 'CL_MEM_REFERENCE_COUNT'.
clGetMemReferenceCount :: CLMem -> IO CLuint
clGetMemReferenceCount mem =
    wrapGetInfo (\(dat :: Ptr CLuint)->
        raw_clGetMemObjectInfo mem infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_MEM_REFERENCE_COUNT
      size = fromIntegral $ sizeOf (0 :: CLuint)

-- | Return context specified when memory object is created.
--
-- This function execute OpenCL clGetMemObjectInfo with 'CL_MEM_CONTEXT'.
clGetMemContext :: CLMem -> IO CLContext
clGetMemContext mem =
    wrapGetInfo (\(dat :: Ptr CLContext)->
        raw_clGetMemObjectInfo mem infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_MEM_CONTEXT
      size = fromIntegral $ sizeOf (0 :: CLuint)

-- -----------------------------------------------------------------------------
{-| Creates a sampler object. A sampler object describes how to sample an image
when the image is read in the kernel. The built-in functions to read from an
image in a kernel take a sampler as an argument. The sampler arguments to the
image read function can be sampler objects created using OpenCL functions and
passed as argument values to the kernel or can be samplers declared inside a
kernel. In this section we discuss how sampler objects are created using OpenCL
functions.

Returns a valid non-zero sampler object if the sampler object is created
successfully. Otherwise, it throws one of the following 'CLError' exceptions:

 * 'CL_INVALID_CONTEXT' if context is not a valid context.

 * 'CL_INVALID_VALUE' if addressing_mode, filter_mode, or normalized_coords or a
combination of these argument values are not valid.

 * 'CL_INVALID_OPERATION' if images are not supported by any device associated
with context (i.e. 'CL_DEVICE_IMAGE_SUPPORT' specified in the table of OpenCL
Device Queries for clGetDeviceInfo is 'False').

 * 'CL_OUT_OF_HOST_MEMORY' if there is a failure to allocate resources required
by the OpenCL implementation on the host.
-}
clCreateSampler :: CLContext -> Bool -> CLAddressingMode -> CLFilterMode
                   -> IO CLSampler
clCreateSampler ctx norm am fm = wrapPError $ \perr -> do
  raw_clCreateSampler ctx (fromBool norm) (getCLValue am) (getCLValue fm) perr

-- | Increments the sampler reference count. 'clCreateSampler' does an implicit
-- retain. Returns 'True' if the function is executed successfully. It returns
-- 'False' if sampler is not a valid sampler object.
clRetainSampler :: CLSampler -> IO Bool
clRetainSampler mem = wrapCheckSuccess $ raw_clRetainSampler mem

-- | Decrements the sampler reference count. The sampler object is deleted after
-- the reference count becomes zero and commands queued for execution on a
-- command-queue(s) that use sampler have finished. 'clReleaseSampler' returns
-- 'True' if the function is executed successfully. It returns 'False' if
-- sampler is not a valid sampler object.
clReleaseSampler :: CLSampler -> IO Bool
clReleaseSampler mem = wrapCheckSuccess $ raw_clReleaseSampler mem

#c
enum CLSamplerInfo {
  cL_SAMPLER_REFERENCE_COUNT=CL_SAMPLER_REFERENCE_COUNT,
  cL_SAMPLER_CONTEXT=CL_SAMPLER_CONTEXT,
  cL_SAMPLER_ADDRESSING_MODE=CL_SAMPLER_ADDRESSING_MODE,
  cL_SAMPLER_FILTER_MODE=CL_SAMPLER_FILTER_MODE,
  cL_SAMPLER_NORMALIZED_COORDS=CL_SAMPLER_NORMALIZED_COORDS
  };
#endc
{#enum CLSamplerInfo {upcaseFirstLetter} #}

-- | Return the sampler reference count. The reference count returned should be
-- considered immediately stale. It is unsuitable for general use in
-- applications. This feature is provided for identifying memory leaks.
--
-- This function execute OpenCL clGetSamplerInfo with
-- 'CL_SAMPLER_REFERENCE_COUNT'.
clGetSamplerReferenceCount :: CLSampler -> IO CLuint
clGetSamplerReferenceCount sam =
    wrapGetInfo (\(dat :: Ptr CLuint)->
        raw_clGetSamplerInfo sam infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_SAMPLER_REFERENCE_COUNT
      size = fromIntegral $ sizeOf (0 :: CLuint)

-- | Return the context specified when the sampler is created.
--
-- This function execute OpenCL clGetSamplerInfo with 'CL_SAMPLER_CONTEXT'.
clGetSamplerContext :: CLSampler -> IO CLContext
clGetSamplerContext sam =
    wrapGetInfo (\(dat :: Ptr CLContext)->
        raw_clGetSamplerInfo sam infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_SAMPLER_CONTEXT
      size = fromIntegral $ sizeOf (nullPtr :: CLContext)

-- | Return the value specified by addressing_mode argument to clCreateSampler.
--
-- This function execute OpenCL clGetSamplerInfo with
-- 'CL_SAMPLER_ADDRESSING_MODE'.
clGetSamplerAddressingMode :: CLSampler -> IO CLAddressingMode
clGetSamplerAddressingMode sam =
    wrapGetInfo (\(dat :: Ptr CLAddressingMode_)->
        raw_clGetSamplerInfo sam infoid size (castPtr dat)) getEnumCL
    where
      infoid = getCLValue CL_SAMPLER_ADDRESSING_MODE
      size = fromIntegral $ sizeOf (0 :: CLAddressingMode_)

-- | Return the value specified by filter_mode argument to clCreateSampler.
--
-- This function execute OpenCL clGetSamplerInfo with 'CL_SAMPLER_FILTER_MODE'.
clGetSamplerFilterMode :: CLSampler -> IO CLFilterMode
clGetSamplerFilterMode sam =
    wrapGetInfo (\(dat :: Ptr CLFilterMode_)->
        raw_clGetSamplerInfo sam infoid size (castPtr dat)) getEnumCL
    where
      infoid = getCLValue CL_SAMPLER_FILTER_MODE
      size = fromIntegral $ sizeOf (0 :: CLFilterMode_)

-- | Return the value specified by normalized_coords argument to
-- clCreateSampler.
--
-- This function execute OpenCL clGetSamplerInfo with
-- 'CL_SAMPLER_NORMALIZED_COORDS'.
clGetSamplerNormalizedCoords :: CLSampler -> IO Bool
clGetSamplerNormalizedCoords sam =
    wrapGetInfo (\(dat :: Ptr CLbool)->
        raw_clGetSamplerInfo sam infoid size (castPtr dat)) (/=0)
    where
      infoid = getCLValue CL_SAMPLER_NORMALIZED_COORDS
      size = fromIntegral $ sizeOf (0 :: CLbool)

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

{- Copyright (c) 2011 Luis Cabellos,

All rights reserved.

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

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

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

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

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-}
{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, CPP #-}
module Control.Parallel.OpenCL.Memory(
  -- * Types
  CLMem, CLSampler, CLMemFlag(..), CLMemObjectType(..), CLAddressingMode(..),
  CLFilterMode(..),
  -- * Memory Functions
  clCreateBuffer, clRetainMemObject, clReleaseMemObject, clGetMemType,
  clGetMemFlags, clGetMemSize, clGetMemHostPtr, clGetMemMapCount,
  clGetMemReferenceCount, clGetMemContext,
  -- * Sampler Functions
  clCreateSampler, clRetainSampler, clReleaseSampler, clGetSamplerReferenceCount,
  clGetSamplerContext, clGetSamplerAddressingMode, clGetSamplerFilterMode,
  clGetSamplerNormalizedCoords
  ) where

-- -----------------------------------------------------------------------------
import Foreign
import Foreign.C.Types
import Control.Parallel.OpenCL.Types(
  CLMem, CLContext, CLSampler, CLint, CLuint, CLbool, CLMemFlags_,
  CLMemInfo_, CLAddressingMode_, CLFilterMode_, CLSamplerInfo_,
  CLAddressingMode(..), CLFilterMode(..), CLMemFlag(..), CLMemObjectType_,
  CLMemObjectType(..),
  wrapPError, wrapCheckSuccess, wrapGetInfo, getEnumCL, bitmaskFromFlags,
  bitmaskToMemFlags, getCLValue )

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

-- -----------------------------------------------------------------------------
foreign import CALLCONV "clCreateBuffer" raw_clCreateBuffer ::
  CLContext -> CLMemFlags_ -> CSize -> Ptr () -> Ptr CLint -> IO CLMem
--foreign import CALLCONV "clCreateImage2D" raw_clCreateImage2D ::
--  CLContext -> CLMemFlags_ -> CLImageFormat_p -> CSize -> CSize -> CSize
--  -> Ptr () -> Ptr CLint -> IO CLMem
--foreign import CALLCONV "clCreateImage3D" raw_clCreateImage3D ::
--  CLContext -> CLMemFlags_-> CLImageFormat_p -> CSize -> CSize -> CSize -> CSize
--  -> CSize -> Ptr () -> Ptr CLint -> IO CLMem
foreign import CALLCONV "clRetainMemObject" raw_clRetainMemObject ::
  CLMem -> IO CLint
foreign import CALLCONV "clReleaseMemObject" raw_clReleaseMemObject ::
  CLMem -> IO CLint
--foreign import CALLCONV "clGetSupportedImageFormats" raw_clGetSupportedImageFormats ::
--  CLContext -> CLMemFlags_ -> CLMemObjectType_ -> CLuint -> CLImageFormat_p
--  -> Ptr CLuint -> IO CLint
foreign import CALLCONV "clGetMemObjectInfo" raw_clGetMemObjectInfo ::
  CLMem -> CLMemInfo_ -> CSize -> Ptr () -> Ptr CSize -> IO CLint
--foreign import CALLCONV "clGetImageInfo" raw_clGetImageInfo ::
--  CLMem -> CLImageInfo_ -> CSize -> Ptr () -> Ptr CSize -> IO CLint
foreign import CALLCONV "clCreateSampler" raw_clCreateSampler ::
  CLContext -> CLbool -> CLAddressingMode_ -> CLFilterMode_ -> Ptr CLint -> IO CLSampler
foreign import CALLCONV "clRetainSampler" raw_clRetainSampler ::
  CLSampler -> IO CLint
foreign import CALLCONV "clReleaseSampler" raw_clReleaseSampler ::
  CLSampler -> IO CLint
foreign import CALLCONV "clGetSamplerInfo" raw_clGetSamplerInfo ::
  CLSampler -> CLSamplerInfo_ -> CSize -> Ptr () -> Ptr CSize -> IO CLint

-- -----------------------------------------------------------------------------
{-| Creates a buffer object. Returns a valid non-zero buffer object if the
buffer object is created successfully. Otherwise, it throws the 'CLError':

 * 'CL_INVALID_CONTEXT' if context is not a valid context.

 * 'CL_INVALID_VALUE' if values specified in flags are not valid.

 * 'CL_INVALID_BUFFER_SIZE' if size is 0 or is greater than
'clDeviceMaxMemAllocSize' value for all devices in context.

 * 'CL_INVALID_HOST_PTR' if host_ptr is NULL and 'CL_MEM_USE_HOST_PTR' or
'CL_MEM_COPY_HOST_PTR' are set in flags or if host_ptr is not NULL but
'CL_MEM_COPY_HOST_PTR' or 'CL_MEM_USE_HOST_PTR' are not set in flags.

 * 'CL_MEM_OBJECT_ALLOCATION_FAILURE' if there is a failure to allocate memory
for buffer object.

 * 'CL_OUT_OF_HOST_MEMORY' if there is a failure to allocate resources required
by the OpenCL implementation on the host.
-}
clCreateBuffer :: Integral a => CLContext -> [CLMemFlag] -> (a, Ptr ()) -> IO CLMem
clCreateBuffer ctx xs (sbuff,buff) = wrapPError $ \perr -> do
  raw_clCreateBuffer ctx flags (fromIntegral sbuff) buff perr
    where
      flags = bitmaskFromFlags xs

-- | Increments the memory object reference count. returns 'True' if the
-- function is executed successfully. After the memobj reference count becomes
-- zero and commands queued for execution on a command-queue(s) that use memobj
-- have finished, the memory object is deleted. It returns 'False' if memobj is
-- not a valid memory object.
clRetainMemObject :: CLMem -> IO Bool
clRetainMemObject mem = wrapCheckSuccess $ raw_clRetainMemObject mem

-- | Decrements the memory object reference count. After the memobj reference
-- count becomes zero and commands queued for execution on a command-queue(s)
-- that use memobj have finished, the memory object is deleted. Returns 'True'
-- if the function is executed successfully. It returns 'False' if memobj is not
-- a valid memory object.
clReleaseMemObject :: CLMem -> IO Bool
clReleaseMemObject mem = wrapCheckSuccess $ raw_clReleaseMemObject mem

#c
enum CLMemInfo {
  cL_MEM_TYPE=CL_MEM_TYPE,
  cL_MEM_FLAGS=CL_MEM_FLAGS,
  cL_MEM_SIZE=CL_MEM_SIZE,
  cL_MEM_HOST_PTR=CL_MEM_HOST_PTR,
  cL_MEM_MAP_COUNT=CL_MEM_MAP_COUNT,
  cL_MEM_REFERENCE_COUNT=CL_MEM_REFERENCE_COUNT,
  cL_MEM_CONTEXT=CL_MEM_CONTEXT,
  };
#endc
{#enum CLMemInfo {upcaseFirstLetter} #}

-- | Returns the mem object type.
--
-- This function execute OpenCL clGetMemObjectInfo with 'CL_MEM_TYPE'.
clGetMemType :: CLMem -> IO CLMemObjectType
clGetMemType mem =
    wrapGetInfo (\(dat :: Ptr CLMemObjectType_) ->
        raw_clGetMemObjectInfo mem infoid size (castPtr dat)) getEnumCL
    where
      infoid = getCLValue CL_MEM_TYPE
      size = fromIntegral $ sizeOf (0::CLMemObjectType_)

-- | Return the flags argument value specified when memobj was created.
--
-- This function execute OpenCL clGetMemObjectInfo with 'CL_MEM_FLAGS'.
clGetMemFlags :: CLMem -> IO [CLMemFlag]
clGetMemFlags mem =
    wrapGetInfo (\(dat :: Ptr CLMemFlags_)->
        raw_clGetMemObjectInfo mem infoid size (castPtr dat)) bitmaskToMemFlags
    where
      infoid = getCLValue CL_MEM_FLAGS
      size = fromIntegral $ sizeOf (0::CLMemFlags_)

-- | Return actual size of memobj in bytes.
--
-- This function execute OpenCL clGetMemObjectInfo with 'CL_MEM_SIZE'.
clGetMemSize :: CLMem -> IO CSize
clGetMemSize mem =
    wrapGetInfo (\(dat :: Ptr CSize)->
        raw_clGetMemObjectInfo mem infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_MEM_SIZE
      size = fromIntegral $ sizeOf (0::CSize)

-- | Return the host_ptr argument value specified when memobj is created.
--
-- This function execute OpenCL clGetMemObjectInfo with 'CL_MEM_HOST_PTR'.
clGetMemHostPtr :: CLMem -> IO (Ptr ())
clGetMemHostPtr mem =
    wrapGetInfo (\(dat :: Ptr (Ptr ()))->
        raw_clGetMemObjectInfo mem infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_MEM_HOST_PTR
      size = fromIntegral $ sizeOf (nullPtr::Ptr ())

-- | Map count. The map count returned should be considered immediately
-- stale. It is unsuitable for general use in applications. This feature is
-- provided for debugging.
--
-- This function execute OpenCL clGetMemObjectInfo with 'CL_MEM_MAP_COUNT'.
clGetMemMapCount :: CLMem -> IO CLuint
clGetMemMapCount mem =
    wrapGetInfo (\(dat :: Ptr CLuint)->
        raw_clGetMemObjectInfo mem infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_MEM_MAP_COUNT
      size = fromIntegral $ sizeOf (0 :: CLuint)

-- | Return memobj reference count. The reference count returned should be
-- considered immediately stale. It is unsuitable for general use in
-- applications. This feature is provided for identifying memory leaks.
--
-- This function execute OpenCL clGetMemObjectInfo with 'CL_MEM_REFERENCE_COUNT'.
clGetMemReferenceCount :: CLMem -> IO CLuint
clGetMemReferenceCount mem =
    wrapGetInfo (\(dat :: Ptr CLuint)->
        raw_clGetMemObjectInfo mem infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_MEM_REFERENCE_COUNT
      size = fromIntegral $ sizeOf (0 :: CLuint)

-- | Return context specified when memory object is created.
--
-- This function execute OpenCL clGetMemObjectInfo with 'CL_MEM_CONTEXT'.
clGetMemContext :: CLMem -> IO CLContext
clGetMemContext mem =
    wrapGetInfo (\(dat :: Ptr CLContext)->
        raw_clGetMemObjectInfo mem infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_MEM_CONTEXT
      size = fromIntegral $ sizeOf (0 :: CLuint)

-- -----------------------------------------------------------------------------
{-| Creates a sampler object. A sampler object describes how to sample an image
when the image is read in the kernel. The built-in functions to read from an
image in a kernel take a sampler as an argument. The sampler arguments to the
image read function can be sampler objects created using OpenCL functions and
passed as argument values to the kernel or can be samplers declared inside a
kernel. In this section we discuss how sampler objects are created using OpenCL
functions.

Returns a valid non-zero sampler object if the sampler object is created
successfully. Otherwise, it throws one of the following 'CLError' exceptions:

 * 'CL_INVALID_CONTEXT' if context is not a valid context.

 * 'CL_INVALID_VALUE' if addressing_mode, filter_mode, or normalized_coords or a
combination of these argument values are not valid.

 * 'CL_INVALID_OPERATION' if images are not supported by any device associated
with context (i.e. 'CL_DEVICE_IMAGE_SUPPORT' specified in the table of OpenCL
Device Queries for clGetDeviceInfo is 'False').

 * 'CL_OUT_OF_HOST_MEMORY' if there is a failure to allocate resources required
by the OpenCL implementation on the host.
-}
clCreateSampler :: CLContext -> Bool -> CLAddressingMode -> CLFilterMode
                   -> IO CLSampler
clCreateSampler ctx norm am fm = wrapPError $ \perr -> do
  raw_clCreateSampler ctx (fromBool norm) (getCLValue am) (getCLValue fm) perr

-- | Increments the sampler reference count. 'clCreateSampler' does an implicit
-- retain. Returns 'True' if the function is executed successfully. It returns
-- 'False' if sampler is not a valid sampler object.
clRetainSampler :: CLSampler -> IO Bool
clRetainSampler mem = wrapCheckSuccess $ raw_clRetainSampler mem

-- | Decrements the sampler reference count. The sampler object is deleted after
-- the reference count becomes zero and commands queued for execution on a
-- command-queue(s) that use sampler have finished. 'clReleaseSampler' returns
-- 'True' if the function is executed successfully. It returns 'False' if
-- sampler is not a valid sampler object.
clReleaseSampler :: CLSampler -> IO Bool
clReleaseSampler mem = wrapCheckSuccess $ raw_clReleaseSampler mem

#c
enum CLSamplerInfo {
  cL_SAMPLER_REFERENCE_COUNT=CL_SAMPLER_REFERENCE_COUNT,
  cL_SAMPLER_CONTEXT=CL_SAMPLER_CONTEXT,
  cL_SAMPLER_ADDRESSING_MODE=CL_SAMPLER_ADDRESSING_MODE,
  cL_SAMPLER_FILTER_MODE=CL_SAMPLER_FILTER_MODE,
  cL_SAMPLER_NORMALIZED_COORDS=CL_SAMPLER_NORMALIZED_COORDS
  };
#endc
{#enum CLSamplerInfo {upcaseFirstLetter} #}

-- | Return the sampler reference count. The reference count returned should be
-- considered immediately stale. It is unsuitable for general use in
-- applications. This feature is provided for identifying memory leaks.
--
-- This function execute OpenCL clGetSamplerInfo with
-- 'CL_SAMPLER_REFERENCE_COUNT'.
clGetSamplerReferenceCount :: CLSampler -> IO CLuint
clGetSamplerReferenceCount sam =
    wrapGetInfo (\(dat :: Ptr CLuint)->
        raw_clGetSamplerInfo sam infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_SAMPLER_REFERENCE_COUNT
      size = fromIntegral $ sizeOf (0 :: CLuint)

-- | Return the context specified when the sampler is created.
--
-- This function execute OpenCL clGetSamplerInfo with 'CL_SAMPLER_CONTEXT'.
clGetSamplerContext :: CLSampler -> IO CLContext
clGetSamplerContext sam =
    wrapGetInfo (\(dat :: Ptr CLContext)->
        raw_clGetSamplerInfo sam infoid size (castPtr dat)) id
    where
      infoid = getCLValue CL_SAMPLER_CONTEXT
      size = fromIntegral $ sizeOf (nullPtr :: CLContext)

-- | Return the value specified by addressing_mode argument to clCreateSampler.
--
-- This function execute OpenCL clGetSamplerInfo with
-- 'CL_SAMPLER_ADDRESSING_MODE'.
clGetSamplerAddressingMode :: CLSampler -> IO CLAddressingMode
clGetSamplerAddressingMode sam =
    wrapGetInfo (\(dat :: Ptr CLAddressingMode_)->
        raw_clGetSamplerInfo sam infoid size (castPtr dat)) getEnumCL
    where
      infoid = getCLValue CL_SAMPLER_ADDRESSING_MODE
      size = fromIntegral $ sizeOf (0 :: CLAddressingMode_)

-- | Return the value specified by filter_mode argument to clCreateSampler.
--
-- This function execute OpenCL clGetSamplerInfo with 'CL_SAMPLER_FILTER_MODE'.
clGetSamplerFilterMode :: CLSampler -> IO CLFilterMode
clGetSamplerFilterMode sam =
    wrapGetInfo (\(dat :: Ptr CLFilterMode_)->
        raw_clGetSamplerInfo sam infoid size (castPtr dat)) getEnumCL
    where
      infoid = getCLValue CL_SAMPLER_FILTER_MODE
      size = fromIntegral $ sizeOf (0 :: CLFilterMode_)

-- | Return the value specified by normalized_coords argument to
-- clCreateSampler.
--
-- This function execute OpenCL clGetSamplerInfo with
-- 'CL_SAMPLER_NORMALIZED_COORDS'.
clGetSamplerNormalizedCoords :: CLSampler -> IO Bool
clGetSamplerNormalizedCoords sam =
    wrapGetInfo (\(dat :: Ptr CLbool)->
        raw_clGetSamplerInfo sam infoid size (castPtr dat)) (/=0)
    where
      infoid = getCLValue CL_SAMPLER_NORMALIZED_COORDS
      size = fromIntegral $ sizeOf (0 :: CLbool)

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


Use nocode c2hs option.

Use nocode c2hs option.

{-# LANGUAGE TypeFamilies, FlexibleInstances, TypeSynonymInstances #-}

-- |
-- Module     	: Database.HyperDex.Internal.Admin
-- Copyright  	: (c) Aaron Friel 2013-2014
--            	  (c) Niklas Hambüchen 2013-2014
-- License    	: BSD-style
-- Maintainer 	: mayreply@aaronfriel.com
-- Stability  	: unstable
-- Portability	: portable
--
module Database.HyperDex.Internal.Admin
  ( Admin
  , AdminConnection
  , ReturnCode (..)
  , adminConnect
  , peekReturnCode
  , adminDeferred
  , adminImmediate
  )
  where

import Database.HyperDex.Internal.Core
import Database.HyperDex.Internal.Handle
import Database.HyperDex.Internal.Options
import Database.HyperDex.Internal.Util

import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Foreign
import Foreign.C

#include "hyperdex/admin.h"

data OpaqueAdmin
{#pointer *hyperdex_admin as Admin -> OpaqueAdmin #}

type AdminConnection = HyperDexConnection Admin

peekReturnCode :: MonadIO m
               => Ptr CInt
               -> m (ReturnCode Admin)
peekReturnCode = liftIO . fmap (toEnum . fromIntegral) . peek

instance HyperDex Admin where
  data ReturnCode Admin = AdminSuccess
                        | AdminNomem
                        | AdminNonepending
                        | AdminPollfailed
                        | AdminTimeout
                        | AdminInterrupted
                        | AdminServererror
                        | AdminCoordfail
                        | AdminBadspace
                        | AdminDuplicate
                        | AdminNotfound
                        | AdminInternal
                        | AdminException
                        | AdminGarbage
                        deriving (Eq,Show)

  failureCode = AdminGarbage

  isTransient AdminInterrupted = True
  isTransient AdminTimeout     = True
  isTransient _                = False

  isGlobalError AdminInternal  = True
  isGlobalError AdminException = True
  isGlobalError AdminGarbage   = True
  isGlobalError _              = False

  isNonePending AdminNonepending = True
  isNonePending _                = False

  create host port =
    wrapHyperCall $ {# call hyperdex_admin_create #} host port

  destroy ptr =
    wrapHyperCall $ {# call hyperdex_admin_destroy #} ptr

  loop ptr timeout =
    alloca $ \returnCodePtr -> do
      handle <- wrapHyperCall $ {# call hyperdex_admin_loop #} ptr timeout returnCodePtr
      returnCode <- peekReturnCode returnCodePtr
      return (mkHandle handle, returnCode)

{# enum hyperdex_admin_returncode as `ReturnCode Admin`
   nocode#}

-- instance Enum (ReturnCode Admin) where
--   fromEnum AdminSuccess = 8704
--   fromEnum AdminNomem = 8768
--   fromEnum AdminNonepending = 8769
--   fromEnum AdminPollfailed = 8770
--   fromEnum AdminTimeout = 8771
--   fromEnum AdminInterrupted = 8772
--   fromEnum AdminServererror = 8773
--   fromEnum AdminCoordfail = 8774
--   fromEnum AdminBadspace = 8775
--   fromEnum AdminDuplicate = 8776
--   fromEnum AdminNotfound = 8777
--   fromEnum AdminInternal = 8829
--   fromEnum AdminException = 8830
--   fromEnum AdminGarbage = 8831

--   toEnum 8704 = AdminSuccess
--   toEnum 8768 = AdminNomem
--   toEnum 8769 = AdminNonepending
--   toEnum 8770 = AdminPollfailed
--   toEnum 8771 = AdminTimeout
--   toEnum 8772 = AdminInterrupted
--   toEnum 8773 = AdminServererror
--   toEnum 8774 = AdminCoordfail
--   toEnum 8775 = AdminBadspace
--   toEnum 8776 = AdminDuplicate
--   toEnum 8777 = AdminNotfound
--   toEnum 8829 = AdminInternal
--   toEnum 8830 = AdminException
--   toEnum 8831 = AdminGarbage
--   toEnum unmatched = error ("AdminReturnCode.toEnum: Cannot match " ++ show unmatched)

adminConnect :: ConnectInfo -> IO (AdminConnection)
adminConnect = connect

adminDeferred :: ResIO (AsyncCall Admin a)
              -> AdminConnection
              -> IO (AsyncResult Admin a)
adminDeferred = wrapDeferred (AdminSuccess==)

adminImmediate :: ResIO (SyncCall Admin a)
               -> AdminConnection
               -> IO (AsyncResult Admin a)
adminImmediate = wrapImmediate

-- adminDisconnect :: (AdminConnection) -> IO ()
-- adminDisconnect = disconnect

{-# LANGUAGE TypeFamilies, FlexibleInstances, TypeSynonymInstances #-}

-- |
-- Module     	: Database.HyperDex.Internal.Admin
-- Copyright  	: (c) Aaron Friel 2013-2014
--            	  (c) Niklas Hambüchen 2013-2014
-- License    	: BSD-style
-- Maintainer 	: mayreply@aaronfriel.com
-- Stability  	: unstable
-- Portability	: portable
--
module Database.HyperDex.Internal.Admin
  ( Admin
  , AdminConnection
  , ReturnCode (..)
  , adminConnect
  , peekReturnCode
  , adminDeferred
  , adminImmediate
  )
  where

import Database.HyperDex.Internal.Core
import Database.HyperDex.Internal.Handle
import Database.HyperDex.Internal.Options
import Database.HyperDex.Internal.Util

import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Foreign
import Foreign.C

#include "hyperdex/admin.h"

data OpaqueAdmin
{#pointer *hyperdex_admin as Admin -> OpaqueAdmin #}

type AdminConnection = HyperDexConnection Admin

peekReturnCode :: MonadIO m
               => Ptr CInt
               -> m (ReturnCode Admin)
peekReturnCode = liftIO . fmap (toEnum . fromIntegral) . peek

instance HyperDex Admin where
  data ReturnCode Admin = AdminSuccess
                        | AdminNomem
                        | AdminNonepending
                        | AdminPollfailed
                        | AdminTimeout
                        | AdminInterrupted
                        | AdminServererror
                        | AdminCoordfail
                        | AdminBadspace
                        | AdminDuplicate
                        | AdminNotfound
                        | AdminInternal
                        | AdminException
                        | AdminGarbage
                        deriving (Eq,Show)

  failureCode = AdminGarbage

  isTransient AdminInterrupted = True
  isTransient AdminTimeout     = True
  isTransient _                = False

  isGlobalError AdminInternal  = True
  isGlobalError AdminException = True
  isGlobalError AdminGarbage   = True
  isGlobalError _              = False

  isNonePending AdminNonepending = True
  isNonePending _                = False

  create host port =
    wrapHyperCall $ {# call hyperdex_admin_create #} host port

  destroy ptr =
    wrapHyperCall $ {# call hyperdex_admin_destroy #} ptr

  loop ptr timeout =
    alloca $ \returnCodePtr -> do
      handle <- wrapHyperCall $ {# call hyperdex_admin_loop #} ptr timeout returnCodePtr
      returnCode <- peekReturnCode returnCodePtr
      return (mkHandle handle, returnCode)

instance Enum (ReturnCode Admin) where
  fromEnum AdminSuccess = 8704
  fromEnum AdminNomem = 8768
  fromEnum AdminNonepending = 8769
  fromEnum AdminPollfailed = 8770
  fromEnum AdminTimeout = 8771
  fromEnum AdminInterrupted = 8772
  fromEnum AdminServererror = 8773
  fromEnum AdminCoordfail = 8774
  fromEnum AdminBadspace = 8775
  fromEnum AdminDuplicate = 8776
  fromEnum AdminNotfound = 8777
  fromEnum AdminInternal = 8829
  fromEnum AdminException = 8830
  fromEnum AdminGarbage = 8831

  toEnum 8704 = AdminSuccess
  toEnum 8768 = AdminNomem
  toEnum 8769 = AdminNonepending
  toEnum 8770 = AdminPollfailed
  toEnum 8771 = AdminTimeout
  toEnum 8772 = AdminInterrupted
  toEnum 8773 = AdminServererror
  toEnum 8774 = AdminCoordfail
  toEnum 8775 = AdminBadspace
  toEnum 8776 = AdminDuplicate
  toEnum 8777 = AdminNotfound
  toEnum 8829 = AdminInternal
  toEnum 8830 = AdminException
  toEnum 8831 = AdminGarbage
  toEnum unmatched = error ("AdminReturnCode.toEnum: Cannot match " ++ show unmatched)

adminConnect :: ConnectInfo -> IO (AdminConnection)
adminConnect = connect

adminDeferred :: ResIO (AsyncCall Admin a)
              -> AdminConnection
              -> IO (AsyncResult Admin a)
adminDeferred = wrapDeferred (AdminSuccess==)

adminImmediate :: ResIO (SyncCall Admin a)
               -> AdminConnection
               -> IO (AsyncResult Admin a)
adminImmediate = wrapImmediate

-- adminDisconnect :: (AdminConnection) -> IO ()
-- adminDisconnect = disconnect


Finish PopplerAction module

Finish PopplerAction module

{-# 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.Enums (
-- * Enums
    Error(..),
    Orientation(..),
    SelectionStyle(..),
    PageTransitionType(..),
    PageTransitionAlignment(..),
    PageTransitionDirection(..),
    Backend(..),
    PageLayout(..),
    PageMode(..),
    FontType(..),
    ViewerPreferences(..),
    Permissions(..),
    ActionType(..),
    DestType(..),
    ) 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.UTFString

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

{# enum PopplerError as Error {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerOrientation as Orientation {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerSelectionStyle as SelectionStyle {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerPageTransitionType as PageTransitionType {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerPageTransitionAlignment as PageTransitionAlignment {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerPageTransitionDirection as PageTransitionDirection {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerBackend as Backend {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}

{# enum PopplerPageLayout as PageLayout {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerPageMode as PageMode {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerFontType as FontType {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerViewerPreferences as ViewerPreferences {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerPermissions as Permissions {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerActionType as ActionType {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerDestType as DestType {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}

{-# 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.Enums (
-- * Enums
    Error(..),
    Orientation(..),
    SelectionStyle(..),
    PageTransitionType(..),
    PageTransitionAlignment(..),
    PageTransitionDirection(..),
    Backend(..),
    PageLayout(..),
    PageMode(..),
    FontType(..),
    ViewerPreferences(..),
    Permissions(..),
    ) 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.UTFString

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

{# enum PopplerError as Error {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerOrientation as Orientation {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerSelectionStyle as SelectionStyle {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerPageTransitionType as PageTransitionType {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerPageTransitionAlignment as PageTransitionAlignment {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerPageTransitionDirection as PageTransitionDirection {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerBackend as Backend {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}

{# enum PopplerPageLayout as PageLayout {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerPageMode as PageMode {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerFontType as FontType {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerViewerPreferences as ViewerPreferences {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}
{# enum PopplerPermissions as Permissions {underscoreToCase} with prefix = "Poppler" deriving (Eq, Ord, Bounded, Show, Typeable) #}


Fix build failure, unused variable rc.

Fix build failure, unused variable rc.

Signed-off-by: Aaron Friel <a5ea5f697a6ae483c62b3ef3ac4b9a617542218d@aaronfriel.com>

{-# LANGUAGE TypeFamilies, FlexibleInstances, TypeSynonymInstances #-}

-- |
-- Module     	: Database.HyperDex.Internal.Admin
-- Copyright  	: (c) Aaron Friel 2013-2014
--            	  (c) Niklas Hambüchen 2013-2014
-- License    	: BSD-style
-- Maintainer 	: mayreply@aaronfriel.com
-- Stability  	: unstable
-- Portability	: portable
--
module Database.HyperDex.Internal.Admin
  ( Admin
  , AdminConnection
  , ReturnCode (..)
  , adminConnect
  , peekReturnCode
  , adminDeferred
  , adminImmediate
  )
  where

import Database.HyperDex.Internal.Core
import Database.HyperDex.Internal.Handle
import Database.HyperDex.Internal.Options
import Database.HyperDex.Internal.Util

import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Foreign
import Foreign.C

#include "hyperdex/admin.h"

data OpaqueAdmin
{#pointer *hyperdex_admin as Admin -> OpaqueAdmin #}

type AdminConnection = HyperDexConnection Admin

peekReturnCode :: MonadIO m
               => Ptr CInt
               -> m (ReturnCode Admin)
peekReturnCode = liftIO . fmap (toEnum . fromIntegral) . peek

instance HyperDex Admin where
  data ReturnCode Admin = AdminSuccess
                        | AdminNomem
                        | AdminNonepending
                        | AdminPollfailed
                        | AdminTimeout
                        | AdminInterrupted
                        | AdminServererror
                        | AdminCoordfail
                        | AdminBadspace
                        | AdminDuplicate
                        | AdminNotfound
                        | AdminInternal
                        | AdminException
                        | AdminGarbage
                        deriving (Eq,Show)

  failureCode = AdminGarbage

  isTransient AdminInterrupted = True
  isTransient AdminTimeout     = True
  isTransient _                = False

  isGlobalError AdminInternal  = True
  isGlobalError AdminException = True
  isGlobalError AdminGarbage   = True
  isGlobalError _              = False

  isNonePending AdminNonepending = True
  isNonePending _                = False

  create host port =
    wrapHyperCall $ {# call hyperdex_admin_create #} host port

  destroy ptr =
    wrapHyperCall $ {# call hyperdex_admin_destroy #} ptr

  loop ptr timeout =
    alloca $ \returnCodePtr -> do
      handle <- wrapHyperCall $ {# call hyperdex_admin_loop #} ptr timeout returnCodePtr
      returnCode <- peekReturnCode returnCodePtr
      return (mkHandle handle, returnCode)

instance Enum (ReturnCode Admin) where
  fromEnum AdminSuccess = 8704
  fromEnum AdminNomem = 8768
  fromEnum AdminNonepending = 8769
  fromEnum AdminPollfailed = 8770
  fromEnum AdminTimeout = 8771
  fromEnum AdminInterrupted = 8772
  fromEnum AdminServererror = 8773
  fromEnum AdminCoordfail = 8774
  fromEnum AdminBadspace = 8775
  fromEnum AdminDuplicate = 8776
  fromEnum AdminNotfound = 8777
  fromEnum AdminInternal = 8829
  fromEnum AdminException = 8830
  fromEnum AdminGarbage = 8831

  toEnum 8704 = AdminSuccess
  toEnum 8768 = AdminNomem
  toEnum 8769 = AdminNonepending
  toEnum 8770 = AdminPollfailed
  toEnum 8771 = AdminTimeout
  toEnum 8772 = AdminInterrupted
  toEnum 8773 = AdminServererror
  toEnum 8774 = AdminCoordfail
  toEnum 8775 = AdminBadspace
  toEnum 8776 = AdminDuplicate
  toEnum 8777 = AdminNotfound
  toEnum 8829 = AdminInternal
  toEnum 8830 = AdminException
  toEnum 8831 = AdminGarbage
  toEnum unmatched = error ("AdminReturnCode.toEnum: Cannot match " ++ show unmatched)

adminConnect :: ConnectInfo -> IO (AdminConnection)
adminConnect = connect

adminDeferred :: ResIO (AsyncCall Admin a)
              -> AdminConnection
              -> IO (AsyncResult Admin a)
adminDeferred = wrapDeferred (AdminSuccess==)

adminImmediate :: ResIO (SyncCall Admin a)
               -> AdminConnection
               -> IO (AsyncResult Admin a)
adminImmediate = wrapImmediate

-- adminDisconnect :: (AdminConnection) -> IO ()
-- adminDisconnect = disconnect

{-# LANGUAGE TypeFamilies, FlexibleInstances, TypeSynonymInstances #-}

-- |
-- Module     	: Database.HyperDex.Internal.Admin
-- Copyright  	: (c) Aaron Friel 2013-2014
--            	  (c) Niklas Hambüchen 2013-2014
-- License    	: BSD-style
-- Maintainer 	: mayreply@aaronfriel.com
-- Stability  	: unstable
-- Portability	: portable
--
module Database.HyperDex.Internal.Admin
  ( Admin
  , AdminConnection
  , ReturnCode (..)
  , adminConnect
  , peekReturnCode
  , adminDeferred
  , adminImmediate
  )
  where

import Database.HyperDex.Internal.Core
import Database.HyperDex.Internal.Handle
import Database.HyperDex.Internal.Options
import Database.HyperDex.Internal.Util

import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Foreign
import Foreign.C

#include "hyperdex/admin.h"

data OpaqueAdmin
{#pointer *hyperdex_admin as Admin -> OpaqueAdmin #}

type AdminConnection = HyperDexConnection Admin

peekReturnCode :: MonadIO m
               => Ptr CInt
               -> m (ReturnCode Admin)
peekReturnCode = liftIO . fmap (toEnum . fromIntegral) . peek

instance HyperDex Admin where
  data ReturnCode Admin = AdminSuccess
                        | AdminNomem
                        | AdminNonepending
                        | AdminPollfailed
                        | AdminTimeout
                        | AdminInterrupted
                        | AdminServererror
                        | AdminCoordfail
                        | AdminBadspace
                        | AdminDuplicate
                        | AdminNotfound
                        | AdminInternal
                        | AdminException
                        | AdminGarbage
                        deriving (Eq,Show)

  failureCode = AdminGarbage

  isTransient AdminInterrupted = True
  isTransient AdminTimeout     = True
  isTransient rc               = False

  isGlobalError AdminInternal  = True
  isGlobalError AdminException = True
  isGlobalError AdminGarbage   = True
  isGlobalError _              = False

  isNonePending AdminNonepending = True
  isNonePending _                = False

  create host port =
    wrapHyperCall $ {# call hyperdex_admin_create #} host port

  destroy ptr =
    wrapHyperCall $ {# call hyperdex_admin_destroy #} ptr

  loop ptr timeout =
    alloca $ \returnCodePtr -> do
      handle <- wrapHyperCall $ {# call hyperdex_admin_loop #} ptr timeout returnCodePtr
      returnCode <- peekReturnCode returnCodePtr
      return (mkHandle handle, returnCode)

instance Enum (ReturnCode Admin) where
  fromEnum AdminSuccess = 8704
  fromEnum AdminNomem = 8768
  fromEnum AdminNonepending = 8769
  fromEnum AdminPollfailed = 8770
  fromEnum AdminTimeout = 8771
  fromEnum AdminInterrupted = 8772
  fromEnum AdminServererror = 8773
  fromEnum AdminCoordfail = 8774
  fromEnum AdminBadspace = 8775
  fromEnum AdminDuplicate = 8776
  fromEnum AdminNotfound = 8777
  fromEnum AdminInternal = 8829
  fromEnum AdminException = 8830
  fromEnum AdminGarbage = 8831

  toEnum 8704 = AdminSuccess
  toEnum 8768 = AdminNomem
  toEnum 8769 = AdminNonepending
  toEnum 8770 = AdminPollfailed
  toEnum 8771 = AdminTimeout
  toEnum 8772 = AdminInterrupted
  toEnum 8773 = AdminServererror
  toEnum 8774 = AdminCoordfail
  toEnum 8775 = AdminBadspace
  toEnum 8776 = AdminDuplicate
  toEnum 8777 = AdminNotfound
  toEnum 8829 = AdminInternal
  toEnum 8830 = AdminException
  toEnum 8831 = AdminGarbage
  toEnum unmatched = error ("AdminReturnCode.toEnum: Cannot match " ++ show unmatched)

adminConnect :: ConnectInfo -> IO (AdminConnection)
adminConnect = connect

adminDeferred :: ResIO (AsyncCall Admin a)
              -> AdminConnection
              -> IO (AsyncResult Admin a)
adminDeferred = wrapDeferred (AdminSuccess==)

adminImmediate :: ResIO (SyncCall Admin a)
               -> AdminConnection
               -> IO (AsyncResult Admin a)
adminImmediate = wrapImmediate

-- adminDisconnect :: (AdminConnection) -> IO ()
-- adminDisconnect = disconnect