Fix IconTheme to only compile if gio is present.

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget IconTheme
--
--  Author : Andy Stewart
--
--  Created: 28 Mar 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 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Looking up icons by name
--
-- * Module available since Gtk+ version 2.4
--
module Graphics.UI.Gtk.General.IconTheme (

-- * Detail
--
-- | 'IconTheme' provides a facility for looking up icons by name and size. The main reason for using a
-- name rather than simply providing a filename is to allow different icons to be used depending on
-- what icon theme is selecetd by the user. The operation of icon themes on Linux and Unix follows the
-- Icon Theme Specification. There is a default icon theme, named hicolor where applications should
-- install their icons, but more additional application themes can be installed as operating system
-- vendors and users choose.
--
-- Named icons are similar to the Themeable Stock Images facility, and the distinction between the
-- two may be a bit confusing. A few things to keep in mind:
--
--   ● Stock images usually are used in conjunction with Stock Items, such as ''StockOk'' or
--     ''StockOpen''. Named icons are easier to set up and therefore are more useful for new icons
--     that an application wants to add, such as application icons or window icons.
--
--   ● Stock images can only be loaded at the symbolic sizes defined by the 'IconSize' enumeration, or
--     by custom sizes defined by 'iconSizeRegister', while named icons are more flexible and any
--     pixel size can be specified.
--
--   ● Because stock images are closely tied to stock items, and thus to actions in the user interface,
--     stock images may come in multiple variants for different widget states or writing directions.
--
-- A good rule of thumb is that if there is a stock image for what you want to use, use it, otherwise
-- use a named icon. It turns out that internally stock images are generally defined in terms of one or
-- more named icons. (An example of the more than one case is icons that depend on writing direction;
-- ''StockGoForward'' uses the two themed icons 'gtkStockGoForwardLtr' and
-- 'gtkStockGoForwardRtl'.)
--
-- In many cases, named themes are used indirectly, via 'Image' or stock items, rather than directly,
-- but looking up icons directly is also simple. The 'IconTheme' object acts as a database of all the
-- icons in the current theme. You can create new 'IconTheme' objects, but its much more efficient to
-- use the standard icon theme for the 'Screen' so that the icon information is shared with other
-- people looking up icons. In the case where the default screen is being used, looking up an icon can
-- be as simple as:
--
-- * Class Hierarchy
--
-- |
-- @
-- |  'GObject'
-- |   +----IconTheme
-- @

#if GTK_CHECK_VERSION(2,4,0) && HAVE_GIO
-- * Types
  IconTheme,
  IconThemeClass,
  castToIconTheme,
  toIconTheme,

  IconInfo,

-- * Enums
  IconLookupFlags(..),
  IconThemeError(..),

-- * Constructors
  iconThemeNew,

#if GTK_CHECK_VERSION(2,14,0)
  iconInfoNewForPixbuf,
#endif

-- * Methods
  iconThemeGetDefault,
  iconThemeGetForScreen,
  iconThemeSetScreen,
  iconThemeSetSearchPath,
  iconThemeGetSearchPath,
  iconThemeAppendSearchPath,
  iconThemePrependSearchPath,
  iconThemeSetCustomTheme,
  iconThemeHasIcon,
  iconThemeLookupIcon,
#if GTK_CHECK_VERSION(2,12,0)
  iconThemeChooseIcon,
#ifdef ENABLE_GIO
#if GTK_CHECK_VERSION(2,14,0)
  iconThemeLookupByGicon,
#endif
#endif
#endif
  iconThemeLoadIcon,
#if GTK_CHECK_VERSION(2,12,0)
  iconThemeListContexts,
#endif
  iconThemeListIcons,
#if GTK_CHECK_VERSION(2,6,0)
  iconThemeGetIconSizes,
#endif
  iconThemeGetExampleIconName,
  iconThemeRescanIfNeeded,
  iconThemeAddBuiltinIcon,
  iconThemeErrorQuark,

  iconInfoCopy,
  iconInfoGetAttachPoints,
  iconInfoGetBaseSize,
  iconInfoGetBuiltinPixbuf,
  iconInfoGetDisplayName,
  iconInfoGetEmbeddedRect,
  iconInfoGetFilename,
  iconInfoLoadIcon,
  iconInfoSetRawCoordinates,

-- * Signals
  iconThemeChanged,
#endif
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.Attributes
import System.Glib.Properties
import System.Glib.UTFString
import System.Glib.GList
import System.Glib.Flags
import System.Glib.GObject		(constructNewGObject, makeNewGObject, Quark)
import System.Glib.GError   (GErrorDomain, GErrorClass(..), propagateGError)
import Graphics.UI.Gtk.General.Structs (Rectangle, Point)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Signals#}
#ifdef ENABLE_GIO
{#import System.GIO.Types#}
#endif

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

#if GTK_CHECK_VERSION(2,4,0) && HAVE_GIO
--------------------
-- Enums
{#enum IconLookupFlags {underscoreToCase} deriving (Bounded,Eq,Show)#}

{#enum IconThemeError {underscoreToCase} deriving (Bounded,Eq,Show)#}

--------------------
-- Constructors

-- | Creates a new icon theme object. Icon theme objects are used to lookup up
-- an icon by name in a particular icon theme. Usually, you'll want to use
-- 'iconThemeGetDefault' or 'iconThemeGetForScreen' rather than creating a new
-- icon theme object for scratch.
--
iconThemeNew :: IO IconTheme
iconThemeNew =
  constructNewGObject mkIconTheme $
  {# call gtk_icon_theme_new #}

--------------------
-- Methods

-- | Gets the icon theme for the default screen. See 'iconThemeGetForScreen'.
--
iconThemeGetDefault ::
    IO IconTheme -- ^ returns A unique 'IconTheme' associated with the default
                 -- screen. This icon theme is associated with the screen and
                 -- can be used as long as the screen is open.
iconThemeGetDefault =
  makeNewGObject mkIconTheme $
  {# call gtk_icon_theme_get_default #}

-- | Gets the icon theme object associated with @screen@; if this function has
-- not previously been called for the given screen, a new icon theme object
-- will be created and associated with the screen. Icon theme objects are
-- fairly expensive to create, so using this function is usually a better
-- choice than calling than 'iconThemeNew' and setting the screen yourself; by
-- using this function a single icon theme object will be shared between users.
--
iconThemeGetForScreen ::
    Screen       -- ^ @screen@ - a 'Screen'
 -> IO IconTheme -- ^ returns A unique 'IconTheme' associated with the given
                 -- screen.
iconThemeGetForScreen screen =
  makeNewGObject mkIconTheme $
  {# call gtk_icon_theme_get_for_screen #}
    screen

-- | Sets the screen for an icon theme; the screen is used to track the user's
-- currently configured icon theme, which might be different for different
-- screens.
--
iconThemeSetScreen :: IconThemeClass self => self
 -> Screen -- ^ @screen@ - a 'Screen'
 -> IO ()
iconThemeSetScreen self screen =
  {# call gtk_icon_theme_set_screen #}
    (toIconTheme self)
    screen

-- | Sets the search path for the icon theme object. When looking for an icon
-- theme, Gtk+ will search for a subdirectory of one or more of the directories
-- in @path@ with the same name as the icon theme. (Themes from multiple of the
-- path elements are combined to allow themes to be extended by adding icons in
-- the user's home directory.)
--
-- In addition if an icon found isn't found either in the current icon theme
-- or the default icon theme, and an image file with the right name is found
-- directly in one of the elements of @path@, then that image will be used for
-- the icon name. (This is legacy feature, and new icons should be put into the
-- default icon theme, which is called DEFAULT_THEME_NAME, rather than directly
-- on the icon path.)
--
iconThemeSetSearchPath :: IconThemeClass self => self
 -> [FilePath] -- ^ @path@ - list of directories that are searched for icon
           -- themes
 -> Int    -- ^ @nElements@ - number of elements in @path@.
 -> IO ()
iconThemeSetSearchPath self path nElements =
  withUTFStringArray path $ \pathPtr ->
  {# call gtk_icon_theme_set_search_path #}
    (toIconTheme self)
    pathPtr
    (fromIntegral nElements)

-- | Gets the current search path. See 'iconThemeSetSearchPath'.
--
iconThemeGetSearchPath :: IconThemeClass self => self
 -> IO ([FilePath], Int)         -- ^ @(path, nElements)@
                                -- @path@ - location to store a list of icon theme path
                                -- directories.
iconThemeGetSearchPath self =
  alloca $ \nElementsPtr ->
  allocaArray 0 $ \pathPtr -> do
  {# call gtk_icon_theme_get_search_path #}
    (toIconTheme self)
    (castPtr pathPtr)
    nElementsPtr
  pathStr <- readUTFStringArray0 pathPtr
  nElements <- peek nElementsPtr
  return (pathStr, fromIntegral nElements)

-- | Appends a directory to the search path. See 'iconThemeSetSearchPath'.
--
iconThemeAppendSearchPath :: IconThemeClass self => self
 -> FilePath -- ^ @path@ - directory name to append to the icon path
 -> IO ()
iconThemeAppendSearchPath self path =
  withUTFString path $ \pathPtr ->
  {# call gtk_icon_theme_append_search_path #}
    (toIconTheme self)
    pathPtr

-- | Prepends a directory to the search path. See 'iconThemeSetSearchPath'.
--
iconThemePrependSearchPath :: IconThemeClass self => self
 -> FilePath -- ^ @path@ - directory name to prepend to the icon path
 -> IO ()
iconThemePrependSearchPath self path =
  withUTFString path $ \pathPtr ->
  {# call gtk_icon_theme_prepend_search_path #}
    (toIconTheme self)
    pathPtr

-- | Sets the name of the icon theme that the 'IconTheme' object uses
-- overriding system configuration. This function cannot be called on the icon
-- theme objects returned from 'iconThemeGetDefault' and
-- 'iconThemeGetForScreen'.
--
iconThemeSetCustomTheme :: IconThemeClass self => self
 -> (Maybe String) -- ^ @themeName@ name of icon theme to use instead of configured theme, or 'Nothing' to unset a previously set custom theme
 -> IO ()
iconThemeSetCustomTheme self themeName =
  maybeWith withUTFString themeName $ \themeNamePtr ->
  {# call gtk_icon_theme_set_custom_theme #}
    (toIconTheme self)
    themeNamePtr

-- | Checks whether an icon theme includes an icon for a particular name.
--
iconThemeHasIcon :: IconThemeClass self => self
 -> String  -- ^ @iconName@ - the name of an icon
 -> IO Bool -- ^ returns @True@ if @iconTheme@ includes an icon for
            -- @iconName@.
iconThemeHasIcon self iconName =
  liftM toBool $
  withUTFString iconName $ \iconNamePtr ->
  {# call gtk_icon_theme_has_icon #}
    (toIconTheme self)
    iconNamePtr

-- | Looks up a named icon and returns a structure containing information such
-- as the filename of the icon. The icon can then be rendered into a pixbuf
-- using 'iconInfoLoadIcon'. ('iconThemeLoadIcon' combines these two steps if
-- all you need is the pixbuf.)
--
iconThemeLookupIcon :: IconThemeClass self => self
 -> String              -- ^ @iconName@ - the name of the icon to lookup
 -> Int                 -- ^ @size@ - desired icon size
 -> IconLookupFlags   -- ^ @flags@ - flags modifying the behavior of the
                        -- icon lookup
 -> IO (Maybe IconInfo)        -- ^ returns a 'IconInfo'
                        -- structure containing information about the icon, or
                         -- 'Nothing' if the icon wasn't found.
iconThemeLookupIcon self iconName size flags =
  withUTFString iconName $ \iconNamePtr -> do
  iiPtr <- {# call gtk_icon_theme_lookup_icon #}
          (toIconTheme self)
          iconNamePtr
          (fromIntegral size)
          ((fromIntegral . fromEnum) flags)
  if iiPtr == nullPtr
     then return Nothing
     else liftM Just (mkIconInfo (castPtr iiPtr))

#if GTK_CHECK_VERSION(2,12,0)
-- | Looks up a named icon and returns a structure containing information such
-- as the filename of the icon. The icon can then be rendered into a pixbuf
-- using 'iconInfoLoadIcon'. ('iconThemeLoadIcon' combines these two steps if
-- all you need is the pixbuf.)
--
-- If @iconNames@ contains more than one name, this function tries them all
-- in the given order before falling back to inherited icon themes.
--
-- * Available since Gtk+ version 2.12
--
iconThemeChooseIcon :: IconThemeClass self => self
 -> [String]              -- ^ @iconNames@ terminated list of icon names to lookup
 -> Int                 -- ^ @size@ - desired icon size
 -> IconLookupFlags   -- ^ @flags@ - flags modifying the behavior of the
                        -- icon lookup
 -> IO (Maybe IconInfo)        -- ^ returns a 'IconInfo'
                        -- structure containing information about the icon, or
                         -- 'Nothing' if the icon wasn't found.
iconThemeChooseIcon self iconNames size flags =
  withUTFStringArray0 iconNames $ \iconNamesPtr -> do
  iiPtr <- {# call gtk_icon_theme_choose_icon #}
          (toIconTheme self)
          iconNamesPtr
          (fromIntegral size)
          ((fromIntegral . fromEnum) flags)
  if iiPtr == nullPtr
     then return Nothing
     else liftM Just (mkIconInfo (castPtr iiPtr))

#ifdef ENABLE_GIO
#if GTK_CHECK_VERSION(2,14,0)
-- | Looks up an icon and returns a structure containing information such as
-- the filename of the icon. The icon can then be rendered into a pixbuf using
-- 'iconInfoLoadIcon'.
--
-- * Available since Gtk+ version 2.14
--
iconThemeLookupByGicon :: (IconThemeClass self, IconClass icon) => self
 -> icon          -- ^ @icon@ - the 'Icon' to look up
 -> Int                 -- ^ @size@ - desired icon size
 -> IconLookupFlags   -- ^ @flags@ - flags modifying the behavior of the
                        -- icon lookup
 -> IO (Maybe IconInfo)        -- ^ returns a 'IconInfo'
                        -- structure containing information about the icon, or
                        -- 'Nothing' if the icon wasn't found.
iconThemeLookupByGicon self icon size flags = do
    iiPtr <- {# call gtk_icon_theme_lookup_by_gicon #}
            (toIconTheme self)
            (toIcon icon)
            (fromIntegral size)
            ((fromIntegral . fromEnum) flags)
    if iiPtr == nullPtr
       then return Nothing
       else liftM Just (mkIconInfo (castPtr iiPtr))
#endif
#endif
#endif

-- | Looks up an icon in an icon theme, scales it to the given size and
-- renders it into a pixbuf. This is a convenience function; if more details
-- about the icon are needed, use 'iconThemeLookupIcon' followed by
-- 'iconInfoLoadIcon'.
--
-- Note that you probably want to listen for icon theme changes and update
-- the icon. This is usually done by connecting to the 'Widget'::style-set
-- signal. If for some reason you do not want to update the icon when the icon
-- theme changes, you should consider using 'pixbufCopy' to make a private copy
-- of the pixbuf returned by this function. Otherwise Gtk+ may need to keep the
-- old icon theme loaded, which would be a waste of memory.
--
iconThemeLoadIcon :: IconThemeClass self => self
 -> String            -- ^ @iconName@ - the name of the icon to lookup
 -> Int               -- ^ @size@ - the desired icon size. The resulting icon
                      -- may not be exactly this size; see 'iconInfoLoadIcon'.
 -> IconLookupFlags -- ^ @flags@ - flags modifying the behavior of the icon
                      -- lookup
 -> IO (Maybe Pixbuf)  -- ^ returns the rendered icon; this may be a newly
                      -- created icon or a new reference to an internal icon,
                      -- so you must not modify the icon.
                      -- `Nothing` if the icon isn't found.
iconThemeLoadIcon self iconName size flags =
  maybeNull (makeNewGObject mkPixbuf) $
  propagateGError $ \errorPtr ->
  withUTFString iconName $ \iconNamePtr ->
  {# call gtk_icon_theme_load_icon #}
    (toIconTheme self)
    iconNamePtr
    (fromIntegral size)
    ((fromIntegral . fromEnum) flags)
    errorPtr

#if GTK_CHECK_VERSION(2,12,0)
-- | Gets the list of contexts available within the current hierarchy of icon
-- themes
--
-- * Available since Gtk+ version 2.12
--
iconThemeListContexts :: IconThemeClass self => self
 -> IO [String] -- ^ returns a String list
                            -- holding the names of all the contexts in the
                            -- theme.
iconThemeListContexts self = do
  glistPtr <- {# call gtk_icon_theme_list_contexts #} (toIconTheme self)
  list <- fromGList glistPtr
  result <- mapM readUTFString list
  {#call unsafe g_list_free #} (castPtr glistPtr)
  return result
#endif

-- | Lists the icons in the current icon theme. Only a subset of the icons can
-- be listed by providing a context string. The set of values for the context
-- string is system dependent, but will typically include such values as
-- \"Applications\" and \"MimeTypes\".
--
iconThemeListIcons :: IconThemeClass self => self
 -> (Maybe String) -- ^ @context@    a string identifying a particular type of icon, or 'Nothing' to list all icons.
 -> IO [String] -- ^ returns a String list
               -- holding the names of all the icons in the theme.
iconThemeListIcons self context =
  maybeWith withUTFString context $ \contextPtr -> do
  glistPtr <- {# call gtk_icon_theme_list_icons #}
             (toIconTheme self)
             contextPtr
  list <- fromGList glistPtr
  result <- mapM readUTFString list
  {#call unsafe g_list_free#} (castPtr glistPtr)
  return result

#if GTK_CHECK_VERSION(2,6,0)
-- | Returns an list of integers describing the sizes at which the icon is
-- available without scaling. A size of -1 means that the icon is available in
-- a scalable format. The list is zero-terminated.
--
-- * Available since Gtk+ version 2.6
--
iconThemeGetIconSizes :: IconThemeClass self => self
 -> String       -- ^ @iconName@ - the name of an icon
 -> IO [Int] -- ^ returns An newly allocated list describing the sizes at
            -- which the icon is available.
iconThemeGetIconSizes self iconName =
  withUTFString iconName $ \iconNamePtr -> do
  listPtr <- {# call gtk_icon_theme_get_icon_sizes #}
              (toIconTheme self)
              iconNamePtr
  list <- peekArray 0 listPtr
  {#call unsafe g_free #} (castPtr listPtr)
  return (map fromIntegral list)
#endif

-- | Gets the name of an icon that is representative of the current theme (for
-- instance, to use when presenting a list of themes to the user.)
--
iconThemeGetExampleIconName :: IconThemeClass self => self
 -> IO (Maybe String)            -- ^ returns the name of an example icon or `Nothing'
iconThemeGetExampleIconName self = do
  namePtr <- {# call gtk_icon_theme_get_example_icon_name #} (toIconTheme self)
  if namePtr == nullPtr
     then return Nothing
     else liftM Just $ readUTFString namePtr

-- | Checks to see if the icon theme has changed; if it has, any currently
-- cached information is discarded and will be reloaded next time @iconTheme@
-- is accessed.
--
iconThemeRescanIfNeeded :: IconThemeClass self => self
 -> IO Bool -- ^ returns @True@ if the icon theme has changed and needed to be
            -- reloaded.
iconThemeRescanIfNeeded self =
  liftM toBool $
  {# call gtk_icon_theme_rescan_if_needed #}
    (toIconTheme self)

-- | Registers a built-in icon for icon theme lookups. The idea of built-in
-- icons is to allow an application or library that uses themed icons to
-- function requiring files to be present in the file system. For instance, the
-- default images for all of Gtk+'s stock icons are registered as built-icons.
--
-- In general, if you use 'iconThemeAddBuiltinIcon' you should also install
-- the icon in the icon theme, so that the icon is generally available.
--
-- This function will generally be used with pixbufs loaded via
-- 'pixbufNewFromInline'.
--
iconThemeAddBuiltinIcon ::
    String -- ^ @iconName@ - the name of the icon to register
 -> Int    -- ^ @size@ - the size at which to register the icon (different
           -- images can be registered for the same icon name at different
           -- sizes.)
 -> Pixbuf -- ^ @pixbuf@ - 'Pixbuf' that contains the image to use for
           -- @iconName@.
 -> IO ()
iconThemeAddBuiltinIcon iconName size pixbuf =
  withUTFString iconName $ \iconNamePtr ->
  {# call gtk_icon_theme_add_builtin_icon #}
    iconNamePtr
    (fromIntegral size)
    pixbuf

-- |
--
iconThemeErrorQuark :: IO Quark
iconThemeErrorQuark =
  {# call gtk_icon_theme_error_quark #}

--------------------
-- Types
{#pointer *IconInfo foreign newtype#}

foreign import ccall unsafe "&gtk_icon_info_free"
  icon_info_free :: FinalizerPtr IconInfo

-- | Helper function for build 'IconInfo'
mkIconInfo :: Ptr IconInfo -> IO IconInfo
mkIconInfo infoPtr =
  liftM IconInfo $ newForeignPtr infoPtr icon_info_free

--------------------
-- Constructors

#if GTK_CHECK_VERSION(2,14,0)
-- |
--
iconInfoNewForPixbuf :: IconThemeClass iconTheme => iconTheme -> Pixbuf -> IO IconInfo
iconInfoNewForPixbuf iconTheme pixbuf =
  {# call gtk_icon_info_new_for_pixbuf #}
          (toIconTheme iconTheme)
          pixbuf
  >>= mkIconInfo
#endif

--------------------
-- Methods

-- |
--
iconInfoCopy :: IconInfo -> IO IconInfo
iconInfoCopy self =
  {# call gtk_icon_info_copy #} self
  >>= mkIconInfo

-- | Fetches the set of attach points for an icon. An attach point is a location in the icon that can be
-- used as anchor points for attaching emblems or overlays to the icon.
iconInfoGetAttachPoints :: IconInfo -> IO (Maybe [Point])
iconInfoGetAttachPoints self =
  alloca $ \arrPtrPtr ->
  alloca $ \nPointsPtr -> do
  success <- liftM toBool $
            {# call gtk_icon_info_get_attach_points #}
              self
              (castPtr arrPtrPtr)
              nPointsPtr
  if success
     then do
       arrPtr <- peek arrPtrPtr
       nPoints <- peek nPointsPtr
       pointList <- peekArray (fromIntegral nPoints) arrPtr
       {#call unsafe g_free#} (castPtr arrPtr)
       return $ Just pointList
     else return Nothing

-- | Gets the base size for the icon. The base size is a size for the icon that was specified by the icon
-- theme creator. This may be different than the actual size of image; an example of this is small
-- emblem icons that can be attached to a larger icon. These icons will be given the same base size as
-- the larger icons to which they are attached.
--
iconInfoGetBaseSize :: IconInfo -> IO Int
iconInfoGetBaseSize self =
  liftM fromIntegral $
  {# call gtk_icon_info_get_base_size #} self

-- | Gets the built-in image for this icon, if any. To allow GTK+ to use built in icon images, you must
-- pass the ''IconLookupUseBuiltin'' to 'iconThemeLookupIcon'.
iconInfoGetBuiltinPixbuf :: IconInfo
 -> IO (Maybe Pixbuf) -- ^ returns the built-in image pixbuf, or 'Nothing'.
iconInfoGetBuiltinPixbuf self = do
  pixbufPtr <- {# call gtk_icon_info_get_builtin_pixbuf #} self
  if pixbufPtr == nullPtr
     then return Nothing
     else liftM Just $ makeNewGObject mkPixbuf (return pixbufPtr)

-- | Gets the display name for an icon. A display name is a string to be used in place of the icon name
-- in a user visible context like a list of icons.
iconInfoGetDisplayName :: IconInfo
 -> IO (Maybe String) -- ^ returns the display name for the icon or 'Nothing', if the icon doesn't have a specified display name.
iconInfoGetDisplayName self = do
  strPtr <- {# call gtk_icon_info_get_display_name #} self
  if strPtr == nullPtr
     then return Nothing
     else liftM Just $ peekUTFString strPtr

-- | Gets the coordinates of a rectangle within the icon that can be used for display of information such
-- as a preview of the contents of a text file. See 'iconInfoSetRawCoordinates' for further
-- information about the coordinate system.
iconInfoGetEmbeddedRect :: IconInfo
 -> IO (Maybe Rectangle)  -- ^ @rectangle@ 'Rectangle' in which to store embedded
                         -- rectangle coordinates.
iconInfoGetEmbeddedRect self =
  alloca $ \rectPtr -> do
  success <- liftM toBool $
            {# call gtk_icon_info_get_embedded_rect #}
            self
            (castPtr rectPtr)
  if success
     then liftM Just $ peek rectPtr
     else return Nothing

-- | Gets the filename for the icon. If the ''IconLookupUseBuiltin'' flag was passed to
-- 'iconThemeLookupIcon', there may be no filename if a builtin icon is returned; in this case,
-- you should use 'iconInfoGetBuiltinPixbuf'.
iconInfoGetFilename :: IconInfo
 -> IO (Maybe String) -- ^ returns the filename for the icon,
                     -- or 'Nothing' if 'iconInfoGetBuiltinPixbuf' should be used instead.
iconInfoGetFilename self = do
  namePtr <- {# call gtk_icon_info_get_filename #} self
  if namePtr == nullPtr
     then return Nothing
     else liftM Just $ peekUTFString namePtr

-- | Looks up an icon in an icon theme, scales it to the given size and renders it into a pixbuf. This is
-- a convenience function; if more details about the icon are needed, use 'iconThemeLookupIcon'
-- followed by 'iconInfoLoadIcon'.
--
-- Note that you probably want to listen for icon theme changes and update the icon. This is usually
-- done by connecting to the 'styleSet' signal. If for some reason you do not want to update
-- the icon when the icon theme changes, you should consider using 'pixbufCopy' to make a private
-- copy of the pixbuf returned by this function. Otherwise GTK+ may need to keep the old icon theme
-- loaded, which would be a waste of memory.
iconInfoLoadIcon :: IconInfo -> IO Pixbuf
iconInfoLoadIcon self =
  makeNewGObject mkPixbuf $
  propagateGError $ \errorPtr ->
  {# call gtk_icon_info_load_icon #}
    self
    errorPtr

-- | Sets whether the coordinates returned by 'iconInfoGetEmbeddedRect' and
-- 'iconInfoGetAttachPoints' should be returned in their original form as specified in the icon
-- theme, instead of scaled appropriately for the pixbuf returned by 'iconInfoLoadIcon'.
--
-- Raw coordinates are somewhat strange; they are specified to be with respect to the unscaled pixmap
-- for PNG and XPM icons, but for SVG icons, they are in a 1000x1000 coordinate space that is scaled to
-- the final size of the icon. You can determine if the icon is an SVG icon by using
-- 'iconInfoGetFilename', and seeing if it is non-'Nothing' and ends in '.svg'.
--
-- This function is provided primarily to allow compatibility wrappers for older API's, and is not
-- expected to be useful for applications.
iconInfoSetRawCoordinates :: IconInfo
 -> Bool  -- ^ @rawCoordinates@ whether the coordinates of
         -- embedded rectangles and attached points should be returned in their original
 -> IO ()
iconInfoSetRawCoordinates self rawCoordinates =
  {# call gtk_icon_info_set_raw_coordinates #}
    self
    (fromBool rawCoordinates)

--------------------
-- Signals

-- | Emitted when the current icon theme is switched or Gtk+ detects that a
-- change has occurred in the contents of the current icon theme.
--
iconThemeChanged :: IconThemeClass self => Signal self (IO ())
iconThemeChanged = Signal (connect_NONE__NONE "changed")

#endif

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget IconTheme
--
--  Author : Andy Stewart
--
--  Created: 28 Mar 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 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Looking up icons by name
--
-- * Module available since Gtk+ version 2.4
--
module Graphics.UI.Gtk.General.IconTheme (

-- * Detail
--
-- | 'IconTheme' provides a facility for looking up icons by name and size. The main reason for using a
-- name rather than simply providing a filename is to allow different icons to be used depending on
-- what icon theme is selecetd by the user. The operation of icon themes on Linux and Unix follows the
-- Icon Theme Specification. There is a default icon theme, named hicolor where applications should
-- install their icons, but more additional application themes can be installed as operating system
-- vendors and users choose.
--
-- Named icons are similar to the Themeable Stock Images(3) facility, and the distinction between the
-- two may be a bit confusing. A few things to keep in mind:
--
--   ● Stock images usually are used in conjunction with Stock Items(3)., such as ''StockOk'' or
--     ''StockOpen''. Named icons are easier to set up and therefore are more useful for new icons
--     that an application wants to add, such as application icons or window icons.
--
--   ● Stock images can only be loaded at the symbolic sizes defined by the 'IconSize' enumeration, or
--     by custom sizes defined by 'iconSizeRegister', while named icons are more flexible and any
--     pixel size can be specified.
--
--   ● Because stock images are closely tied to stock items, and thus to actions in the user interface,
--     stock images may come in multiple variants for different widget states or writing directions.
--
-- A good rule of thumb is that if there is a stock image for what you want to use, use it, otherwise
-- use a named icon. It turns out that internally stock images are generally defined in terms of one or
-- more named icons. (An example of the more than one case is icons that depend on writing direction;
-- ''StockGoForward'' uses the two themed icons 'gtkStockGoForwardLtr' and
-- 'gtkStockGoForwardRtl'.)
--
-- In many cases, named themes are used indirectly, via 'Image' or stock items, rather than directly,
-- but looking up icons directly is also simple. The 'IconTheme' object acts as a database of all the
-- icons in the current theme. You can create new 'IconTheme' objects, but its much more efficient to
-- use the standard icon theme for the 'Screen' so that the icon information is shared with other
-- people looking up icons. In the case where the default screen is being used, looking up an icon can
-- be as simple as:
--
-- * Class Hierarchy
--
-- |
-- @
-- |  'GObject'
-- |   +----IconTheme
-- @

#if GTK_CHECK_VERSION(2,4,0)
-- * Types
  IconTheme,
  IconThemeClass,
  castToIconTheme,
  toIconTheme,

  IconInfo,

-- * Enums
  IconLookupFlags(..),
  IconThemeError(..),

-- * Constructors
  iconThemeNew,

#if GTK_CHECK_VERSION(2,14,0)
  iconInfoNewForPixbuf,
#endif

-- * Methods
  iconThemeGetDefault,
  iconThemeGetForScreen,
  iconThemeSetScreen,
  iconThemeSetSearchPath,
  iconThemeGetSearchPath,
  iconThemeAppendSearchPath,
  iconThemePrependSearchPath,
  iconThemeSetCustomTheme,
  iconThemeHasIcon,
  iconThemeLookupIcon,
#if GTK_CHECK_VERSION(2,12,0)
  iconThemeChooseIcon,
#ifdef ENABLE_GIO
#if GTK_CHECK_VERSION(2,14,0)
  iconThemeLookupByGicon,
#endif
#endif
#endif
  iconThemeLoadIcon,
#if GTK_CHECK_VERSION(2,12,0)
  iconThemeListContexts,
#endif
  iconThemeListIcons,
#if GTK_CHECK_VERSION(2,6,0)
  iconThemeGetIconSizes,
#endif
  iconThemeGetExampleIconName,
  iconThemeRescanIfNeeded,
  iconThemeAddBuiltinIcon,
  iconThemeErrorQuark,

  iconInfoCopy,
  iconInfoGetAttachPoints,
  iconInfoGetBaseSize,
  iconInfoGetBuiltinPixbuf,
  iconInfoGetDisplayName,
  iconInfoGetEmbeddedRect,
  iconInfoGetFilename,
  iconInfoLoadIcon,
  iconInfoSetRawCoordinates,

-- * Signals
  iconThemeChanged,
#endif
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.Attributes
import System.Glib.Properties
import System.Glib.UTFString
import System.Glib.GList
import System.Glib.Flags
import System.Glib.GObject		(constructNewGObject, makeNewGObject, Quark)
import System.Glib.GError   (GErrorDomain, GErrorClass(..), propagateGError)
import Graphics.UI.Gtk.General.Structs (Rectangle, Point)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Signals#}
#ifdef ENABLE_GIO
{#import System.GIO.Types#}
#endif

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

#if GTK_CHECK_VERSION(2,4,0)
--------------------
-- Enums
{#enum IconLookupFlags {underscoreToCase} deriving (Bounded,Eq,Show)#}

{#enum IconThemeError {underscoreToCase} deriving (Bounded,Eq,Show)#}

--------------------
-- Constructors

-- | Creates a new icon theme object. Icon theme objects are used to lookup up
-- an icon by name in a particular icon theme. Usually, you'll want to use
-- 'iconThemeGetDefault' or 'iconThemeGetForScreen' rather than creating a new
-- icon theme object for scratch.
--
iconThemeNew :: IO IconTheme
iconThemeNew =
  constructNewGObject mkIconTheme $
  {# call gtk_icon_theme_new #}

--------------------
-- Methods

-- | Gets the icon theme for the default screen. See 'iconThemeGetForScreen'.
--
iconThemeGetDefault ::
    IO IconTheme -- ^ returns A unique 'IconTheme' associated with the default
                 -- screen. This icon theme is associated with the screen and
                 -- can be used as long as the screen is open.
iconThemeGetDefault =
  makeNewGObject mkIconTheme $
  {# call gtk_icon_theme_get_default #}

-- | Gets the icon theme object associated with @screen@; if this function has
-- not previously been called for the given screen, a new icon theme object
-- will be created and associated with the screen. Icon theme objects are
-- fairly expensive to create, so using this function is usually a better
-- choice than calling than 'iconThemeNew' and setting the screen yourself; by
-- using this function a single icon theme object will be shared between users.
--
iconThemeGetForScreen ::
    Screen       -- ^ @screen@ - a 'Screen'
 -> IO IconTheme -- ^ returns A unique 'IconTheme' associated with the given
                 -- screen.
iconThemeGetForScreen screen =
  makeNewGObject mkIconTheme $
  {# call gtk_icon_theme_get_for_screen #}
    screen

-- | Sets the screen for an icon theme; the screen is used to track the user's
-- currently configured icon theme, which might be different for different
-- screens.
--
iconThemeSetScreen :: IconThemeClass self => self
 -> Screen -- ^ @screen@ - a 'Screen'
 -> IO ()
iconThemeSetScreen self screen =
  {# call gtk_icon_theme_set_screen #}
    (toIconTheme self)
    screen

-- | Sets the search path for the icon theme object. When looking for an icon
-- theme, Gtk+ will search for a subdirectory of one or more of the directories
-- in @path@ with the same name as the icon theme. (Themes from multiple of the
-- path elements are combined to allow themes to be extended by adding icons in
-- the user's home directory.)
--
-- In addition if an icon found isn't found either in the current icon theme
-- or the default icon theme, and an image file with the right name is found
-- directly in one of the elements of @path@, then that image will be used for
-- the icon name. (This is legacy feature, and new icons should be put into the
-- default icon theme, which is called DEFAULT_THEME_NAME, rather than directly
-- on the icon path.)
--
iconThemeSetSearchPath :: IconThemeClass self => self
 -> [FilePath] -- ^ @path@ - list of directories that are searched for icon
           -- themes
 -> Int    -- ^ @nElements@ - number of elements in @path@.
 -> IO ()
iconThemeSetSearchPath self path nElements =
  withUTFStringArray path $ \pathPtr ->
  {# call gtk_icon_theme_set_search_path #}
    (toIconTheme self)
    pathPtr
    (fromIntegral nElements)

-- | Gets the current search path. See 'iconThemeSetSearchPath'.
--
iconThemeGetSearchPath :: IconThemeClass self => self
 -> IO ([FilePath], Int)         -- ^ @(path, nElements)@
                                -- @path@ - location to store a list of icon theme path
                                -- directories.
iconThemeGetSearchPath self =
  alloca $ \nElementsPtr ->
  allocaArray 0 $ \pathPtr -> do
  {# call gtk_icon_theme_get_search_path #}
    (toIconTheme self)
    (castPtr pathPtr)
    nElementsPtr
  pathStr <- readUTFStringArray0 pathPtr
  nElements <- peek nElementsPtr
  return (pathStr, fromIntegral nElements)

-- | Appends a directory to the search path. See 'iconThemeSetSearchPath'.
--
iconThemeAppendSearchPath :: IconThemeClass self => self
 -> FilePath -- ^ @path@ - directory name to append to the icon path
 -> IO ()
iconThemeAppendSearchPath self path =
  withUTFString path $ \pathPtr ->
  {# call gtk_icon_theme_append_search_path #}
    (toIconTheme self)
    pathPtr

-- | Prepends a directory to the search path. See 'iconThemeSetSearchPath'.
--
iconThemePrependSearchPath :: IconThemeClass self => self
 -> FilePath -- ^ @path@ - directory name to prepend to the icon path
 -> IO ()
iconThemePrependSearchPath self path =
  withUTFString path $ \pathPtr ->
  {# call gtk_icon_theme_prepend_search_path #}
    (toIconTheme self)
    pathPtr

-- | Sets the name of the icon theme that the 'IconTheme' object uses
-- overriding system configuration. This function cannot be called on the icon
-- theme objects returned from 'iconThemeGetDefault' and
-- 'iconThemeGetForScreen'.
--
iconThemeSetCustomTheme :: IconThemeClass self => self
 -> (Maybe String) -- ^ @themeName@ name of icon theme to use instead of configured theme, or 'Nothing' to unset a previously set custom theme
 -> IO ()
iconThemeSetCustomTheme self themeName =
  maybeWith withUTFString themeName $ \themeNamePtr ->
  {# call gtk_icon_theme_set_custom_theme #}
    (toIconTheme self)
    themeNamePtr

-- | Checks whether an icon theme includes an icon for a particular name.
--
iconThemeHasIcon :: IconThemeClass self => self
 -> String  -- ^ @iconName@ - the name of an icon
 -> IO Bool -- ^ returns @True@ if @iconTheme@ includes an icon for
            -- @iconName@.
iconThemeHasIcon self iconName =
  liftM toBool $
  withUTFString iconName $ \iconNamePtr ->
  {# call gtk_icon_theme_has_icon #}
    (toIconTheme self)
    iconNamePtr

-- | Looks up a named icon and returns a structure containing information such
-- as the filename of the icon. The icon can then be rendered into a pixbuf
-- using 'iconInfoLoadIcon'. ('iconThemeLoadIcon' combines these two steps if
-- all you need is the pixbuf.)
--
iconThemeLookupIcon :: IconThemeClass self => self
 -> String              -- ^ @iconName@ - the name of the icon to lookup
 -> Int                 -- ^ @size@ - desired icon size
 -> IconLookupFlags   -- ^ @flags@ - flags modifying the behavior of the
                        -- icon lookup
 -> IO (Maybe IconInfo)        -- ^ returns a 'IconInfo'
                        -- structure containing information about the icon, or
                         -- 'Nothing' if the icon wasn't found.
iconThemeLookupIcon self iconName size flags =
  withUTFString iconName $ \iconNamePtr -> do
  iiPtr <- {# call gtk_icon_theme_lookup_icon #}
          (toIconTheme self)
          iconNamePtr
          (fromIntegral size)
          ((fromIntegral . fromEnum) flags)
  if iiPtr == nullPtr
     then return Nothing
     else liftM Just (mkIconInfo (castPtr iiPtr))

#if GTK_CHECK_VERSION(2,12,0)
-- | Looks up a named icon and returns a structure containing information such
-- as the filename of the icon. The icon can then be rendered into a pixbuf
-- using 'iconInfoLoadIcon'. ('iconThemeLoadIcon' combines these two steps if
-- all you need is the pixbuf.)
--
-- If @iconNames@ contains more than one name, this function tries them all
-- in the given order before falling back to inherited icon themes.
--
-- * Available since Gtk+ version 2.12
--
iconThemeChooseIcon :: IconThemeClass self => self
 -> [String]              -- ^ @iconNames@ terminated list of icon names to lookup
 -> Int                 -- ^ @size@ - desired icon size
 -> IconLookupFlags   -- ^ @flags@ - flags modifying the behavior of the
                        -- icon lookup
 -> IO (Maybe IconInfo)        -- ^ returns a 'IconInfo'
                        -- structure containing information about the icon, or
                         -- 'Nothing' if the icon wasn't found.
iconThemeChooseIcon self iconNames size flags =
  withUTFStringArray0 iconNames $ \iconNamesPtr -> do
  iiPtr <- {# call gtk_icon_theme_choose_icon #}
          (toIconTheme self)
          iconNamesPtr
          (fromIntegral size)
          ((fromIntegral . fromEnum) flags)
  if iiPtr == nullPtr
     then return Nothing
     else liftM Just (mkIconInfo (castPtr iiPtr))

#ifdef ENABLE_GIO
#if GTK_CHECK_VERSION(2,14,0)
-- | Looks up an icon and returns a structure containing information such as
-- the filename of the icon. The icon can then be rendered into a pixbuf using
-- 'iconInfoLoadIcon'.
--
-- * Available since Gtk+ version 2.14
--
iconThemeLookupByGicon :: (IconThemeClass self, IconClass icon) => self
 -> icon          -- ^ @icon@ - the 'Icon' to look up
 -> Int                 -- ^ @size@ - desired icon size
 -> IconLookupFlags   -- ^ @flags@ - flags modifying the behavior of the
                        -- icon lookup
 -> IO (Maybe IconInfo)        -- ^ returns a 'IconInfo'
                        -- structure containing information about the icon, or
                        -- 'Nothing' if the icon wasn't found.
iconThemeLookupByGicon self icon size flags = do
    iiPtr <- {# call gtk_icon_theme_lookup_by_gicon #}
            (toIconTheme self)
            (toIcon icon)
            (fromIntegral size)
            ((fromIntegral . fromEnum) flags)
    if iiPtr == nullPtr
       then return Nothing
       else liftM Just (mkIconInfo (castPtr iiPtr))
#endif
#endif
#endif

-- | Looks up an icon in an icon theme, scales it to the given size and
-- renders it into a pixbuf. This is a convenience function; if more details
-- about the icon are needed, use 'iconThemeLookupIcon' followed by
-- 'iconInfoLoadIcon'.
--
-- Note that you probably want to listen for icon theme changes and update
-- the icon. This is usually done by connecting to the 'Widget'::style-set
-- signal. If for some reason you do not want to update the icon when the icon
-- theme changes, you should consider using 'pixbufCopy' to make a private copy
-- of the pixbuf returned by this function. Otherwise Gtk+ may need to keep the
-- old icon theme loaded, which would be a waste of memory.
--
iconThemeLoadIcon :: IconThemeClass self => self
 -> String            -- ^ @iconName@ - the name of the icon to lookup
 -> Int               -- ^ @size@ - the desired icon size. The resulting icon
                      -- may not be exactly this size; see 'iconInfoLoadIcon'.
 -> IconLookupFlags -- ^ @flags@ - flags modifying the behavior of the icon
                      -- lookup
 -> IO (Maybe Pixbuf)  -- ^ returns the rendered icon; this may be a newly
                      -- created icon or a new reference to an internal icon,
                      -- so you must not modify the icon.
                      -- `Nothing` if the icon isn't found.
iconThemeLoadIcon self iconName size flags =
  maybeNull (makeNewGObject mkPixbuf) $
  propagateGError $ \errorPtr ->
  withUTFString iconName $ \iconNamePtr ->
  {# call gtk_icon_theme_load_icon #}
    (toIconTheme self)
    iconNamePtr
    (fromIntegral size)
    ((fromIntegral . fromEnum) flags)
    errorPtr

#if GTK_CHECK_VERSION(2,12,0)
-- | Gets the list of contexts available within the current hierarchy of icon
-- themes
--
-- * Available since Gtk+ version 2.12
--
iconThemeListContexts :: IconThemeClass self => self
 -> IO [String] -- ^ returns a String list
                            -- holding the names of all the contexts in the
                            -- theme.
iconThemeListContexts self = do
  glistPtr <- {# call gtk_icon_theme_list_contexts #} (toIconTheme self)
  list <- fromGList glistPtr
  result <- mapM readUTFString list
  {#call unsafe g_list_free #} (castPtr glistPtr)
  return result
#endif

-- | Lists the icons in the current icon theme. Only a subset of the icons can
-- be listed by providing a context string. The set of values for the context
-- string is system dependent, but will typically include such values as
-- \"Applications\" and \"MimeTypes\".
--
iconThemeListIcons :: IconThemeClass self => self
 -> (Maybe String) -- ^ @context@    a string identifying a particular type of icon, or 'Nothing' to list all icons.
 -> IO [String] -- ^ returns a String list
               -- holding the names of all the icons in the theme.
iconThemeListIcons self context =
  maybeWith withUTFString context $ \contextPtr -> do
  glistPtr <- {# call gtk_icon_theme_list_icons #}
             (toIconTheme self)
             contextPtr
  list <- fromGList glistPtr
  result <- mapM readUTFString list
  {#call unsafe g_list_free#} (castPtr glistPtr)
  return result

#if GTK_CHECK_VERSION(2,6,0)
-- | Returns an list of integers describing the sizes at which the icon is
-- available without scaling. A size of -1 means that the icon is available in
-- a scalable format. The list is zero-terminated.
--
-- * Available since Gtk+ version 2.6
--
iconThemeGetIconSizes :: IconThemeClass self => self
 -> String       -- ^ @iconName@ - the name of an icon
 -> IO [Int] -- ^ returns An newly allocated list describing the sizes at
            -- which the icon is available.
iconThemeGetIconSizes self iconName =
  withUTFString iconName $ \iconNamePtr -> do
  listPtr <- {# call gtk_icon_theme_get_icon_sizes #}
              (toIconTheme self)
              iconNamePtr
  list <- peekArray 0 listPtr
  {#call unsafe g_free #} (castPtr listPtr)
  return (map fromIntegral list)
#endif

-- | Gets the name of an icon that is representative of the current theme (for
-- instance, to use when presenting a list of themes to the user.)
--
iconThemeGetExampleIconName :: IconThemeClass self => self
 -> IO (Maybe String)            -- ^ returns the name of an example icon or `Nothing'
iconThemeGetExampleIconName self = do
  namePtr <- {# call gtk_icon_theme_get_example_icon_name #} (toIconTheme self)
  if namePtr == nullPtr
     then return Nothing
     else liftM Just $ readUTFString namePtr

-- | Checks to see if the icon theme has changed; if it has, any currently
-- cached information is discarded and will be reloaded next time @iconTheme@
-- is accessed.
--
iconThemeRescanIfNeeded :: IconThemeClass self => self
 -> IO Bool -- ^ returns @True@ if the icon theme has changed and needed to be
            -- reloaded.
iconThemeRescanIfNeeded self =
  liftM toBool $
  {# call gtk_icon_theme_rescan_if_needed #}
    (toIconTheme self)

-- | Registers a built-in icon for icon theme lookups. The idea of built-in
-- icons is to allow an application or library that uses themed icons to
-- function requiring files to be present in the file system. For instance, the
-- default images for all of Gtk+'s stock icons are registered as built-icons.
--
-- In general, if you use 'iconThemeAddBuiltinIcon' you should also install
-- the icon in the icon theme, so that the icon is generally available.
--
-- This function will generally be used with pixbufs loaded via
-- 'pixbufNewFromInline'.
--
iconThemeAddBuiltinIcon ::
    String -- ^ @iconName@ - the name of the icon to register
 -> Int    -- ^ @size@ - the size at which to register the icon (different
           -- images can be registered for the same icon name at different
           -- sizes.)
 -> Pixbuf -- ^ @pixbuf@ - 'Pixbuf' that contains the image to use for
           -- @iconName@.
 -> IO ()
iconThemeAddBuiltinIcon iconName size pixbuf =
  withUTFString iconName $ \iconNamePtr ->
  {# call gtk_icon_theme_add_builtin_icon #}
    iconNamePtr
    (fromIntegral size)
    pixbuf

-- |
--
iconThemeErrorQuark :: IO Quark
iconThemeErrorQuark =
  {# call gtk_icon_theme_error_quark #}

--------------------
-- Types
{#pointer *IconInfo foreign newtype#}

foreign import ccall unsafe "&gtk_icon_info_free"
  icon_info_free :: FinalizerPtr IconInfo

-- | Helper function for build 'IconInfo'
mkIconInfo :: Ptr IconInfo -> IO IconInfo
mkIconInfo infoPtr =
  liftM IconInfo $ newForeignPtr infoPtr icon_info_free

--------------------
-- Constructors

#if GTK_CHECK_VERSION(2,14,0)
-- |
--
iconInfoNewForPixbuf :: IconThemeClass iconTheme => iconTheme -> Pixbuf -> IO IconInfo
iconInfoNewForPixbuf iconTheme pixbuf =
  {# call gtk_icon_info_new_for_pixbuf #}
          (toIconTheme iconTheme)
          pixbuf
  >>= mkIconInfo
#endif

--------------------
-- Methods

-- |
--
iconInfoCopy :: IconInfo -> IO IconInfo
iconInfoCopy self =
  {# call gtk_icon_info_copy #} self
  >>= mkIconInfo

-- | Fetches the set of attach points for an icon. An attach point is a location in the icon that can be
-- used as anchor points for attaching emblems or overlays to the icon.
iconInfoGetAttachPoints :: IconInfo -> IO (Maybe [Point])
iconInfoGetAttachPoints self =
  alloca $ \arrPtrPtr ->
  alloca $ \nPointsPtr -> do
  success <- liftM toBool $
            {# call gtk_icon_info_get_attach_points #}
              self
              (castPtr arrPtrPtr)
              nPointsPtr
  if success
     then do
       arrPtr <- peek arrPtrPtr
       nPoints <- peek nPointsPtr
       pointList <- peekArray (fromIntegral nPoints) arrPtr
       {#call unsafe g_free#} (castPtr arrPtr)
       return $ Just pointList
     else return Nothing

-- | Gets the base size for the icon. The base size is a size for the icon that was specified by the icon
-- theme creator. This may be different than the actual size of image; an example of this is small
-- emblem icons that can be attached to a larger icon. These icons will be given the same base size as
-- the larger icons to which they are attached.
--
iconInfoGetBaseSize :: IconInfo -> IO Int
iconInfoGetBaseSize self =
  liftM fromIntegral $
  {# call gtk_icon_info_get_base_size #} self

-- | Gets the built-in image for this icon, if any. To allow GTK+ to use built in icon images, you must
-- pass the ''IconLookupUseBuiltin'' to 'iconThemeLookupIcon'.
iconInfoGetBuiltinPixbuf :: IconInfo
 -> IO (Maybe Pixbuf) -- ^ returns the built-in image pixbuf, or 'Nothing'.
iconInfoGetBuiltinPixbuf self = do
  pixbufPtr <- {# call gtk_icon_info_get_builtin_pixbuf #} self
  if pixbufPtr == nullPtr
     then return Nothing
     else liftM Just $ makeNewGObject mkPixbuf (return pixbufPtr)

-- | Gets the display name for an icon. A display name is a string to be used in place of the icon name
-- in a user visible context like a list of icons.
iconInfoGetDisplayName :: IconInfo
 -> IO (Maybe String) -- ^ returns the display name for the icon or 'Nothing', if the icon doesn't have a specified display name.
iconInfoGetDisplayName self = do
  strPtr <- {# call gtk_icon_info_get_display_name #} self
  if strPtr == nullPtr
     then return Nothing
     else liftM Just $ peekUTFString strPtr

-- | Gets the coordinates of a rectangle within the icon that can be used for display of information such
-- as a preview of the contents of a text file. See 'iconInfoSetRawCoordinates' for further
-- information about the coordinate system.
iconInfoGetEmbeddedRect :: IconInfo
 -> IO (Maybe Rectangle)  -- ^ @rectangle@ 'Rectangle' in which to store embedded
                         -- rectangle coordinates.
iconInfoGetEmbeddedRect self =
  alloca $ \rectPtr -> do
  success <- liftM toBool $
            {# call gtk_icon_info_get_embedded_rect #}
            self
            (castPtr rectPtr)
  if success
     then liftM Just $ peek rectPtr
     else return Nothing

-- | Gets the filename for the icon. If the ''IconLookupUseBuiltin'' flag was passed to
-- 'iconThemeLookupIcon', there may be no filename if a builtin icon is returned; in this case,
-- you should use 'iconInfoGetBuiltinPixbuf'.
iconInfoGetFilename :: IconInfo
 -> IO (Maybe String) -- ^ returns the filename for the icon,
                     -- or 'Nothing' if 'iconInfoGetBuiltinPixbuf' should be used instead.
iconInfoGetFilename self = do
  namePtr <- {# call gtk_icon_info_get_filename #} self
  if namePtr == nullPtr
     then return Nothing
     else liftM Just $ peekUTFString namePtr

-- | Looks up an icon in an icon theme, scales it to the given size and renders it into a pixbuf. This is
-- a convenience function; if more details about the icon are needed, use 'iconThemeLookupIcon'
-- followed by 'iconInfoLoadIcon'.
--
-- Note that you probably want to listen for icon theme changes and update the icon. This is usually
-- done by connecting to the 'styleSet' signal. If for some reason you do not want to update
-- the icon when the icon theme changes, you should consider using 'pixbufCopy' to make a private
-- copy of the pixbuf returned by this function. Otherwise GTK+ may need to keep the old icon theme
-- loaded, which would be a waste of memory.
iconInfoLoadIcon :: IconInfo -> IO Pixbuf
iconInfoLoadIcon self =
  makeNewGObject mkPixbuf $
  propagateGError $ \errorPtr ->
  {# call gtk_icon_info_load_icon #}
    self
    errorPtr

-- | Sets whether the coordinates returned by 'iconInfoGetEmbeddedRect' and
-- 'iconInfoGetAttachPoints' should be returned in their original form as specified in the icon
-- theme, instead of scaled appropriately for the pixbuf returned by 'iconInfoLoadIcon'.
--
-- Raw coordinates are somewhat strange; they are specified to be with respect to the unscaled pixmap
-- for PNG and XPM icons, but for SVG icons, they are in a 1000x1000 coordinate space that is scaled to
-- the final size of the icon. You can determine if the icon is an SVG icon by using
-- 'iconInfoGetFilename', and seeing if it is non-'Nothing' and ends in '.svg'.
--
-- This function is provided primarily to allow compatibility wrappers for older API's, and is not
-- expected to be useful for applications.
iconInfoSetRawCoordinates :: IconInfo
 -> Bool  -- ^ @rawCoordinates@ whether the coordinates of
         -- embedded rectangles and attached points should be returned in their original
 -> IO ()
iconInfoSetRawCoordinates self rawCoordinates =
  {# call gtk_icon_info_set_raw_coordinates #}
    self
    (fromBool rawCoordinates)

--------------------
-- Signals

-- | Emitted when the current icon theme is switched or Gtk+ detects that a
-- change has occurred in the contents of the current icon theme.
--
iconThemeChanged :: IconThemeClass self => Signal self (IO ())
iconThemeChanged = Signal (connect_NONE__NONE "changed")

#endif


Pull result from an either or throw an error

Ignore-this: f9596bcd7c841b28db9f08656b85aa09

darcs-hash:20090720021758-115f9-f5db7a4bcd2edafb9d1f1b4d994cd6348b12de98.gz

{-
 - Utilities
 -}

{-# LANGUAGE ForeignFunctionInterface #-}

module Foreign.CUDA.Utils
  (
    getErrorString,
    resultIfOk, nothingIfOk,
    forceEither
  )
  where

import Foreign.CUDA.Types
import Foreign.CUDA.Internal.C2HS

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

--------------------------------------------------------------------------------
-- Error Handling
--------------------------------------------------------------------------------

--
-- Return the descriptive string associated with a particular error code.
-- Logically, this must a pure function, returning a pointer to a statically
-- defined string constant.
--
{# fun pure unsafe GetErrorString as ^
    { cFromEnum `Status' } -> `String' #}

resultIfOk :: (Status, a) -> Either String a
resultIfOk (status,result) =
    case status of
        Success -> Right result
        _       -> Left (getErrorString status)

nothingIfOk :: Status -> Maybe String
nothingIfOk = nothingIf (== Success) getErrorString

forceEither :: Either String a -> a
forceEither (Left  s) = error s
forceEither (Right r) = r

{-
 - Utilities
 -}

{-# LANGUAGE ForeignFunctionInterface #-}

module Foreign.CUDA.Utils
  (
    getErrorString, resultIfOk, nothingIfOk
  )
  where

import Foreign.CUDA.Types

import Foreign.CUDA.Internal.C2HS

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

--------------------------------------------------------------------------------
-- Error Handling
--------------------------------------------------------------------------------

--
-- Return the descriptive string associated with a particular error code.
-- Logically, this must a pure function, returning a pointer to a statically
-- defined string constant.
--
{# fun pure unsafe GetErrorString as ^
    { cFromEnum `Status' } -> `String' #}

resultIfOk :: (Status, a) -> Either String a
resultIfOk (status,result) =
    case status of
        Success -> Right result
        _       -> Left (getErrorString status)

nothingIfOk :: Status -> Maybe String
nothingIfOk = nothingIf (== Success) getErrorString


fixes for 7.8.4

fixes for 7.8.4

{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ForeignFunctionInterface #-}

module GDAL.Internal.GCP (
    GroundControlPoint (..)
  , GroundControlPointPtr
  , withGCPArrayLen
  , fromGCPArray
  , gcp
) where

#include "gdal.h"

import Data.ByteString.Char8 (empty, packCString)
import Data.ByteString.Internal (ByteString(..))
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Data.Coerce (coerce)

import Control.Applicative ((<$>), (<*>))
import Control.Exception (bracket)
import Control.Monad (liftM, mapM_)

import Foreign.Marshal.Alloc (free)
import Foreign.Marshal.Array (mallocArray0, allocaArray, peekArray, copyArray)
import Foreign.C.Types (CChar(..), CDouble(..))
import Foreign.Ptr (Ptr, castPtr, plusPtr)
import Foreign.Storable (Storable(..))

import GDAL.Internal.Types (XY(..))

type GroundControlPointPtr = Ptr GroundControlPoint
{#pointer *GDAL_GCP as GroundControlPointPtr nocode#}

data GroundControlPoint =
  GCP {
    gcpId    :: ByteString
  , gcpInfo  :: ByteString
  , gcpPixel :: !(XY Double)
  , gcpPoint :: !(XY Double)
  , gcpElev  :: !Double
  } deriving (Eq, Show)

-- So the unsafe Storable instance doesn't escape the module
newtype GroundControlPointInternal = GCPI GroundControlPoint

gcp :: ByteString -> XY Double -> XY Double -> GroundControlPoint
gcp id_ px pt = GCP id_ empty px pt 0

withGCPArrayLen
  :: [GroundControlPoint] -> (Int -> GroundControlPointPtr -> IO a) -> IO a
withGCPArrayLen gcps act =
  allocaArray nPoints $ \pPoints ->
  bracket (mapM_ (uncurry (pokeElemOff pPoints)) (zip [0..] gcps'))
          (const (mapM_ (freeGCP . plusPtr pPoints) [0..nPoints-1]))
          (const (act nPoints (castPtr pPoints)))
  where
    freeGCP p = do
      {#get GDAL_GCP->pszId#} p >>= free
      {#get GDAL_GCP->pszInfo#} p >>= free
    nPoints  = length gcps
    gcps'    = coerce gcps :: [GroundControlPointInternal]

fromGCPArray :: Int -> GroundControlPointPtr -> IO [GroundControlPoint]
fromGCPArray i p = liftM coerce (peekArray i p')
  where p' = castPtr p :: Ptr GroundControlPointInternal

instance Storable GroundControlPointInternal where
  sizeOf _    = {#sizeof GDAL_GCP#}
  alignment _ = {#alignof GDAL_GCP#}
  poke p (GCPI GCP{..}) = do
    unsafeUseAsCStringLen gcpId $ \(pId,len) -> do
      ptr0 <- mallocArray0 len
      pokeElemOff ptr0 len 0
      copyArray ptr0 pId len
      {#set GDAL_GCP->pszId#} p ptr0
    unsafeUseAsCStringLen gcpInfo $ \(pInfo,len) -> do
      ptr0 <- mallocArray0 len
      pokeElemOff ptr0 len 0
      copyArray ptr0 pInfo len
      {#set GDAL_GCP->pszInfo#} p ptr0
    {#set GDAL_GCP->dfGCPPixel#} p (realToFrac (px gcpPixel))
    {#set GDAL_GCP->dfGCPLine#} p (realToFrac (py gcpPixel))
    {#set GDAL_GCP->dfGCPX#} p (realToFrac (px gcpPoint))
    {#set GDAL_GCP->dfGCPY#} p (realToFrac (py gcpPoint))
    {#set GDAL_GCP->dfGCPZ#} p (realToFrac gcpElev)
  peek p = liftM GCPI $
    GCP <$> ({#get GDAL_GCP->pszId#}   p >>= packCString)
        <*> ({#get GDAL_GCP->pszInfo#} p >>= packCString)
        <*> (XY <$> liftM realToFrac ({#get GDAL_GCP->dfGCPPixel#} p)
                <*> liftM realToFrac ({#get GDAL_GCP->dfGCPLine#} p))
       <*> (XY <$> liftM realToFrac ({#get GDAL_GCP->dfGCPX#} p)
               <*> liftM realToFrac ({#get GDAL_GCP->dfGCPY#} p))
       <*> liftM realToFrac ({#get GDAL_GCP->dfGCPZ#} p)

{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ForeignFunctionInterface #-}

module GDAL.Internal.GCP (
    GroundControlPoint (..)
  , GroundControlPointPtr
  , withGCPArrayLen
  , fromGCPArray
  , gcp
) where

#include "gdal.h"

import Data.ByteString.Char8 (empty, packCString)
import Data.ByteString.Internal (ByteString(..))
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Data.Coerce (coerce)

import Control.Applicative ((<$>), (<*>))
import Control.Exception (bracket)
import Control.Monad (liftM, mapM_)

import Foreign.Marshal.Alloc (free)
import Foreign.Marshal.Array (callocArray0, allocaArray, peekArray, copyArray)
import Foreign.C.Types (CChar(..), CDouble(..))
import Foreign.Ptr (Ptr, castPtr, plusPtr)
import Foreign.Storable (Storable(..))

import GDAL.Internal.Types (XY(..))

type GroundControlPointPtr = Ptr GroundControlPoint
{#pointer *GDAL_GCP as GroundControlPointPtr nocode#}

data GroundControlPoint =
  GCP {
    gcpId    :: ByteString
  , gcpInfo  :: ByteString
  , gcpPixel :: !(XY Double)
  , gcpPoint :: !(XY Double)
  , gcpElev  :: !Double
  } deriving (Eq, Show)

-- So the unsafe Storable instance doesn't escape the module
newtype GroundControlPointInternal = GCPI GroundControlPoint

gcp :: ByteString -> XY Double -> XY Double -> GroundControlPoint
gcp id_ px pt = GCP id_ empty px pt 0

withGCPArrayLen
  :: [GroundControlPoint] -> (Int -> GroundControlPointPtr -> IO a) -> IO a
withGCPArrayLen gcps act =
  allocaArray nPoints $ \pPoints ->
  bracket (mapM_ (uncurry (pokeElemOff pPoints)) (zip [0..] gcps'))
          (const (mapM_ (freeGCP . plusPtr pPoints) [0..nPoints-1]))
          (const (act nPoints (castPtr pPoints)))
  where
    freeGCP p = do
      {#get GDAL_GCP->pszId#} p >>= free
      {#get GDAL_GCP->pszInfo#} p >>= free
    nPoints  = length gcps
    gcps'    = coerce gcps :: [GroundControlPointInternal]

fromGCPArray :: Int -> GroundControlPointPtr -> IO [GroundControlPoint]
fromGCPArray i p = liftM coerce (peekArray i p')
  where p' = castPtr p :: Ptr GroundControlPointInternal

instance Storable GroundControlPointInternal where
  sizeOf _    = {#sizeof GDAL_GCP#}
  alignment _ = {#alignof GDAL_GCP#}
  poke p (GCPI GCP{..}) = do
    unsafeUseAsCStringLen gcpId $ \(pId,len) -> do
      ptr0 <- callocArray0 len
      copyArray ptr0 pId len
      {#set GDAL_GCP->pszId#} p ptr0
    unsafeUseAsCStringLen gcpInfo $ \(pInfo,len) -> do
      ptr0 <- callocArray0 len
      copyArray ptr0 pInfo len
      {#set GDAL_GCP->pszInfo#} p ptr0
    {#set GDAL_GCP->dfGCPPixel#} p (realToFrac (px gcpPixel))
    {#set GDAL_GCP->dfGCPLine#} p (realToFrac (py gcpPixel))
    {#set GDAL_GCP->dfGCPX#} p (realToFrac (px gcpPoint))
    {#set GDAL_GCP->dfGCPY#} p (realToFrac (py gcpPoint))
    {#set GDAL_GCP->dfGCPZ#} p (realToFrac gcpElev)
  peek p = liftM GCPI $
    GCP <$> ({#get GDAL_GCP->pszId#}   p >>= packCString)
        <*> ({#get GDAL_GCP->pszInfo#} p >>= packCString)
        <*> (XY <$> liftM realToFrac ({#get GDAL_GCP->dfGCPPixel#} p)
                <*> liftM realToFrac ({#get GDAL_GCP->dfGCPLine#} p))
       <*> (XY <$> liftM realToFrac ({#get GDAL_GCP->dfGCPX#} p)
               <*> liftM realToFrac ({#get GDAL_GCP->dfGCPY#} p))
       <*> liftM realToFrac ({#get GDAL_GCP->dfGCPZ#} p)


remove unnecessary Types.chs from git repo

{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE CPP #-}
-- -*-haskell-*-
-- -------------------- automatically generated file - do not edit ----------
--  Object hierarchy for the GIMP Toolkit (GTK) Binding for Haskell
--
--  Author : Axel Simon
--
--  Copyright (C) 2001-2005 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- #hide

-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- This file reflects the Gtk+ object hierarchy in terms of Haskell classes.
--
-- Note: the mk... functions were originally meant to simply be an alias
-- for the constructor. However, in order to communicate the destructor
-- of an object to objectNew, the mk... functions are now a tuple containing
-- Haskell constructor and the destructor function pointer. This hack avoids
-- changing all modules that simply pass mk... to objectNew.
--
module Graphics.UI.Gtk.Poppler.Types (

  Document(Document), DocumentClass,
  toDocument,
  mkDocument, unDocument,
  castToDocument, gTypeDocument,
  FontsIter(FontsIter), FontsIterClass,
  toFontsIter,
  mkFontsIter, unFontsIter,
  castToFontsIter, gTypeFontsIter,
  Page(Page), PageClass,
  toPage,
  mkPage, unPage,
  castToPage, gTypePage,
  FormField(FormField), FormFieldClass,
  toFormField,
  mkFormField, unFormField,
  castToFormField, gTypeFormField,
  PSFile(PSFile), PSFileClass,
  toPSFile,
  mkPSFile, unPSFile,
  castToPSFile, gTypePSFile,
  FontInfo(FontInfo), FontInfoClass,
  toFontInfo,
  mkFontInfo, unFontInfo,
  castToFontInfo, gTypeFontInfo,
  Attachment(Attachment), AttachmentClass,
  toAttachment,
  mkAttachment, unAttachment,
  castToAttachment, gTypeAttachment,
  Layer(Layer), LayerClass,
  toLayer,
  mkLayer, unLayer,
  castToLayer, gTypeLayer
  ) where

import Foreign.ForeignPtr (ForeignPtr, castForeignPtr, unsafeForeignPtrToPtr)
import Foreign.C.Types    (CULong(..), CUInt(..))
import System.Glib.GType  (GType, typeInstanceIsA)
import System.Glib.GObject

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

-- The usage of foreignPtrToPtr should be safe as the evaluation will only be
-- forced if the object is used afterwards
--
castTo :: (GObjectClass obj, GObjectClass obj') => GType -> String
                                                -> (obj -> obj')
castTo gtype objTypeName obj =
  case toGObject obj of
    gobj@(GObject objFPtr)
      | typeInstanceIsA ((unsafeForeignPtrToPtr.castForeignPtr) objFPtr) gtype
                  -> unsafeCastGObject gobj
      | otherwise -> error $ "Cannot cast object to " ++ objTypeName

-- ******************************************************************* Document

{#pointer *Document foreign newtype #} deriving (Eq,Ord)

mkDocument = (Document, objectUnref)
unDocument (Document o) = o

class GObjectClass o => DocumentClass o
toDocument :: DocumentClass o => o -> Document
toDocument = unsafeCastGObject . toGObject

instance DocumentClass Document
instance GObjectClass Document where
  toGObject = GObject . castForeignPtr . unDocument
  unsafeCastGObject = Document . castForeignPtr . unGObject

castToDocument :: GObjectClass obj => obj -> Document
castToDocument = castTo gTypeDocument "Document"

gTypeDocument :: GType
gTypeDocument =
  {# call fun unsafe poppler_document_get_type #}

-- ****************************************************************** FontsIter

{#pointer *FontsIter foreign newtype #} deriving (Eq,Ord)

mkFontsIter = (FontsIter, objectUnref)
unFontsIter (FontsIter o) = o

class GObjectClass o => FontsIterClass o
toFontsIter :: FontsIterClass o => o -> FontsIter
toFontsIter = unsafeCastGObject . toGObject

instance FontsIterClass FontsIter
instance GObjectClass FontsIter where
  toGObject = GObject . castForeignPtr . unFontsIter
  unsafeCastGObject = FontsIter . castForeignPtr . unGObject

castToFontsIter :: GObjectClass obj => obj -> FontsIter
castToFontsIter = castTo gTypeFontsIter "FontsIter"

gTypeFontsIter :: GType
gTypeFontsIter =
  {# call fun unsafe poppler_fonts_iter_get_type #}

-- *********************************************************************** Page

{#pointer *Page foreign newtype #} deriving (Eq,Ord)

mkPage = (Page, objectUnref)
unPage (Page o) = o

class GObjectClass o => PageClass o
toPage :: PageClass o => o -> Page
toPage = unsafeCastGObject . toGObject

instance PageClass Page
instance GObjectClass Page where
  toGObject = GObject . castForeignPtr . unPage
  unsafeCastGObject = Page . castForeignPtr . unGObject

castToPage :: GObjectClass obj => obj -> Page
castToPage = castTo gTypePage "Page"

gTypePage :: GType
gTypePage =
  {# call fun unsafe poppler_page_get_type #}

-- ****************************************************************** FormField

{#pointer *FormField foreign newtype #} deriving (Eq,Ord)

mkFormField = (FormField, objectUnref)
unFormField (FormField o) = o

class GObjectClass o => FormFieldClass o
toFormField :: FormFieldClass o => o -> FormField
toFormField = unsafeCastGObject . toGObject

instance FormFieldClass FormField
instance GObjectClass FormField where
  toGObject = GObject . castForeignPtr . unFormField
  unsafeCastGObject = FormField . castForeignPtr . unGObject

castToFormField :: GObjectClass obj => obj -> FormField
castToFormField = castTo gTypeFormField "FormField"

gTypeFormField :: GType
gTypeFormField =
  {# call fun unsafe poppler_form_field_get_type #}

-- ********************************************************************* PSFile

{#pointer *PSFile foreign newtype #} deriving (Eq,Ord)

mkPSFile = (PSFile, objectUnref)
unPSFile (PSFile o) = o

class GObjectClass o => PSFileClass o
toPSFile :: PSFileClass o => o -> PSFile
toPSFile = unsafeCastGObject . toGObject

instance PSFileClass PSFile
instance GObjectClass PSFile where
  toGObject = GObject . castForeignPtr . unPSFile
  unsafeCastGObject = PSFile . castForeignPtr . unGObject

castToPSFile :: GObjectClass obj => obj -> PSFile
castToPSFile = castTo gTypePSFile "PSFile"

gTypePSFile :: GType
gTypePSFile =
  {# call fun unsafe poppler_ps_file_get_type #}

-- ******************************************************************* FontInfo

{#pointer *FontInfo foreign newtype #} deriving (Eq,Ord)

mkFontInfo = (FontInfo, objectUnref)
unFontInfo (FontInfo o) = o

class GObjectClass o => FontInfoClass o
toFontInfo :: FontInfoClass o => o -> FontInfo
toFontInfo = unsafeCastGObject . toGObject

instance FontInfoClass FontInfo
instance GObjectClass FontInfo where
  toGObject = GObject . castForeignPtr . unFontInfo
  unsafeCastGObject = FontInfo . castForeignPtr . unGObject

castToFontInfo :: GObjectClass obj => obj -> FontInfo
castToFontInfo = castTo gTypeFontInfo "FontInfo"

gTypeFontInfo :: GType
gTypeFontInfo =
  {# call fun unsafe poppler_font_info_get_type #}

-- ***************************************************************** Attachment

{#pointer *Attachment foreign newtype #} deriving (Eq,Ord)

mkAttachment = (Attachment, objectUnref)
unAttachment (Attachment o) = o

class GObjectClass o => AttachmentClass o
toAttachment :: AttachmentClass o => o -> Attachment
toAttachment = unsafeCastGObject . toGObject

instance AttachmentClass Attachment
instance GObjectClass Attachment where
  toGObject = GObject . castForeignPtr . unAttachment
  unsafeCastGObject = Attachment . castForeignPtr . unGObject

castToAttachment :: GObjectClass obj => obj -> Attachment
castToAttachment = castTo gTypeAttachment "Attachment"

gTypeAttachment :: GType
gTypeAttachment =
  {# call fun unsafe poppler_attachment_get_type #}

-- ********************************************************************** Layer

{#pointer *Layer foreign newtype #} deriving (Eq,Ord)

mkLayer = (Layer, objectUnref)
unLayer (Layer o) = o

class GObjectClass o => LayerClass o
toLayer :: LayerClass o => o -> Layer
toLayer = unsafeCastGObject . toGObject

instance LayerClass Layer
instance GObjectClass Layer where
  toGObject = GObject . castForeignPtr . unLayer
  unsafeCastGObject = Layer . castForeignPtr . unGObject

castToLayer :: GObjectClass obj => obj -> Layer
castToLayer = castTo gTypeLayer "Layer"

gTypeLayer :: GType
gTypeLayer =
  {# call fun unsafe poppler_layer_get_type #}


more local allocation functions

more local allocation functions

Ignore-this: 8fb7875adc5dba47ccdad01431c7fa2d

darcs-hash:20090724060859-115f9-27c06f521ccd71683556163754b931ed2ca2d15d.gz

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Marshal
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- Memory allocation and marshalling support for CUDA devices
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Marshal
  (
    DevicePtr,
    withDevicePtr,

    -- ** Dynamic allocation
    free,
    malloc,
--    malloc2D,
--    malloc3D,
    memset,
--    memset2D,
--    memset3D,

    -- ** Local allocation
    alloca,
    allocaBytes,

    -- ** Marshalling
    peek,
    poke,
    peekArray,
    pokeArray,

    -- ** Combined allocation and marshalling
    new,
    with,
    newArray,
    withArray,
    withArrayLen,

    -- ** Copying
  )
  where

import Data.Int
import Control.Exception

import Foreign.C
import Foreign.Ptr
import Foreign.ForeignPtr hiding (newForeignPtr)
import Foreign.Concurrent (newForeignPtr)
import Foreign.Storable (Storable)

import qualified Foreign.Storable as F
import qualified Foreign.Marshal  as F

import Foreign.CUDA.Utils
import Foreign.CUDA.Error
import Foreign.CUDA.Stream
import Foreign.CUDA.Internal.C2HS

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

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

-- |
-- A reference to data stored on the device. It is automatically freed.
--
type DevicePtr a = ForeignPtr a

withDevicePtr :: DevicePtr a -> (Ptr b -> IO c) -> IO c
withDevicePtr =  withForeignPtr . castForeignPtr

newDevicePtr   :: Ptr a -> IO (DevicePtr a)
newDevicePtr p =  newForeignPtr p (free_ p)
--newDevicePtr p =  (doAutoRelease free_) >>= \f -> newForeignPtr f p

--
-- Memory copy
--
{# enum cudaMemcpyKind as CopyDirection {}
    with prefix="cudaMemcpy" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Dynamic allocation
--------------------------------------------------------------------------------

-- |
-- Allocate the specified number of bytes in linear memory on the device. The
-- memory is suitably aligned for any kind of variable, and is not cleared.
--
malloc       :: Int64 -> IO (Either String (DevicePtr a))
malloc bytes =  do
    (rv,ptr) <- cudaMalloc bytes
    case rv of
        Success -> Right `fmap` newDevicePtr (castPtr ptr)
        _       -> return . Left . describe $ rv

{# fun unsafe cudaMalloc
    { alloca'-  `Ptr ()' peek'* ,
      cIntConv  `Int64'         } -> `Status' cToEnum #}
    where alloca' = F.alloca
          peek'   = F.peek

-- |
-- Allocate at least @width * height@ bytes of linear memory on the device. The
-- function may pad the allocation to ensure corresponding pointers in each row
-- meet coalescing requirements. The actual allocation width is returned.
--
malloc2D :: (Int64, Int64)              -- ^ allocation (width,height) in bytes
         -> IO (Either String (DevicePtr a, Int64))
malloc2D (width,height) =  do
    (rv,ptr,pitch) <- cudaMallocPitch width height
    case rv of
        Success -> (\p -> Right (p,pitch)) `fmap` newDevicePtr (castPtr ptr)
        _       -> return . Left . describe $ rv

{# fun unsafe cudaMallocPitch
    { alloca'-  `Ptr ()' peek'*       ,
      alloca'-  `Int64'  peekIntConv* ,
      cIntConv  `Int64'               ,
      cIntConv  `Int64'               } -> `Status' cToEnum #}
    where
        -- C->Haskell doesn't like qualified imports
        --
        alloca' :: Storable a => (Ptr a -> IO b) -> IO b
        alloca' =  F.alloca
        peek'   =  F.peek

-- |
-- Allocate at least @width * height * depth@ bytes of linear memory on the
-- device. The function may pad the allocation to ensure hardware alignment
-- requirements are met. The actual allocation pitch is returned
--
malloc3D :: (Int64,Int64,Int64)         -- ^ allocation (width,height,depth) in bytes
         -> IO (Either String (DevicePtr a, Int64))
malloc3D = moduleErr "malloc3D" "not implemented yet"

-- |
-- Free previously allocated memory on the device
--
free   :: DevicePtr a -> IO (Maybe String)
free p =  nothingIfOk `fmap` (withDevicePtr p cudaFree)

free_   :: Ptr a -> IO ()
free_ p =  cudaFree p >>= \rv ->
    case rv of
        Success -> return ()
        _       -> moduleErr "free" (describe rv)

{# fun unsafe cudaFree
    { castPtr `Ptr a' } -> `Status' cToEnum #}

foreign import ccall "wrapper"
    doAutoRelease   :: (Ptr a -> IO ()) -> IO (FunPtr (Ptr a -> IO ()))

-- |
-- Initialise device memory to a given value
--
memset :: DevicePtr a                   -- ^ The device memory
       -> Int64                         -- ^ Number of bytes
       -> Int                           -- ^ Value to set for each byte
       -> IO (Maybe String)
memset ptr bytes symbol =
    nothingIfOk `fmap` cudaMemset ptr symbol bytes

{# fun unsafe cudaMemset
    { withDevicePtr* `DevicePtr a' ,
                     `Int'         ,
      cIntConv       `Int64'       } -> `Status' cToEnum #}

-- |
-- Initialise a matrix to a given value
--
memset2D :: DevicePtr a                 -- ^ The device memory
         -> (Int64, Int64)              -- ^ The (width,height) of the matrix in bytes
         -> Int64                       -- ^ The allocation pitch, as returned by 'malloc2D'
         -> Int                         -- ^ Value to set for each byte
         -> IO (Maybe String)
memset2D ptr (width,height) pitch symbol =
    nothingIfOk `fmap` cudaMemset2D ptr pitch symbol width height

{# fun unsafe cudaMemset2D
    { withDevicePtr* `DevicePtr a' ,
      cIntConv       `Int64'       ,
                     `Int'         ,
      cIntConv       `Int64'       ,
      cIntConv       `Int64'       } -> `Status' cToEnum #}

-- |
-- Initialise the elements of a 3D array to a given value
--
memset3D :: DevicePtr a                 -- ^ The device memory
         -> (Int64,Int64,Int64)         -- ^ The (width,height,depth) of the array in bytes
         -> Int64                       -- ^ The allocation pitch, as returned by 'malloc3D'
         -> Int                         -- ^ Value to set for each byte
         -> IO (Maybe String)
memset3D = moduleErr "memset3D" "not implemented yet"

--------------------------------------------------------------------------------
-- Local allocation
--------------------------------------------------------------------------------

-- |
-- Execute a computation, passing a pointer to a temporarily allocated block of
-- memory
--
alloca :: (Storable a) => a -> (DevicePtr a -> IO b) -> IO b
alloca =  allocaBytes . fromIntegral . F.sizeOf

-- |
-- Execute a computation, passing a pointer to a block of 'n' bytes of memory
--
allocaBytes :: Int64 -> (DevicePtr a -> IO b) -> IO b
allocaBytes bytes fun =
    forceEither `fmap` malloc bytes >>= \dptr ->
    fun dptr                        >>= return

--------------------------------------------------------------------------------
-- Marshalling
--------------------------------------------------------------------------------

-- |
-- Retrieve the specified value from device memory
--
peek :: Storable a => DevicePtr a -> IO a
peek d = doPeek undefined
  where
    doPeek   :: Storable a' => a' -> IO a'
    doPeek x =  F.alloca        $ \hptr ->
                withDevicePtr d $ \dptr ->
                memcpy hptr dptr (fromIntegral (F.sizeOf x)) DeviceToHost >>= \rv ->
                case rv of
                    Nothing -> F.peek hptr
                    Just s  -> moduleErr "peek" s

-- |
-- Retrieve the specified number of elements from device memory and return as a
-- Haskell list
--
peekArray :: Storable a => Int -> DevicePtr a -> IO [a]
peekArray n d = doPeek undefined
  where
    doPeek   :: Storable a' => a' -> IO [a']
    doPeek x =  let bytes = fromIntegral n * (fromIntegral (F.sizeOf x)) in
                F.allocaArray n $ \hptr ->
                withDevicePtr d $ \dptr ->
                memcpy hptr dptr bytes DeviceToHost >>= \rv ->
                case rv of
                   Nothing -> F.peekArray n hptr
                   Just s  -> moduleErr "peekArray" s

-- |
-- Store the given value to device memory
--
poke :: Storable a => DevicePtr a -> a -> IO ()
poke d v =
    F.with v        $ \hptr ->
    withDevicePtr d $ \dptr ->
    memcpy dptr hptr (fromIntegral (F.sizeOf v)) HostToDevice >>= \rv ->
    case rv of
        Nothing -> return ()
        Just s  -> moduleErr "poke" s

-- |
-- Store the list elements consecutively in device memory
--
pokeArray :: Storable a => DevicePtr a -> [a] -> IO ()
pokeArray d = doPoke undefined
  where
    doPoke     :: Storable a' => a' -> [a'] -> IO ()
    doPoke x v =  F.withArrayLen v $ \n hptr ->
                  withDevicePtr  d $ \dptr ->
                  let bytes = (fromIntegral n) * (fromIntegral (F.sizeOf x)) in
                  memcpy dptr hptr bytes HostToDevice >>= \rv ->
                  case rv of
                      Nothing -> return ()
                      Just s  -> moduleErr "pokeArray" s

--------------------------------------------------------------------------------
-- Combined allocation and marshalling
--------------------------------------------------------------------------------

-- |
-- Allocate a block of memory on the device and transfer a value into it
--
new :: Storable a => a -> IO (DevicePtr a)
new v =
    let bytes = fromIntegral (F.sizeOf v) in
    forceEither `fmap` malloc bytes >>= \dptr ->
    poke dptr v >> return dptr

-- |
-- Write the list of storable elements into a newly allocated linear array on
-- the device
--
newArray   :: Storable a => [a] -> IO (DevicePtr a)
newArray v =
    let bytes = fromIntegral (length v) * fromIntegral (F.sizeOf (head v)) in
    forceEither `fmap` malloc bytes >>= \dptr ->
    pokeArray dptr v >> return dptr

-- |
-- Execute a computation passing a pointer to a temporarily allocated block of
-- device memory containing the value
--
with :: Storable a => a -> (DevicePtr a -> IO b) -> IO b
with v f =
    new v  >>= \dptr ->
    f dptr >>= return

-- |
-- Temporarily store a list of variable in device memory and operate on them
--
withArray :: Storable a => [a] -> (DevicePtr a -> IO b) -> IO b
withArray v f =
    newArray v >>= \dptr ->
    f dptr     >>= return

withArrayLen :: Storable a => [a] -> (Int -> DevicePtr a -> IO b) -> IO b
withArrayLen vals fun =
    let len   = length vals
        bytes = fromIntegral len * fromIntegral (F.sizeOf (head vals))
    in do
        dptr <- forceEither `fmap` malloc bytes
        pokeArray dptr vals
        fun len dptr

--------------------------------------------------------------------------------
-- Copying
--------------------------------------------------------------------------------

-- |
-- Copy data between host and device
--
memcpy :: Ptr a                 -- ^ destination
       -> Ptr a                 -- ^ source
       -> Int64                 -- ^ number of bytes
       -> CopyDirection
       -> IO (Maybe String)
memcpy dst src bytes dir =
    nothingIfOk `fmap` cudaMemcpy dst src bytes dir

{# fun unsafe cudaMemcpy
    { castPtr   `Ptr a'         ,
      castPtr   `Ptr a'         ,
      cIntConv  `Int64'         ,
      cFromEnum `CopyDirection' } -> `Status' cToEnum #}

-- |
-- Copy data between host and device asynchronously
--
memcpyAsync :: Stream           -- ^ asynchronous stream to operate over
            -> Ptr a            -- ^ destination
            -> Ptr a            -- ^ source
            -> Int64            -- ^ number of bytes
            -> CopyDirection
            -> IO (Maybe String)
memcpyAsync stream dst src bytes dir =
    nothingIfOk `fmap` cudaMemcpyAsync dst src bytes dir stream

{# fun unsafe cudaMemcpyAsync
    { castPtr    `Ptr a'         ,
      castPtr    `Ptr a'         ,
      cIntConv   `Int64'         ,
      cFromEnum  `CopyDirection' ,
      cIntConv   `Stream'        } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Internal utilities
--------------------------------------------------------------------------------

moduleErr :: String -> String -> a
moduleErr fun msg =  error ("Foreign.CUDA." ++ fun ++ ':':' ':msg)

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Marshal
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- Memory allocation and marshalling support for CUDA devices
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Marshal
  (
    DevicePtr,
    withDevicePtr,

    -- ** Dynamic allocation
    free,
    malloc,
--    malloc2D,
--    malloc3D,
    memset,
--    memset2D,
--    memset3D,

    -- ** Marshalling
    peek,
    poke,
    peekArray,
    pokeArray,

    -- ** Combined allocation and marshalling
    new,
    with,
    newArray,
    withArray,

    -- ** Copying
  )
  where

import Data.Int

import Foreign.C
import Foreign.Ptr
import Foreign.ForeignPtr hiding (newForeignPtr)
import Foreign.Concurrent (newForeignPtr)
import Foreign.Storable (Storable)

import qualified Foreign.Storable as F
import qualified Foreign.Marshal  as F

import Foreign.CUDA.Utils
import Foreign.CUDA.Error
import Foreign.CUDA.Stream
import Foreign.CUDA.Internal.C2HS

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

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

-- |
-- A reference to data stored on the device. It is automatically freed.
--
type DevicePtr a = ForeignPtr a

withDevicePtr :: DevicePtr a -> (Ptr b -> IO c) -> IO c
withDevicePtr =  withForeignPtr . castForeignPtr

newDevicePtr   :: Ptr a -> IO (DevicePtr a)
newDevicePtr p =  newForeignPtr p (free_ p)
--newDevicePtr p =  (doAutoRelease free_) >>= \f -> newForeignPtr f p

--
-- Memory copy
--
{# enum cudaMemcpyKind as CopyDirection {}
    with prefix="cudaMemcpy" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Dynamic allocation
--------------------------------------------------------------------------------

-- |
-- Allocate the specified number of bytes in linear memory on the device. The
-- memory is suitably aligned for any kind of variable, and is not cleared.
--
malloc       :: Int64 -> IO (Either String (DevicePtr a))
malloc bytes = do
    (rv,ptr) <- cudaMalloc bytes
    case rv of
        Success -> Right `fmap` newDevicePtr (castPtr ptr)
        _       -> return . Left . describe $ rv

{# fun unsafe cudaMalloc
    { alloca'-  `Ptr ()' peek'* ,
      cIntConv  `Int64'         } -> `Status' cToEnum #}
    where alloca' = F.alloca
          peek'   = F.peek

-- |
-- Allocate at least @width * height@ bytes of linear memory on the device. The
-- function may pad the allocation to ensure corresponding pointers in each row
-- meet coalescing requirements. The actual allocation width is returned.
--
malloc2D :: (Int64, Int64)              -- ^ allocation (width,height) in bytes
         -> IO (Either String (DevicePtr a, Int64))
malloc2D (width,height) =  do
    (rv,ptr,pitch) <- cudaMallocPitch width height
    case rv of
        Success -> (\p -> Right (p,pitch)) `fmap` newDevicePtr (castPtr ptr)
        _       -> return . Left . describe $ rv

{# fun unsafe cudaMallocPitch
    { alloca'-  `Ptr ()' peek'*       ,
      alloca'-  `Int64'  peekIntConv* ,
      cIntConv  `Int64'               ,
      cIntConv  `Int64'               } -> `Status' cToEnum #}
    where
        -- C->Haskell doesn't like qualified imports
        --
        alloca' :: Storable a => (Ptr a -> IO b) -> IO b
        alloca' =  F.alloca
        peek'   =  F.peek

-- |
-- Allocate at least @width * height * depth@ bytes of linear memory on the
-- device. The function may pad the allocation to ensure hardware alignment
-- requirements are met. The actual allocation pitch is returned
--
malloc3D :: (Int64,Int64,Int64)         -- ^ allocation (width,height,depth) in bytes
         -> IO (Either String (DevicePtr a, Int64))
malloc3D = moduleErr "malloc3D" "not implemented yet"

-- |
-- Free previously allocated memory on the device
--
free   :: DevicePtr a -> IO (Maybe String)
free p =  nothingIfOk `fmap` (withDevicePtr p cudaFree)

free_   :: Ptr a -> IO ()
free_ p =  cudaFree p >>= \rv ->
    case rv of
        Success -> return ()
        _       -> moduleErr "free" (describe rv)

{# fun unsafe cudaFree
    { castPtr `Ptr a' } -> `Status' cToEnum #}

foreign import ccall "wrapper"
    doAutoRelease   :: (Ptr a -> IO ()) -> IO (FunPtr (Ptr a -> IO ()))

-- |
-- Initialise device memory to a given value
--
memset                  :: DevicePtr a -> Int64 -> Int -> IO (Maybe String)
memset ptr bytes symbol =  nothingIfOk `fmap` cudaMemset ptr symbol bytes

{# fun unsafe cudaMemset
    { withDevicePtr* `DevicePtr a' ,
                     `Int'         ,
      cIntConv       `Int64'       } -> `Status' cToEnum #}

-- |
-- Initialise a matrix to a given value
--
memset2D :: DevicePtr a                 -- ^ The device memory
         -> (Int64, Int64)              -- ^ The (width,height) of the matrix in bytes
         -> Int64                       -- ^ The allocation pitch, as returned by 'malloc2D'
         -> Int                         -- ^ Value to set for each byte
         -> IO (Maybe String)
memset2D ptr (width,height) pitch symbol = nothingIfOk `fmap` cudaMemset2D ptr pitch symbol width height

{# fun unsafe cudaMemset2D
    { withDevicePtr* `DevicePtr a' ,
      cIntConv       `Int64'       ,
                     `Int'         ,
      cIntConv       `Int64'       ,
      cIntConv       `Int64'       } -> `Status' cToEnum #}

-- |
-- Initialise the elements of a 3D array to a given value
--
memset3D :: DevicePtr a                 -- ^ The device memory
         -> (Int64,Int64,Int64)         -- ^ The (width,height,depth) of the array in bytes
         -> Int64                       -- ^ The allocation pitch, as returned by 'malloc3D'
         -> Int                         -- ^ Value to set for each byte
         -> IO (Maybe String)
memset3D = moduleErr "memset3D" "not implemented yet"

--------------------------------------------------------------------------------
-- Marshalling
--------------------------------------------------------------------------------

-- |
-- Retrieve the specified value from device memory
--
peek :: Storable a => DevicePtr a -> IO a
peek d = doPeek undefined
  where
    doPeek   :: Storable a' => a' -> IO a'
    doPeek x =  F.alloca        $ \hptr ->
                withDevicePtr d $ \dptr ->
                memcpy hptr dptr (fromIntegral (F.sizeOf x)) DeviceToHost >>= \rv ->
                case rv of
                    Nothing -> F.peek hptr
                    Just s  -> moduleErr "peek" s

-- |
-- Retrieve the specified number of elements from device memory and return as a
-- Haskell list
--
peekArray :: Storable a => Int -> DevicePtr a -> IO [a]
peekArray n d = doPeek undefined
  where
    doPeek   :: Storable a' => a' -> IO [a']
    doPeek x =  let bytes = fromIntegral n * (fromIntegral (F.sizeOf x)) in
                F.allocaArray n $ \hptr ->
                withDevicePtr d $ \dptr ->
                memcpy hptr dptr bytes DeviceToHost >>= \rv ->
                case rv of
                   Nothing -> F.peekArray n hptr
                   Just s  -> moduleErr "peekArray" s

-- |
-- Store the given value to device memory
--
poke :: Storable a => DevicePtr a -> a -> IO ()
poke d v =
    F.with v        $ \hptr ->
    withDevicePtr d $ \dptr ->
    memcpy dptr hptr (fromIntegral (F.sizeOf v)) HostToDevice >>= \rv ->
    case rv of
        Nothing -> return ()
        Just s  -> moduleErr "poke" s

-- |
-- Store the list elements consecutively in device memory
--
pokeArray :: Storable a => DevicePtr a -> [a] -> IO ()
pokeArray d = doPoke undefined
  where
    doPoke     :: Storable a' => a' -> [a'] -> IO ()
    doPoke x v =  F.withArrayLen v $ \n hptr ->
                  withDevicePtr  d $ \dptr ->
                  let bytes = (fromIntegral n) * (fromIntegral (F.sizeOf x)) in
                  memcpy dptr hptr bytes HostToDevice >>= \rv ->
                  case rv of
                      Nothing -> return ()
                      Just s  -> moduleErr "pokeArray" s

--------------------------------------------------------------------------------
-- Combined allocation and marshalling
--------------------------------------------------------------------------------

-- |
-- Allocate a block of memory on the device and transfer a value into it
--
new :: Storable a => a -> IO (DevicePtr a)
new v =
    let bytes = fromIntegral (F.sizeOf v) in
    forceEither `fmap` malloc bytes >>= \dptr ->
    poke dptr v >> return dptr

-- |
-- Write the list of storable elements into a newly allocated linear array on
-- the device
--
newArray   :: Storable a => [a] -> IO (DevicePtr a)
newArray v =
    let bytes = fromIntegral (length v) * fromIntegral (F.sizeOf (head v)) in
    forceEither `fmap` malloc bytes >>= \dptr ->
    pokeArray dptr v >> return dptr

-- |
-- Execute a computation passing a pointer to a temporarily allocated block of
-- device memory containing the value
--
with :: Storable a => a -> (DevicePtr a -> IO b) -> IO b
with v f =
    new v  >>= \dptr ->
    f dptr >>= return

-- |
-- Temporarily store a list of variable in device memory and operate on them
--
withArray :: Storable a => [a] -> (DevicePtr a -> IO b) -> IO b
withArray v f =
    newArray v >>= \dptr ->
    f dptr     >>= return

--------------------------------------------------------------------------------
-- Copying
--------------------------------------------------------------------------------

-- |
-- Copy data between host and device
--
memcpy :: Ptr a                 -- ^ destination
       -> Ptr a                 -- ^ source
       -> Int64                 -- ^ number of bytes
       -> CopyDirection
       -> IO (Maybe String)
memcpy dst src bytes dir =
    nothingIfOk `fmap` cudaMemcpy dst src bytes dir

{# fun unsafe cudaMemcpy
    { castPtr   `Ptr a'         ,
      castPtr   `Ptr a'         ,
      cIntConv  `Int64'         ,
      cFromEnum `CopyDirection' } -> `Status' cToEnum #}

-- |
-- Copy data between host and device asynchronously
--
memcpyAsync :: Stream           -- ^ asynchronous stream to operate over
            -> Ptr a            -- ^ destination
            -> Ptr a            -- ^ source
            -> Int64            -- ^ number of bytes
            -> CopyDirection
            -> IO (Maybe String)
memcpyAsync stream dst src bytes dir =
    nothingIfOk `fmap` cudaMemcpyAsync dst src bytes dir stream

{# fun unsafe cudaMemcpyAsync
    { castPtr    `Ptr a'         ,
      castPtr    `Ptr a'         ,
      cIntConv   `Int64'         ,
      cFromEnum  `CopyDirection' ,
      cIntConv   `Stream'        } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Internal utilities
--------------------------------------------------------------------------------

moduleErr :: String -> String -> a
moduleErr fun msg =  error ("Foreign.CUDA." ++ fun ++ ':':' ':msg)