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 #}


gstreamer: M.S.G.Core.Types: export mkCaps & unCaps, document MiniObjectM

darcs-hash:20080116191424-21862-90cb074dbea43c6e63b14b5a45868565794c3f96.gz

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer -*-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/>.
--
--  GStreamer, 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 GStreamer documentation.

-- #hide

-- | Maintainer  : gtk2hs-devel\@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module Media.Streaming.GStreamer.Core.Types (

  module Media.Streaming.GStreamer.Core.Constants,
  module Media.Streaming.GStreamer.Core.Hierarchy,
  module Media.Streaming.GStreamer.Core.HierarchyBase,
  module Media.Streaming.GStreamer.Core.MiniHierarchy,
  module Media.Streaming.GStreamer.Core.MiniHierarchyBase,
  module Media.Streaming.GStreamer.Core.GObjectHierarchy,

  cToFlags,
  cFromFlags,
  cToEnum,
  cFromEnum,

  FourCC,
  Fraction,

  Format(..),
  FormatDefinition(..),

  mkObjectGetFlags,
  mkObjectSetFlags,
  mkObjectUnsetFlags,

  withObject,
  peekObject,
  takeObject,
  giveObject,

  PadDirection(..),
  PadPresence(..),
  PadLinkReturn(..),
  FlowReturn(..),
  ActivateMode(..),

  State(..),
  StateChangeReturn(..),
  SeekFlags(..),
  SeekType(..),

  PluginFilter,
  PluginFeatureFilter,

  BusFunc,
  BusSyncHandler,
  BusSyncReply(..),

  ClockTimeDiff,
  ClockReturn(..),
  ClockID(..),
  withClockID,
  takeClockID,
  peekClockID,

  IndexCertainty(..),
  IndexEntry(..),
  takeIndexEntry,
  peekIndexEntry,
  IndexEntryType(..),

  IndexLookupMethod(..),
  IndexFilter,
  IndexAssociation(..),
  AssocFlags(..),

  withMiniObject,
  peekMiniObject,
  takeMiniObject,
  giveMiniObject,
  MiniObjectT(..),
  askMiniObjectPtr,
  runMiniObjectT,
  marshalMiniObjectModify,
  mkMiniObjectGetFlags,
  mkMiniObjectGetFlagsM,
  mkMiniObjectSetFlagsM,
  mkMiniObjectUnsetFlagsM,

  QueryType,
  QueryTypeDefinition(..),

  EventTypeFlags(..),

  PtrIterator(..),
  Iterator(..),
  IteratorItem(..),
  IteratorResult(..),
  Iterable(..),
  IteratorFilter,
  IteratorFoldFunction,
  withIterator,
  takeIterator,
  peekIterator,
  -- giveIterator - not defined - iterators don't have a refcount and
  -- are not copyable

  Caps(..),
  mkCaps,
  unCaps,
  withCaps,
  takeCaps,
  peekCaps,
  giveCaps,

  Structure(..),
  StructureForeachFunc,
  withStructure,
  takeStructure,
  peekStructure,
  giveStructure,
  StructureM(..),
  StructureMRep,

  TagList,
  withTagList,
  takeTagList,
  peekTagList,
  giveTagList,
  Tag,
  TagFlag,
  TagMergeMode,

  Segment(..),

  ) where

