Fix conflict in Screen, adding the screenGetRGBAColormap function.

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget Screen
--
--  Author : Duncan Coutts
--
--  Created: 29 October 2007
--
--  Copyright (C) 2007 Duncan Coutts
--
--  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)
--
-- Object representing a physical screen
--
-- * Module available since Gdk version 2.2
--
module Graphics.UI.Gtk.Gdk.Screen (

-- * Detail
--
-- | 'Screen' objects are the GDK representation of a physical screen. It is
-- used throughout GDK and Gtk+ to specify which screen the top level windows
-- are to be displayed on. It is also used to query the screen specification
-- and default settings such as the default colormap
-- ('screenGetDefaultColormap'), the screen width ('screenGetWidth'), etc.
--
-- Note that a screen may consist of multiple monitors which are merged to
-- form a large screen area.

-- * Class Hierarchy
--
-- |
-- @
-- |  'GObject'
-- |   +----Screen
-- @

#if GTK_CHECK_VERSION(2,2,0)
-- * Types
  Screen,
  ScreenClass,
  castToScreen,
  toScreen,

-- * Methods
  screenGetDefault,
  screenGetSystemColormap,
#if GTK_CHECK_VERSION(2,8,0)
  screenGetRGBAColormap,
#endif
#ifndef DISABLE_DEPRECATED
  screenGetDefaultColormap,
  screenSetDefaultColormap,
#endif

--  screenGetSystemVisual,
#if GTK_CHECK_VERSION(2,10,0)
  screenIsComposited,
#endif
  screenGetRootWindow,
  screenGetDisplay,
  screenGetNumber,
  screenGetWidth,
  screenGetHeight,
  screenGetWidthMm,
  screenGetHeightMm,
  screenGetWidthMM,
  screenGetHeightMM,
  screenListVisuals,
  screenGetToplevelWindows,
  screenMakeDisplayName,
  screenGetNMonitors,
  screenGetMonitorGeometry,
  screenGetMonitorAtPoint,
  screenGetMonitorAtWindow,
#if GTK_CHECK_VERSION(2,14,0)
  screenGetMonitorHeightMm,
  screenGetMonitorWidthMm,
  screenGetMonitorPlugName,
#endif
--  screenGetSetting,
#if GTK_CHECK_VERSION(2,10,0)
  screenGetActiveWindow,
  screenGetWindowStack,
#endif

-- * Attributes
  screenFontOptions,
  screenResolution,
  screenDefaultColormap,

-- * Signals
  screenSizeChanged,
#if GTK_CHECK_VERSION(2,10,0)
  screenCompositedChanged,
#if GTK_CHECK_VERSION(2,14,0)
  screenMonitorsChanged,
#endif
#endif

#endif
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.Signals
import System.Glib.Attributes
import System.Glib.Properties
import System.Glib.GList
{#import Graphics.UI.Gtk.Types#}
import Graphics.UI.Gtk.Signals
import Graphics.Rendering.Cairo.Types ( FontOptions(..), mkFontOptions,
                                        withFontOptions)
import Graphics.UI.Gtk.General.Structs ( Rectangle(..) )

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

#if GTK_CHECK_VERSION(2,2,0)
--------------------
-- Methods

-- | Gets the default screen for the default display. (See
-- 'displayGetDefault').
--
screenGetDefault ::
    IO (Maybe Screen) -- ^ returns a 'Screen', or @Nothing@ if there is no
                      --  default display.
screenGetDefault =
  maybeNull (makeNewGObject mkScreen) $
  {# call gdk_screen_get_default #}

screenGetDefaultColormap :: Screen
 -> IO Colormap -- ^ returns the default 'Colormap'.
screenGetDefaultColormap self =
  makeNewGObject mkColormap $
  {# call gdk_screen_get_default_colormap #}
    self
{-# DEPRECATED screenGetDefaultColormap "instead of 'screenGetDefaultColormap obj' use 'get obj screenDefaultColormap'" #-}

screenSetDefaultColormap :: Screen
 -> Colormap -- ^ @colormap@ - a 'Colormap'
 -> IO ()
screenSetDefaultColormap self colormap =
  {# call gdk_screen_set_default_colormap #}
    self
    colormap
{-# DEPRECATED screenSetDefaultColormap "instead of 'screenSetDefaultColormap obj value' use 'set obj [ screenDefaultColormap := value ]'" #-}

-- | Gets the system default colormap for @screen@
--
screenGetSystemColormap :: Screen
 -> IO Colormap -- ^ returns the default colormap for @screen@.
screenGetSystemColormap self =
  makeNewGObject mkColormap $
  {# call gdk_screen_get_system_colormap #}
    self

#if GTK_CHECK_VERSION(2,8,0)
-- | Gets a colormap to use for creating windows or pixmaps with an alpha
-- channel. The windowing system on which Gtk+ is running may not support this
-- capability, in which case @Nothing@ will be returned. Even if a
-- non-@Nothing@ value is returned, its possible that the window's alpha
-- channel won't be honored when displaying the window on the screen: in
-- particular, for X an appropriate windowing manager and compositing manager
-- must be running to provide appropriate display.
--
-- * Available since Gdk version 2.8
--
screenGetRGBAColormap :: Screen
 -> IO (Maybe Colormap) -- ^ returns a colormap to use for windows with an
                        -- alpha channel or @Nothing@ if the capability is not
                       -- available.
screenGetRGBAColormap self =
  maybeNull (makeNewGObject mkColormap) $
  {# call gdk_screen_get_rgba_colormap #}
    self
#endif

-- | Get the system's default visual for @screen@. This is the visual for the
-- root window of the display.
--
screenGetSystemVisual :: Screen
 -> IO Visual -- ^ returns the system visual
screenGetSystemVisual self =
  makeNewGObject mkVisual $
  {# call gdk_screen_get_system_visual #}
    self

#if GTK_CHECK_VERSION(2,10,0)
-- | Returns whether windows with an RGBA visual can reasonably be expected to
-- have their alpha channel drawn correctly on the screen.
--
-- On X11 this function returns whether a compositing manager is compositing
-- @screen@.
--
-- * Available since Gdk version 2.10
--
screenIsComposited :: Screen
 -> IO Bool -- ^ returns Whether windows with RGBA visuals can reasonably be
            -- expected to have their alpha channels drawn correctly on the
            -- screen.
screenIsComposited self =
  liftM toBool $
  {# call gdk_screen_is_composited #}
    self
#endif

-- | Gets the root window of @screen@.
--
screenGetRootWindow :: Screen
 -> IO DrawWindow -- ^ returns the root window
screenGetRootWindow self =
  makeNewGObject mkDrawWindow $
  {# call gdk_screen_get_root_window #}
    self

-- | Gets the display to which the @screen@ belongs.
--
screenGetDisplay :: Screen
 -> IO Display -- ^ returns the display to which @screen@ belongs
screenGetDisplay self =
  makeNewGObject mkDisplay $
  {# call gdk_screen_get_display #}
    self

-- | Gets the index of @screen@ among the screens in the display to which it
-- belongs. (See 'screenGetDisplay')
--
screenGetNumber :: Screen
 -> IO Int -- ^ returns the index
screenGetNumber self =
  liftM fromIntegral $
  {# call gdk_screen_get_number #}
    self

-- | Gets the width of @screen@ in pixels
--
screenGetWidth :: Screen
 -> IO Int -- ^ returns the width of @screen@ in pixels.
screenGetWidth self =
  liftM fromIntegral $
  {# call gdk_screen_get_width #}
    self

-- | Gets the height of @screen@ in pixels
--
screenGetHeight :: Screen
 -> IO Int -- ^ returns the height of @screen@ in pixels.
screenGetHeight self =
  liftM fromIntegral $
  {# call gdk_screen_get_height #}
    self

-- | Gets the width of @screen@ in millimeters. Note that on some X servers
-- this value will not be correct.
--
screenGetWidthMM :: Screen
 -> IO Int -- ^ returns the width of @screen@ in millimeters.
screenGetWidthMM self =
  liftM fromIntegral $
  {# call gdk_screen_get_width_mm #}
    self

screenGetWidthMm = screenGetWidthMM

-- | Returns the height of @screen@ in millimeters. Note that on some X
-- servers this value will not be correct.
--
screenGetHeightMM :: Screen
 -> IO Int -- ^ returns the heigth of @screen@ in millimeters.
screenGetHeightMM self =
  liftM fromIntegral $
  {# call gdk_screen_get_height_mm #}
    self

screenGetHeightMm = screenGetHeightMM

-- | Lists the available visuals for the specified @screen@. A visual
-- describes a hardware image data format. For example, a visual might support
-- 24-bit color, or 8-bit color, and might expect pixels to be in a certain
-- format.
--
screenListVisuals :: Screen
 -> IO [Visual] -- ^ returns a list of visuals
screenListVisuals self =
  {# call gdk_screen_list_visuals #}
    self
  >>= fromGList
  >>= mapM (makeNewGObject mkVisual . return)

-- | Obtains a list of all toplevel windows known to GDK on the screen
-- @screen@. A toplevel window is a child of the root window (see
-- 'getDefaultRootWindow').
--
screenGetToplevelWindows :: Screen
 -> IO [DrawWindow] -- ^ returns list of toplevel windows
screenGetToplevelWindows self =
  {# call gdk_screen_get_toplevel_windows #}
    self
  >>= fromGList
  >>= mapM (makeNewGObject mkDrawWindow . return)

-- | Determines the name to pass to 'displayOpen' to get a 'Display' with this
-- screen as the default screen.
--
screenMakeDisplayName :: Screen
 -> IO String -- ^ returns a newly allocated string
screenMakeDisplayName self =
  {# call gdk_screen_make_display_name #}
    self
  >>= readUTFString

-- | Returns the number of monitors which @screen@ consists of.
--
screenGetNMonitors :: Screen
 -> IO Int -- ^ returns number of monitors which @screen@ consists of.
screenGetNMonitors self =
  liftM fromIntegral $
  {# call gdk_screen_get_n_monitors #}
    self

-- | Retrieves the 'Rectangle' representing the size and
-- position of the individual monitor within the entire screen area.
--
-- Note that the size of the entire screen area can be retrieved via
-- 'screenGetWidth' and 'screenGetHeight'.
--
screenGetMonitorGeometry :: Screen
 -> Int               -- ^ @monitorNum@ - the monitor number.
 -> IO Rectangle
screenGetMonitorGeometry self monitorNum =
  alloca $ \rPtr -> do
  {# call gdk_screen_get_monitor_geometry #}
    self
    (fromIntegral monitorNum)
    (castPtr rPtr)
  peek rPtr

-- | Returns the monitor number in which the point (@x@,@y@) is located.
--
screenGetMonitorAtPoint :: Screen
 -> Int    -- ^ @x@ - the x coordinate in the virtual screen.
 -> Int    -- ^ @y@ - the y coordinate in the virtual screen.
 -> IO Int -- ^ returns the monitor number in which the point (@x@,@y@) lies,
           -- or a monitor close to (@x@,@y@) if the point is not in any
           -- monitor.
screenGetMonitorAtPoint self x y =
  liftM fromIntegral $
  {# call gdk_screen_get_monitor_at_point #}
    self
    (fromIntegral x)
    (fromIntegral y)

-- | Returns the number of the monitor in which the largest area of the
-- bounding rectangle of @window@ resides.
--
screenGetMonitorAtWindow :: Screen
 -> DrawWindow -- ^ @window@ - a 'DrawWindow'
 -> IO Int     -- ^ returns the monitor number in which most of @window@ is
               -- located, or if @window@ does not intersect any monitors, a
               -- monitor, close to @window@.
screenGetMonitorAtWindow self window =
  liftM fromIntegral $
  {# call gdk_screen_get_monitor_at_window #}
    self
    window

#if GTK_CHECK_VERSION(2,14,0)
-- | Gets the height in millimeters of the specified monitor.
--
-- * Available since Gdk version 2.14
--
screenGetMonitorHeightMm :: Screen
 -> Int    -- ^ @monitorNum@ - number of the monitor
 -> IO Int -- ^ returns the height of the monitor, or -1 if not available
screenGetMonitorHeightMm self monitorNum =
  liftM fromIntegral $
  {# call gdk_screen_get_monitor_height_mm #}
    self
    (fromIntegral monitorNum)

-- | Gets the width in millimeters of the specified monitor, if available.
--
-- * Available since Gdk version 2.14
--
screenGetMonitorWidthMm :: Screen
 -> Int    -- ^ @monitorNum@ - number of the monitor
 -> IO Int -- ^ returns the width of the monitor, or -1 if not available
screenGetMonitorWidthMm self monitorNum =
  liftM fromIntegral $
  {# call gdk_screen_get_monitor_width_mm #}
    self
    (fromIntegral monitorNum)

-- | Returns the output name of the specified monitor. Usually something like
-- VGA, DVI, or TV, not the actual product name of the display device.
--
-- * Available since Gdk version 2.14
--
screenGetMonitorPlugName :: Screen
 -> Int       -- ^ @monitorNum@ - number of the monitor
 -> IO (Maybe String) -- ^ returns a newly-allocated string containing the name of the
              -- monitor, or @Nothing@ if the name cannot be determined
screenGetMonitorPlugName self monitorNum = do
  sPtr <-
    {# call gdk_screen_get_monitor_plug_name #}
    self
    (fromIntegral monitorNum)
  if sPtr==nullPtr then return Nothing else liftM Just $ readUTFString sPtr
#endif

{-
-- | Retrieves a desktop-wide setting such as double-click time for the
-- 'Screen'@screen@.
--
-- FIXME needs a list of valid settings here, or a link to more information.
--
screenGetSetting :: Screen
 -> String      -- ^ @name@ - the name of the setting
 -> {-GValue*-} -- ^ @value@ - location to store the value of the setting
 -> IO Bool     -- ^ returns @True@ if the setting existed and a value was
                -- stored in @value@, @False@ otherwise.
screenGetSetting self name value =
  liftM toBool $
  withUTFString name $ \namePtr ->
  {# call gdk_screen_get_setting #}
    self
    namePtr
    {-value-}
-}

-- these are only used for the attributes
screenGetFontOptions :: Screen
 -> IO (Maybe FontOptions)
screenGetFontOptions self = do
  fPtr <- {# call gdk_screen_get_font_options #} self
  if fPtr==nullPtr then return Nothing else liftM Just $ mkFontOptions (castPtr fPtr)

screenSetFontOptions :: Screen
 -> Maybe FontOptions
 -> IO ()
screenSetFontOptions self Nothing =
  {# call gdk_screen_set_font_options #} self nullPtr
screenSetFontOptions self (Just options) =
  withFontOptions options $ \fPtr ->
    {# call gdk_screen_set_font_options #} self (castPtr fPtr)

#if GTK_CHECK_VERSION(2,10,0)
-- | Returns the currently active window of this screen.
--
-- On X11, this is done by inspecting the _NET_ACTIVE_WINDOW property on the
-- root window, as described in the Extended Window Manager Hints. If there is
-- no currently currently active window, or the window manager does not support
-- the _NET_ACTIVE_WINDOW hint, this function returns @Nothing@.
--
-- On other platforms, this function may return @Nothing@, depending on whether
-- it is implementable on that platform.
--
-- * Available since Gdk version 2.10
--
screenGetActiveWindow :: Screen
 -> IO (Maybe DrawWindow) -- ^ returns the currently active window, or
                          -- @Nothing@.
screenGetActiveWindow self =
  maybeNull (makeNewGObject mkDrawWindow) $
  {# call gdk_screen_get_active_window #}
    self
#endif

-- | Returns a list of 'DrawWindow's representing the
-- current window stack.
--
-- On X11, this is done by inspecting the _NET_CLIENT_LIST_STACKING property
-- on the root window, as described in the Extended Window Manager Hints. If
-- the window manager does not support the _NET_CLIENT_LIST_STACKING hint, this
-- function returns @Nothing@.
--
-- On other platforms, this function may return @Nothing@, depending on whether it is
-- implementable on that platform.
--
-- * Available since Gdk version 2.10
--
screenGetWindowStack :: Screen
 -> IO (Maybe [DrawWindow]) -- ^ returns a list of 'DrawWindow's for the
                            -- current window stack, or @Nothing@.
screenGetWindowStack self = do
  lPtr <- {# call gdk_screen_get_window_stack #} self
  if lPtr==nullPtr then return Nothing else liftM Just $ do
  fromGList lPtr >>= mapM (constructNewGObject mkDrawWindow . return)
#endif

--------------------
-- Attributes

-- | The default font options for the screen.
--
screenFontOptions :: Attr Screen (Maybe FontOptions)
screenFontOptions = newAttr
  screenGetFontOptions
  screenSetFontOptions

-- | The resolution for fonts on the screen.
--
-- Default value: -1
--
screenResolution :: Attr Screen Double
screenResolution = newAttrFromDoubleProperty "resolution"

-- | Sets the default @colormap@ for @screen@.
--
-- Gets the default colormap for @screen@.
--
screenDefaultColormap :: Attr Screen Colormap
screenDefaultColormap = newAttr
  screenGetDefaultColormap
  screenSetDefaultColormap

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

-- | The ::size_changed signal is emitted when the pixel width or height of a
-- screen changes.
--
screenSizeChanged :: ScreenClass self => Signal self (IO ())
screenSizeChanged = Signal (connect_NONE__NONE "size_changed")

#if GTK_CHECK_VERSION(2,10,0)
-- | The 'screenCompositedChanged' signal is emitted when the composited status of
-- the screen changes
--
-- * Available since Gdk version 2.10
--
screenCompositedChanged :: ScreenClass self => Signal self (IO ())
screenCompositedChanged = Signal (connect_NONE__NONE "composited_changed")

#if GTK_CHECK_VERSION(2,14,0)
-- | The 'screenMonitorsChanged' signal is emitted when the number, size or
-- position of the monitors attached to the screen change.
--
-- Only for X for now. Future implementations for Win32 and OS X may be a
-- possibility.
--
-- * Available since Gdk version 2.14
--
screenMonitorsChanged :: ScreenClass self => Signal self (IO ())
screenMonitorsChanged = Signal (connect_NONE__NONE "monitors-changed")
#endif
#endif

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget Screen
--
--  Author : Duncan Coutts
--
--  Created: 29 October 2007
--
--  Copyright (C) 2007 Duncan Coutts
--
--  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)
--
-- Object representing a physical screen
--
-- * Module available since Gdk version 2.2
--
module Graphics.UI.Gtk.Gdk.Screen (

-- * Detail
--
-- | 'Screen' objects are the GDK representation of a physical screen. It is
-- used throughout GDK and Gtk+ to specify which screen the top level windows
-- are to be displayed on. It is also used to query the screen specification
-- and default settings such as the default colormap
-- ('screenGetDefaultColormap'), the screen width ('screenGetWidth'), etc.
--
-- Note that a screen may consist of multiple monitors which are merged to
-- form a large screen area.

-- * Class Hierarchy
--
-- |
-- @
-- |  'GObject'
-- |   +----Screen
-- @

#if GTK_CHECK_VERSION(2,2,0)
-- * Types
  Screen,
  ScreenClass,
  castToScreen,
  toScreen,

-- * Methods
  screenGetDefault,
  screenGetSystemColormap,
--  screenGetSystemVisual,
#if GTK_CHECK_VERSION(2,10,0)
  screenIsComposited,
#endif
  screenGetRootWindow,
  screenGetDisplay,
  screenGetNumber,
  screenGetWidth,
  screenGetHeight,
  screenGetWidthMm,
  screenGetHeightMm,
  screenGetWidthMM,
  screenGetHeightMM,
  screenListVisuals,
  screenGetToplevelWindows,
  screenMakeDisplayName,
  screenGetNMonitors,
  screenGetMonitorGeometry,
  screenGetMonitorAtPoint,
  screenGetMonitorAtWindow,
#if GTK_CHECK_VERSION(2,14,0)
  screenGetMonitorHeightMm,
  screenGetMonitorWidthMm,
  screenGetMonitorPlugName,
#endif
--  screenGetSetting,
#if GTK_CHECK_VERSION(2,10,0)
  screenGetActiveWindow,
  screenGetWindowStack,
#endif

-- * Attributes
  screenFontOptions,
  screenResolution,
  screenDefaultColormap,

-- * Signals
  screenSizeChanged,
#if GTK_CHECK_VERSION(2,10,0)
  screenCompositedChanged,
#if GTK_CHECK_VERSION(2,14,0)
  screenMonitorsChanged,
#endif
#endif

#endif
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.Signals
import System.Glib.Attributes
import System.Glib.Properties
import System.Glib.GList
{#import Graphics.UI.Gtk.Types#}
import Graphics.UI.Gtk.Signals
import Graphics.Rendering.Cairo.Types ( FontOptions(..), mkFontOptions,
                                        withFontOptions)
import Graphics.UI.Gtk.General.Structs ( Rectangle(..) )

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

#if GTK_CHECK_VERSION(2,2,0)
--------------------
-- Methods

-- | Gets the default screen for the default display. (See
-- 'displayGetDefault').
--
screenGetDefault ::
    IO (Maybe Screen) -- ^ returns a 'Screen', or @Nothing@ if there is no
                      --  default display.
screenGetDefault =
  maybeNull (makeNewGObject mkScreen) $
  {# call gdk_screen_get_default #}

screenGetDefaultColormap :: Screen
 -> IO Colormap -- ^ returns the default 'Colormap'.
screenGetDefaultColormap self =
  makeNewGObject mkColormap $
  {# call gdk_screen_get_default_colormap #}
    self
{-# DEPRECATED screenGetDefaultColormap "instead of 'screenGetDefaultColormap obj' use 'get obj screenDefaultColormap'" #-}

screenSetDefaultColormap :: Screen
 -> Colormap -- ^ @colormap@ - a 'Colormap'
 -> IO ()
screenSetDefaultColormap self colormap =
  {# call gdk_screen_set_default_colormap #}
    self
    colormap
{-# DEPRECATED screenSetDefaultColormap "instead of 'screenSetDefaultColormap obj value' use 'set obj [ screenDefaultColormap := value ]'" #-}

-- | Gets the system default colormap for @screen@
--
screenGetSystemColormap :: Screen
 -> IO Colormap -- ^ returns the default colormap for @screen@.
screenGetSystemColormap self =
  makeNewGObject mkColormap $
  {# call gdk_screen_get_system_colormap #}
    self

-- | Get the system's default visual for @screen@. This is the visual for the
-- root window of the display.
--
screenGetSystemVisual :: Screen
 -> IO Visual -- ^ returns the system visual
screenGetSystemVisual self =
  makeNewGObject mkVisual $
  {# call gdk_screen_get_system_visual #}
    self

#if GTK_CHECK_VERSION(2,10,0)
-- | Returns whether windows with an RGBA visual can reasonably be expected to
-- have their alpha channel drawn correctly on the screen.
--
-- On X11 this function returns whether a compositing manager is compositing
-- @screen@.
--
-- * Available since Gdk version 2.10
--
screenIsComposited :: Screen
 -> IO Bool -- ^ returns Whether windows with RGBA visuals can reasonably be
            -- expected to have their alpha channels drawn correctly on the
            -- screen.
screenIsComposited self =
  liftM toBool $
  {# call gdk_screen_is_composited #}
    self
#endif

-- | Gets the root window of @screen@.
--
screenGetRootWindow :: Screen
 -> IO DrawWindow -- ^ returns the root window
screenGetRootWindow self =
  makeNewGObject mkDrawWindow $
  {# call gdk_screen_get_root_window #}
    self

-- | Gets the display to which the @screen@ belongs.
--
screenGetDisplay :: Screen
 -> IO Display -- ^ returns the display to which @screen@ belongs
screenGetDisplay self =
  makeNewGObject mkDisplay $
  {# call gdk_screen_get_display #}
    self

-- | Gets the index of @screen@ among the screens in the display to which it
-- belongs. (See 'screenGetDisplay')
--
screenGetNumber :: Screen
 -> IO Int -- ^ returns the index
screenGetNumber self =
  liftM fromIntegral $
  {# call gdk_screen_get_number #}
    self

-- | Gets the width of @screen@ in pixels
--
screenGetWidth :: Screen
 -> IO Int -- ^ returns the width of @screen@ in pixels.
screenGetWidth self =
  liftM fromIntegral $
  {# call gdk_screen_get_width #}
    self

-- | Gets the height of @screen@ in pixels
--
screenGetHeight :: Screen
 -> IO Int -- ^ returns the height of @screen@ in pixels.
screenGetHeight self =
  liftM fromIntegral $
  {# call gdk_screen_get_height #}
    self

-- | Gets the width of @screen@ in millimeters. Note that on some X servers
-- this value will not be correct.
--
screenGetWidthMM :: Screen
 -> IO Int -- ^ returns the width of @screen@ in millimeters.
screenGetWidthMM self =
  liftM fromIntegral $
  {# call gdk_screen_get_width_mm #}
    self

screenGetWidthMm = screenGetWidthMM

-- | Returns the height of @screen@ in millimeters. Note that on some X
-- servers this value will not be correct.
--
screenGetHeightMM :: Screen
 -> IO Int -- ^ returns the heigth of @screen@ in millimeters.
screenGetHeightMM self =
  liftM fromIntegral $
  {# call gdk_screen_get_height_mm #}
    self

screenGetHeightMm = screenGetHeightMM

-- | Lists the available visuals for the specified @screen@. A visual
-- describes a hardware image data format. For example, a visual might support
-- 24-bit color, or 8-bit color, and might expect pixels to be in a certain
-- format.
--
screenListVisuals :: Screen
 -> IO [Visual] -- ^ returns a list of visuals
screenListVisuals self =
  {# call gdk_screen_list_visuals #}
    self
  >>= fromGList
  >>= mapM (makeNewGObject mkVisual . return)

-- | Obtains a list of all toplevel windows known to GDK on the screen
-- @screen@. A toplevel window is a child of the root window (see
-- 'getDefaultRootWindow').
--
screenGetToplevelWindows :: Screen
 -> IO [DrawWindow] -- ^ returns list of toplevel windows
screenGetToplevelWindows self =
  {# call gdk_screen_get_toplevel_windows #}
    self
  >>= fromGList
  >>= mapM (makeNewGObject mkDrawWindow . return)

-- | Determines the name to pass to 'displayOpen' to get a 'Display' with this
-- screen as the default screen.
--
screenMakeDisplayName :: Screen
 -> IO String -- ^ returns a newly allocated string
screenMakeDisplayName self =
  {# call gdk_screen_make_display_name #}
    self
  >>= readUTFString

-- | Returns the number of monitors which @screen@ consists of.
--
screenGetNMonitors :: Screen
 -> IO Int -- ^ returns number of monitors which @screen@ consists of.
screenGetNMonitors self =
  liftM fromIntegral $
  {# call gdk_screen_get_n_monitors #}
    self

-- | Retrieves the 'Rectangle' representing the size and
-- position of the individual monitor within the entire screen area.
--
-- Note that the size of the entire screen area can be retrieved via
-- 'screenGetWidth' and 'screenGetHeight'.
--
screenGetMonitorGeometry :: Screen
 -> Int               -- ^ @monitorNum@ - the monitor number.
 -> IO Rectangle
screenGetMonitorGeometry self monitorNum =
  alloca $ \rPtr -> do
  {# call gdk_screen_get_monitor_geometry #}
    self
    (fromIntegral monitorNum)
    (castPtr rPtr)
  peek rPtr

-- | Returns the monitor number in which the point (@x@,@y@) is located.
--
screenGetMonitorAtPoint :: Screen
 -> Int    -- ^ @x@ - the x coordinate in the virtual screen.
 -> Int    -- ^ @y@ - the y coordinate in the virtual screen.
 -> IO Int -- ^ returns the monitor number in which the point (@x@,@y@) lies,
           -- or a monitor close to (@x@,@y@) if the point is not in any
           -- monitor.
screenGetMonitorAtPoint self x y =
  liftM fromIntegral $
  {# call gdk_screen_get_monitor_at_point #}
    self
    (fromIntegral x)
    (fromIntegral y)

-- | Returns the number of the monitor in which the largest area of the
-- bounding rectangle of @window@ resides.
--
screenGetMonitorAtWindow :: Screen
 -> DrawWindow -- ^ @window@ - a 'DrawWindow'
 -> IO Int     -- ^ returns the monitor number in which most of @window@ is
               -- located, or if @window@ does not intersect any monitors, a
               -- monitor, close to @window@.
screenGetMonitorAtWindow self window =
  liftM fromIntegral $
  {# call gdk_screen_get_monitor_at_window #}
    self
    window

#if GTK_CHECK_VERSION(2,14,0)
-- | Gets the height in millimeters of the specified monitor.
--
-- * Available since Gdk version 2.14
--
screenGetMonitorHeightMm :: Screen
 -> Int    -- ^ @monitorNum@ - number of the monitor
 -> IO Int -- ^ returns the height of the monitor, or -1 if not available
screenGetMonitorHeightMm self monitorNum =
  liftM fromIntegral $
  {# call gdk_screen_get_monitor_height_mm #}
    self
    (fromIntegral monitorNum)

-- | Gets the width in millimeters of the specified monitor, if available.
--
-- * Available since Gdk version 2.14
--
screenGetMonitorWidthMm :: Screen
 -> Int    -- ^ @monitorNum@ - number of the monitor
 -> IO Int -- ^ returns the width of the monitor, or -1 if not available
screenGetMonitorWidthMm self monitorNum =
  liftM fromIntegral $
  {# call gdk_screen_get_monitor_width_mm #}
    self
    (fromIntegral monitorNum)

-- | Returns the output name of the specified monitor. Usually something like
-- VGA, DVI, or TV, not the actual product name of the display device.
--
-- * Available since Gdk version 2.14
--
screenGetMonitorPlugName :: Screen
 -> Int       -- ^ @monitorNum@ - number of the monitor
 -> IO (Maybe String) -- ^ returns a newly-allocated string containing the name of the
              -- monitor, or @Nothing@ if the name cannot be determined
screenGetMonitorPlugName self monitorNum = do
  sPtr <-
    {# call gdk_screen_get_monitor_plug_name #}
    self
    (fromIntegral monitorNum)
  if sPtr==nullPtr then return Nothing else liftM Just $ readUTFString sPtr
#endif

{-
-- | Retrieves a desktop-wide setting such as double-click time for the
-- 'Screen'@screen@.
--
-- FIXME needs a list of valid settings here, or a link to more information.
--
screenGetSetting :: Screen
 -> String      -- ^ @name@ - the name of the setting
 -> {-GValue*-} -- ^ @value@ - location to store the value of the setting
 -> IO Bool     -- ^ returns @True@ if the setting existed and a value was
                -- stored in @value@, @False@ otherwise.
screenGetSetting self name value =
  liftM toBool $
  withUTFString name $ \namePtr ->
  {# call gdk_screen_get_setting #}
    self
    namePtr
    {-value-}
-}

-- these are only used for the attributes
screenGetFontOptions :: Screen
 -> IO (Maybe FontOptions)
screenGetFontOptions self = do
  fPtr <- {# call gdk_screen_get_font_options #} self
  if fPtr==nullPtr then return Nothing else liftM Just $ mkFontOptions (castPtr fPtr)

screenSetFontOptions :: Screen
 -> Maybe FontOptions
 -> IO ()
screenSetFontOptions self Nothing =
  {# call gdk_screen_set_font_options #} self nullPtr
screenSetFontOptions self (Just options) =
  withFontOptions options $ \fPtr ->
    {# call gdk_screen_set_font_options #} self (castPtr fPtr)

#if GTK_CHECK_VERSION(2,10,0)
-- | Returns the currently active window of this screen.
--
-- On X11, this is done by inspecting the _NET_ACTIVE_WINDOW property on the
-- root window, as described in the Extended Window Manager Hints. If there is
-- no currently currently active window, or the window manager does not support
-- the _NET_ACTIVE_WINDOW hint, this function returns @Nothing@.
--
-- On other platforms, this function may return @Nothing@, depending on whether
-- it is implementable on that platform.
--
-- * Available since Gdk version 2.10
--
screenGetActiveWindow :: Screen
 -> IO (Maybe DrawWindow) -- ^ returns the currently active window, or
                          -- @Nothing@.
screenGetActiveWindow self =
  maybeNull (makeNewGObject mkDrawWindow) $
  {# call gdk_screen_get_active_window #}
    self
#endif

-- | Returns a list of 'DrawWindow's representing the
-- current window stack.
--
-- On X11, this is done by inspecting the _NET_CLIENT_LIST_STACKING property
-- on the root window, as described in the Extended Window Manager Hints. If
-- the window manager does not support the _NET_CLIENT_LIST_STACKING hint, this
-- function returns @Nothing@.
--
-- On other platforms, this function may return @Nothing@, depending on whether it is
-- implementable on that platform.
--
-- * Available since Gdk version 2.10
--
screenGetWindowStack :: Screen
 -> IO (Maybe [DrawWindow]) -- ^ returns a list of 'DrawWindow's for the
                            -- current window stack, or @Nothing@.
screenGetWindowStack self = do
  lPtr <- {# call gdk_screen_get_window_stack #} self
  if lPtr==nullPtr then return Nothing else liftM Just $ do
  fromGList lPtr >>= mapM (constructNewGObject mkDrawWindow . return)
#endif

--------------------
-- Attributes

-- | The default font options for the screen.
--
screenFontOptions :: Attr Screen (Maybe FontOptions)
screenFontOptions = newAttr
  screenGetFontOptions
  screenSetFontOptions

-- | The resolution for fonts on the screen.
--
-- Default value: -1
--
screenResolution :: Attr Screen Double
screenResolution = newAttrFromDoubleProperty "resolution"

-- | Sets the default @colormap@ for @screen@.
--
-- Gets the default colormap for @screen@.
--
screenDefaultColormap :: Attr Screen Colormap
screenDefaultColormap = newAttr
  screenGetDefaultColormap
  screenSetDefaultColormap

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

-- | The ::size_changed signal is emitted when the pixel width or height of a
-- screen changes.
--
screenSizeChanged :: ScreenClass self => Signal self (IO ())
screenSizeChanged = Signal (connect_NONE__NONE "size_changed")

#if GTK_CHECK_VERSION(2,10,0)
-- | The 'screenCompositedChanged' signal is emitted when the composited status of
-- the screen changes
--
-- * Available since Gdk version 2.10
--
screenCompositedChanged :: ScreenClass self => Signal self (IO ())
screenCompositedChanged = Signal (connect_NONE__NONE "composited_changed")

#if GTK_CHECK_VERSION(2,14,0)
-- | The 'screenMonitorsChanged' signal is emitted when the number, size or
-- position of the monitors attached to the screen change.
--
-- Only for X for now. Future implementations for Win32 and OS X may be a
-- possibility.
--
-- * Available since Gdk version 2.14
--
screenMonitorsChanged :: ScreenClass self => Signal self (IO ())
screenMonitorsChanged = Signal (connect_NONE__NONE "monitors-changed")
#endif
#endif


Missing link

Missing link

-- -*-haskell-*-
--  GIMP Toolkit (GTK) General
--
--  Author : Axel Simon, Manuel M. T. Chakravarty
--
--  Created: 8 December 1998
--
--  Copyright (C) 2000..2005 Axel Simon, Manuel M. T. Chakravarty
--
--  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.
--
-- TODO
--
-- quitAddDestroy, quitAdd, quitRemove
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- library initialization, main event loop, and events
--
module Graphics.UI.Gtk.General.General (
--  getDefaultLanguage,
  -- * Initialisation
  initGUI,

  -- ** Support for OS threads
  unsafeInitGUIForThreadedRTS,
  postGUISync,
  postGUIAsync,

  -- * Main event loop
  mainGUI,
  mainQuit,

  -- ** Less commonly used event loop functions
  eventsPending,
  mainLevel,
  mainIteration,
  mainIterationDo,

  -- * Grab widgets
  grabAdd,
  grabGetCurrent,
  grabRemove,

  -- * Timeout and idle callbacks
  Priority,
  priorityLow,
  priorityDefaultIdle,
  priorityHighIdle,
  priorityDefault,
  priorityHigh,
  timeoutAdd,
  timeoutAddFull,
  timeoutRemove,
  idleAdd,
  idleRemove,
  inputAdd,
  inputRemove,
  IOCondition,
  HandlerId
  ) where

import System.Environment (getProgName, getArgs)
import Control.Monad      (liftM, mapM, when)
import Control.Concurrent (rtsSupportsBoundThreads, newEmptyMVar,
                           putMVar, takeMVar)
import Data.IORef         (IORef, newIORef, readIORef, writeIORef)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.MainLoop
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.Types#}

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

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

-- We compile this module using -#includ"gtk/wingtk.h" to bypass the win32 abi
-- check however we do not compile users programs with this headder so if
-- initGUI was ever inlined in a users program, then that program would not
-- bypass the abi check and would fail on startup. So to stop that we must
-- prevent initGUI from being inlined.
{-# NOINLINE initGUI #-}
-- | Initialize the GUI.
--
-- This must be called before any other function in the Gtk2Hs library.
--
-- This function initializes the GUI toolkit and parses all Gtk
-- specific arguments. The remaining arguments are returned. If the
-- initialization of the toolkit fails for whatever reason, an exception
-- is thrown.
--
-- * Throws: @error \"Cannot initialize GUI.\"@
--
initGUI :: IO [String]
initGUI = do
  name <- getProgName
  when (rtsSupportsBoundThreads && name /= "<interactive>") $ fail $ "\n" ++
    "initGUI: Gtk+ is single threaded and so cannot safely be used from\n" ++
    "multiple Haskell threads when using GHC's threaded RTS. You can\n" ++
    "avoid this error by relinking your program without using the\n" ++
    "'-threaded' flag. If you have to use the threaded RTS and are\n" ++
    "absolutely sure that you only ever call Gtk+ from a single OS\n" ++
    "thread then you can use the function: unsafeInitGUIForThreadedRTS\n"

  unsafeInitGUIForThreadedRTS

{-# NOINLINE unsafeInitGUIForThreadedRTS #-}
-- | Same as initGUI except that it prints no warning when used with GHC's
-- threaded RTS.
--
-- If you want to use Gtk2Hs and the threaded RTS then it is your obligation
-- to ensure that all calls to Gtk+ happen on a single OS thread.
-- If you want to make calls to Gtk2Hs functions from a Haskell thread other
-- than the one that calls this functions and 'mainGUI' then you will have to
-- \'post\' your GUI actions to the main GUI thread. You can do this using
-- 'postGUISync' or 'postGUIAsync'.
--
unsafeInitGUIForThreadedRTS :: IO [String]
unsafeInitGUIForThreadedRTS = do
  when rtsSupportsBoundThreads initialiseGThreads
  prog <- getProgName
  args <- getArgs
  let allArgs = (prog:args)
  withMany withUTFString allArgs $ \addrs  ->
    withArrayLen       addrs   $ \argc argv ->
    with	       argv    $ \argvp ->
    with	       argc    $ \argcp -> do
      res <- {#call unsafe init_check#} (castPtr argcp) (castPtr argvp)
      if (toBool res) then do
        argc'   <- peek argcp
        argv'   <- peek argvp
        _:addrs'  <- peekArray argc' argv'  -- drop the program name
        mapM peekUTFString addrs'
        else error "Cannot initialize GUI."

-- g_thread_init aborts the whole program if it's called more than once so
-- we've got to keep track of whether or not we've called it already. Sigh.
--
foreign import ccall "hsgthread.h gtk2hs_threads_initialise"
  initialiseGThreads :: IO ()

-- | Post an action to be run in the main GUI thread.
--
-- The current thread blocks until the action completes and the result is
-- returned.
--
postGUISync :: IO a -> IO a
postGUISync action = do
  resultVar <- newEmptyMVar
  idleAdd (action >>= putMVar resultVar >> return False) priorityDefault
  takeMVar resultVar

-- | Post an action to be run in the main GUI thread.
--
-- The current thread continues and does not wait for the result of the
-- action.
--
postGUIAsync :: IO () -> IO ()
postGUIAsync action = do
  idleAdd (action >> return False) priorityDefault
  return ()

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

-- | Run the Gtk+ main event loop.
--
mainGUI :: IO ()
mainGUI  = {#call main#}

-- | Inquire the main loop level.
--
-- * Callbacks that take more time to process can call 'mainIteration' to keep
-- the GUI responsive. Each time the main loop is restarted this way, the main
-- loop counter is increased. This function returns this counter.
--
mainLevel :: IO Int
mainLevel  = liftM (toEnum.fromEnum) {#call unsafe main_level#}

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

-- | Process an event, block if necessary.
--
-- * Returns @True@ if 'mainQuit' was called while processing the event.
--
mainIteration :: IO Bool
mainIteration  = liftM toBool {#call main_iteration#}

-- | Process a single event.
--
-- * Called with @True@, this function behaves as 'mainIteration' in that it
-- waits until an event is available for processing. It will return
-- immediately, if passed @False@.
--
-- * Returns @True@ if the 'mainQuit' was called while processing the event.
--
mainIterationDo :: Bool -> IO Bool
mainIterationDo blocking =
  liftM toBool $ {#call main_iteration_do#} (fromBool blocking)

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

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

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

-- -*-haskell-*-
--  GIMP Toolkit (GTK) General
--
--  Author : Axel Simon, Manuel M. T. Chakravarty
--
--  Created: 8 December 1998
--
--  Copyright (C) 2000..2005 Axel Simon, Manuel M. T. Chakravarty
--
--  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.
--
-- TODO
--
-- quitAddDestroy, quitAdd, quitRemove
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- library initialization, main event loop, and events
--
module Graphics.UI.Gtk.General.General (
--  getDefaultLanguage,
  -- * Initialisation
  initGUI,

  -- ** Support for OS threads
  unsafeInitGUIForThreadedRTS,
  postGUISync,
  postGUIAsync,

  -- * Main event loop
  mainGUI,
  mainQuit,

  -- ** Less commonly used event loop functions
  eventsPending,
  mainLevel,
  mainIteration,
  mainIterationDo,

  -- * Grab widgets
  grabAdd,
  grabGetCurrent,
  grabRemove,

  -- * Timeout and idle callbacks
  Priority,
  priorityLow,
  priorityDefaultIdle,
  priorityHighIdle,
  priorityDefault,
  priorityHigh,
  timeoutAdd,
  timeoutAddFull,
  timeoutRemove,
  idleAdd,
  idleRemove,
  inputAdd,
  inputRemove,
  IOCondition,
  HandlerId
  ) where

import System.Environment (getProgName, getArgs)
import Control.Monad      (liftM, mapM, when)
import Control.Concurrent (rtsSupportsBoundThreads, newEmptyMVar,
                           putMVar, takeMVar)
import Data.IORef         (IORef, newIORef, readIORef, writeIORef)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.MainLoop
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.Types#}

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

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

-- We compile this module using -#includ"gtk/wingtk.h" to bypass the win32 abi
-- check however we do not compile users programs with this headder so if
-- initGUI was ever inlined in a users program, then that program would not
-- bypass the abi check and would fail on startup. So to stop that we must
-- prevent initGUI from being inlined.
{-# NOINLINE initGUI #-}
-- | Initialize the GUI.
--
-- This must be called before any other function in the Gtk2Hs library.
--
-- This function initializes the GUI toolkit and parses all Gtk
-- specific arguments. The remaining arguments are returned. If the
-- initialization of the toolkit fails for whatever reason, an exception
-- is thrown.
--
-- * Throws: @error \"Cannot initialize GUI.\"@
--
initGUI :: IO [String]
initGUI = do
  name <- getProgName
  when (rtsSupportsBoundThreads && name /= "<interactive>") $ fail $ "\n" ++
    "initGUI: Gtk+ is single threaded and so cannot safely be used from\n" ++
    "multiple Haskell threads when using GHC's threaded RTS. You can\n" ++
    "avoid this error by relinking your program without using the\n" ++
    "'-threaded' flag. If you have to use the threaded RTS and are\n" ++
    "absolutely sure that you only ever call Gtk+ from a single OS\n" ++
    "thread then you can use the function: unsafeInitGUIForThreadedRTS\n"

  unsafeInitGUIForThreadedRTS

{-# NOINLINE unsafeInitGUIForThreadedRTS #-}
-- | Same as initGUI except that it prints no warning when used with GHC's
-- threaded RTS.
--
-- If you want to use Gtk2Hs and the threaded RTS then it is your obligation
-- to ensure that all calls to Gtk+ happen on a single OS thread.
-- If you want to make calls to Gtk2Hs functions from a Haskell thread other
-- than the one that calls this functions and mainGUI then you will have to
-- \'post\' your GUI actions to the main GUI thread. You can do this using
-- 'postGUISync' or 'postGUIAsync'.
--
unsafeInitGUIForThreadedRTS :: IO [String]
unsafeInitGUIForThreadedRTS = do
  when rtsSupportsBoundThreads initialiseGThreads
  prog <- getProgName
  args <- getArgs
  let allArgs = (prog:args)
  withMany withUTFString allArgs $ \addrs  ->
    withArrayLen       addrs   $ \argc argv ->
    with	       argv    $ \argvp ->
    with	       argc    $ \argcp -> do
      res <- {#call unsafe init_check#} (castPtr argcp) (castPtr argvp)
      if (toBool res) then do
        argc'   <- peek argcp
        argv'   <- peek argvp
        _:addrs'  <- peekArray argc' argv'  -- drop the program name
        mapM peekUTFString addrs'
        else error "Cannot initialize GUI."

-- g_thread_init aborts the whole program if it's called more than once so
-- we've got to keep track of whether or not we've called it already. Sigh.
--
foreign import ccall "hsgthread.h gtk2hs_threads_initialise"
  initialiseGThreads :: IO ()

-- | Post an action to be run in the main GUI thread.
--
-- The current thread blocks until the action completes and the result is
-- returned.
--
postGUISync :: IO a -> IO a
postGUISync action = do
  resultVar <- newEmptyMVar
  idleAdd (action >>= putMVar resultVar >> return False) priorityDefault
  takeMVar resultVar

-- | Post an action to be run in the main GUI thread.
--
-- The current thread continues and does not wait for the result of the
-- action.
--
postGUIAsync :: IO () -> IO ()
postGUIAsync action = do
  idleAdd (action >> return False) priorityDefault
  return ()

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

-- | Run the Gtk+ main event loop.
--
mainGUI :: IO ()
mainGUI  = {#call main#}

-- | Inquire the main loop level.
--
-- * Callbacks that take more time to process can call 'mainIteration' to keep
-- the GUI responsive. Each time the main loop is restarted this way, the main
-- loop counter is increased. This function returns this counter.
--
mainLevel :: IO Int
mainLevel  = liftM (toEnum.fromEnum) {#call unsafe main_level#}

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

-- | Process an event, block if necessary.
--
-- * Returns @True@ if 'mainQuit' was called while processing the event.
--
mainIteration :: IO Bool
mainIteration  = liftM toBool {#call main_iteration#}

-- | Process a single event.
--
-- * Called with @True@, this function behaves as 'mainIteration' in that it
-- waits until an event is available for processing. It will return
-- immediately, if passed @False@.
--
-- * Returns @True@ if the 'mainQuit' was called while processing the event.
--
mainIterationDo :: Bool -> IO Bool
mainIterationDo blocking =
  liftM toBool $ {#call main_iteration_do#} (fromBool blocking)

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

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

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


Must not use _static version of pango_font_description_set_family Since the string buffer is only kept around temporarily, not forever like pango_font_description_set_family_static requires.

-- -*-haskell-*-
--  GIMP Toolkit (GTK) - text layout functions: Font Descriptions
--
--  Author : Axel Simon
--
--  Created: 8 Feburary 2003
--
--  Copyright (C) 1999-2005 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- #hide

-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Functions to manage font descriptions.
--
-- * Font descriptions provide a way to query and state requirements on
--   fonts. This data structure has several fields describing different
--   characteristics of a font. Each of these fields can be set of left
--   unspecified.
--
module Graphics.UI.Gtk.Pango.Description (
  FontDescription,
  fontDescriptionNew,
  fontDescriptionCopy,
  fontDescriptionSetFamily,
  fontDescriptionGetFamily,
  fontDescriptionSetStyle,
  fontDescriptionGetStyle,
  fontDescriptionSetVariant,
  fontDescriptionGetVariant,
  fontDescriptionSetWeight,
  fontDescriptionGetWeight,
  fontDescriptionSetStretch,
  fontDescriptionGetStretch,
  fontDescriptionSetSize,
  fontDescriptionGetSize,
  FontMask(..),
  fontDescriptionUnsetFields,
  fontDescriptionMerge,
  fontDescriptionBetterMatch,
  fontDescriptionFromString,
  fontDescriptionToString
  ) where

import Control.Monad    (liftM)

import System.Glib.FFI
import System.Glib.Flags		(Flags, fromFlags)
import System.Glib.UTFString
{#import Graphics.UI.Gtk.Types#} ()
{#import Graphics.UI.Gtk.Pango.Types#}
import Graphics.UI.Gtk.Pango.Enums

{# context lib="pango" prefix="pango_font_description" #}

-- | Create a new font description.
--
-- * All field are unset.
--
fontDescriptionNew :: IO FontDescription
fontDescriptionNew = {#call unsafe new#} >>= makeNewFontDescription

-- | Make a deep copy of a font description.
--
fontDescriptionCopy :: FontDescription -> IO FontDescription
fontDescriptionCopy fd = {#call unsafe copy#} fd >>= makeNewFontDescription

-- | Set the font famliy.
--
-- * A font family is a name designating the design of the font (e.g. Sans
--   or Times) without the variant.
--
-- * In some contexts a comma separated list of font families can be used.
--
fontDescriptionSetFamily :: FontDescription -> String -> IO ()
fontDescriptionSetFamily fd family = withUTFString family $ \strPtr ->
  {#call unsafe set_family#} fd strPtr

-- | Get the font family.
--
-- * 'Nothing' is returned if the font family is not set.
--
fontDescriptionGetFamily :: FontDescription -> IO (Maybe String)
fontDescriptionGetFamily fd = do
  strPtr <- {#call unsafe get_family#} fd
  if strPtr==nullPtr then return Nothing else
    liftM Just $ peekUTFString strPtr

-- | Flags denoting which fields in a font description are set.
{#enum PangoFontMask as FontMask {underscoreToCase} deriving(Bounded) #}

instance Flags FontMask

-- | Set the style field.
--
-- * Most fonts will have either a 'StyleItalic' or 'StyleOblique'
--   but rarely both.
--
fontDescriptionSetStyle :: FontDescription -> FontStyle -> IO ()
fontDescriptionSetStyle fd p =
    {#call unsafe set_style#} fd (fromIntegral (fromEnum p))

-- | Get the style field.
fontDescriptionGetStyle :: FontDescription -> IO (Maybe FontStyle)
fontDescriptionGetStyle fd = do
  fields <- {#call unsafe get_set_fields#} fd
  if (fromEnum PangoFontMaskStyle) .&. (fromIntegral fields) /=0
     then liftM (Just . toEnum . fromIntegral) $
	      {#call unsafe get_style#} fd
     else return Nothing

-- | Set the variant field.
--
fontDescriptionSetVariant :: FontDescription -> Variant -> IO ()
fontDescriptionSetVariant fd p =
    {#call unsafe set_variant#} fd (fromIntegral (fromEnum p))

-- | Get the variant field.
fontDescriptionGetVariant :: FontDescription -> IO (Maybe Variant)
fontDescriptionGetVariant fd = do
  fields <- {#call unsafe get_set_fields#} fd
  if (fromEnum PangoFontMaskVariant) .&. (fromIntegral fields) /=0
     then liftM (Just . toEnum . fromIntegral) $
	      {#call unsafe get_variant#} fd
     else return Nothing

-- | Set the weight field.
--
fontDescriptionSetWeight :: FontDescription -> Weight -> IO ()
fontDescriptionSetWeight fd p =
  {#call unsafe set_weight#} fd (fromIntegral (fromEnum p))

-- | Get the weight field.
fontDescriptionGetWeight :: FontDescription -> IO (Maybe Weight)
fontDescriptionGetWeight fd = do
  fields <- {#call unsafe get_set_fields#} fd
  if (fromEnum PangoFontMaskWeight) .&. (fromIntegral fields) /=0
     then liftM (Just . toEnum . fromIntegral) $
	      {#call unsafe get_weight#} fd
     else return Nothing

-- | Set the stretch field.
--
fontDescriptionSetStretch :: FontDescription -> Stretch -> IO ()
fontDescriptionSetStretch fd p =
  {#call unsafe set_stretch#} fd (fromIntegral (fromEnum p))

-- | Get the stretch field.
fontDescriptionGetStretch :: FontDescription -> IO (Maybe Stretch)
fontDescriptionGetStretch fd = do
  fields <- {#call unsafe get_set_fields#} fd
  if (fromEnum PangoFontMaskStretch) .&. (fromIntegral fields) /=0
     then liftM (Just . toEnum . fromIntegral) $
	      {#call unsafe get_stretch#} fd
     else return Nothing

-- | Set the size field.
--
-- * The given size is in points (pts). One point is 1\/72 inch.
--
fontDescriptionSetSize :: FontDescription -> Double -> IO ()
fontDescriptionSetSize fd p =
  {#call unsafe set_size#} fd (puToInt p)

-- | Get the size field.
fontDescriptionGetSize :: FontDescription -> IO (Maybe Double)
fontDescriptionGetSize fd = do
  fields <- {#call unsafe get_set_fields#} fd
  if (fromEnum PangoFontMaskSize) .&. (fromIntegral fields) /=0
     then liftM (\x -> Just (intToPu x)) $
	      {#call unsafe get_size#} fd
     else return Nothing

-- | Reset fields in a font description.
--
fontDescriptionUnsetFields :: FontDescription -> [FontMask] -> IO ()
fontDescriptionUnsetFields fd mask =
  {#call unsafe unset_fields#} fd (fromIntegral (fromFlags mask))

-- | Merge two font descriptions.
--
-- * Copy fields from the second description to the first. If the boolean
--   parameter is set, existing fields in the first description will be
--   replaced.
--
fontDescriptionMerge :: FontDescription -> FontDescription -> Bool -> IO ()
fontDescriptionMerge fd1 fd2 replace =
  {#call unsafe merge#} fd1 fd2 (fromBool replace)

-- | Determine if two descriptions are simliar.
--
-- * Returns 'True' if the two descriptions only differ in weight or style.
--
fontDescriptionIsMatch :: FontDescription -> FontDescription -> Bool
fontDescriptionIsMatch fdA fdB = unsafePerformIO $ liftM toBool $
  {#call unsafe better_match#} fdA (FontDescription nullForeignPtr) fdB

-- | Determine which of two descriptions matches a given description better.
--
-- * Returns @True@ if the last description is a better match to the first
--   arguement than the middle one.
--
-- * Approximate matching is done on weight and style. If the other
--   attributes do not match, the function returns @False@.
--
fontDescriptionBetterMatch :: FontDescription -> FontDescription ->
			      FontDescription -> Bool
fontDescriptionBetterMatch fd fdA fdB = unsafePerformIO $ liftM toBool $
  {#call unsafe better_match#} fd fdA fdB

-- | Create a font description from a string.
--
-- * The given argument must have the form
--   @[FAMILY-LIST] [STYLE-OPTIONS] [SIZE]@ where @FAMILY_LIST@ is a comma
--   separated list of font families optionally terminated by a comma,
--   @STYLE_OPTIONS@ is a whitespace separated list of words where each
--   word describes one of style, variant, weight or stretch. @SIZE@ is
--   a decimal number giving the size of the font in points. If any of
--   these fields is absent, the resulting 'FontDescription' will have
--   the corresponing fields unset.
--
fontDescriptionFromString :: String -> IO FontDescription
fontDescriptionFromString descr = withUTFString descr $ \strPtr ->
  {#call unsafe from_string#} strPtr >>= makeNewFontDescription

-- | Convert a font description to a string.
--
-- * Creates a string representation of a font description. See
--   'fontDescriptionFromString' for the format of the string.
--
fontDescriptionToString :: FontDescription -> IO String
fontDescriptionToString fd = do
  strPtr <- {#call unsafe to_string#} fd
  str <- peekUTFString strPtr
  {#call unsafe g_free#} (castPtr strPtr)
  return str

-- -*-haskell-*-
--  GIMP Toolkit (GTK) - text layout functions: Font Descriptions
--
--  Author : Axel Simon
--
--  Created: 8 Feburary 2003
--
--  Copyright (C) 1999-2005 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- #hide

-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Functions to manage font descriptions.
--
-- * Font descriptions provide a way to query and state requirements on
--   fonts. This data structure has several fields describing different
--   characteristics of a font. Each of these fields can be set of left
--   unspecified.
--
module Graphics.UI.Gtk.Pango.Description (
  FontDescription,
  fontDescriptionNew,
  fontDescriptionCopy,
  fontDescriptionSetFamily,
  fontDescriptionGetFamily,
  fontDescriptionSetStyle,
  fontDescriptionGetStyle,
  fontDescriptionSetVariant,
  fontDescriptionGetVariant,
  fontDescriptionSetWeight,
  fontDescriptionGetWeight,
  fontDescriptionSetStretch,
  fontDescriptionGetStretch,
  fontDescriptionSetSize,
  fontDescriptionGetSize,
  FontMask(..),
  fontDescriptionUnsetFields,
  fontDescriptionMerge,
  fontDescriptionBetterMatch,
  fontDescriptionFromString,
  fontDescriptionToString
  ) where

import Control.Monad    (liftM)

import System.Glib.FFI
import System.Glib.Flags		(Flags, fromFlags)
import System.Glib.UTFString
{#import Graphics.UI.Gtk.Types#} ()
{#import Graphics.UI.Gtk.Pango.Types#}
import Graphics.UI.Gtk.Pango.Enums

{# context lib="pango" prefix="pango_font_description" #}

-- | Create a new font description.
--
-- * All field are unset.
--
fontDescriptionNew :: IO FontDescription
fontDescriptionNew = {#call unsafe new#} >>= makeNewFontDescription

-- | Make a deep copy of a font description.
--
fontDescriptionCopy :: FontDescription -> IO FontDescription
fontDescriptionCopy fd = {#call unsafe copy#} fd >>= makeNewFontDescription

-- | Set the font famliy.
--
-- * A font family is a name designating the design of the font (e.g. Sans
--   or Times) without the variant.
--
-- * In some contexts a comma separated list of font families can be used.
--
fontDescriptionSetFamily :: FontDescription -> String -> IO ()
fontDescriptionSetFamily fd family = withUTFString family $ \strPtr ->
  {#call unsafe set_family_static#} fd strPtr

-- | Get the font family.
--
-- * 'Nothing' is returned if the font family is not set.
--
fontDescriptionGetFamily :: FontDescription -> IO (Maybe String)
fontDescriptionGetFamily fd = do
  strPtr <- {#call unsafe get_family#} fd
  if strPtr==nullPtr then return Nothing else
    liftM Just $ peekUTFString strPtr

-- | Flags denoting which fields in a font description are set.
{#enum PangoFontMask as FontMask {underscoreToCase} deriving(Bounded) #}

instance Flags FontMask

-- | Set the style field.
--
-- * Most fonts will have either a 'StyleItalic' or 'StyleOblique'
--   but rarely both.
--
fontDescriptionSetStyle :: FontDescription -> FontStyle -> IO ()
fontDescriptionSetStyle fd p =
    {#call unsafe set_style#} fd (fromIntegral (fromEnum p))

-- | Get the style field.
fontDescriptionGetStyle :: FontDescription -> IO (Maybe FontStyle)
fontDescriptionGetStyle fd = do
  fields <- {#call unsafe get_set_fields#} fd
  if (fromEnum PangoFontMaskStyle) .&. (fromIntegral fields) /=0
     then liftM (Just . toEnum . fromIntegral) $
	      {#call unsafe get_style#} fd
     else return Nothing

-- | Set the variant field.
--
fontDescriptionSetVariant :: FontDescription -> Variant -> IO ()
fontDescriptionSetVariant fd p =
    {#call unsafe set_variant#} fd (fromIntegral (fromEnum p))

-- | Get the variant field.
fontDescriptionGetVariant :: FontDescription -> IO (Maybe Variant)
fontDescriptionGetVariant fd = do
  fields <- {#call unsafe get_set_fields#} fd
  if (fromEnum PangoFontMaskVariant) .&. (fromIntegral fields) /=0
     then liftM (Just . toEnum . fromIntegral) $
	      {#call unsafe get_variant#} fd
     else return Nothing

-- | Set the weight field.
--
fontDescriptionSetWeight :: FontDescription -> Weight -> IO ()
fontDescriptionSetWeight fd p =
  {#call unsafe set_weight#} fd (fromIntegral (fromEnum p))

-- | Get the weight field.
fontDescriptionGetWeight :: FontDescription -> IO (Maybe Weight)
fontDescriptionGetWeight fd = do
  fields <- {#call unsafe get_set_fields#} fd
  if (fromEnum PangoFontMaskWeight) .&. (fromIntegral fields) /=0
     then liftM (Just . toEnum . fromIntegral) $
	      {#call unsafe get_weight#} fd
     else return Nothing

-- | Set the stretch field.
--
fontDescriptionSetStretch :: FontDescription -> Stretch -> IO ()
fontDescriptionSetStretch fd p =
  {#call unsafe set_stretch#} fd (fromIntegral (fromEnum p))

-- | Get the stretch field.
fontDescriptionGetStretch :: FontDescription -> IO (Maybe Stretch)
fontDescriptionGetStretch fd = do
  fields <- {#call unsafe get_set_fields#} fd
  if (fromEnum PangoFontMaskStretch) .&. (fromIntegral fields) /=0
     then liftM (Just . toEnum . fromIntegral) $
	      {#call unsafe get_stretch#} fd
     else return Nothing

-- | Set the size field.
--
-- * The given size is in points (pts). One point is 1\/72 inch.
--
fontDescriptionSetSize :: FontDescription -> Double -> IO ()
fontDescriptionSetSize fd p =
  {#call unsafe set_size#} fd (puToInt p)

-- | Get the size field.
fontDescriptionGetSize :: FontDescription -> IO (Maybe Double)
fontDescriptionGetSize fd = do
  fields <- {#call unsafe get_set_fields#} fd
  if (fromEnum PangoFontMaskSize) .&. (fromIntegral fields) /=0
     then liftM (\x -> Just (intToPu x)) $
	      {#call unsafe get_size#} fd
     else return Nothing

-- | Reset fields in a font description.
--
fontDescriptionUnsetFields :: FontDescription -> [FontMask] -> IO ()
fontDescriptionUnsetFields fd mask =
  {#call unsafe unset_fields#} fd (fromIntegral (fromFlags mask))

-- | Merge two font descriptions.
--
-- * Copy fields from the second description to the first. If the boolean
--   parameter is set, existing fields in the first description will be
--   replaced.
--
fontDescriptionMerge :: FontDescription -> FontDescription -> Bool -> IO ()
fontDescriptionMerge fd1 fd2 replace =
  {#call unsafe merge#} fd1 fd2 (fromBool replace)

-- | Determine if two descriptions are simliar.
--
-- * Returns 'True' if the two descriptions only differ in weight or style.
--
fontDescriptionIsMatch :: FontDescription -> FontDescription -> Bool
fontDescriptionIsMatch fdA fdB = unsafePerformIO $ liftM toBool $
  {#call unsafe better_match#} fdA (FontDescription nullForeignPtr) fdB

-- | Determine which of two descriptions matches a given description better.
--
-- * Returns @True@ if the last description is a better match to the first
--   arguement than the middle one.
--
-- * Approximate matching is done on weight and style. If the other
--   attributes do not match, the function returns @False@.
--
fontDescriptionBetterMatch :: FontDescription -> FontDescription ->
			      FontDescription -> Bool
fontDescriptionBetterMatch fd fdA fdB = unsafePerformIO $ liftM toBool $
  {#call unsafe better_match#} fd fdA fdB

-- | Create a font description from a string.
--
-- * The given argument must have the form
--   @[FAMILY-LIST] [STYLE-OPTIONS] [SIZE]@ where @FAMILY_LIST@ is a comma
--   separated list of font families optionally terminated by a comma,
--   @STYLE_OPTIONS@ is a whitespace separated list of words where each
--   word describes one of style, variant, weight or stretch. @SIZE@ is
--   a decimal number giving the size of the font in points. If any of
--   these fields is absent, the resulting 'FontDescription' will have
--   the corresponing fields unset.
--
fontDescriptionFromString :: String -> IO FontDescription
fontDescriptionFromString descr = withUTFString descr $ \strPtr ->
  {#call unsafe from_string#} strPtr >>= makeNewFontDescription

-- | Convert a font description to a string.
--
-- * Creates a string representation of a font description. See
--   'fontDescriptionFromString' for the format of the string.
--
fontDescriptionToString :: FontDescription -> IO String
fontDescriptionToString fd = do
  strPtr <- {#call unsafe to_string#} fd
  str <- peekUTFString strPtr
  {#call unsafe g_free#} (castPtr strPtr)
  return str


Must not use _static version of pango_font_description_set_family

Since the string buffer is only kept around temporarily, not forever like
pango_font_description_set_family_static requires.

darcs-hash:20070723145641-adfee-9f8777e0fecb042cd1bc8b7925fe8c8223339d95.gz


Add nullHostPtr constant for driver API

Add nullHostPtr constant for driver API

Ignore-this: 68c43d4d7b0f07335e29d71b9d0c0300

darcs-hash:20100218022439-dcabc-6a9f0cb1394ec31206f2009d193f112567c49dc3.gz

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

module Foreign.CUDA.Driver.Marshal
  (
    -- * Host Allocation
    HostPtr(..), AllocFlag(..),
    withHostPtr, mallocHostArray, freeHost, nullHostPtr,

    -- * Device Allocation
    DevicePtr,
    mallocArray, allocaArray, free, nullDevPtr,

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

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

    -- * Utility
    memset, getDevicePtr
  )
  where

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

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

-- System
import Unsafe.Coerce
import Control.Monad                            (liftM)
import Control.Exception.Extensible

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

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

-- |
-- A reference to memory allocated on the device
--
newtype DevicePtr a = DevicePtr { useDevicePtr :: {# type CUdeviceptr #}}

instance Storable (DevicePtr a) where
  sizeOf _      = sizeOf    (undefined :: {# type CUdeviceptr #})
  alignment _   = alignment (undefined :: {# type CUdeviceptr #})
  peek p        = DevicePtr `fmap` peek (castPtr p)
  poke p v      = poke (castPtr p) (useDevicePtr v)

-- |
-- A reference to memory on the host that is page-locked and directly-accessible
-- from the device. Since the memory can be accessed directly, it can be read or
-- written at a much higher bandwidth than pageable memory from the traditional
-- malloc.
--
-- The driver automatically accelerates calls to functions such as `memcpy'
-- which reference page-locked memory.
--
newtype HostPtr a = HostPtr { useHostPtr :: Ptr a }

-- |
-- Unwrap a host pointer and execute a computation using the base pointer object
--
withHostPtr :: HostPtr a -> (Ptr a -> IO b) -> IO b
withHostPtr p f = f (useHostPtr p)

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

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

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

{# fun unsafe cuMemHostAlloc
  { alloca'-        `HostPtr a'   peekHP*
  ,                 `Int'
  , combineBitMasks `[AllocFlag]'         } -> `Status' cToEnum #}
  where
    alloca'  = F.alloca
    peekHP p = (HostPtr . castPtr) `fmap` peek p

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

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

-- |
-- The constant 'nullHostPtr' contains the distinguished memory location that is
-- not associated with a valid memory location
--
nullHostPtr :: HostPtr a
nullHostPtr =  HostPtr nullPtr

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

{# fun unsafe cuMemAlloc
  { alloca'- `DevicePtr a' peekDP*
  ,          `Int'               } -> `Status' cToEnum #}
  where
    alloca' = F.alloca
    peekDP  = liftM DevicePtr . peek

-- |
-- 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.
--
allocaArray :: Storable a => Int -> (DevicePtr a -> IO b) -> IO b
allocaArray n = bracket (mallocArray n) free

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

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

-- |
-- The constant 'nullDevPtr' contains the distinguished memory location that is
-- not associated with a valid memory location
--
nullDevPtr :: DevicePtr a
nullDevPtr =  DevicePtr 0

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

-- |
-- Copy a number of elements from the device to host memory. This is a
-- synchronous operation
--
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)

{# fun unsafe cuMemcpyDtoH
  { castPtr      `Ptr a'
  , useDevicePtr `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.
--
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 =<< case mst of
        Nothing -> cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) (Stream nullPtr)
        Just st -> cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) st

{# fun unsafe cuMemcpyDtoHAsync
  { useHP        `HostPtr a'
  , useDevicePtr `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.
--
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
--
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)

{# fun unsafe cuMemcpyHtoD
  { useDevicePtr `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.
--
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 =<< case mst of
        Nothing -> cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) (Stream nullPtr)
        Just st -> cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) st

{# fun unsafe cuMemcpyHtoDAsync
  { useDevicePtr `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.
--
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.
--
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)

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

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

-- |
-- Write a list of storable elements into a newly allocated device array. 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.
--
newListArray :: Storable a => [a] -> IO (DevicePtr a)
newListArray xs =
  F.withArrayLen xs                     $ \len p ->
  bracketOnError (mallocArray len) free $ \d_xs  -> do
    pokeArray len p d_xs
    return d_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.
--
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
--
withListArrayLen :: Storable a => [a] -> (Int -> DevicePtr a -> IO b) -> IO b
withListArrayLen xs f =
  allocaArray   len $ \d_xs -> do
  F.allocaArray len $ \h_xs -> do
    F.pokeArray h_xs xs
    pokeArray len h_xs d_xs
  f len d_xs
  where
    len = length xs

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

-- |
-- Set a number of data elements to the specified value, which may be either 8-,
-- 16-, or 32-bits wide.
--
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.
--
{# fun unsafe cuMemsetD8
  { useDevicePtr `DevicePtr a'
  , unsafeCoerce `a'
  ,              `Int'         } -> `Status' cToEnum #}

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

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

-- |
-- 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.
--
getDevicePtr :: [AllocFlag] -> HostPtr a -> IO (DevicePtr a)
getDevicePtr flags hp = resultIfOk =<< cuMemHostGetDevicePointer hp flags

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

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

module Foreign.CUDA.Driver.Marshal
  (
    -- * Host Allocation
    HostPtr(..), AllocFlag(..),
    withHostPtr, mallocHostArray, freeHost,

    -- * Device Allocation
    DevicePtr,
    mallocArray, allocaArray, free, nullDevPtr,

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

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

    -- * Utility
    memset, getDevicePtr
  )
  where

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

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

-- System
import Unsafe.Coerce
import Control.Monad                            (liftM)
import Control.Exception.Extensible

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

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

-- |
-- A reference to memory allocated on the device
--
newtype DevicePtr a = DevicePtr { useDevicePtr :: {# type CUdeviceptr #}}

instance Storable (DevicePtr a) where
  sizeOf _      = sizeOf    (undefined :: {# type CUdeviceptr #})
  alignment _   = alignment (undefined :: {# type CUdeviceptr #})
  peek p        = DevicePtr `fmap` peek (castPtr p)
  poke p v      = poke (castPtr p) (useDevicePtr v)

-- |
-- A reference to memory on the host that is page-locked and directly-accessible
-- from the device. Since the memory can be accessed directly, it can be read or
-- written at a much higher bandwidth than pageable memory from the traditional
-- malloc.
--
-- The driver automatically accelerates calls to functions such as `memcpy'
-- which reference page-locked memory.
--
newtype HostPtr a = HostPtr { useHostPtr :: Ptr a }

-- |
-- Unwrap a host pointer and execute a computation using the base pointer object
--
withHostPtr :: HostPtr a -> (Ptr a -> IO b) -> IO b
withHostPtr p f = f (useHostPtr p)

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

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

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

{# fun unsafe cuMemHostAlloc
  { alloca'-        `HostPtr a'   peekHP*
  ,                 `Int'
  , combineBitMasks `[AllocFlag]'         } -> `Status' cToEnum #}
  where
    alloca'  = F.alloca
    peekHP p = (HostPtr . castPtr) `fmap` peek p

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

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

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

{# fun unsafe cuMemAlloc
  { alloca'- `DevicePtr a' peekDP*
  ,          `Int'               } -> `Status' cToEnum #}
  where
    alloca' = F.alloca
    peekDP  = liftM DevicePtr . peek

-- |
-- 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.
--
allocaArray :: Storable a => Int -> (DevicePtr a -> IO b) -> IO b
allocaArray n = bracket (mallocArray n) free

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

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

-- |
-- The constant 'nullDevPtr' contains the distinguished memory location that is
-- not associated with a valid memory location
--
nullDevPtr :: DevicePtr a
nullDevPtr =  DevicePtr 0

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

-- |
-- Copy a number of elements from the device to host memory. This is a
-- synchronous operation
--
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)

{# fun unsafe cuMemcpyDtoH
  { castPtr      `Ptr a'
  , useDevicePtr `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.
--
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 =<< case mst of
        Nothing -> cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) (Stream nullPtr)
        Just st -> cuMemcpyDtoHAsync hptr dptr (n * sizeOf x) st

{# fun unsafe cuMemcpyDtoHAsync
  { useHP        `HostPtr a'
  , useDevicePtr `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.
--
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
--
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)

{# fun unsafe cuMemcpyHtoD
  { useDevicePtr `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.
--
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 =<< case mst of
        Nothing -> cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) (Stream nullPtr)
        Just st -> cuMemcpyHtoDAsync dptr hptr (n * sizeOf x) st

{# fun unsafe cuMemcpyHtoDAsync
  { useDevicePtr `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.
--
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.
--
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)

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

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

-- |
-- Write a list of storable elements into a newly allocated device array. 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.
--
newListArray :: Storable a => [a] -> IO (DevicePtr a)
newListArray xs =
  F.withArrayLen xs                     $ \len p ->
  bracketOnError (mallocArray len) free $ \d_xs  -> do
    pokeArray len p d_xs
    return d_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.
--
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
--
withListArrayLen :: Storable a => [a] -> (Int -> DevicePtr a -> IO b) -> IO b
withListArrayLen xs f =
  allocaArray   len $ \d_xs -> do
  F.allocaArray len $ \h_xs -> do
    F.pokeArray h_xs xs
    pokeArray len h_xs d_xs
  f len d_xs
  where
    len = length xs

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

-- |
-- Set a number of data elements to the specified value, which may be either 8-,
-- 16-, or 32-bits wide.
--
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.
--
{# fun unsafe cuMemsetD8
  { useDevicePtr `DevicePtr a'
  , unsafeCoerce `a'
  ,              `Int'         } -> `Status' cToEnum #}

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

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

-- |
-- 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.
--
getDevicePtr :: [AllocFlag] -> HostPtr a -> IO (DevicePtr a)
getDevicePtr flags hp = resultIfOk =<< cuMemHostGetDevicePointer hp flags

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