Fix the bug of `iconInfoGetEmbeddedRect`

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

{-# 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
 -> Rectangle  -- ^ @rectangle@ 'Rectangle' in which to store embedded
              -- rectangle coordinates; coordinates are only stored when this function
 -> IO Bool -- ^ returns   'True' if the icon has an embedded rectangle
iconInfoGetEmbeddedRect self rectangle =
  liftM toBool $
  with rectangle $ \ rectanglePtr ->
  {# call gtk_icon_info_get_embedded_rect #}
    self
    (castPtr rectanglePtr)

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


driver: add support for unified memory

driver: add support for unified memory

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# OPTIONS_HADDOCK prune #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Marshal
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Memory management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Marshal (

  -- * Host Allocation
  AllocFlag(..),
  mallocHostArray, freeHost, registerArray, unregisterArray,

  -- * Device Allocation
  mallocArray, allocaArray, free,

  -- * Unified Memory
  AttachFlag(..),
  mallocManagedArray,

  -- * Marshalling
  peekArray, peekArrayAsync, peekListArray,
  pokeArray, pokeArrayAsync, pokeListArray,
  copyArrayAsync,
  copyArrayPeer, copyArrayPeerAsync,

  -- * Combined Allocation and Marshalling
  newListArray,  newListArrayLen,
  withListArray, withListArrayLen,

  -- * Utility
  memset, memsetAsync,
  getDevicePtr, getBasePtr, getMemInfo,

  -- Internal
  useDeviceHandle, peekDeviceHandle

) where

#include "cbits/stubs.h"
{# context lib="cuda" #}

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

-- System
import Data.Int
import Data.Maybe
import Unsafe.Coerce
import Control.Applicative
import Control.Exception

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

#c
typedef enum CUmemhostalloc_option_enum {
    CU_MEMHOSTALLOC_OPTION_PORTABLE       = CU_MEMHOSTALLOC_PORTABLE,
    CU_MEMHOSTALLOC_OPTION_DEVICE_MAPPED  = CU_MEMHOSTALLOC_DEVICEMAP,
    CU_MEMHOSTALLOC_OPTION_WRITE_COMBINED = CU_MEMHOSTALLOC_WRITECOMBINED
} CUmemhostalloc_option;
#endc

#if CUDA_VERSION >= 6000
#c
typedef enum CUmemAttachFlags_option_enum {
    CU_MEM_ATTACH_OPTION_GLOBAL = CU_MEM_ATTACH_GLOBAL,
    CU_MEM_ATTACH_OPTION_HOST   = CU_MEM_ATTACH_HOST,
    CU_MEM_ATTACH_OPTION_SINGLE = CU_MEM_ATTACH_SINGLE
} CUmemAttachFlags_option;
#endc
#endif

--------------------------------------------------------------------------------
-- Host Allocation
--------------------------------------------------------------------------------

-- |
-- Options for host allocation
--
{# enum CUmemhostalloc_option as AllocFlag
    { underscoreToCase }
    with prefix="CU_MEMHOSTALLOC_OPTION" deriving (Eq, Show) #}

-- |
-- Allocate a section of linear memory on the host which is page-locked and
-- directly accessible from the device. The storage is sufficient to hold the
-- given number of elements of a storable type.
--
-- Note that since the amount of pageable memory is thusly reduced, overall
-- system performance may suffer. This is best used sparingly to allocate
-- staging areas for data exchange.
--
{-# INLINEABLE mallocHostArray #-}
mallocHostArray :: Storable a => [AllocFlag] -> Int -> IO (HostPtr a)
mallocHostArray !flags = doMalloc undefined
  where
    doMalloc :: Storable a' => a' -> Int -> IO (HostPtr a')
    doMalloc x !n = resultIfOk =<< cuMemHostAlloc (n * sizeOf x) flags

{-# INLINE cuMemHostAlloc #-}
{# fun unsafe cuMemHostAlloc
  { alloca'-        `HostPtr a'   peekHP*
  ,                 `Int'
  , combineBitMasks `[AllocFlag]'         } -> `Status' cToEnum #}
  where
    alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)
    peekHP !p  = HostPtr . castPtr <$> peek p

-- |
-- Free a section of page-locked host memory
--
{-# INLINEABLE freeHost #-}
freeHost :: HostPtr a -> IO ()
freeHost !p = nothingIfOk =<< cuMemFreeHost p

{-# INLINE cuMemFreeHost #-}
{# fun unsafe cuMemFreeHost
  { useHP `HostPtr a' } -> `Status' cToEnum #}
  where
    useHP = castPtr . useHostPtr

-- |
-- Page-locks the specified array (on the host) and maps it for the device(s) as
-- specified by the given allocation flags. Subsequently, the memory is accessed
-- directly by the device so can be read and written with much higher bandwidth
-- than pageable memory that has not been registered. The memory range is added
-- to the same tracking mechanism as 'mallocHostArray' to automatically
-- accelerate calls to functions such as 'pokeArray'.
--
-- Note that page-locking excessive amounts of memory may degrade system
-- performance, since it reduces the amount of pageable memory available. This
-- is best used sparingly to allocate staging areas for data exchange.
--
-- This function is not yet implemented on Mac OS X. Requires cuda-4.0.
--
{-# INLINEABLE registerArray #-}
registerArray :: Storable a => [AllocFlag] -> Int -> Ptr a -> IO (HostPtr a)
#if CUDA_VERSION < 4000
registerArray _ _ _     = requireSDK 4.0 "registerArray"
#else
registerArray !flags !n = go undefined
  where
    go :: Storable b => b -> Ptr b -> IO (HostPtr b)
    go x !p = do
      status <- cuMemHostRegister p (n * sizeOf x) flags
      resultIfOk (status,HostPtr p)

{-# INLINE cuMemHostRegister #-}
{# fun unsafe cuMemHostRegister
  { castPtr         `Ptr a'
  ,                 `Int'
  , combineBitMasks `[AllocFlag]' } -> `Status' cToEnum #}
#endif

-- |
-- Unmaps the memory from the given pointer, and makes it pageable again.
--
-- This function is not yet implemented on Mac OS X. Requires cuda-4.0.
--
{-# INLINEABLE unregisterArray #-}
unregisterArray :: HostPtr a -> IO (Ptr a)
#if CUDA_VERSION < 4000
unregisterArray _           = requireSDK 4.0 "unregisterArray"
#else
unregisterArray (HostPtr !p) = do
  status <- cuMemHostUnregister p
  resultIfOk (status,p)

{-# INLINE cuMemHostUnregister #-}
{# fun unsafe cuMemHostUnregister
  { castPtr `Ptr a' } -> `Status' cToEnum #}
#endif

--------------------------------------------------------------------------------
-- Device Allocation
--------------------------------------------------------------------------------

-- |
-- Allocate a section of linear memory on the device, and return a reference to
-- it. The memory is sufficient to hold the given number of elements of storable
-- type. It is suitably aligned for any type, and is not cleared.
--
{-# INLINEABLE mallocArray #-}
mallocArray :: Storable a => Int -> IO (DevicePtr a)
mallocArray = doMalloc undefined
  where
    doMalloc :: Storable a' => a' -> Int -> IO (DevicePtr a')
    doMalloc x !n = resultIfOk =<< cuMemAlloc (n * sizeOf x)

{-# INLINE cuMemAlloc #-}
{# fun unsafe cuMemAlloc
  { alloca'- `DevicePtr a' peekDeviceHandle*
  ,          `Int'                           } -> `Status' cToEnum #}
  where
    alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)

-- |
-- Execute a computation on the device, passing a pointer to a temporarily
-- allocated block of memory sufficient to hold the given number of elements of
-- storable type. The memory is freed when the computation terminates (normally
-- or via an exception), so the pointer must not be used after this.
--
-- Note that kernel launches can be asynchronous, so you may want to add a
-- synchronisation point using 'sync' as part of the computation.
--
{-# INLINEABLE allocaArray #-}
allocaArray :: Storable a => Int -> (DevicePtr a -> IO b) -> IO b
allocaArray !n = bracket (mallocArray n) free

-- |
-- Release a section of device memory
--
{-# INLINEABLE free #-}
free :: DevicePtr a -> IO ()
free !dp = nothingIfOk =<< cuMemFree dp

{-# INLINE cuMemFree #-}
{# fun unsafe cuMemFree
  { useDeviceHandle `DevicePtr a' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Unified memory allocations
--------------------------------------------------------------------------------

-- |
-- Options for unified memory allocations
--
#if CUDA_VERSION >= 6000
{# enum CUmemAttachFlags_option as AttachFlag
    { underscoreToCase }
    with prefix="CU_MEM_ATTACH_OPTION" deriving (Eq, Show) #}
#else
data AttachFlag
#endif

-- |
-- Allocates memory that will be automatically managed by the Unified Memory
-- system
--
{-# INLINEABLE mallocManagedArray #-}
mallocManagedArray :: Storable a => [AttachFlag] -> Int -> IO (DevicePtr a)
#if CUDA_VERSION < 6000
mallocManagedArray _      = requireSDK 6.0 "mallocManagedArray"
#else
mallocManagedArray !flags = doMalloc undefined
  where
    doMalloc :: Storable a' => a' -> Int -> IO (DevicePtr a')
    doMalloc x !n = resultIfOk =<< cuMemAllocManaged (n * sizeOf x) flags

{-# INLINE cuMemAllocManaged #-}
{# fun unsafe cuMemAllocManaged
  { alloca'-        `DevicePtr a' peekDeviceHandle*
  ,                 `Int'
  , combineBitMasks `[AttachFlag]'                  } -> `Status' cToEnum #}
  where
    alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)
#endif

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

-- |
-- Copy a number of elements from the device to host memory. This is a
-- synchronous operation
--
{-# INLINEABLE peekArray #-}
peekArray :: Storable a => Int -> DevicePtr a -> Ptr a -> IO ()
peekArray !n !dptr !hptr = doPeek undefined dptr
  where
    doPeek :: Storable a' => a' -> DevicePtr a' -> IO ()
    doPeek x _ = nothingIfOk =<< cuMemcpyDtoH hptr dptr (n * sizeOf x)

{-# INLINE cuMemcpyDtoH #-}
{# fun unsafe cuMemcpyDtoH
  { castPtr         `Ptr a'
  , useDeviceHandle `DevicePtr a'
  ,                 `Int'         } -> `Status' cToEnum #}

-- |
-- Copy memory from the device asynchronously, possibly associated with a
-- particular stream. The destination host memory must be page-locked.
--
{-# INLINEABLE peekArrayAsync #-}
peekArrayAsync :: Storable a => Int -> DevicePtr a -> HostPtr a -> Maybe Stream -> IO ()
peekArrayAsync !n !dptr !hptr !mst = doPeek undefined dptr
  where
    doPeek :: Storable a' => a' -> DevicePtr a' -> IO ()
    doPeek x _ = nothingIfOk =<< cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) (fromMaybe (Stream nullPtr) mst)

{-# INLINE cuMemcpyDtoHAsync #-}
{# fun unsafe cuMemcpyDtoHAsync
  { useHP           `HostPtr a'
  , useDeviceHandle `DevicePtr a'
  ,                 `Int'
  , useStream       `Stream'      } -> `Status' cToEnum #}
  where
    useHP = castPtr . useHostPtr

-- |
-- Copy a number of elements from the device into a new Haskell list. Note that
-- this requires two memory copies: firstly from the device into a heap
-- allocated array, and from there marshalled into a list.
--
{-# INLINEABLE peekListArray #-}
peekListArray :: Storable a => Int -> DevicePtr a -> IO [a]
peekListArray !n !dptr =
  F.allocaArray n $ \p -> do
    peekArray   n dptr p
    F.peekArray n p

-- |
-- Copy a number of elements onto the device. This is a synchronous operation
--
{-# INLINEABLE pokeArray #-}
pokeArray :: Storable a => Int -> Ptr a -> DevicePtr a -> IO ()
pokeArray !n !hptr !dptr = doPoke undefined dptr
  where
    doPoke :: Storable a' => a' -> DevicePtr a' -> IO ()
    doPoke x _ = nothingIfOk =<< cuMemcpyHtoD dptr hptr (n * sizeOf x)

{-# INLINE cuMemcpyHtoD #-}
{# fun unsafe cuMemcpyHtoD
  { useDeviceHandle `DevicePtr a'
  , castPtr         `Ptr a'
  ,                 `Int'         } -> `Status' cToEnum #}

-- |
-- Copy memory onto the device asynchronously, possibly associated with a
-- particular stream. The source host memory must be page-locked.
--
{-# INLINEABLE pokeArrayAsync #-}
pokeArrayAsync :: Storable a => Int -> HostPtr a -> DevicePtr a -> Maybe Stream -> IO ()
pokeArrayAsync !n !hptr !dptr !mst = dopoke undefined dptr
  where
    dopoke :: Storable a' => a' -> DevicePtr a' -> IO ()
    dopoke x _ = nothingIfOk =<< cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) (fromMaybe (Stream nullPtr) mst)

{-# INLINE cuMemcpyHtoDAsync #-}
{# fun unsafe cuMemcpyHtoDAsync
  { useDeviceHandle `DevicePtr a'
  , useHP           `HostPtr a'
  ,                 `Int'
  , useStream       `Stream'      } -> `Status' cToEnum #}
  where
    useHP = castPtr . useHostPtr

-- |
-- Write a list of storable elements into a device array. The device array must
-- be sufficiently large to hold the entire list. This requires two marshalling
-- operations.
--
{-# INLINEABLE pokeListArray #-}
pokeListArray :: Storable a => [a] -> DevicePtr a -> IO ()
pokeListArray !xs !dptr = F.withArrayLen xs $ \ !len !p -> pokeArray len p dptr

-- |
-- Copy the given number of elements from the first device array (source) to the
-- second (destination). The copied areas may not overlap. This operation is
-- asynchronous with respect to the host, but will never overlap with kernel
-- execution.
--
{-# INLINEABLE copyArrayAsync #-}
copyArrayAsync :: Storable a => Int -> DevicePtr a -> DevicePtr a -> IO ()
copyArrayAsync !n = docopy undefined
  where
    docopy :: Storable a' => a' -> DevicePtr a' -> DevicePtr a' -> IO ()
    docopy x src dst = nothingIfOk =<< cuMemcpyDtoD dst src (n * sizeOf x)

{-# INLINE cuMemcpyDtoD #-}
{# fun unsafe cuMemcpyDtoD
  { useDeviceHandle `DevicePtr a'
  , useDeviceHandle `DevicePtr a'
  ,                 `Int'         } -> `Status' cToEnum #}

-- |
-- Copies an array from device memory in one context to device memory in another
-- context. Note that this function is asynchronous with respect to the host,
-- but serialised with respect to all pending and future asynchronous work in
-- the source and destination contexts. To avoid this synchronisation, use
-- 'copyArrayPeerAsync' instead.
--
{-# INLINEABLE copyArrayPeer #-}
copyArrayPeer :: Storable a
              => Int                            -- ^ number of array elements
              -> DevicePtr a -> Context         -- ^ source array and context
              -> DevicePtr a -> Context         -- ^ destination array and context
              -> IO ()
#if CUDA_VERSION < 4000
copyArrayPeer _ _ _ _ _                    = requireSDK 4.0 "copyArrayPeer"
#else
copyArrayPeer !n !src !srcCtx !dst !dstCtx = go undefined src dst
  where
    go :: Storable b => b -> DevicePtr b -> DevicePtr b -> IO ()
    go x _ _ = nothingIfOk =<< cuMemcpyPeer dst dstCtx src srcCtx (n * sizeOf x)

{-# INLINE cuMemcpyPeer #-}
{# fun unsafe cuMemcpyPeer
  { useDeviceHandle `DevicePtr a'
  , useContext      `Context'
  , useDeviceHandle `DevicePtr a'
  , useContext      `Context'
  ,                 `Int'         } -> `Status' cToEnum #}
#endif

-- |
-- Copies from device memory in one context to device memory in another context.
-- Note that this function is asynchronous with respect to the host and all work
-- in other streams and devices.
--
{-# INLINEABLE copyArrayPeerAsync #-}
copyArrayPeerAsync :: Storable a
                   => Int                       -- ^ number of array elements
                   -> DevicePtr a -> Context    -- ^ source array and context
                   -> DevicePtr a -> Context    -- ^ destination array and device context
                   -> Maybe Stream              -- ^ stream to associate with
                   -> IO ()
#if CUDA_VERSION < 4000
copyArrayPeerAsync _ _ _ _ _ _                      = requireSDK 4.0 "copyArrayPeerAsync"
#else
copyArrayPeerAsync !n !src !srcCtx !dst !dstCtx !st = go undefined src dst
  where
    go :: Storable b => b -> DevicePtr b -> DevicePtr b -> IO ()
    go x _ _ = nothingIfOk =<< cuMemcpyPeerAsync dst dstCtx src srcCtx (n * sizeOf x) stream
    stream   = fromMaybe (Stream nullPtr) st

{-# INLINE cuMemcpyPeerAsync #-}
{# fun unsafe cuMemcpyPeerAsync
  { useDeviceHandle `DevicePtr a'
  , useContext      `Context'
  , useDeviceHandle `DevicePtr a'
  , useContext      `Context'
  ,                 `Int'
  , useStream       `Stream'      } -> `Status' cToEnum #}
#endif

--------------------------------------------------------------------------------
-- Combined Allocation and Marshalling
--------------------------------------------------------------------------------

-- |
-- Write a list of storable elements into a newly allocated device array,
-- returning the device pointer together with the number of elements that were
-- written. Note that this requires two memory copies: firstly from a Haskell
-- list to a heap allocated array, and from there onto the graphics device. The
-- memory should be 'free'd when no longer required.
--
{-# INLINEABLE newListArrayLen #-}
newListArrayLen :: Storable a => [a] -> IO (DevicePtr a, Int)
newListArrayLen xs =
  F.withArrayLen xs                     $ \len p ->
  bracketOnError (mallocArray len) free $ \d_xs  -> do
    pokeArray len p d_xs
    return (d_xs, len)

-- |
-- Write a list of storable elements into a newly allocated device array. This
-- is 'newListArrayLen' composed with 'fst'.
--
{-# INLINEABLE newListArray #-}
newListArray :: Storable a => [a] -> IO (DevicePtr a)
newListArray xs = fst `fmap` newListArrayLen xs

-- |
-- Temporarily store a list of elements into a newly allocated device array. An
-- IO action is applied to to the array, the result of which is returned.
-- Similar to 'newListArray', this requires copying the data twice.
--
-- As with 'allocaArray', the memory is freed once the action completes, so you
-- should not return the pointer from the action, and be wary of asynchronous
-- kernel execution.
--
{-# INLINEABLE withListArray #-}
withListArray :: Storable a => [a] -> (DevicePtr a -> IO b) -> IO b
withListArray xs = withListArrayLen xs . const

-- |
-- A variant of 'withListArray' which also supplies the number of elements in
-- the array to the applied function
--
{-# INLINEABLE withListArrayLen #-}
withListArrayLen :: Storable a => [a] -> (Int -> DevicePtr a -> IO b) -> IO b
withListArrayLen xs f =
  bracket (newListArrayLen xs) (free . fst) (uncurry . flip $ f)
--
-- XXX: Will this attempt to double-free the device array on error (together
-- with newListArrayLen)?
--

--------------------------------------------------------------------------------
-- Utility
--------------------------------------------------------------------------------

-- |
-- Set a number of data elements to the specified value, which may be either 8-,
-- 16-, or 32-bits wide.
--
{-# INLINEABLE memset #-}
memset :: Storable a => DevicePtr a -> Int -> a -> IO ()
memset !dptr !n !val = case sizeOf val of
    1 -> nothingIfOk =<< cuMemsetD8  dptr val n
    2 -> nothingIfOk =<< cuMemsetD16 dptr val n
    4 -> nothingIfOk =<< cuMemsetD32 dptr val n
    _ -> cudaError "can only memset 8-, 16-, and 32-bit values"

--
-- We use unsafe coerce below to reinterpret the bits of the value to memset as,
-- into the integer type required by the setting functions.
--
{-# INLINE cuMemsetD8 #-}
{# fun unsafe cuMemsetD8
  { useDeviceHandle `DevicePtr a'
  , unsafeCoerce    `a'
  ,                 `Int'         } -> `Status' cToEnum #}

{-# INLINE cuMemsetD16 #-}
{# fun unsafe cuMemsetD16
  { useDeviceHandle `DevicePtr a'
  , unsafeCoerce    `a'
  ,                 `Int'         } -> `Status' cToEnum #}

{-# INLINE cuMemsetD32 #-}
{# fun unsafe cuMemsetD32
  { useDeviceHandle `DevicePtr a'
  , unsafeCoerce    `a'
  ,                 `Int'         } -> `Status' cToEnum #}

-- |
-- Set the number of data elements to the specified value, which may be either
-- 8-, 16-, or 32-bits wide. The operation is asynchronous and may optionally be
-- associated with a stream. Requires cuda-3.2.
--
{-# INLINEABLE memsetAsync #-}
memsetAsync :: Storable a => DevicePtr a -> Int -> a -> Maybe Stream -> IO ()
#if CUDA_VERSION < 3020
memsetAsync _ _ _ _            = requireSDK 3.2 "memsetAsync"
#else
memsetAsync !dptr !n !val !mst = case sizeOf val of
    1 -> nothingIfOk =<< cuMemsetD8Async  dptr val n stream
    2 -> nothingIfOk =<< cuMemsetD16Async dptr val n stream
    4 -> nothingIfOk =<< cuMemsetD32Async dptr val n stream
    _ -> cudaError "can only memset 8-, 16-, and 32-bit values"
    where
      stream = fromMaybe (Stream nullPtr) mst

{-# INLINE cuMemsetD8Async #-}
{# fun unsafe cuMemsetD8Async
  { useDeviceHandle `DevicePtr a'
  , unsafeCoerce    `a'
  ,                 `Int'
  , useStream       `Stream'      } -> `Status' cToEnum #}

{-# INLINE cuMemsetD16Async #-}
{# fun unsafe cuMemsetD16Async
  { useDeviceHandle `DevicePtr a'
  , unsafeCoerce    `a'
  ,                 `Int'
  , useStream       `Stream'      } -> `Status' cToEnum #}

{-# INLINE cuMemsetD32Async #-}
{# fun unsafe cuMemsetD32Async
  { useDeviceHandle `DevicePtr a'
  , unsafeCoerce    `a'
  ,                 `Int'
  , useStream       `Stream'      } -> `Status' cToEnum #}
#endif

-- |
-- Return the device pointer associated with a mapped, pinned host buffer, which
-- was allocated with the 'DeviceMapped' option by 'mallocHostArray'.
--
-- Currently, no options are supported and this must be empty.
--
{-# INLINEABLE getDevicePtr #-}
getDevicePtr :: [AllocFlag] -> HostPtr a -> IO (DevicePtr a)
getDevicePtr !flags !hp = resultIfOk =<< cuMemHostGetDevicePointer hp flags

{-# INLINE cuMemHostGetDevicePointer #-}
{# fun unsafe cuMemHostGetDevicePointer
  { alloca'-        `DevicePtr a' peekDeviceHandle*
  , useHP           `HostPtr a'
  , combineBitMasks `[AllocFlag]'                   } -> `Status' cToEnum #}
  where
    alloca'  = F.alloca
    useHP    = castPtr . useHostPtr

-- |
-- Return the base address and allocation size of the given device pointer
--
{-# INLINEABLE getBasePtr #-}
getBasePtr :: DevicePtr a -> IO (DevicePtr a, Int64)
getBasePtr !dptr = do
  (status,base,size) <- cuMemGetAddressRange dptr
  resultIfOk (status, (base,size))

{-# INLINE cuMemGetAddressRange #-}
{# fun unsafe cuMemGetAddressRange
  { alloca'-        `DevicePtr a' peekDeviceHandle*
  , alloca'-        `Int64'       peekIntConv*
  , useDeviceHandle `DevicePtr a'                   } -> `Status' cToEnum #}
  where
    alloca' :: Storable a => (Ptr a -> IO b) -> IO b
    alloca' = F.alloca

-- |
-- Return the amount of free and total memory respectively available to the
-- current context (bytes)
--
{-# INLINEABLE getMemInfo #-}
getMemInfo :: IO (Int64, Int64)
getMemInfo = do
  (!status,!f,!t) <- cuMemGetInfo
  resultIfOk (status,(f,t))

{-# INLINE cuMemGetInfo #-}
{# fun unsafe cuMemGetInfo
  { alloca'- `Int64' peekIntConv*
  , alloca'- `Int64' peekIntConv* } -> `Status' cToEnum #}
  where
    alloca' = F.alloca

--------------------------------------------------------------------------------
-- Internal
--------------------------------------------------------------------------------

type DeviceHandle = {# type CUdeviceptr #}

-- Lift an opaque handle to a typed DevicePtr representation. This occasions
-- arcane distinctions for the different driver versions and Tesla (compute 1.x)
-- and Fermi (compute 2.x) class architectures on 32- and 64-bit hosts.
--
{-# INLINE peekDeviceHandle #-}
peekDeviceHandle :: Ptr DeviceHandle -> IO (DevicePtr a)
peekDeviceHandle !p = DevicePtr . intPtrToPtr . fromIntegral <$> peek p

-- Use a device pointer as an opaque handle type
--
{-# INLINE useDeviceHandle #-}
useDeviceHandle :: DevicePtr a -> DeviceHandle
useDeviceHandle = fromIntegral . ptrToIntPtr . useDevicePtr

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# OPTIONS_HADDOCK prune #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Marshal
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Memory management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Marshal (

  -- * Host Allocation
  AllocFlag(..),
  mallocHostArray, freeHost, registerArray, unregisterArray,

  -- * Device Allocation
  mallocArray, allocaArray, free,

  -- * Marshalling
  peekArray, peekArrayAsync, peekListArray,
  pokeArray, pokeArrayAsync, pokeListArray,
  copyArrayAsync,
  copyArrayPeer, copyArrayPeerAsync,

  -- * Combined Allocation and Marshalling
  newListArray,  newListArrayLen,
  withListArray, withListArrayLen,

  -- * Utility
  memset, memsetAsync,
  getDevicePtr, getBasePtr, getMemInfo,

  -- Internal
  useDeviceHandle, peekDeviceHandle

) where

#include "cbits/stubs.h"
{# context lib="cuda" #}

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

-- System
import Data.Int
import Data.Maybe
import Unsafe.Coerce
import Control.Applicative
import Control.Exception

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

#c
typedef enum CUmemhostalloc_option_enum {
    CU_MEMHOSTALLOC_OPTION_PORTABLE       = CU_MEMHOSTALLOC_PORTABLE,
    CU_MEMHOSTALLOC_OPTION_DEVICE_MAPPED  = CU_MEMHOSTALLOC_DEVICEMAP,
    CU_MEMHOSTALLOC_OPTION_WRITE_COMBINED = CU_MEMHOSTALLOC_WRITECOMBINED
} CUmemhostalloc_option;
#endc

--------------------------------------------------------------------------------
-- Host Allocation
--------------------------------------------------------------------------------

-- |
-- Options for host allocation
--
{# enum CUmemhostalloc_option as AllocFlag
    { underscoreToCase }
    with prefix="CU_MEMHOSTALLOC_OPTION" deriving (Eq, Show) #}

-- |
-- Allocate a section of linear memory on the host which is page-locked and
-- directly accessible from the device. The storage is sufficient to hold the
-- given number of elements of a storable type.
--
-- Note that since the amount of pageable memory is thusly reduced, overall
-- system performance may suffer. This is best used sparingly to allocate
-- staging areas for data exchange.
--
{-# INLINEABLE mallocHostArray #-}
mallocHostArray :: Storable a => [AllocFlag] -> Int -> IO (HostPtr a)
mallocHostArray !flags = doMalloc undefined
  where
    doMalloc :: Storable a' => a' -> Int -> IO (HostPtr a')
    doMalloc x !n = resultIfOk =<< cuMemHostAlloc (n * sizeOf x) flags

{-# INLINE cuMemHostAlloc #-}
{# fun unsafe cuMemHostAlloc
  { alloca'-        `HostPtr a'   peekHP*
  ,                 `Int'
  , combineBitMasks `[AllocFlag]'         } -> `Status' cToEnum #}
  where
    alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)
    peekHP !p  = HostPtr . castPtr <$> peek p

-- |
-- Free a section of page-locked host memory
--
{-# INLINEABLE freeHost #-}
freeHost :: HostPtr a -> IO ()
freeHost !p = nothingIfOk =<< cuMemFreeHost p

{-# INLINE cuMemFreeHost #-}
{# fun unsafe cuMemFreeHost
  { useHP `HostPtr a' } -> `Status' cToEnum #}
  where
    useHP = castPtr . useHostPtr

-- |
-- Page-locks the specified array (on the host) and maps it for the device(s) as
-- specified by the given allocation flags. Subsequently, the memory is accessed
-- directly by the device so can be read and written with much higher bandwidth
-- than pageable memory that has not been registered. The memory range is added
-- to the same tracking mechanism as 'mallocHostArray' to automatically
-- accelerate calls to functions such as 'pokeArray'.
--
-- Note that page-locking excessive amounts of memory may degrade system
-- performance, since it reduces the amount of pageable memory available. This
-- is best used sparingly to allocate staging areas for data exchange.
--
-- This function is not yet implemented on Mac OS X. Requires cuda-4.0.
--
{-# INLINEABLE registerArray #-}
registerArray :: Storable a => [AllocFlag] -> Int -> Ptr a -> IO (HostPtr a)
#if CUDA_VERSION < 4000
registerArray _ _ _     = requireSDK 4.0 "registerArray"
#else
registerArray !flags !n = go undefined
  where
    go :: Storable b => b -> Ptr b -> IO (HostPtr b)
    go x !p = do
      status <- cuMemHostRegister p (n * sizeOf x) flags
      resultIfOk (status,HostPtr p)

{-# INLINE cuMemHostRegister #-}
{# fun unsafe cuMemHostRegister
  { castPtr         `Ptr a'
  ,                 `Int'
  , combineBitMasks `[AllocFlag]' } -> `Status' cToEnum #}
#endif

-- |
-- Unmaps the memory from the given pointer, and makes it pageable again.
--
-- This function is not yet implemented on Mac OS X. Requires cuda-4.0.
--
{-# INLINEABLE unregisterArray #-}
unregisterArray :: HostPtr a -> IO (Ptr a)
#if CUDA_VERSION < 4000
unregisterArray _           = requireSDK 4.0 "unregisterArray"
#else
unregisterArray (HostPtr !p) = do
  status <- cuMemHostUnregister p
  resultIfOk (status,p)

{-# INLINE cuMemHostUnregister #-}
{# fun unsafe cuMemHostUnregister
  { castPtr `Ptr a' } -> `Status' cToEnum #}
#endif

--------------------------------------------------------------------------------
-- Device Allocation
--------------------------------------------------------------------------------

-- |
-- Allocate a section of linear memory on the device, and return a reference to
-- it. The memory is sufficient to hold the given number of elements of storable
-- type. It is suitably aligned for any type, and is not cleared.
--
{-# INLINEABLE mallocArray #-}
mallocArray :: Storable a => Int -> IO (DevicePtr a)
mallocArray = doMalloc undefined
  where
    doMalloc :: Storable a' => a' -> Int -> IO (DevicePtr a')
    doMalloc x !n = resultIfOk =<< cuMemAlloc (n * sizeOf x)

{-# INLINE cuMemAlloc #-}
{# fun unsafe cuMemAlloc
  { alloca'- `DevicePtr a' peekDeviceHandle*
  ,          `Int'                           } -> `Status' cToEnum #}
  where
    alloca' !f = F.alloca $ \ !p -> poke p nullPtr >> f (castPtr p)

-- |
-- Execute a computation on the device, passing a pointer to a temporarily
-- allocated block of memory sufficient to hold the given number of elements of
-- storable type. The memory is freed when the computation terminates (normally
-- or via an exception), so the pointer must not be used after this.
--
-- Note that kernel launches can be asynchronous, so you may want to add a
-- synchronisation point using 'sync' as part of the computation.
--
{-# INLINEABLE allocaArray #-}
allocaArray :: Storable a => Int -> (DevicePtr a -> IO b) -> IO b
allocaArray !n = bracket (mallocArray n) free

-- |
-- Release a section of device memory
--
{-# INLINEABLE free #-}
free :: DevicePtr a -> IO ()
free !dp = nothingIfOk =<< cuMemFree dp

{-# INLINE cuMemFree #-}
{# fun unsafe cuMemFree
  { useDeviceHandle `DevicePtr a' } -> `Status' cToEnum #}

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

-- |
-- Copy a number of elements from the device to host memory. This is a
-- synchronous operation
--
{-# INLINEABLE peekArray #-}
peekArray :: Storable a => Int -> DevicePtr a -> Ptr a -> IO ()
peekArray !n !dptr !hptr = doPeek undefined dptr
  where
    doPeek :: Storable a' => a' -> DevicePtr a' -> IO ()
    doPeek x _ = nothingIfOk =<< cuMemcpyDtoH hptr dptr (n * sizeOf x)

{-# INLINE cuMemcpyDtoH #-}
{# fun unsafe cuMemcpyDtoH
  { castPtr         `Ptr a'
  , useDeviceHandle `DevicePtr a'
  ,                 `Int'         } -> `Status' cToEnum #}

-- |
-- Copy memory from the device asynchronously, possibly associated with a
-- particular stream. The destination host memory must be page-locked.
--
{-# INLINEABLE peekArrayAsync #-}
peekArrayAsync :: Storable a => Int -> DevicePtr a -> HostPtr a -> Maybe Stream -> IO ()
peekArrayAsync !n !dptr !hptr !mst = doPeek undefined dptr
  where
    doPeek :: Storable a' => a' -> DevicePtr a' -> IO ()
    doPeek x _ = nothingIfOk =<< cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) (fromMaybe (Stream nullPtr) mst)

{-# INLINE cuMemcpyDtoHAsync #-}
{# fun unsafe cuMemcpyDtoHAsync
  { useHP           `HostPtr a'
  , useDeviceHandle `DevicePtr a'
  ,                 `Int'
  , useStream       `Stream'      } -> `Status' cToEnum #}
  where
    useHP = castPtr . useHostPtr

-- |
-- Copy a number of elements from the device into a new Haskell list. Note that
-- this requires two memory copies: firstly from the device into a heap
-- allocated array, and from there marshalled into a list.
--
{-# INLINEABLE peekListArray #-}
peekListArray :: Storable a => Int -> DevicePtr a -> IO [a]
peekListArray !n !dptr =
  F.allocaArray n $ \p -> do
    peekArray   n dptr p
    F.peekArray n p

-- |
-- Copy a number of elements onto the device. This is a synchronous operation
--
{-# INLINEABLE pokeArray #-}
pokeArray :: Storable a => Int -> Ptr a -> DevicePtr a -> IO ()
pokeArray !n !hptr !dptr = doPoke undefined dptr
  where
    doPoke :: Storable a' => a' -> DevicePtr a' -> IO ()
    doPoke x _ = nothingIfOk =<< cuMemcpyHtoD dptr hptr (n * sizeOf x)

{-# INLINE cuMemcpyHtoD #-}
{# fun unsafe cuMemcpyHtoD
  { useDeviceHandle `DevicePtr a'
  , castPtr         `Ptr a'
  ,                 `Int'         } -> `Status' cToEnum #}

-- |
-- Copy memory onto the device asynchronously, possibly associated with a
-- particular stream. The source host memory must be page-locked.
--
{-# INLINEABLE pokeArrayAsync #-}
pokeArrayAsync :: Storable a => Int -> HostPtr a -> DevicePtr a -> Maybe Stream -> IO ()
pokeArrayAsync !n !hptr !dptr !mst = dopoke undefined dptr
  where
    dopoke :: Storable a' => a' -> DevicePtr a' -> IO ()
    dopoke x _ = nothingIfOk =<< cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) (fromMaybe (Stream nullPtr) mst)

{-# INLINE cuMemcpyHtoDAsync #-}
{# fun unsafe cuMemcpyHtoDAsync
  { useDeviceHandle `DevicePtr a'
  , useHP           `HostPtr a'
  ,                 `Int'
  , useStream       `Stream'      } -> `Status' cToEnum #}
  where
    useHP = castPtr . useHostPtr

-- |
-- Write a list of storable elements into a device array. The device array must
-- be sufficiently large to hold the entire list. This requires two marshalling
-- operations.
--
{-# INLINEABLE pokeListArray #-}
pokeListArray :: Storable a => [a] -> DevicePtr a -> IO ()
pokeListArray !xs !dptr = F.withArrayLen xs $ \ !len !p -> pokeArray len p dptr

-- |
-- Copy the given number of elements from the first device array (source) to the
-- second (destination). The copied areas may not overlap. This operation is
-- asynchronous with respect to the host, but will never overlap with kernel
-- execution.
--
{-# INLINEABLE copyArrayAsync #-}
copyArrayAsync :: Storable a => Int -> DevicePtr a -> DevicePtr a -> IO ()
copyArrayAsync !n = docopy undefined
  where
    docopy :: Storable a' => a' -> DevicePtr a' -> DevicePtr a' -> IO ()
    docopy x src dst = nothingIfOk =<< cuMemcpyDtoD dst src (n * sizeOf x)

{-# INLINE cuMemcpyDtoD #-}
{# fun unsafe cuMemcpyDtoD
  { useDeviceHandle `DevicePtr a'
  , useDeviceHandle `DevicePtr a'
  ,                 `Int'         } -> `Status' cToEnum #}

-- |
-- Copies an array from device memory in one context to device memory in another
-- context. Note that this function is asynchronous with respect to the host,
-- but serialised with respect to all pending and future asynchronous work in
-- the source and destination contexts. To avoid this synchronisation, use
-- 'copyArrayPeerAsync' instead.
--
{-# INLINEABLE copyArrayPeer #-}
copyArrayPeer :: Storable a
              => Int                            -- ^ number of array elements
              -> DevicePtr a -> Context         -- ^ source array and context
              -> DevicePtr a -> Context         -- ^ destination array and context
              -> IO ()
#if CUDA_VERSION < 4000
copyArrayPeer _ _ _ _ _                    = requireSDK 4.0 "copyArrayPeer"
#else
copyArrayPeer !n !src !srcCtx !dst !dstCtx = go undefined src dst
  where
    go :: Storable b => b -> DevicePtr b -> DevicePtr b -> IO ()
    go x _ _ = nothingIfOk =<< cuMemcpyPeer dst dstCtx src srcCtx (n * sizeOf x)

{-# INLINE cuMemcpyPeer #-}
{# fun unsafe cuMemcpyPeer
  { useDeviceHandle `DevicePtr a'
  , useContext      `Context'
  , useDeviceHandle `DevicePtr a'
  , useContext      `Context'
  ,                 `Int'         } -> `Status' cToEnum #}
#endif

-- |
-- Copies from device memory in one context to device memory in another context.
-- Note that this function is asynchronous with respect to the host and all work
-- in other streams and devices.
--
{-# INLINEABLE copyArrayPeerAsync #-}
copyArrayPeerAsync :: Storable a
                   => Int                       -- ^ number of array elements
                   -> DevicePtr a -> Context    -- ^ source array and context
                   -> DevicePtr a -> Context    -- ^ destination array and device context
                   -> Maybe Stream              -- ^ stream to associate with
                   -> IO ()
#if CUDA_VERSION < 4000
copyArrayPeerAsync _ _ _ _ _ _                      = requireSDK 4.0 "copyArrayPeerAsync"
#else
copyArrayPeerAsync !n !src !srcCtx !dst !dstCtx !st = go undefined src dst
  where
    go :: Storable b => b -> DevicePtr b -> DevicePtr b -> IO ()
    go x _ _ = nothingIfOk =<< cuMemcpyPeerAsync dst dstCtx src srcCtx (n * sizeOf x) stream
    stream   = fromMaybe (Stream nullPtr) st

{-# INLINE cuMemcpyPeerAsync #-}
{# fun unsafe cuMemcpyPeerAsync
  { useDeviceHandle `DevicePtr a'
  , useContext      `Context'
  , useDeviceHandle `DevicePtr a'
  , useContext      `Context'
  ,                 `Int'
  , useStream       `Stream'      } -> `Status' cToEnum #}
#endif

--------------------------------------------------------------------------------
-- Combined Allocation and Marshalling
--------------------------------------------------------------------------------

-- |
-- Write a list of storable elements into a newly allocated device array,
-- returning the device pointer together with the number of elements that were
-- written. Note that this requires two memory copies: firstly from a Haskell
-- list to a heap allocated array, and from there onto the graphics device. The
-- memory should be 'free'd when no longer required.
--
{-# INLINEABLE newListArrayLen #-}
newListArrayLen :: Storable a => [a] -> IO (DevicePtr a, Int)
newListArrayLen xs =
  F.withArrayLen xs                     $ \len p ->
  bracketOnError (mallocArray len) free $ \d_xs  -> do
    pokeArray len p d_xs
    return (d_xs, len)

-- |
-- Write a list of storable elements into a newly allocated device array. This
-- is 'newListArrayLen' composed with 'fst'.
--
{-# INLINEABLE newListArray #-}
newListArray :: Storable a => [a] -> IO (DevicePtr a)
newListArray xs = fst `fmap` newListArrayLen xs

-- |
-- Temporarily store a list of elements into a newly allocated device array. An
-- IO action is applied to to the array, the result of which is returned.
-- Similar to 'newListArray', this requires copying the data twice.
--
-- As with 'allocaArray', the memory is freed once the action completes, so you
-- should not return the pointer from the action, and be wary of asynchronous
-- kernel execution.
--
{-# INLINEABLE withListArray #-}
withListArray :: Storable a => [a] -> (DevicePtr a -> IO b) -> IO b
withListArray xs = withListArrayLen xs . const

-- |
-- A variant of 'withListArray' which also supplies the number of elements in
-- the array to the applied function
--
{-# INLINEABLE withListArrayLen #-}
withListArrayLen :: Storable a => [a] -> (Int -> DevicePtr a -> IO b) -> IO b
withListArrayLen xs f =
  bracket (newListArrayLen xs) (free . fst) (uncurry . flip $ f)
--
-- XXX: Will this attempt to double-free the device array on error (together
-- with newListArrayLen)?
--

--------------------------------------------------------------------------------
-- Utility
--------------------------------------------------------------------------------

-- |
-- Set a number of data elements to the specified value, which may be either 8-,
-- 16-, or 32-bits wide.
--
{-# INLINEABLE memset #-}
memset :: Storable a => DevicePtr a -> Int -> a -> IO ()
memset !dptr !n !val = case sizeOf val of
    1 -> nothingIfOk =<< cuMemsetD8  dptr val n
    2 -> nothingIfOk =<< cuMemsetD16 dptr val n
    4 -> nothingIfOk =<< cuMemsetD32 dptr val n
    _ -> cudaError "can only memset 8-, 16-, and 32-bit values"

--
-- We use unsafe coerce below to reinterpret the bits of the value to memset as,
-- into the integer type required by the setting functions.
--
{-# INLINE cuMemsetD8 #-}
{# fun unsafe cuMemsetD8
  { useDeviceHandle `DevicePtr a'
  , unsafeCoerce    `a'
  ,                 `Int'         } -> `Status' cToEnum #}

{-# INLINE cuMemsetD16 #-}
{# fun unsafe cuMemsetD16
  { useDeviceHandle `DevicePtr a'
  , unsafeCoerce    `a'
  ,                 `Int'         } -> `Status' cToEnum #}

{-# INLINE cuMemsetD32 #-}
{# fun unsafe cuMemsetD32
  { useDeviceHandle `DevicePtr a'
  , unsafeCoerce    `a'
  ,                 `Int'         } -> `Status' cToEnum #}

-- |
-- Set the number of data elements to the specified value, which may be either
-- 8-, 16-, or 32-bits wide. The operation is asynchronous and may optionally be
-- associated with a stream. Requires cuda-3.2.
--
{-# INLINEABLE memsetAsync #-}
memsetAsync :: Storable a => DevicePtr a -> Int -> a -> Maybe Stream -> IO ()
#if CUDA_VERSION < 3020
memsetAsync _ _ _ _            = requireSDK 3.2 "memsetAsync"
#else
memsetAsync !dptr !n !val !mst = case sizeOf val of
    1 -> nothingIfOk =<< cuMemsetD8Async  dptr val n stream
    2 -> nothingIfOk =<< cuMemsetD16Async dptr val n stream
    4 -> nothingIfOk =<< cuMemsetD32Async dptr val n stream
    _ -> cudaError "can only memset 8-, 16-, and 32-bit values"
    where
      stream = fromMaybe (Stream nullPtr) mst

{-# INLINE cuMemsetD8Async #-}
{# fun unsafe cuMemsetD8Async
  { useDeviceHandle `DevicePtr a'
  , unsafeCoerce    `a'
  ,                 `Int'
  , useStream       `Stream'      } -> `Status' cToEnum #}

{-# INLINE cuMemsetD16Async #-}
{# fun unsafe cuMemsetD16Async
  { useDeviceHandle `DevicePtr a'
  , unsafeCoerce    `a'
  ,                 `Int'
  , useStream       `Stream'      } -> `Status' cToEnum #}

{-# INLINE cuMemsetD32Async #-}
{# fun unsafe cuMemsetD32Async
  { useDeviceHandle `DevicePtr a'
  , unsafeCoerce    `a'
  ,                 `Int'
  , useStream       `Stream'      } -> `Status' cToEnum #}
#endif

-- |
-- Return the device pointer associated with a mapped, pinned host buffer, which
-- was allocated with the 'DeviceMapped' option by 'mallocHostArray'.
--
-- Currently, no options are supported and this must be empty.
--
{-# INLINEABLE getDevicePtr #-}
getDevicePtr :: [AllocFlag] -> HostPtr a -> IO (DevicePtr a)
getDevicePtr !flags !hp = resultIfOk =<< cuMemHostGetDevicePointer hp flags

{-# INLINE cuMemHostGetDevicePointer #-}
{# fun unsafe cuMemHostGetDevicePointer
  { alloca'-        `DevicePtr a' peekDeviceHandle*
  , useHP           `HostPtr a'
  , combineBitMasks `[AllocFlag]'                   } -> `Status' cToEnum #}
  where
    alloca'  = F.alloca
    useHP    = castPtr . useHostPtr

-- |
-- Return the base address and allocation size of the given device pointer
--
{-# INLINEABLE getBasePtr #-}
getBasePtr :: DevicePtr a -> IO (DevicePtr a, Int64)
getBasePtr !dptr = do
  (status,base,size) <- cuMemGetAddressRange dptr
  resultIfOk (status, (base,size))

{-# INLINE cuMemGetAddressRange #-}
{# fun unsafe cuMemGetAddressRange
  { alloca'-        `DevicePtr a' peekDeviceHandle*
  , alloca'-        `Int64'       peekIntConv*
  , useDeviceHandle `DevicePtr a'                   } -> `Status' cToEnum #}
  where
    alloca' :: Storable a => (Ptr a -> IO b) -> IO b
    alloca' = F.alloca

-- |
-- Return the amount of free and total memory respectively available to the
-- current context (bytes)
--
{-# INLINEABLE getMemInfo #-}
getMemInfo :: IO (Int64, Int64)
getMemInfo = do
  (!status,!f,!t) <- cuMemGetInfo
  resultIfOk (status,(f,t))

{-# INLINE cuMemGetInfo #-}
{# fun unsafe cuMemGetInfo
  { alloca'- `Int64' peekIntConv*
  , alloca'- `Int64' peekIntConv* } -> `Status' cToEnum #}
  where
    alloca' = F.alloca

--------------------------------------------------------------------------------
-- Internal
--------------------------------------------------------------------------------

type DeviceHandle = {# type CUdeviceptr #}

-- Lift an opaque handle to a typed DevicePtr representation. This occasions
-- arcane distinctions for the different driver versions and Tesla (compute 1.x)
-- and Fermi (compute 2.x) class architectures on 32- and 64-bit hosts.
--
{-# INLINE peekDeviceHandle #-}
peekDeviceHandle :: Ptr DeviceHandle -> IO (DevicePtr a)
peekDeviceHandle !p = DevicePtr . intPtrToPtr . fromIntegral <$> peek p

-- Use a device pointer as an opaque handle type
--
{-# INLINE useDeviceHandle #-}
useDeviceHandle :: DevicePtr a -> DeviceHandle
useDeviceHandle = fromIntegral . ptrToIntPtr . useDevicePtr