import Control.Monad       ( liftM )
import Control.Monad.Reader
import Control.Monad.Trans
import Data.Ratio          ( Ratio )
import System.Glib.FFI
import System.Glib.Flags
{#import System.Glib.GType#}
{#import System.Glib.GObject#}
{#import System.Glib.GValue#}
import System.Glib.UTFString
import Media.Streaming.GStreamer.Core.Constants
import Media.Streaming.GStreamer.Core.HierarchyBase
{#import Media.Streaming.GStreamer.Core.MiniHierarchyBase#}
{#import Media.Streaming.GStreamer.Core.Hierarchy#}
{#import Media.Streaming.GStreamer.Core.MiniHierarchy#}
{#import Media.Streaming.GStreamer.Core.GObjectHierarchy#}

{# context lib = "gstreamer" prefix = "gst" #}

type FourCC = Word32
type Fraction = Ratio Int

{# enum GstParseError as ParseError {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

cToFlags :: (Integral int, Flags flags)
         => int
         -> [flags]
cToFlags = toFlags . fromIntegral
cFromFlags :: (Integral int, Flags flags)
           => [flags]
           -> int
cFromFlags = fromIntegral . fromFlags

cToEnum :: (Integral int, Enum enum)
        => int
        -> enum
cToEnum = toEnum . fromIntegral
cFromEnum :: (Integral int, Enum enum)
           => enum
           -> int
cFromEnum = fromIntegral . fromEnum

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

{# enum GstFormat as Format {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

data FormatDefinition = FormatDefinition { formatValue       :: Format
                                         , formatNick        :: String
                                         , formatDescription :: String
                                         , formatQuark       :: Quark }
                        deriving (Eq, Show)
instance Storable FormatDefinition where
    sizeOf = undefined
    alignment = undefined
    peek ptr =
        do value       <- liftM cToEnum $ {# get GstFormatDefinition->value #} ptr
           nick        <- {# get GstFormatDefinition->nick #} ptr >>= peekUTFString
           description <- {# get GstFormatDefinition->description #} ptr >>= peekUTFString
           quark       <- {# get GstFormatDefinition->quark #} ptr
           return $ FormatDefinition value nick description quark
    poke _ _ = undefined
instance Iterable FormatDefinition where
    peekIterable = peek . castPtr
    withIterable = with

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

withObject :: ObjectClass objectT
           => objectT
           -> (Ptr objectT -> IO a)
           -> IO a
withObject object action =
    let objectFPtr = unObject $ toObject object
    in withForeignPtr (castForeignPtr objectFPtr) action

peekObject, takeObject :: ObjectClass obj
                       => Ptr obj
                       -> IO obj
peekObject cObject = do
    liftM (unsafeCastGObject . GObject . castForeignPtr) $
        do cObjectRef $ castPtr cObject
           newForeignPtr (castPtr cObject) objectFinalizer
foreign import ccall unsafe "&gst_object_unref"
  objectFinalizer :: FunPtr (Ptr () -> IO ())
foreign import ccall unsafe "gst_object_ref"
  cObjectRef :: Ptr ()
             -> IO (Ptr ())

takeObject cObject =
    liftM (unsafeCastGObject . GObject . castForeignPtr) $
        do cObjectUnfloat $ castPtr cObject
           newForeignPtr (castPtr cObject) objectFinalizer
foreign import ccall unsafe "_hs_gst_object_unfloat"
  cObjectUnfloat :: Ptr ()
                 -> IO ()

mkObjectGetFlags :: (ObjectClass objectT, Flags flagsT)
                 => objectT
                 -> IO [flagsT]
mkObjectGetFlags object =
    liftM cToFlags $
        withObject (toObject object) cObjectGetFlags
foreign import ccall unsafe "_hs_gst_object_flags"
    cObjectGetFlags :: Ptr Object
                    -> IO CUInt

mkObjectSetFlags :: (ObjectClass objectT, Flags flagsT)
                 => objectT
                 -> [flagsT]
                 -> IO ()
mkObjectSetFlags object flags =
    withObject (toObject object) $ \cObject ->
        cObjectSetFlags cObject (fromIntegral $ fromFlags flags)
foreign import ccall unsafe "_hs_gst_object_flag_set"
    cObjectSetFlags :: Ptr Object
                    -> CUInt
                    -> IO ()

mkObjectUnsetFlags :: (ObjectClass objectT, Flags flagsT)
                   => objectT
                   -> [flagsT]
                   -> IO ()
mkObjectUnsetFlags object flags =
    withObject (toObject object) $ \cObject ->
        cObjectUnsetFlags cObject (fromIntegral $ fromFlags flags)
foreign import ccall unsafe "_hs_gst_object_flag_unset"
    cObjectUnsetFlags :: Ptr Object
                    -> CUInt
                    -> IO ()

-- | Use 'giveObject' to pass an object to a function that takes
--   ownership of it.
giveObject :: (ObjectClass obj, MonadIO m)
           => obj
           -> (obj -> m a)
           -> m a
giveObject obj action =
    do liftIO $ withObject (toObject obj) $ {# call gst_object_ref #} . castPtr
       action obj

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

{# enum GstPadDirection  as PadDirection  {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstPadPresence   as PadPresence   {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstPadLinkReturn as PadLinkReturn {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstFlowReturn    as FlowReturn    {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstActivateMode  as ActivateMode  {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

instance Iterable Pad where
    peekIterable = peekObject . castPtr
    withIterable = withObject

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

{# enum GstPluginError as PluginError {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

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

{# enum GstSeekFlags as SeekFlags {underscoreToCase} with prefix = "GST" deriving (Eq, Bounded, Show) #}
instance Flags SeekFlags
{# enum GstSeekType  as SeekType  {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstState     as State     {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

{# enum GstStateChangeReturn as StateChangeReturn {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

instance Iterable Element where
    peekIterable = peekObject . castPtr
    withIterable = withObject

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

type PluginFilter = Plugin -> IO Bool
type PluginFeatureFilter = PluginFeature -> IO Bool

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

{# enum GstBusSyncReply as BusSyncReply {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

type BusFunc =  Bus
             -> Message
             -> IO Bool
type BusSyncHandler =  Bus
                    -> Message
                    -> IO BusSyncReply

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

type ClockTimeDiff = Int64

{# enum GstClockReturn as ClockReturn {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

{# pointer *GstClockID as ClockID foreign newtype #}
withClockID :: ClockID
            -> (Ptr ClockID -> IO a)
            -> IO a
withClockID (ClockID clockID) = withForeignPtr clockID
takeClockID, peekClockID :: Ptr ClockID
                        -> IO ClockID
takeClockID clockIDPtr =
    liftM ClockID $ newForeignPtr clockIDPtr clockIDFinalizer
peekClockID clockIDPtr =
    do {# call clock_id_ref #} $ castPtr clockIDPtr
       takeClockID clockIDPtr

foreign import ccall unsafe "&gst_clock_id_unref"
    clockIDFinalizer :: FunPtr (Ptr ClockID -> IO ())

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

{# enum GstIndexCertainty    as IndexCertainty    {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstIndexEntryType    as IndexEntryType    {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstIndexLookupMethod as IndexLookupMethod {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

{# pointer *GstIndexEntry as IndexEntry foreign newtype #}

takeIndexEntry :: Ptr IndexEntry
              -> IO IndexEntry
takeIndexEntry ptr =
    liftM IndexEntry $ newForeignPtr ptr indexEntryFinalizer
foreign import ccall unsafe "&gst_index_entry_free"
    indexEntryFinalizer :: FunPtr (Ptr IndexEntry -> IO ())
peekIndexEntry :: Ptr IndexEntry
               -> IO IndexEntry
peekIndexEntry ptr =
    (liftM IndexEntry $ newForeignPtr_ ptr) >>=
        {# call index_entry_copy #} >>=
            takeIndexEntry

type IndexFilter  = Index
                 -> IndexEntry
                 -> IO Bool

data IndexAssociation = IndexAssociation Format Int64
                        deriving (Eq, Show)
instance Storable IndexAssociation where
    sizeOf _ = {# sizeof GstIndexAssociation #}
    alignment _ = alignment (undefined :: CString)
    peek ptr =
        do format <- {# get GstIndexAssociation->format #} ptr
           value <- {# get GstIndexAssociation->value #} ptr
           return $ IndexAssociation (cToEnum format) (fromIntegral value)
    poke ptr (IndexAssociation format value) =
        do {# set GstIndexAssociation->format #} ptr $ cFromEnum format
           {# set GstIndexAssociation->value #} ptr $ fromIntegral value

{# enum GstAssocFlags as AssocFlags {underscoreToCase} with prefix = "GST" deriving (Eq, Bounded, Show) #}
instance Flags AssocFlags

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

withMiniObject :: MiniObjectClass miniObjectT
               => miniObjectT
               -> (Ptr miniObjectT -> IO a)
               -> IO a
withMiniObject miniObject action =
    let miniObjectFPtr = unMiniObject $ toMiniObject miniObject
    in withForeignPtr (castForeignPtr miniObjectFPtr) action

takeMiniObject, peekMiniObject :: (MiniObjectClass obj)
                               => Ptr obj
                               -> IO obj
peekMiniObject cMiniObject =
    do cMiniObjectRef $ castPtr cMiniObject
       takeMiniObject cMiniObject
foreign import ccall unsafe "gst_mini_object_ref"
  cMiniObjectRef :: Ptr ()
                 -> IO (Ptr ())

takeMiniObject cMiniObject =
    do cMiniObjectMakeReadOnly $ castPtr cMiniObject
       object <- newForeignPtr (castPtr cMiniObject) miniObjectFinalizer
       return $ unsafeCastMiniObject $ MiniObject $ castForeignPtr object
foreign import ccall unsafe "&gst_mini_object_unref"
  miniObjectFinalizer :: FunPtr (Ptr () -> IO ())
foreign import ccall unsafe "_hs_gst_mini_object_make_read_only"
  cMiniObjectMakeReadOnly :: Ptr MiniObject
                          -> IO ()

-- | Use 'giveMiniObject' to pass an miniObject to a function that takes
--   ownership of it.
giveMiniObject :: (MiniObjectClass obj, MonadIO m)
               => obj
               -> (obj -> m a)
               -> m a
giveMiniObject obj action =
    do liftIO $ {# call gst_mini_object_ref #} (toMiniObject obj)
       action obj

-- | A 'Monad' for sequencing modifications to a 'MiniObject'.
newtype (MiniObjectClass miniObjectT, Monad m) =>
    MiniObjectT miniObjectT m a =
        MiniObjectT (ReaderT (Ptr miniObjectT) m a)
        deriving (Functor, Monad, MonadTrans)
instance (MiniObjectClass miniObjectT, Monad m, MonadIO m) =>
    MonadIO (MiniObjectT miniObjectT m) where
        liftIO = MiniObjectT . liftIO

askMiniObjectPtr :: (MiniObjectClass miniObjectT, Monad m)
                 => MiniObjectT miniObjectT m (Ptr miniObjectT)
askMiniObjectPtr = MiniObjectT $ ask

runMiniObjectT :: (MiniObjectClass miniObjectT, Monad m)
               => MiniObjectT miniObjectT m a
               -> (Ptr miniObjectT)
               -> m a
runMiniObjectT (MiniObjectT action) = runReaderT action

marshalMiniObjectModify :: (MiniObjectClass miniObjectT, MonadIO m)
                        => m (Ptr miniObjectT)
                        -> MiniObjectT miniObjectT m a
                        -> m (miniObjectT, a)
marshalMiniObjectModify mkMiniObject action =
    do ptr' <- mkMiniObject
       ptr <- liftIO $ liftM castPtr $ gst_mini_object_make_writable $ castPtr ptr'
       result <- runMiniObjectT action ptr
       object <- liftIO $ takeMiniObject ptr
       return (object, result)
    where _ = {# call mini_object_make_writable #}

mkMiniObjectGetFlags :: (MiniObjectClass miniObjectT, Flags flagsT)
                     => miniObjectT
                     -> [flagsT]
mkMiniObjectGetFlags miniObject =
    cToFlags $ unsafePerformIO $
        withMiniObject (toMiniObject miniObject) cMiniObjectGetFlags
foreign import ccall unsafe "_hs_gst_mini_object_flags"
    cMiniObjectGetFlags :: Ptr MiniObject
                        -> IO CUInt

mkMiniObjectGetFlagsM :: (MiniObjectClass miniObjectT, Flags flagsT, MonadIO m)
                      => MiniObjectT miniObjectT m [flagsT]
mkMiniObjectGetFlagsM = do
  ptr <- askMiniObjectPtr
  liftIO $ liftM cToFlags $ cMiniObjectGetFlags $ castPtr ptr

mkMiniObjectSetFlagsM :: (MiniObjectClass miniObjectT, Flags flagsT, MonadIO m)
                      => [flagsT]
                      -> MiniObjectT miniObjectT m ()
mkMiniObjectSetFlagsM flags = do
  ptr <- askMiniObjectPtr
  liftIO $ cMiniObjectSetFlags (castPtr ptr) $ cFromFlags flags
foreign import ccall unsafe "_hs_gst_mini_object_flag_set"
    cMiniObjectSetFlags :: Ptr MiniObject
                        -> CUInt
                        -> IO ()

mkMiniObjectUnsetFlagsM :: (MiniObjectClass miniObjectT, Flags flagsT, MonadIO m)
                        => [flagsT]
                        -> MiniObjectT miniObjectT m ()
mkMiniObjectUnsetFlagsM flags = do
  ptr <- askMiniObjectPtr
  liftIO $ cMiniObjectUnsetFlags (castPtr ptr) $ cFromFlags flags
foreign import ccall unsafe "_hs_gst_mini_object_flag_unset"
    cMiniObjectUnsetFlags :: Ptr MiniObject
                          -> CUInt
                          -> IO ()

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

type QueryType = {# type GstQueryType #}
data QueryTypeDefinition = QueryTypeDefinition {
    queryTypeDefinitionValue       :: QueryType,
    queryTypeDefinitionNick        :: String,
    queryTypeDefinitionDescription :: String,
    queryTypeDefinitionQuark       :: Quark
    } deriving (Eq, Show)
instance Storable QueryTypeDefinition where
    sizeOf _ = {# sizeof GstQuery #}
    alignment _ = alignment (undefined :: CString)
    peek ptr =
        do value <- {# get GstQueryTypeDefinition->value #} ptr
           nick <- {# get GstQueryTypeDefinition->nick #} ptr >>= peekUTFString
           description <- {# get GstQueryTypeDefinition->description #} ptr >>= peekUTFString
           quark <- {# get GstQueryTypeDefinition->quark #} ptr
           return $ QueryTypeDefinition value
                                        nick
                                        description
                                        quark
    poke _ _ = undefined
instance Iterable QueryTypeDefinition where
    peekIterable = peek . castPtr
    withIterable = with

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

{# enum GstEventTypeFlags as EventTypeFlags {underscoreToCase} with prefix = "GST" deriving (Eq, Bounded, Show) #}
instance Flags EventTypeFlags

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

{# pointer *GstIterator as PtrIterator foreign newtype #}

withPtrIterator :: PtrIterator
                -> (Ptr PtrIterator -> IO a)
                -> IO a
withPtrIterator (PtrIterator cPtrIterator) = withForeignPtr cPtrIterator

takePtrIterator, peekPtrIterator :: Ptr PtrIterator
                                 -> IO PtrIterator
takePtrIterator ptrIteratorPtr =
    liftM PtrIterator $ newForeignPtr ptrIteratorPtr ptrIteratorFinalizer
peekPtrIterator ptrIteratorPtr =
    liftM PtrIterator $ newForeignPtr_ ptrIteratorPtr

foreign import ccall unsafe "&gst_iterator_free"
    ptrIteratorFinalizer :: FunPtr (Ptr PtrIterator -> IO ())

{# enum GstIteratorItem   as IteratorItem   {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstIteratorResult as IteratorResult {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

mkIterator newPtrIterator cPtrIterator =
    do ptrIterator <- newPtrIterator cPtrIterator
       return $ Iterator ptrIterator

newtype Iterable a => Iterator a = Iterator PtrIterator

withIterator :: Iterator a
             -> (Ptr PtrIterator -> IO a)
             -> IO a
withIterator (Iterator ptrIterator) = withPtrIterator ptrIterator

takeIterator, peekIterator :: Ptr PtrIterator
                          -> IO (Iterator a)
takeIterator  cPtrIterator = mkIterator takePtrIterator  cPtrIterator
peekIterator cPtrIterator = mkIterator peekPtrIterator cPtrIterator

class Iterable a where
    peekIterable :: Ptr ()
                 -> IO a
    withIterable :: a
                 -> (Ptr a -> IO b)
                 -> IO b

type IteratorFilter itemT = itemT
                         -> IO Bool
type IteratorFoldFunction itemT accumT = itemT
                                      -> accumT
                                      -> IO (Bool, accumT)

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

{# pointer *GstCaps as Caps foreign newtype #}
mkCaps :: ForeignPtr Caps -> Caps
mkCaps = Caps
unCaps :: Caps -> ForeignPtr Caps
unCaps (Caps caps) = caps

withCaps :: Caps -> (Ptr Caps -> IO a) -> IO a
withCaps = withForeignPtr . unCaps

takeCaps, peekCaps :: Ptr Caps
                  -> IO Caps
takeCaps capsPtr =
    liftM Caps $ newForeignPtr capsPtr capsFinalizer
peekCaps capsPtr =
    cCapsRef capsPtr >>= takeCaps
foreign import ccall unsafe "gst_caps_ref"
    cCapsRef :: Ptr Caps
             -> IO (Ptr Caps)

giveCaps :: MonadIO m
         => Caps
         -> (Caps -> m a)
         -> m a
giveCaps caps action =
    do liftIO $ {# call caps_ref #} caps
       action caps

foreign import ccall unsafe "&gst_caps_unref"
    capsFinalizer :: FunPtr (Ptr Caps -> IO ())

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

{# pointer *GstStructure as Structure foreign newtype #}
mkStructure :: ForeignPtr Structure -> Structure
mkStructure = Structure
unStructure :: Structure -> ForeignPtr Structure
unStructure (Structure structure) = structure

withStructure :: Structure -> (Ptr Structure -> IO a) -> IO a
withStructure = withForeignPtr . unStructure

mkNewStructure :: (Ptr Structure -> IO (ForeignPtr Structure))
               -> Ptr Structure
               -> IO Structure
mkNewStructure mkFP structurePtr =
    do cStructureMakeImmutable structurePtr
       liftM Structure $ mkFP structurePtr
foreign import ccall unsafe "_hs_gst_structure_make_immutable"
    cStructureMakeImmutable :: Ptr Structure
                            -> IO ()

takeStructure, peekStructure :: Ptr Structure
                            -> IO Structure
takeStructure =
    mkNewStructure $ flip newForeignPtr structureFinalizer
peekStructure =
    mkNewStructure $ newForeignPtr_

giveStructure :: MonadIO m
              => Structure
              -> (Structure -> m a)
              -> m a
giveStructure structure action =
    do structure <- liftIO $
                        {# call structure_copy #} structure >>=
                            peekStructure
       action structure

foreign import ccall unsafe "&gst_structure_free"
    structureFinalizer :: FunPtr (Ptr Structure -> IO ())

type StructureForeachFunc =  Quark
                          -> GValue
                          -> IO Bool

newtype StructureM a = StructureM (StructureMRep a)
type StructureMRep a = (Structure -> IO a)

instance Monad StructureM where
    (StructureM aM) >>= fbM =
        StructureM $ \structure ->
            do a <- aM structure
               let StructureM bM = fbM a
               bM structure
    return a = StructureM $ const $ return a

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

type TagList = Structure
mkTagList = mkStructure
unTagList = unStructure
withTagList = withStructure
takeTagList = takeStructure
peekTagList = takeStructure
giveTagList :: MonadIO m
            => TagList
            -> (TagList -> m a)
            -> m a
giveTagList = giveStructure

type Tag = String

{# enum GstTagFlag      as TagFlag      {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstTagMergeMode as TagMergeMode {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

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

data Segment = Segment { segmentRate        :: Double
                       , segmentAbsRate     :: Double
                       , segmentFormat      :: Format
                       , segmentFlags       :: [SeekFlags]
                       , segmentStart       :: Int64
                       , segmentStop        :: Int64
                       , segmentTime        :: Int64
                       , segmentAccum       :: Int64
                       , segmentLastStop    :: Int64
                       , segmentDuration    :: Int64 }
               deriving (Eq, Show)
instance Storable Segment where
    sizeOf _ = fromIntegral cSegmentSizeof
    alignment _ = alignment (undefined :: CString)
    peek ptr =
        do rate        <- {# get GstSegment->rate #} ptr
           absRate     <- {# get GstSegment->abs_rate #} ptr
           format      <- {# get GstSegment->format #} ptr
           flags       <- {# get GstSegment->flags #} ptr
           start       <- {# get GstSegment->start #} ptr
           stop        <- {# get GstSegment->stop #} ptr
           time        <- {# get GstSegment->time #} ptr
           accum       <- {# get GstSegment->accum #} ptr
           lastStop    <- {# get GstSegment->last_stop #} ptr
           duration    <- {# get GstSegment->duration #} ptr
           return $ Segment (realToFrac rate)
                            (realToFrac absRate)
                            (cToEnum format)
                            (cToFlags flags)
                            (fromIntegral start)
                            (fromIntegral stop)
                            (fromIntegral time)
                            (fromIntegral accum)
                            (fromIntegral lastStop)
                            (fromIntegral duration)
    poke ptr (Segment rate
                      absRate
                      format
                      flags
                      start
                      stop
                      time
                      accum
                      lastStop
                      duration) =
        do {# call segment_init #} (castPtr ptr)
                                   (cFromEnum format)
           {# set GstSegment->rate #} ptr $ realToFrac rate
           {# set GstSegment->abs_rate #} ptr $ realToFrac absRate
           {# set GstSegment->format #} ptr $ cFromEnum format
           {# set GstSegment->flags #} ptr $ fromIntegral $ fromFlags flags
           {# set GstSegment->start #} ptr $ fromIntegral start
           {# set GstSegment->stop #} ptr $ fromIntegral stop
           {# set GstSegment->time #} ptr $ fromIntegral time
           {# set GstSegment->accum #} ptr $ fromIntegral accum
           {# set GstSegment->last_stop #} ptr $ fromIntegral lastStop
           {# set GstSegment->duration #} ptr $ fromIntegral duration
foreign import ccall unsafe "_hs_gst_segment_sizeof"
    cSegmentSizeof :: {# type gsize #}

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

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer -*-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/>.
--
--  GStreamer, 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 GStreamer documentation.

-- #hide

-- | Maintainer  : gtk2hs-devel\@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module Media.Streaming.GStreamer.Core.Types (

  module Media.Streaming.GStreamer.Core.Constants,
  module Media.Streaming.GStreamer.Core.Hierarchy,
  module Media.Streaming.GStreamer.Core.HierarchyBase,
  module Media.Streaming.GStreamer.Core.MiniHierarchy,
  module Media.Streaming.GStreamer.Core.MiniHierarchyBase,
  module Media.Streaming.GStreamer.Core.GObjectHierarchy,

  cToFlags,
  cFromFlags,
  cToEnum,
  cFromEnum,

  FourCC,
  Fraction,

  Format(..),
  FormatDefinition(..),

  mkObjectGetFlags,
  mkObjectSetFlags,
  mkObjectUnsetFlags,

  withObject,
  peekObject,
  takeObject,
  giveObject,

  PadDirection(..),
  PadPresence(..),
  PadLinkReturn(..),
  FlowReturn(..),
  ActivateMode(..),

  State(..),
  StateChangeReturn(..),
  SeekFlags(..),
  SeekType(..),

  PluginFilter,
  PluginFeatureFilter,

  BusFunc,
  BusSyncHandler,
  BusSyncReply(..),

  ClockTimeDiff,
  ClockReturn(..),
  ClockID(..),
  withClockID,
  takeClockID,
  peekClockID,

  IndexCertainty(..),
  IndexEntry(..),
  takeIndexEntry,
  peekIndexEntry,
  IndexEntryType(..),

  IndexLookupMethod(..),
  IndexFilter,
  IndexAssociation(..),
  AssocFlags(..),

  withMiniObject,
  peekMiniObject,
  takeMiniObject,
  giveMiniObject,
  MiniObjectT(..),
  askMiniObjectPtr,
  runMiniObjectT,
  marshalMiniObjectModify,
  mkMiniObjectGetFlags,
  mkMiniObjectGetFlagsM,
  mkMiniObjectSetFlagsM,
  mkMiniObjectUnsetFlagsM,

  QueryType,
  QueryTypeDefinition(..),

  EventTypeFlags(..),

  PtrIterator(..),
  Iterator(..),
  IteratorItem(..),
  IteratorResult(..),
  Iterable(..),
  IteratorFilter,
  IteratorFoldFunction,
  withIterator,
  takeIterator,
  peekIterator,
  -- giveIterator - not defined - iterators don't have a refcount and
  -- are not copyable

  Caps(..),
  withCaps,
  takeCaps,
  peekCaps,
  giveCaps,

  Structure(..),
  StructureForeachFunc,
  withStructure,
  takeStructure,
  peekStructure,
  giveStructure,
  StructureM(..),
  StructureMRep,

  TagList,
  withTagList,
  takeTagList,
  peekTagList,
  giveTagList,
  Tag,
  TagFlag,
  TagMergeMode,

  Segment(..),

  ) where

import Control.Monad       ( liftM )
import Control.Monad.Reader
import Control.Monad.Trans
import Data.Ratio          ( Ratio )
import System.Glib.FFI
import System.Glib.Flags
{#import System.Glib.GType#}
{#import System.Glib.GObject#}
{#import System.Glib.GValue#}
import System.Glib.UTFString
import Media.Streaming.GStreamer.Core.Constants
import Media.Streaming.GStreamer.Core.HierarchyBase
{#import Media.Streaming.GStreamer.Core.MiniHierarchyBase#}
{#import Media.Streaming.GStreamer.Core.Hierarchy#}
{#import Media.Streaming.GStreamer.Core.MiniHierarchy#}
{#import Media.Streaming.GStreamer.Core.GObjectHierarchy#}

{# context lib = "gstreamer" prefix = "gst" #}

type FourCC = Word32
type Fraction = Ratio Int

{# enum GstParseError as ParseError {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

cToFlags :: (Integral int, Flags flags)
         => int
         -> [flags]
cToFlags = toFlags . fromIntegral
cFromFlags :: (Integral int, Flags flags)
           => [flags]
           -> int
cFromFlags = fromIntegral . fromFlags

cToEnum :: (Integral int, Enum enum)
        => int
        -> enum
cToEnum = toEnum . fromIntegral
cFromEnum :: (Integral int, Enum enum)
           => enum
           -> int
cFromEnum = fromIntegral . fromEnum

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

{# enum GstFormat as Format {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

data FormatDefinition = FormatDefinition { formatValue       :: Format
                                         , formatNick        :: String
                                         , formatDescription :: String
                                         , formatQuark       :: Quark }
                        deriving (Eq, Show)
instance Storable FormatDefinition where
    sizeOf = undefined
    alignment = undefined
    peek ptr =
        do value       <- liftM cToEnum $ {# get GstFormatDefinition->value #} ptr
           nick        <- {# get GstFormatDefinition->nick #} ptr >>= peekUTFString
           description <- {# get GstFormatDefinition->description #} ptr >>= peekUTFString
           quark       <- {# get GstFormatDefinition->quark #} ptr
           return $ FormatDefinition value nick description quark
    poke _ _ = undefined
instance Iterable FormatDefinition where
    peekIterable = peek . castPtr
    withIterable = with

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

withObject :: ObjectClass objectT
           => objectT
           -> (Ptr objectT -> IO a)
           -> IO a
withObject object action =
    let objectFPtr = unObject $ toObject object
    in withForeignPtr (castForeignPtr objectFPtr) action

peekObject, takeObject :: ObjectClass obj
                       => Ptr obj
                       -> IO obj
peekObject cObject = do
    liftM (unsafeCastGObject . GObject . castForeignPtr) $
        do cObjectRef $ castPtr cObject
           newForeignPtr (castPtr cObject) objectFinalizer
foreign import ccall unsafe "&gst_object_unref"
  objectFinalizer :: FunPtr (Ptr () -> IO ())
foreign import ccall unsafe "gst_object_ref"
  cObjectRef :: Ptr ()
             -> IO (Ptr ())

takeObject cObject =
    liftM (unsafeCastGObject . GObject . castForeignPtr) $
        do cObjectUnfloat $ castPtr cObject
           newForeignPtr (castPtr cObject) objectFinalizer
foreign import ccall unsafe "_hs_gst_object_unfloat"
  cObjectUnfloat :: Ptr ()
                 -> IO ()

mkObjectGetFlags :: (ObjectClass objectT, Flags flagsT)
                 => objectT
                 -> IO [flagsT]
mkObjectGetFlags object =
    liftM cToFlags $
        withObject (toObject object) cObjectGetFlags
foreign import ccall unsafe "_hs_gst_object_flags"
    cObjectGetFlags :: Ptr Object
                    -> IO CUInt

mkObjectSetFlags :: (ObjectClass objectT, Flags flagsT)
                 => objectT
                 -> [flagsT]
                 -> IO ()
mkObjectSetFlags object flags =
    withObject (toObject object) $ \cObject ->
        cObjectSetFlags cObject (fromIntegral $ fromFlags flags)
foreign import ccall unsafe "_hs_gst_object_flag_set"
    cObjectSetFlags :: Ptr Object
                    -> CUInt
                    -> IO ()

mkObjectUnsetFlags :: (ObjectClass objectT, Flags flagsT)
                   => objectT
                   -> [flagsT]
                   -> IO ()
mkObjectUnsetFlags object flags =
    withObject (toObject object) $ \cObject ->
        cObjectUnsetFlags cObject (fromIntegral $ fromFlags flags)
foreign import ccall unsafe "_hs_gst_object_flag_unset"
    cObjectUnsetFlags :: Ptr Object
                    -> CUInt
                    -> IO ()

-- | Use 'giveObject' to pass an object to a function that takes
--   ownership of it.
giveObject :: (ObjectClass obj, MonadIO m)
           => obj
           -> (obj -> m a)
           -> m a
giveObject obj action =
    do liftIO $ withObject (toObject obj) $ {# call gst_object_ref #} . castPtr
       action obj

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

{# enum GstPadDirection  as PadDirection  {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstPadPresence   as PadPresence   {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstPadLinkReturn as PadLinkReturn {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstFlowReturn    as FlowReturn    {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstActivateMode  as ActivateMode  {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

instance Iterable Pad where
    peekIterable = peekObject . castPtr
    withIterable = withObject

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

{# enum GstPluginError as PluginError {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

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

{# enum GstSeekFlags as SeekFlags {underscoreToCase} with prefix = "GST" deriving (Eq, Bounded, Show) #}
instance Flags SeekFlags
{# enum GstSeekType  as SeekType  {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstState     as State     {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

{# enum GstStateChangeReturn as StateChangeReturn {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

instance Iterable Element where
    peekIterable = peekObject . castPtr
    withIterable = withObject

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

type PluginFilter = Plugin -> IO Bool
type PluginFeatureFilter = PluginFeature -> IO Bool

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

{# enum GstBusSyncReply as BusSyncReply {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

type BusFunc =  Bus
             -> Message
             -> IO Bool
type BusSyncHandler =  Bus
                    -> Message
                    -> IO BusSyncReply

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

type ClockTimeDiff = Int64

{# enum GstClockReturn as ClockReturn {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

{# pointer *GstClockID as ClockID foreign newtype #}
withClockID :: ClockID
            -> (Ptr ClockID -> IO a)
            -> IO a
withClockID (ClockID clockID) = withForeignPtr clockID
takeClockID, peekClockID :: Ptr ClockID
                        -> IO ClockID
takeClockID clockIDPtr =
    liftM ClockID $ newForeignPtr clockIDPtr clockIDFinalizer
peekClockID clockIDPtr =
    do {# call clock_id_ref #} $ castPtr clockIDPtr
       takeClockID clockIDPtr

foreign import ccall unsafe "&gst_clock_id_unref"
    clockIDFinalizer :: FunPtr (Ptr ClockID -> IO ())

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

{# enum GstIndexCertainty    as IndexCertainty    {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstIndexEntryType    as IndexEntryType    {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstIndexLookupMethod as IndexLookupMethod {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

{# pointer *GstIndexEntry as IndexEntry foreign newtype #}

takeIndexEntry :: Ptr IndexEntry
              -> IO IndexEntry
takeIndexEntry ptr =
    liftM IndexEntry $ newForeignPtr ptr indexEntryFinalizer
foreign import ccall unsafe "&gst_index_entry_free"
    indexEntryFinalizer :: FunPtr (Ptr IndexEntry -> IO ())
peekIndexEntry :: Ptr IndexEntry
               -> IO IndexEntry
peekIndexEntry ptr =
    (liftM IndexEntry $ newForeignPtr_ ptr) >>=
        {# call index_entry_copy #} >>=
            takeIndexEntry

type IndexFilter  = Index
                 -> IndexEntry
                 -> IO Bool

data IndexAssociation = IndexAssociation Format Int64
                        deriving (Eq, Show)
instance Storable IndexAssociation where
    sizeOf _ = {# sizeof GstIndexAssociation #}
    alignment _ = alignment (undefined :: CString)
    peek ptr =
        do format <- {# get GstIndexAssociation->format #} ptr
           value <- {# get GstIndexAssociation->value #} ptr
           return $ IndexAssociation (cToEnum format) (fromIntegral value)
    poke ptr (IndexAssociation format value) =
        do {# set GstIndexAssociation->format #} ptr $ cFromEnum format
           {# set GstIndexAssociation->value #} ptr $ fromIntegral value

{# enum GstAssocFlags as AssocFlags {underscoreToCase} with prefix = "GST" deriving (Eq, Bounded, Show) #}
instance Flags AssocFlags

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

withMiniObject :: MiniObjectClass miniObjectT
               => miniObjectT
               -> (Ptr miniObjectT -> IO a)
               -> IO a
withMiniObject miniObject action =
    let miniObjectFPtr = unMiniObject $ toMiniObject miniObject
    in withForeignPtr (castForeignPtr miniObjectFPtr) action

takeMiniObject, peekMiniObject :: (MiniObjectClass obj)
                               => Ptr obj
                               -> IO obj
peekMiniObject cMiniObject =
    do cMiniObjectRef $ castPtr cMiniObject
       takeMiniObject cMiniObject
foreign import ccall unsafe "gst_mini_object_ref"
  cMiniObjectRef :: Ptr ()
                 -> IO (Ptr ())

takeMiniObject cMiniObject =
    do cMiniObjectMakeReadOnly $ castPtr cMiniObject
       object <- newForeignPtr (castPtr cMiniObject) miniObjectFinalizer
       return $ unsafeCastMiniObject $ MiniObject $ castForeignPtr object
foreign import ccall unsafe "&gst_mini_object_unref"
  miniObjectFinalizer :: FunPtr (Ptr () -> IO ())
foreign import ccall unsafe "_hs_gst_mini_object_make_read_only"
  cMiniObjectMakeReadOnly :: Ptr MiniObject
                          -> IO ()

-- | Use 'giveMiniObject' to pass an miniObject to a function that takes
--   ownership of it.
giveMiniObject :: (MiniObjectClass obj, MonadIO m)
               => obj
               -> (obj -> m a)
               -> m a
giveMiniObject obj action =
    do liftIO $ {# call gst_mini_object_ref #} (toMiniObject obj)
       action obj

newtype (MiniObjectClass miniObjectT, Monad m) =>
    MiniObjectT miniObjectT m a =
        MiniObjectT (ReaderT (Ptr miniObjectT) m a)
        deriving (Functor, Monad, MonadTrans)
instance (MiniObjectClass miniObjectT, Monad m, MonadIO m) =>
    MonadIO (MiniObjectT miniObjectT m) where
        liftIO = MiniObjectT . liftIO

askMiniObjectPtr :: (MiniObjectClass miniObjectT, Monad m)
                 => MiniObjectT miniObjectT m (Ptr miniObjectT)
askMiniObjectPtr = MiniObjectT $ ask

runMiniObjectT :: (MiniObjectClass miniObjectT, Monad m)
               => MiniObjectT miniObjectT m a
               -> (Ptr miniObjectT)
               -> m a
runMiniObjectT (MiniObjectT action) = runReaderT action

marshalMiniObjectModify :: (MiniObjectClass miniObjectT, MonadIO m)
                        => m (Ptr miniObjectT)
                        -> MiniObjectT miniObjectT m a
                        -> m (miniObjectT, a)
marshalMiniObjectModify mkMiniObject action =
    do ptr' <- mkMiniObject
       ptr <- liftIO $ liftM castPtr $ gst_mini_object_make_writable $ castPtr ptr'
       result <- runMiniObjectT action ptr
       object <- liftIO $ takeMiniObject ptr
       return (object, result)
    where _ = {# call mini_object_make_writable #}

mkMiniObjectGetFlags :: (MiniObjectClass miniObjectT, Flags flagsT)
                     => miniObjectT
                     -> [flagsT]
mkMiniObjectGetFlags miniObject =
    cToFlags $ unsafePerformIO $
        withMiniObject (toMiniObject miniObject) cMiniObjectGetFlags
foreign import ccall unsafe "_hs_gst_mini_object_flags"
    cMiniObjectGetFlags :: Ptr MiniObject
                        -> IO CUInt

mkMiniObjectGetFlagsM :: (MiniObjectClass miniObjectT, Flags flagsT, MonadIO m)
                      => MiniObjectT miniObjectT m [flagsT]
mkMiniObjectGetFlagsM = do
  ptr <- askMiniObjectPtr
  liftIO $ liftM cToFlags $ cMiniObjectGetFlags $ castPtr ptr

mkMiniObjectSetFlagsM :: (MiniObjectClass miniObjectT, Flags flagsT, MonadIO m)
                      => [flagsT]
                      -> MiniObjectT miniObjectT m ()
mkMiniObjectSetFlagsM flags = do
  ptr <- askMiniObjectPtr
  liftIO $ cMiniObjectSetFlags (castPtr ptr) $ cFromFlags flags
foreign import ccall unsafe "_hs_gst_mini_object_flag_set"
    cMiniObjectSetFlags :: Ptr MiniObject
                        -> CUInt
                        -> IO ()

mkMiniObjectUnsetFlagsM :: (MiniObjectClass miniObjectT, Flags flagsT, MonadIO m)
                        => [flagsT]
                        -> MiniObjectT miniObjectT m ()
mkMiniObjectUnsetFlagsM flags = do
  ptr <- askMiniObjectPtr
  liftIO $ cMiniObjectUnsetFlags (castPtr ptr) $ cFromFlags flags
foreign import ccall unsafe "_hs_gst_mini_object_flag_unset"
    cMiniObjectUnsetFlags :: Ptr MiniObject
                          -> CUInt
                          -> IO ()

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

type QueryType = {# type GstQueryType #}
data QueryTypeDefinition = QueryTypeDefinition {
    queryTypeDefinitionValue       :: QueryType,
    queryTypeDefinitionNick        :: String,
    queryTypeDefinitionDescription :: String,
    queryTypeDefinitionQuark       :: Quark
    } deriving (Eq, Show)
instance Storable QueryTypeDefinition where
    sizeOf _ = {# sizeof GstQuery #}
    alignment _ = alignment (undefined :: CString)
    peek ptr =
        do value <- {# get GstQueryTypeDefinition->value #} ptr
           nick <- {# get GstQueryTypeDefinition->nick #} ptr >>= peekUTFString
           description <- {# get GstQueryTypeDefinition->description #} ptr >>= peekUTFString
           quark <- {# get GstQueryTypeDefinition->quark #} ptr
           return $ QueryTypeDefinition value
                                        nick
                                        description
                                        quark
    poke _ _ = undefined
instance Iterable QueryTypeDefinition where
    peekIterable = peek . castPtr
    withIterable = with

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

{# enum GstEventTypeFlags as EventTypeFlags {underscoreToCase} with prefix = "GST" deriving (Eq, Bounded, Show) #}
instance Flags EventTypeFlags

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

{# pointer *GstIterator as PtrIterator foreign newtype #}

withPtrIterator :: PtrIterator
                -> (Ptr PtrIterator -> IO a)
                -> IO a
withPtrIterator (PtrIterator cPtrIterator) = withForeignPtr cPtrIterator

takePtrIterator, peekPtrIterator :: Ptr PtrIterator
                                 -> IO PtrIterator
takePtrIterator ptrIteratorPtr =
    liftM PtrIterator $ newForeignPtr ptrIteratorPtr ptrIteratorFinalizer
peekPtrIterator ptrIteratorPtr =
    liftM PtrIterator $ newForeignPtr_ ptrIteratorPtr

foreign import ccall unsafe "&gst_iterator_free"
    ptrIteratorFinalizer :: FunPtr (Ptr PtrIterator -> IO ())

{# enum GstIteratorItem   as IteratorItem   {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstIteratorResult as IteratorResult {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

mkIterator newPtrIterator cPtrIterator =
    do ptrIterator <- newPtrIterator cPtrIterator
       return $ Iterator ptrIterator

newtype Iterable a => Iterator a = Iterator PtrIterator

withIterator :: Iterator a
             -> (Ptr PtrIterator -> IO a)
             -> IO a
withIterator (Iterator ptrIterator) = withPtrIterator ptrIterator

takeIterator, peekIterator :: Ptr PtrIterator
                          -> IO (Iterator a)
takeIterator  cPtrIterator = mkIterator takePtrIterator  cPtrIterator
peekIterator cPtrIterator = mkIterator peekPtrIterator cPtrIterator

class Iterable a where
    peekIterable :: Ptr ()
                 -> IO a
    withIterable :: a
                 -> (Ptr a -> IO b)
                 -> IO b

type IteratorFilter itemT = itemT
                         -> IO Bool
type IteratorFoldFunction itemT accumT = itemT
                                      -> accumT
                                      -> IO (Bool, accumT)

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

{# pointer *GstCaps as Caps foreign newtype #}
mkCaps :: ForeignPtr Caps -> Caps
mkCaps = Caps
unCaps :: Caps -> ForeignPtr Caps
unCaps (Caps caps) = caps

withCaps :: Caps -> (Ptr Caps -> IO a) -> IO a
withCaps = withForeignPtr . unCaps

takeCaps, peekCaps :: Ptr Caps
                  -> IO Caps
takeCaps capsPtr =
    liftM Caps $ newForeignPtr capsPtr capsFinalizer
peekCaps capsPtr =
    cCapsRef capsPtr >>= takeCaps
foreign import ccall unsafe "gst_caps_ref"
    cCapsRef :: Ptr Caps
             -> IO (Ptr Caps)

giveCaps :: MonadIO m
         => Caps
         -> (Caps -> m a)
         -> m a
giveCaps caps action =
    do liftIO $ {# call caps_ref #} caps
       action caps

foreign import ccall unsafe "&gst_caps_unref"
    capsFinalizer :: FunPtr (Ptr Caps -> IO ())

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

{# pointer *GstStructure as Structure foreign newtype #}
mkStructure :: ForeignPtr Structure -> Structure
mkStructure = Structure
unStructure :: Structure -> ForeignPtr Structure
unStructure (Structure structure) = structure

withStructure :: Structure -> (Ptr Structure -> IO a) -> IO a
withStructure = withForeignPtr . unStructure

mkNewStructure :: (Ptr Structure -> IO (ForeignPtr Structure))
               -> Ptr Structure
               -> IO Structure
mkNewStructure mkFP structurePtr =
    do cStructureMakeImmutable structurePtr
       liftM Structure $ mkFP structurePtr
foreign import ccall unsafe "_hs_gst_structure_make_immutable"
    cStructureMakeImmutable :: Ptr Structure
                            -> IO ()

takeStructure, peekStructure :: Ptr Structure
                            -> IO Structure
takeStructure =
    mkNewStructure $ flip newForeignPtr structureFinalizer
peekStructure =
    mkNewStructure $ newForeignPtr_

giveStructure :: MonadIO m
              => Structure
              -> (Structure -> m a)
              -> m a
giveStructure structure action =
    do structure <- liftIO $
                        {# call structure_copy #} structure >>=
                            peekStructure
       action structure

foreign import ccall unsafe "&gst_structure_free"
    structureFinalizer :: FunPtr (Ptr Structure -> IO ())

type StructureForeachFunc =  Quark
                          -> GValue
                          -> IO Bool

newtype StructureM a = StructureM (StructureMRep a)
type StructureMRep a = (Structure -> IO a)

instance Monad StructureM where
    (StructureM aM) >>= fbM =
        StructureM $ \structure ->
            do a <- aM structure
               let StructureM bM = fbM a
               bM structure
    return a = StructureM $ const $ return a

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

type TagList = Structure
mkTagList = mkStructure
unTagList = unStructure
withTagList = withStructure
takeTagList = takeStructure
peekTagList = takeStructure
giveTagList :: MonadIO m
            => TagList
            -> (TagList -> m a)
            -> m a
giveTagList = giveStructure

type Tag = String

{# enum GstTagFlag      as TagFlag      {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}
{# enum GstTagMergeMode as TagMergeMode {underscoreToCase} with prefix = "GST" deriving (Eq, Show) #}

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

data Segment = Segment { segmentRate        :: Double
                       , segmentAbsRate     :: Double
                       , segmentFormat      :: Format
                       , segmentFlags       :: [SeekFlags]
                       , segmentStart       :: Int64
                       , segmentStop        :: Int64
                       , segmentTime        :: Int64
                       , segmentAccum       :: Int64
                       , segmentLastStop    :: Int64
                       , segmentDuration    :: Int64 }
               deriving (Eq, Show)
instance Storable Segment where
    sizeOf _ = fromIntegral cSegmentSizeof
    alignment _ = alignment (undefined :: CString)
    peek ptr =
        do rate        <- {# get GstSegment->rate #} ptr
           absRate     <- {# get GstSegment->abs_rate #} ptr
           format      <- {# get GstSegment->format #} ptr
           flags       <- {# get GstSegment->flags #} ptr
           start       <- {# get GstSegment->start #} ptr
           stop        <- {# get GstSegment->stop #} ptr
           time        <- {# get GstSegment->time #} ptr
           accum       <- {# get GstSegment->accum #} ptr
           lastStop    <- {# get GstSegment->last_stop #} ptr
           duration    <- {# get GstSegment->duration #} ptr
           return $ Segment (realToFrac rate)
                            (realToFrac absRate)
                            (cToEnum format)
                            (cToFlags flags)
                            (fromIntegral start)
                            (fromIntegral stop)
                            (fromIntegral time)
                            (fromIntegral accum)
                            (fromIntegral lastStop)
                            (fromIntegral duration)
    poke ptr (Segment rate
                      absRate
                      format
                      flags
                      start
                      stop
                      time
                      accum
                      lastStop
                      duration) =
        do {# call segment_init #} (castPtr ptr)
                                   (cFromEnum format)
           {# set GstSegment->rate #} ptr $ realToFrac rate
           {# set GstSegment->abs_rate #} ptr $ realToFrac absRate
           {# set GstSegment->format #} ptr $ cFromEnum format
           {# set GstSegment->flags #} ptr $ fromIntegral $ fromFlags flags
           {# set GstSegment->start #} ptr $ fromIntegral start
           {# set GstSegment->stop #} ptr $ fromIntegral stop
           {# set GstSegment->time #} ptr $ fromIntegral time
           {# set GstSegment->accum #} ptr $ fromIntegral accum
           {# set GstSegment->last_stop #} ptr $ fromIntegral lastStop
           {# set GstSegment->duration #} ptr $ fromIntegral duration
foreign import ccall unsafe "_hs_gst_segment_sizeof"
    cSegmentSizeof :: {# type gsize #}

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


Fix #5 non-deterministic solution (GC).

Fix #5 non-deterministic solution (GC).

The solution array pointer was being read from the C model and then copied to a
Storable.Vector in Haskell.
However, if the C model was garbage collected after the array pointer
was read, but before the array was copied, the array became invalid, and
invalid elements were copied into the Storable.Vector.
Fortunately the solution is simple. We just need to touch the foreign pointer
after reading the array, to keep it from being collected.

{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-do-bind -fno-warn-unused-matches #-}
module Numeric.Limp.Solvers.Cbc.Internal.Foreign where

import Foreign
import Foreign.C

import Control.Applicative

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

import Unsafe.Coerce

#include "Cbc.h"

newtype CbcModel = CbcModel (ForeignPtr CbcModel)
{#pointer *CbcModel as CbcModelPtr -> CbcModel #}

foreign import ccall "&freeModel"
   cbcDeleteModel_funptr :: FunPtr (Ptr CbcModel -> IO ())

mkCbcModel :: CbcModelPtr -> IO CbcModel
mkCbcModel p
    = CbcModel <$> newForeignPtr cbcDeleteModel_funptr p

withCbcModel :: CbcModel -> (CbcModelPtr -> IO b) -> IO b
withCbcModel (CbcModel ptr) f
    = do    withForeignPtr ptr f

{#fun newModel as ^
    { } -> `CbcModel' mkCbcModel* #}

withVecI    :: Vector Int -> (Ptr CInt -> IO b) -> IO b
withVecI v f
 = V.unsafeWith (V.map fromIntegral v) f

withVecD    :: Vector Double -> (Ptr CDouble -> IO b) -> IO b
withVecD v f
 = V.unsafeWith v (f . castPtr)

{#fun loadProblem as ^
    { withCbcModel* `CbcModel'

    ,               `Int'               -- # rows
    ,               `Int'               -- # columns

    , withVecI*     `Vector Int'        -- starts
    , withVecI*     `Vector Int'        -- indices
    , withVecD*     `Vector Double'     -- values

    , withVecD*     `Vector Double'     -- col lower bounds
    , withVecD*     `Vector Double'     -- col upper bounds

    , withVecD*     `Vector Double'     -- objective coefficients
    , withVecD*     `Vector Double'     -- row lower bounds
    , withVecD*     `Vector Double'     -- row upper bounds
    }
    -> `()' #}

{#fun setInteger as ^
    { withCbcModel* `CbcModel'
    ,               `Int' }
    -> `()' #}

{#fun branchAndBound as ^
    { withCbcModel* `CbcModel' }
    -> `()' #}

getSolution :: CbcModel -> IO (Vector Double)
getSolution m@(CbcModel fp)
 = do   ncols <- fromIntegral <$> withCbcModel m {#call getNumCols#}
        vd    <- unsafeCoerce <$> withCbcModel m {#call getBestSolution#}
        arr <- V.generateM ncols (peekElemOff vd)

        -- The model owns the array, so ensure we keep it around until after we've read the whole array
        touchForeignPtr fp
        return arr

{#fun setObjSense as ^
    { withCbcModel* `CbcModel'
    ,               `Double' }
    -> `()' #}

{#fun setLogLevel as ^
    { withCbcModel* `CbcModel'
    ,               `Int' }
    -> `()' #}

{#fun isProvenInfeasible as ^
    { withCbcModel* `CbcModel' }
    -> `Bool' #}

{#fun pure getCoinDblMax as ^
    { } -> `Double' #}

{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-do-bind -fno-warn-unused-matches #-}
module Numeric.Limp.Solvers.Cbc.Internal.Foreign where

import Foreign
import Foreign.C

import Control.Applicative

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

import Unsafe.Coerce

#include "Cbc.h"

newtype CbcModel = CbcModel (ForeignPtr CbcModel)
{#pointer *CbcModel as CbcModelPtr -> CbcModel #}

foreign import ccall "&freeModel"
   cbcDeleteModel_funptr :: FunPtr (Ptr CbcModel -> IO ())

mkCbcModel :: CbcModelPtr -> IO CbcModel
mkCbcModel p
    = CbcModel <$> newForeignPtr cbcDeleteModel_funptr p

withCbcModel :: CbcModel -> (CbcModelPtr -> IO b) -> IO b
withCbcModel (CbcModel ptr) f
    = do    withForeignPtr ptr f

{#fun newModel as ^
    { } -> `CbcModel' mkCbcModel* #}

withVecI    :: Vector Int -> (Ptr CInt -> IO b) -> IO b
withVecI v f
 = V.unsafeWith (V.map fromIntegral v) f

withVecD    :: Vector Double -> (Ptr CDouble -> IO b) -> IO b
withVecD v f
 = V.unsafeWith v (f . castPtr)

{#fun loadProblem as ^
    { withCbcModel* `CbcModel'

    ,               `Int'               -- # rows
    ,               `Int'               -- # columns

    , withVecI*     `Vector Int'        -- starts
    , withVecI*     `Vector Int'        -- indices
    , withVecD*     `Vector Double'     -- values

    , withVecD*     `Vector Double'     -- col lower bounds
    , withVecD*     `Vector Double'     -- col upper bounds

    , withVecD*     `Vector Double'     -- objective coefficients
    , withVecD*     `Vector Double'     -- row lower bounds
    , withVecD*     `Vector Double'     -- row upper bounds
    }
    -> `()' #}

{#fun setInteger as ^
    { withCbcModel* `CbcModel'
    ,               `Int' }
    -> `()' #}

{#fun branchAndBound as ^
    { withCbcModel* `CbcModel' }
    -> `()' #}

getSolution :: CbcModel -> IO (Vector Double)
getSolution m
 = do   ncols <- fromIntegral <$> withCbcModel m {#call getNumCols#}
        vd    <- unsafeCoerce <$> withCbcModel m {#call getBestSolution#}

        V.generateM ncols (peekElemOff vd)

{#fun setObjSense as ^
    { withCbcModel* `CbcModel'
    ,               `Double' }
    -> `()' #}

{#fun setLogLevel as ^
    { withCbcModel* `CbcModel'
    ,               `Int' }
    -> `()' #}

{#fun isProvenInfeasible as ^
    { withCbcModel* `CbcModel' }
    -> `Bool' #}

{#fun pure getCoinDblMax as ^
    { } -> `Double' #}