UncommentGValueCharFunctions

UncommentGValueCharFunctions

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GValueTypes
--
--  Author : Axel Simon
--
--  Created: 1 June 2001
--
--  Copyright (c) 1999..2002 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.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- This is used by the implementation of properties and by the
-- 'Graphics.UI.Gtk.TreeList.TreeModel' and
-- related modules.
--
module System.Glib.GValueTypes (
  valueSetUInt,
  valueGetUInt,
  valueSetInt,
  valueGetInt,
  valueSetUInt64,
  valueGetUInt64,
  valueSetInt64,
  valueGetInt64,
  valueSetUChar,
  valueGetUChar,
  valueSetChar,
  valueGetChar,
  valueSetBool,
  valueGetBool,
  valueSetPointer,
  valueGetPointer,
  valueSetFloat,
  valueGetFloat,
  valueSetDouble,
  valueGetDouble,
  valueSetEnum,
  valueGetEnum,
  valueSetFlags,
  valueGetFlags,
  valueSetString,
  valueGetString,
  valueSetMaybeString,
  valueGetMaybeString,
  valueSetBoxed,
  valueGetBoxed,
  valueSetGObject,
  valueGetGObject,
  valueSetMaybeGObject,
  valueGetMaybeGObject,
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.Flags
import System.Glib.UTFString
{#import System.Glib.GValue#}		(GValue(GValue))
import System.Glib.GObject

{# context lib="glib" prefix="g" #}

valueSetUInt :: GValue -> Word -> IO ()
valueSetUInt gvalue value =
  {# call unsafe value_set_uint #} gvalue (fromIntegral value)

valueGetUInt :: GValue -> IO Word
valueGetUInt gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_uint #} gvalue

valueSetInt :: GValue -> Int -> IO ()
valueSetInt gvalue value =
  {# call unsafe value_set_int #} gvalue (fromIntegral value)

valueGetInt :: GValue -> IO Int
valueGetInt gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_int #} gvalue

valueSetUInt64 :: GValue -> Word64 -> IO ()
valueSetUInt64 gvalue value =
  {# call unsafe value_set_uint64 #} gvalue (fromIntegral value)

valueGetUInt64 :: GValue -> IO Word64
valueGetUInt64 gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_uint64 #} gvalue

valueSetInt64 :: GValue -> Int64 -> IO ()
valueSetInt64 gvalue value =
  {# call unsafe value_set_int64 #} gvalue (fromIntegral value)

valueGetInt64 :: GValue -> IO Int64
valueGetInt64 gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_int64 #} gvalue

valueSetUChar :: GValue -> Word8 -> IO ()
valueSetUChar gvalue value =
  {# call unsafe value_set_uchar #} gvalue (fromIntegral value)

valueGetUChar :: GValue -> IO Word8
valueGetUChar gvalue =
  liftM fromIntegral $ {# call unsafe value_get_uchar #} gvalue

--these belong somewhere else, are in new c2hs's C2HS module
cToEnum :: (Integral i, Enum e) => i -> e
cToEnum  = toEnum . fromIntegral

cFromEnum :: (Enum e, Integral i) => e -> i
cFromEnum  = fromIntegral . fromEnum

--valueSetChar :: GValue -> {#type gchar#} -> IO ()
valueSetChar :: GValue -> Char -> IO ()
valueSetChar gvalue value =
  {# call unsafe value_set_char #} gvalue (cFromEnum value)

--valueGetChar :: GValue -> IO {#type gchar#}
valueGetChar :: GValue -> IO Char
valueGetChar gvalue =
  liftM cToEnum $ {# call unsafe value_get_char #} gvalue

valueSetBool :: GValue -> Bool -> IO ()
valueSetBool gvalue value =
  {# call unsafe value_set_boolean #} gvalue (fromBool value)

valueGetBool :: GValue -> IO Bool
valueGetBool gvalue =
  liftM toBool $
  {# call  unsafe value_get_boolean #} gvalue

-- These functions should probably never be used as they are dangerous.
--
valueSetPointer :: GValue -> (Ptr ()) -> IO ()
valueSetPointer gvalue value =
  {# call unsafe value_set_pointer #} gvalue value

valueGetPointer :: GValue -> IO (Ptr ())
valueGetPointer gvalue =
  {# call unsafe value_get_pointer #} gvalue

valueSetFloat :: GValue -> Float -> IO ()
valueSetFloat gvalue value =
  {# call unsafe value_set_float #} gvalue (realToFrac value)

valueGetFloat :: GValue -> IO Float
valueGetFloat gvalue =
  liftM realToFrac $
  {# call unsafe value_get_float #} gvalue

valueSetDouble :: GValue -> Double -> IO ()
valueSetDouble gvalue value =
  {# call unsafe value_set_double #} gvalue (realToFrac value)

valueGetDouble :: GValue -> IO Double
valueGetDouble gvalue =
  liftM realToFrac $
  {# call unsafe value_get_double #} gvalue

valueSetEnum :: Enum enum => GValue -> enum -> IO ()
valueSetEnum gvalue value =
  {# call unsafe value_set_enum #} gvalue (fromIntegral $ fromEnum value)

valueGetEnum :: Enum enum => GValue -> IO enum
valueGetEnum gvalue =
  liftM (toEnum . fromIntegral) $
  {# call unsafe value_get_enum #} gvalue

valueSetFlags :: Flags flag => GValue -> [flag] -> IO ()
valueSetFlags gvalue value =
  {# call unsafe value_set_flags #} gvalue (fromIntegral $ fromFlags value)

valueGetFlags :: Flags flag => GValue -> IO [flag]
valueGetFlags gvalue =
  liftM (toFlags . fromIntegral) $
  {# call unsafe value_get_flags #} gvalue

valueSetString :: GValue -> String -> IO ()
valueSetString gvalue str =
  withUTFString str $ \strPtr ->
  {# call unsafe value_set_string #} gvalue strPtr

valueGetString :: GValue -> IO String
valueGetString gvalue = do
  strPtr <- {# call unsafe value_get_string #} gvalue
  if strPtr == nullPtr
    then return ""
    else peekUTFString strPtr

valueSetMaybeString :: GValue -> Maybe String -> IO ()
valueSetMaybeString gvalue (Just str) =
  withUTFString str $ \strPtr ->
  {# call unsafe value_set_string #} gvalue strPtr

valueSetMaybeString gvalue Nothing =
  {# call unsafe value_set_static_string #} gvalue nullPtr

valueGetMaybeString :: GValue -> IO (Maybe String)
valueGetMaybeString gvalue =
  {# call unsafe value_get_string #} gvalue
  >>= maybePeek peekUTFString

valueSetBoxed :: (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GValue -> boxed -> IO ()
valueSetBoxed with gvalue boxed =
  with boxed $ \boxedPtr -> do
  {# call unsafe g_value_set_boxed #} gvalue (castPtr boxedPtr)

valueGetBoxed :: (Ptr boxed -> IO boxed) -> GValue -> IO boxed
valueGetBoxed peek gvalue =
  {# call unsafe g_value_get_boxed #} gvalue >>= peek . castPtr

-- for some weird reason the API says that gv is a gpointer, not a GObject
--
valueSetGObject :: GObjectClass gobj => GValue -> gobj -> IO ()
valueSetGObject gvalue obj =
  withForeignPtr ((unGObject.toGObject) obj) $ \objPtr ->
    {# call unsafe g_value_set_object #} gvalue (castPtr objPtr)

-- Unsafe because it performs an unchecked downcast. Only for internal use.
--
valueGetGObject :: GObjectClass gobj => GValue -> IO gobj
valueGetGObject gvalue =
  liftM unsafeCastGObject $
  makeNewGObject mkGObject $
  throwIfNull "GValue.valueGetObject: extracting invalid object" $
  liftM castPtr $
  {# call unsafe value_get_object #} gvalue

valueSetMaybeGObject :: GObjectClass gobj => GValue -> (Maybe gobj) -> IO ()
valueSetMaybeGObject gvalue (Just obj) = valueSetGObject gvalue obj
valueSetMaybeGObject gvalue Nothing =
    {# call unsafe g_value_set_object #} gvalue nullPtr

valueGetMaybeGObject :: GObjectClass gobj => GValue -> IO (Maybe gobj)
valueGetMaybeGObject gvalue =
  liftM (liftM unsafeCastGObject) $
  maybeNull (makeNewGObject mkGObject) $
  liftM castPtr $
  {# call unsafe value_get_object #} gvalue

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GValueTypes
--
--  Author : Axel Simon
--
--  Created: 1 June 2001
--
--  Copyright (c) 1999..2002 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.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- This is used by the implementation of properties and by the
-- 'Graphics.UI.Gtk.TreeList.TreeModel' and
-- related modules.
--
module System.Glib.GValueTypes (
  valueSetUInt,
  valueGetUInt,
  valueSetInt,
  valueGetInt,
  valueSetUInt64,
  valueGetUInt64,
  valueSetInt64,
  valueGetInt64,
--  valueSetUChar,
--  valueGetUChar,
--  valueSetChar,
--  valueGetChar,
  valueSetBool,
  valueGetBool,
  valueSetPointer,
  valueGetPointer,
  valueSetFloat,
  valueGetFloat,
  valueSetDouble,
  valueGetDouble,
  valueSetEnum,
  valueGetEnum,
  valueSetFlags,
  valueGetFlags,
  valueSetString,
  valueGetString,
  valueSetMaybeString,
  valueGetMaybeString,
  valueSetBoxed,
  valueGetBoxed,
  valueSetGObject,
  valueGetGObject,
  valueSetMaybeGObject,
  valueGetMaybeGObject,
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.Flags
import System.Glib.UTFString
{#import System.Glib.GValue#}		(GValue(GValue))
import System.Glib.GObject

{# context lib="glib" prefix="g" #}

valueSetUInt :: GValue -> Word -> IO ()
valueSetUInt gvalue value =
  {# call unsafe value_set_uint #} gvalue (fromIntegral value)

valueGetUInt :: GValue -> IO Word
valueGetUInt gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_uint #} gvalue

valueSetInt :: GValue -> Int -> IO ()
valueSetInt gvalue value =
  {# call unsafe value_set_int #} gvalue (fromIntegral value)

valueGetInt :: GValue -> IO Int
valueGetInt gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_int #} gvalue

valueSetUInt64 :: GValue -> Word64 -> IO ()
valueSetUInt64 gvalue value =
  {# call unsafe value_set_uint64 #} gvalue (fromIntegral value)

valueGetUInt64 :: GValue -> IO Word64
valueGetUInt64 gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_uint64 #} gvalue

valueSetInt64 :: GValue -> Int64 -> IO ()
valueSetInt64 gvalue value =
  {# call unsafe value_set_int64 #} gvalue (fromIntegral value)

valueGetInt64 :: GValue -> IO Int64
valueGetInt64 gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_int64 #} gvalue

{-
valueSetUChar :: GValue -> Word8 -> IO ()
valueSetUChar gvalue value =
  {# call unsafe value_set_uchar #} gvalue value

valueGetUChar :: GValue -> IO Word8
valueGetUChar gvalue =
  {# call unsafe value_get_uchar #} gvalue

valueSetChar :: GValue -> {#type gchar#} -> IO ()
valueSetChar gvalue value =
  {# call unsafe value_set_char #} gvalue value

valueGetChar :: GValue -> IO {#type gchar#}
valueGetChar gvalue =
  {# call unsafe value_get_char #} gvalue
-}

valueSetBool :: GValue -> Bool -> IO ()
valueSetBool gvalue value =
  {# call unsafe value_set_boolean #} gvalue (fromBool value)

valueGetBool :: GValue -> IO Bool
valueGetBool gvalue =
  liftM toBool $
  {# call  unsafe value_get_boolean #} gvalue

-- These functions should probably never be used as they are dangerous.
--
valueSetPointer :: GValue -> (Ptr ()) -> IO ()
valueSetPointer gvalue value =
  {# call unsafe value_set_pointer #} gvalue value

valueGetPointer :: GValue -> IO (Ptr ())
valueGetPointer gvalue =
  {# call unsafe value_get_pointer #} gvalue

valueSetFloat :: GValue -> Float -> IO ()
valueSetFloat gvalue value =
  {# call unsafe value_set_float #} gvalue (realToFrac value)

valueGetFloat :: GValue -> IO Float
valueGetFloat gvalue =
  liftM realToFrac $
  {# call unsafe value_get_float #} gvalue

valueSetDouble :: GValue -> Double -> IO ()
valueSetDouble gvalue value =
  {# call unsafe value_set_double #} gvalue (realToFrac value)

valueGetDouble :: GValue -> IO Double
valueGetDouble gvalue =
  liftM realToFrac $
  {# call unsafe value_get_double #} gvalue

valueSetEnum :: Enum enum => GValue -> enum -> IO ()
valueSetEnum gvalue value =
  {# call unsafe value_set_enum #} gvalue (fromIntegral $ fromEnum value)

valueGetEnum :: Enum enum => GValue -> IO enum
valueGetEnum gvalue =
  liftM (toEnum . fromIntegral) $
  {# call unsafe value_get_enum #} gvalue

valueSetFlags :: Flags flag => GValue -> [flag] -> IO ()
valueSetFlags gvalue value =
  {# call unsafe value_set_flags #} gvalue (fromIntegral $ fromFlags value)

valueGetFlags :: Flags flag => GValue -> IO [flag]
valueGetFlags gvalue =
  liftM (toFlags . fromIntegral) $
  {# call unsafe value_get_flags #} gvalue

valueSetString :: GValue -> String -> IO ()
valueSetString gvalue str =
  withUTFString str $ \strPtr ->
  {# call unsafe value_set_string #} gvalue strPtr

valueGetString :: GValue -> IO String
valueGetString gvalue = do
  strPtr <- {# call unsafe value_get_string #} gvalue
  if strPtr == nullPtr
    then return ""
    else peekUTFString strPtr

valueSetMaybeString :: GValue -> Maybe String -> IO ()
valueSetMaybeString gvalue (Just str) =
  withUTFString str $ \strPtr ->
  {# call unsafe value_set_string #} gvalue strPtr

valueSetMaybeString gvalue Nothing =
  {# call unsafe value_set_static_string #} gvalue nullPtr

valueGetMaybeString :: GValue -> IO (Maybe String)
valueGetMaybeString gvalue =
  {# call unsafe value_get_string #} gvalue
  >>= maybePeek peekUTFString

valueSetBoxed :: (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GValue -> boxed -> IO ()
valueSetBoxed with gvalue boxed =
  with boxed $ \boxedPtr -> do
  {# call unsafe g_value_set_boxed #} gvalue (castPtr boxedPtr)

valueGetBoxed :: (Ptr boxed -> IO boxed) -> GValue -> IO boxed
valueGetBoxed peek gvalue =
  {# call unsafe g_value_get_boxed #} gvalue >>= peek . castPtr

-- for some weird reason the API says that gv is a gpointer, not a GObject
--
valueSetGObject :: GObjectClass gobj => GValue -> gobj -> IO ()
valueSetGObject gvalue obj =
  withForeignPtr ((unGObject.toGObject) obj) $ \objPtr ->
    {# call unsafe g_value_set_object #} gvalue (castPtr objPtr)

-- Unsafe because it performs an unchecked downcast. Only for internal use.
--
valueGetGObject :: GObjectClass gobj => GValue -> IO gobj
valueGetGObject gvalue =
  liftM unsafeCastGObject $
  makeNewGObject mkGObject $
  throwIfNull "GValue.valueGetObject: extracting invalid object" $
  liftM castPtr $
  {# call unsafe value_get_object #} gvalue

valueSetMaybeGObject :: GObjectClass gobj => GValue -> (Maybe gobj) -> IO ()
valueSetMaybeGObject gvalue (Just obj) = valueSetGObject gvalue obj
valueSetMaybeGObject gvalue Nothing =
    {# call unsafe g_value_set_object #} gvalue nullPtr

valueGetMaybeGObject :: GObjectClass gobj => GValue -> IO (Maybe gobj)
valueGetMaybeGObject gvalue =
  liftM (liftM unsafeCastGObject) $
  maybeNull (makeNewGObject mkGObject) $
  liftM castPtr $
  {# call unsafe value_get_object #} gvalue


[project @ 2002-07-17 16:02:09 by juhp] (scrolledWindowNew): Make it maybe take Adjustments, passing a null ptr when Nothing is given.

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Widget ScrolledWindow@
--
--  Author : Axel Simon
--
--  Created: 23 May 2001
--
--  Version $Revision: 1.3 $ from $Date: 2002/07/17 16:02:09 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file 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 General Public License for more details.
--
-- @description@ --------------------------------------------------------------
--
-- * @ScrolledWindow is a container that adds scroll bars to its child. Some
--   widgets have native scrolling support, in which case the scrolling action
--   is performed by the child itself (e.g. a TreeView widget does this by only
--   moving the table part and not the titles of a table). If a widget does
--   not support native scrolling it has to be put into a @TreeView widget.
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------

module ScrolledWindow(
  ScrolledWindow,
  ScrolledWindowClass,
  castToScrolledWindow,
  scrolledWindowNew,
  scrolledWindowGetHAdjustment,
  scrolledWindowGetVAdjustment,
  PolicyType(..),
  scrolledWindowSetPolicy,
  scrolledWindowAddWithViewport,
  CornerType(..),
  scrolledWindowSetPlacement,
  ShadowType(..),
  scrolledWindowSetShadowType,
  scrolledWindowSetHAdjustment,
  scrolledWindowSetVAdjustment,
  ) where

import Monad	(liftM)
import Foreign
import UTFCForeign
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Enums	(PolicyType(..), CornerType(..), ShadowType(..))
import Maybe    (fromMaybe)
import Structs  (nullForeignPtr)

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

-- methods

-- @constructor scrolledWindowNew@ Create a new @ref type ScrolledWindow@.
--
scrolledWindowNew :: Maybe Adjustment -> Maybe Adjustment -> IO ScrolledWindow
scrolledWindowNew hAdj vAdj = makeNewObject mkScrolledWindow $ liftM castPtr $
  {#call unsafe scrolled_window_new#} (fromMAdj hAdj) (fromMAdj vAdj)
 where
 fromMAdj :: Maybe Adjustment -> Adjustment
 fromMAdj = fromMaybe $ mkAdjustment nullForeignPtr

-- @method scrolledWindowGetHAdjustment@ Retrieve the horizontal
-- @ref arg Adjustment@ of the @ref type ScrolledWindow@.
--
scrolledWindowGetHAdjustment :: ScrolledWindowClass w => w -> IO Adjustment
scrolledWindowGetHAdjustment w = makeNewObject mkAdjustment $
  {#call unsafe scrolled_window_get_hadjustment#} (toScrolledWindow w)

-- @method scrolledWindowGetVAdjustment@ Retrieve the vertical
-- @ref arg Adjustment@ of the @ref type ScrolledWindow@.
--
scrolledWindowGetVAdjustment :: ScrolledWindowClass w => w -> IO Adjustment
scrolledWindowGetVAdjustment w = makeNewObject mkAdjustment $
  {#call unsafe scrolled_window_get_vadjustment#} (toScrolledWindow w)

-- @method scrolledWindowSetPolicy@ Specify if the scrollbars should vanish if
-- the child size is sufficiently small.
--
scrolledWindowSetPolicy :: ScrolledWindowClass w => w -> PolicyType ->
                           PolicyType -> IO ()
scrolledWindowSetPolicy w hPol vPol = {#call scrolled_window_set_policy#}
  (toScrolledWindow w) ((fromIntegral.fromEnum) hPol)
  ((fromIntegral.fromEnum) vPol)

-- @method scrolledWindowAddWithViewport@ Add a child widget without native
-- scrolling support to this @ref type ScrolledWindow@.
--
scrolledWindowAddWithViewport :: (ScrolledWindowClass w, WidgetClass wid) =>
                                 w -> wid -> IO ()
scrolledWindowAddWithViewport w wid =
  {#call scrolled_window_add_with_viewport#} (toScrolledWindow w)
  (toWidget wid)

-- @method scrolledWindowSetPlacement@ Specify where the scrollbars should be
-- placed.
--
scrolledWindowSetPlacement :: ScrolledWindowClass w => w -> CornerType -> IO ()
scrolledWindowSetPlacement w ct =
  {#call scrolled_window_set_placement#} (toScrolledWindow w)
  ((fromIntegral.fromEnum) ct)

-- @method scrolledWindowSetShadowType@ Specify if and how an outer frame
-- should be drawn around the child.
--
scrolledWindowSetShadowType :: ScrolledWindowClass w => w -> ShadowType ->
                               IO ()
scrolledWindowSetShadowType w st = {#call scrolled_window_set_shadow_type#}
  (toScrolledWindow w) ((fromIntegral.fromEnum) st)

-- @method scrolledWindowSetHAdjustment@ Set the horizontal
-- @ref arg Adjustment@ of the @ref type ScrolledWindow@.
--
scrolledWindowSetHAdjustment :: ScrolledWindowClass w => w -> Adjustment ->
                                IO ()
scrolledWindowSetHAdjustment w adj = {#call scrolled_window_set_hadjustment#}
  (toScrolledWindow w) adj

-- @method scrolledWindowSetVAdjustment@ Set the vertical @ref arg Adjustment@
-- of the @ref type ScrolledWindow@.
--
scrolledWindowSetVAdjustment :: ScrolledWindowClass w => w -> Adjustment ->
                                IO ()
scrolledWindowSetVAdjustment w adj = {#call scrolled_window_set_hadjustment#}
  (toScrolledWindow w) adj

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Widget ScrolledWindow@
--
--  Author : Axel Simon
--
--  Created: 23 May 2001
--
--  Version $Revision: 1.2 $ from $Date: 2002/05/24 09:43:25 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file 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 General Public License for more details.
--
-- @description@ --------------------------------------------------------------
--
-- * @ScrolledWindow is a container that adds scroll bars to its child. Some
--   widgets have native scrolling support, in which case the scrolling action
--   is performed by the child itself (e.g. a TreeView widget does this by only
--   moving the table part and not the titles of a table). If a widget does
--   not support native scrolling it has to be put into a @TreeView widget.
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------

module ScrolledWindow(
  ScrolledWindow,
  ScrolledWindowClass,
  castToScrolledWindow,
  scrolledWindowNew,
  scrolledWindowGetHAdjustment,
  scrolledWindowGetVAdjustment,
  PolicyType(..),
  scrolledWindowSetPolicy,
  scrolledWindowAddWithViewport,
  CornerType(..),
  scrolledWindowSetPlacement,
  ShadowType(..),
  scrolledWindowSetShadowType,
  scrolledWindowSetHAdjustment,
  scrolledWindowSetVAdjustment,
  ) where

import Monad	(liftM)
import Foreign
import UTFCForeign
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Enums	(PolicyType(..), CornerType(..), ShadowType(..))

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

-- methods

-- @constructor scrolledWindowNew@ Create a new @ref type ScrolledWindow@.
--
scrolledWindowNew :: Adjustment -> Adjustment -> IO ScrolledWindow
scrolledWindowNew vAdj hAdj = makeNewObject mkScrolledWindow $ liftM castPtr $
  {#call unsafe scrolled_window_new#} hAdj vAdj

-- @method scrolledWindowGetHAdjustment@ Retrieve the horizontal
-- @ref arg Adjustment@ of the @ref type ScrolledWindow@.
--
scrolledWindowGetHAdjustment :: ScrolledWindowClass w => w -> IO Adjustment
scrolledWindowGetHAdjustment w = makeNewObject mkAdjustment $
  {#call unsafe scrolled_window_get_hadjustment#} (toScrolledWindow w)

-- @method scrolledWindowGetVAdjustment@ Retrieve the vertical
-- @ref arg Adjustment@ of the @ref type ScrolledWindow@.
--
scrolledWindowGetVAdjustment :: ScrolledWindowClass w => w -> IO Adjustment
scrolledWindowGetVAdjustment w = makeNewObject mkAdjustment $
  {#call unsafe scrolled_window_get_vadjustment#} (toScrolledWindow w)

-- @method scrolledWindowSetPolicy@ Specify if the scrollbars should vanish if
-- the child size is sufficiently small.
--
scrolledWindowSetPolicy :: ScrolledWindowClass w => w -> PolicyType ->
                           PolicyType -> IO ()
scrolledWindowSetPolicy w hPol vPol = {#call scrolled_window_set_policy#}
  (toScrolledWindow w) ((fromIntegral.fromEnum) hPol)
  ((fromIntegral.fromEnum) vPol)

-- @method scrolledWindowAddWithViewport@ Add a child widget without native
-- scrolling support to this @ref type ScrolledWindow@.
--
scrolledWindowAddWithViewport :: (ScrolledWindowClass w, WidgetClass wid) =>
                                 w -> wid -> IO ()
scrolledWindowAddWithViewport w wid =
  {#call scrolled_window_add_with_viewport#} (toScrolledWindow w)
  (toWidget wid)

-- @method scrolledWindowSetPlacement@ Specify where the scrollbars should be
-- placed.
--
scrolledWindowSetPlacement :: ScrolledWindowClass w => w -> CornerType -> IO ()
scrolledWindowSetPlacement w ct =
  {#call scrolled_window_set_placement#} (toScrolledWindow w)
  ((fromIntegral.fromEnum) ct)

-- @method scrolledWindowSetShadowType@ Specify if and how an outer frame
-- should be drawn around the child.
--
scrolledWindowSetShadowType :: ScrolledWindowClass w => w -> ShadowType ->
                               IO ()
scrolledWindowSetShadowType w st = {#call scrolled_window_set_shadow_type#}
  (toScrolledWindow w) ((fromIntegral.fromEnum) st)

-- @method scrolledWindowSetHAdjustment@ Set the horizontal
-- @ref arg Adjustment@ of the @ref type ScrolledWindow@.
--
scrolledWindowSetHAdjustment :: ScrolledWindowClass w => w -> Adjustment ->
                                IO ()
scrolledWindowSetHAdjustment w adj = {#call scrolled_window_set_hadjustment#}
  (toScrolledWindow w) adj

-- @method scrolledWindowSetVAdjustment@ Set the vertical @ref arg Adjustment@
-- of the @ref type ScrolledWindow@.
--
scrolledWindowSetVAdjustment :: ScrolledWindowClass w => w -> Adjustment ->
                                IO ()
scrolledWindowSetVAdjustment w adj = {#call scrolled_window_set_hadjustment#}
  (toScrolledWindow w) adj


Added comment.

Added comment.

{-# LANGUAGE ForeignFunctionInterface #-}

#include <mpi.h>
#include "init_wrapper.h"

module Bindings.MPI.Internal
   (Comm, Datatype, Status (..), init, finalize, send, recv, commWorld, commRank, int) where

import Prelude hiding (init, error)
import C2HS
import Control.Monad (liftM)
import Control.Applicative ((<$>), (<*>))

{# context prefix = "MPI" #}

type Comm = {# type MPI_Comm #}
type Datatype = {# type MPI_Datatype #}

data Status =
   Status
   { status_source :: Int
   , status_tag :: Int
   , status_error :: Int
   , status_count :: Int
   , status_cancelled :: Int
   }
   deriving (Eq, Ord, Show)

{#pointer *Status as StatusPtr -> Status #}

instance Storable Status where
  sizeOf _ = {#sizeof MPI_Status #}
  alignment _ = 4
  peek p = Status
    <$> liftM cIntConv ({#get MPI_Status->MPI_SOURCE #} p)
    <*> liftM cIntConv ({#get MPI_Status->MPI_TAG #} p)
    <*> liftM cIntConv ({#get MPI_Status->MPI_ERROR #} p)
    <*> liftM cIntConv ({#get MPI_Status->_count #} p)
    <*> liftM cIntConv ({#get MPI_Status->_cancelled #} p)
  poke p x = do
    {#set MPI_Status.MPI_SOURCE #} p (cIntConv $ status_source x)
    {#set MPI_Status.MPI_SOURCE #} p (cIntConv $ status_tag x)
    {#set MPI_Status.MPI_ERROR #} p (cIntConv $ status_error x)
    {#set MPI_Status._count #} p (cIntConv $ status_count x)
    {#set MPI_Status._cancelled #} p (cIntConv $ status_cancelled x)

foreign import ccall "mpi_comm_world" commWorld :: Comm
foreign import ccall "mpi_int" int :: Datatype

{# fun unsafe init_wrapper as init {} -> `Int' #}

{# fun unsafe Finalize as ^ {} -> `Int' #}

withStorable :: Storable a => a -> (Ptr a -> IO b) -> IO b
withStorable x f = alloca (\ptr -> poke ptr x >> f ptr)

withStorableCast :: Storable a => a -> (Ptr c -> IO b) -> IO b
withStorableCast x f = withStorable x (f . castPtr)

-- int MPI_Comm_rank(MPI_Comm comm, int *rank)
{# fun unsafe Comm_rank as ^ { id `Comm', alloca- `Int' peekIntConv* } -> `Int' #}

-- int MPI_Send(void *buf, int count, MPI_Datatype datatype, int dest, int tag, MPI_Comm comm)
{# fun unsafe Send as ^ `Storable a' => { withStorableCast* `a', `Int', id `Datatype', `Int', `Int', id `Comm' } -> `Int' #}

-- int MPI_Recv(void *buf, int count, MPI_Datatype datatype, int source, int tag, MPI_Comm comm, MPI_Status *status)
-- recv = {# call unsafe MPI_Recv as ^ #}
-- XXX this should really make the storable thing an output.
{# fun unsafe Recv as ^ `Storable a' => { withStorableCast* `a', `Int', id `Datatype', `Int', `Int', id `Comm', alloca- `Status' peek* } -> `Int' #}

{-# LANGUAGE ForeignFunctionInterface #-}

#include <mpi.h>
#include "init_wrapper.h"

module Bindings.MPI.Internal
   (Comm, Datatype, Status (..), init, finalize, send, recv, commWorld, commRank, int) where

import Prelude hiding (init, error)
import C2HS
import Control.Monad (liftM)
import Control.Applicative ((<$>), (<*>))

{# context prefix = "MPI" #}

type Comm = {# type MPI_Comm #}
type Datatype = {# type MPI_Datatype #}

data Status =
   Status
   { status_source :: Int
   , status_tag :: Int
   , status_error :: Int
   , status_count :: Int
   , status_cancelled :: Int
   }
   deriving (Eq, Ord, Show)

{#pointer *Status as StatusPtr -> Status #}

instance Storable Status where
  sizeOf _ = {#sizeof MPI_Status #}
  alignment _ = 4
  peek p = Status
    <$> liftM cIntConv ({#get MPI_Status->MPI_SOURCE #} p)
    <*> liftM cIntConv ({#get MPI_Status->MPI_TAG #} p)
    <*> liftM cIntConv ({#get MPI_Status->MPI_ERROR #} p)
    <*> liftM cIntConv ({#get MPI_Status->_count #} p)
    <*> liftM cIntConv ({#get MPI_Status->_cancelled #} p)
  poke p x = do
    {#set MPI_Status.MPI_SOURCE #} p (cIntConv $ status_source x)
    {#set MPI_Status.MPI_SOURCE #} p (cIntConv $ status_tag x)
    {#set MPI_Status.MPI_ERROR #} p (cIntConv $ status_error x)
    {#set MPI_Status._count #} p (cIntConv $ status_count x)
    {#set MPI_Status._cancelled #} p (cIntConv $ status_cancelled x)

foreign import ccall "mpi_comm_world" commWorld :: Comm
foreign import ccall "mpi_int" int :: Datatype

{# fun unsafe init_wrapper as init {} -> `Int' #}

{# fun unsafe Finalize as ^ {} -> `Int' #}

withStorable :: Storable a => a -> (Ptr a -> IO b) -> IO b
withStorable x f = alloca (\ptr -> poke ptr x >> f ptr)

withStorableCast :: Storable a => a -> (Ptr c -> IO b) -> IO b
withStorableCast x f = withStorable x (f . castPtr)

-- int MPI_Comm_rank(MPI_Comm comm, int *rank)
{# fun unsafe Comm_rank as ^ { id `Comm', alloca- `Int' peekIntConv* } -> `Int' #}

-- int MPI_Send(void *buf, int count, MPI_Datatype datatype, int dest, int tag, MPI_Comm comm)
{# fun unsafe Send as ^ `Storable a' => { withStorableCast* `a', `Int', id `Datatype', `Int', `Int', id `Comm' } -> `Int' #}

-- int MPI_Recv(void *buf, int count, MPI_Datatype datatype, int source, int tag, MPI_Comm comm, MPI_Status *status)
-- recv = {# call unsafe MPI_Recv as ^ #}
{# fun unsafe Recv as ^ `Storable a' => { withStorableCast* `a', `Int', id `Datatype', `Int', `Int', id `Comm', alloca- `Status' peek* } -> `Int' #}


rename, more understandable when using top-level export

Ignore-this: 2e1e797ad24ed0c2e9b2ac1dd0486d69

darcs-hash:20091211002143-9241b-fdc7b4566e14d722cd91daf16406d06bbf6c7a0c.gz

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

module Foreign.CUDA.Driver.Device
  (
    Device(..), -- should be exported abstractly
    DeviceProperties(..), DeviceAttribute(..), InitFlag,

    initialise, capability, device, attribute, count, name, props, totalMem
  )
  where

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

-- Friends
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Internal.Offsets

-- System
import Foreign
import Foreign.C
import Control.Monad            (liftM)

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

newtype Device = Device { useDevice :: {# type CUdevice #}}
  deriving (Show)

-- |
-- Device attributes
--
{# enum CUdevice_attribute as DeviceAttribute
    { underscoreToCase }
    with prefix="CU_DEVICE_ATTRIBUTE" deriving (Eq, Show) #}

{# pointer *CUdevprop as ^ foreign -> DeviceProperties nocode #}

-- |
-- Properties of the compute device
--
data DeviceProperties = DeviceProperties
  {
    maxThreadsPerBlock  :: Int,           -- ^ Maximum number of threads per block
    maxThreadsDim       :: (Int,Int,Int), -- ^ Maximum size of each dimension of a block
    maxGridSize         :: (Int,Int,Int), -- ^ Maximum size of each dimension of a grid
    sharedMemPerBlock   :: Int,           -- ^ Shared memory available per block in bytes
    totalConstantMemory :: Int,           -- ^ Constant memory available on device in bytes
    warpSize            :: Int,           -- ^ Warp size in threads (SIMD width)
    memPitch            :: Int,           -- ^ Maximum pitch in bytes allowed by memory copies
    regsPerBlock        :: Int,           -- ^ 32-bit registers available per block
    clockRate           :: Int,           -- ^ Clock frequency in kilohertz
    textureAlign        :: Int            -- ^ Alignment requirement for textures
  }
  deriving (Show)

instance Storable DeviceProperties where
  sizeOf _    = {#sizeof CUdevprop#}
  alignment _ = alignment (undefined :: Ptr ())

  peek p      = do
    tb <- cIntConv `fmap` {#get CUdevprop.maxThreadsPerBlock#} p
    sm <- cIntConv `fmap` {#get CUdevprop.sharedMemPerBlock#} p
    cm <- cIntConv `fmap` {#get CUdevprop.totalConstantMemory#} p
    ws <- cIntConv `fmap` {#get CUdevprop.SIMDWidth#} p
    mp <- cIntConv `fmap` {#get CUdevprop.memPitch#} p
    rb <- cIntConv `fmap` {#get CUdevprop.regsPerBlock#} p
    cl <- cIntConv `fmap` {#get CUdevprop.clockRate#} p
    ta <- cIntConv `fmap` {#get CUdevprop.textureAlign#} p

    (t1:t2:t3:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxThreadDimOffset' :: Ptr CInt)
    (g1:g2:g3:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxGridSizeOffset'  :: Ptr CInt)

    return DeviceProperties
      {
        maxThreadsPerBlock  = tb,
        maxThreadsDim       = (t1,t2,t3),
        maxGridSize         = (g1,g2,g3),
        sharedMemPerBlock   = sm,
        totalConstantMemory = cm,
        warpSize            = ws,
        memPitch            = mp,
        regsPerBlock        = rb,
        clockRate           = cl,
        textureAlign        = ta
      }

-- |
-- Possible option flags for CUDA initialisation. Dummy instance until the API
-- exports actual option values.
--
data InitFlag

instance Enum InitFlag where

--------------------------------------------------------------------------------
-- Initialisation
--------------------------------------------------------------------------------

-- |
-- Initialise the CUDA driver API. Must be called before any other driver
-- function.
--
initialise :: [InitFlag] -> IO (Maybe String)
initialise flags = nothingIfOk `fmap` cuInit flags

{# fun unsafe cuInit
  { combineBitMasks `[InitFlag]' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Device Management
--------------------------------------------------------------------------------

-- |
-- Return the compute compatibility revision supported by the device
--
capability :: Device -> IO (Either String Double)
capability dev =
  (\(s,a,b) -> resultIfOk (s,cap a b)) `fmap` cuDeviceComputeCapability dev
  where
    cap a b = let a' = fromIntegral a in
              let b' = fromIntegral b in
              a' + b' / max 10 (10^ ((ceiling . logBase 10) b' :: Int))

{# fun unsafe cuDeviceComputeCapability
  { alloca-   `Int'    peekIntConv*
  , alloca-   `Int'    peekIntConv*
  , useDevice `Device'              } -> `Status' cToEnum #}

-- |
-- Return a device handle
--
device :: Int -> IO (Either String Device)
device d = resultIfOk `fmap` cuDeviceGet d

{# fun unsafe cuDeviceGet
  { alloca-  `Device' dev*
  , cIntConv `Int'           } -> `Status' cToEnum #}
  where dev = liftM Device . peekIntConv

-- |
-- Return the selected attribute for the given device
--
attribute :: Device -> DeviceAttribute -> IO (Either String Int)
attribute d a = resultIfOk `fmap` cuDeviceGetAttribute a d

{# fun unsafe cuDeviceGetAttribute
  { alloca-   `Int'             peekIntConv*
  , cFromEnum `DeviceAttribute'
  , useDevice `Device'                       } -> `Status' cToEnum #}

-- |
-- Return the number of device with compute capability > 1.0
--
count :: IO (Either String Int)
count = resultIfOk `fmap` cuDeviceGetCount

{# fun unsafe cuDeviceGetCount
  { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}

-- |
-- Name of the device
--
name :: Device -> IO (Either String String)
name d = resultIfOk `fmap` cuDeviceGetName d

{# fun unsafe cuDeviceGetName
  { allocaS-  `String'& peekS*
  , useDevice `Device'         } -> `Status' cToEnum #}
  where
    len            = 512
    allocaS a      = allocaBytes len $ \p -> a (p, cIntConv len)
    peekS s _      = peekCString s

-- |
-- Return the properties of the selected device
--
props :: Device -> IO (Either String DeviceProperties)
props d = resultIfOk `fmap` cuDeviceGetProperties d

{# fun unsafe cuDeviceGetProperties
  { alloca-   `DeviceProperties' peek*
  , useDevice `Device'                 } -> `Status' cToEnum #}

-- |
-- Total memory available on the device (bytes)
--
totalMem :: Device -> IO (Either String Int)
totalMem d = resultIfOk `fmap` cuDeviceTotalMem d

{# fun unsafe cuDeviceTotalMem
  { alloca-   `Int' peekIntConv*
  , useDevice `Device'           } -> `Status' cToEnum #}

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

module Foreign.CUDA.Driver.Device
  (
    Device(..), -- should be exported abstractly
    DeviceProperties(..), DeviceAttribute(..), InitFlag,

    initialise, capability, get, attribute, count, name, props, totalMem
  )
  where

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

-- Friends
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Internal.Offsets

-- System
import Foreign
import Foreign.C
import Control.Monad            (liftM)

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

newtype Device = Device { useDevice :: {# type CUdevice #}}
  deriving (Show)

-- |
-- Device attributes
--
{# enum CUdevice_attribute as DeviceAttribute
    { underscoreToCase }
    with prefix="CU_DEVICE_ATTRIBUTE" deriving (Eq, Show) #}

{# pointer *CUdevprop as ^ foreign -> DeviceProperties nocode #}

-- |
-- Properties of the compute device
--
data DeviceProperties = DeviceProperties
  {
    maxThreadsPerBlock  :: Int,           -- ^ Maximum number of threads per block
    maxThreadsDim       :: (Int,Int,Int), -- ^ Maximum size of each dimension of a block
    maxGridSize         :: (Int,Int,Int), -- ^ Maximum size of each dimension of a grid
    sharedMemPerBlock   :: Int,           -- ^ Shared memory available per block in bytes
    totalConstantMemory :: Int,           -- ^ Constant memory available on device in bytes
    warpSize            :: Int,           -- ^ Warp size in threads (SIMD width)
    memPitch            :: Int,           -- ^ Maximum pitch in bytes allowed by memory copies
    regsPerBlock        :: Int,           -- ^ 32-bit registers available per block
    clockRate           :: Int,           -- ^ Clock frequency in kilohertz
    textureAlign        :: Int            -- ^ Alignment requirement for textures
  }
  deriving (Show)

instance Storable DeviceProperties where
  sizeOf _    = {#sizeof CUdevprop#}
  alignment _ = alignment (undefined :: Ptr ())

  peek p      = do
    tb <- cIntConv `fmap` {#get CUdevprop.maxThreadsPerBlock#} p
    sm <- cIntConv `fmap` {#get CUdevprop.sharedMemPerBlock#} p
    cm <- cIntConv `fmap` {#get CUdevprop.totalConstantMemory#} p
    ws <- cIntConv `fmap` {#get CUdevprop.SIMDWidth#} p
    mp <- cIntConv `fmap` {#get CUdevprop.memPitch#} p
    rb <- cIntConv `fmap` {#get CUdevprop.regsPerBlock#} p
    cl <- cIntConv `fmap` {#get CUdevprop.clockRate#} p
    ta <- cIntConv `fmap` {#get CUdevprop.textureAlign#} p

    (t1:t2:t3:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxThreadDimOffset' :: Ptr CInt)
    (g1:g2:g3:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxGridSizeOffset'  :: Ptr CInt)

    return DeviceProperties
      {
        maxThreadsPerBlock  = tb,
        maxThreadsDim       = (t1,t2,t3),
        maxGridSize         = (g1,g2,g3),
        sharedMemPerBlock   = sm,
        totalConstantMemory = cm,
        warpSize            = ws,
        memPitch            = mp,
        regsPerBlock        = rb,
        clockRate           = cl,
        textureAlign        = ta
      }

-- |
-- Possible option flags for CUDA initialisation. Dummy instance until the API
-- exports actual option values.
--
data InitFlag

instance Enum InitFlag where

--------------------------------------------------------------------------------
-- Initialisation
--------------------------------------------------------------------------------

-- |
-- Initialise the CUDA driver API. Must be called before any other driver
-- function.
--
initialise :: [InitFlag] -> IO (Maybe String)
initialise flags = nothingIfOk `fmap` cuInit flags

{# fun unsafe cuInit
  { combineBitMasks `[InitFlag]' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Device Management
--------------------------------------------------------------------------------

-- |
-- Return the compute compatibility revision supported by the device
--
capability :: Device -> IO (Either String Double)
capability dev =
  (\(s,a,b) -> resultIfOk (s,cap a b)) `fmap` cuDeviceComputeCapability dev
  where
    cap a b = let a' = fromIntegral a in
              let b' = fromIntegral b in
              a' + b' / max 10 (10^ ((ceiling . logBase 10) b' :: Int))

{# fun unsafe cuDeviceComputeCapability
  { alloca-   `Int'    peekIntConv*
  , alloca-   `Int'    peekIntConv*
  , useDevice `Device'              } -> `Status' cToEnum #}

-- |
-- Return a device handle
--
get :: Int -> IO (Either String Device)
get d = resultIfOk `fmap` cuDeviceGet d

{# fun unsafe cuDeviceGet
  { alloca-  `Device' dev*
  , cIntConv `Int'           } -> `Status' cToEnum #}
  where dev = liftM Device . peekIntConv

-- |
-- Return the selected attribute for the given device
--
attribute :: Device -> DeviceAttribute -> IO (Either String Int)
attribute d a = resultIfOk `fmap` cuDeviceGetAttribute a d

{# fun unsafe cuDeviceGetAttribute
  { alloca-   `Int'             peekIntConv*
  , cFromEnum `DeviceAttribute'
  , useDevice `Device'                       } -> `Status' cToEnum #}

-- |
-- Return the number of device with compute capability > 1.0
--
count :: IO (Either String Int)
count = resultIfOk `fmap` cuDeviceGetCount

{# fun unsafe cuDeviceGetCount
  { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}

-- |
-- Name of the device
--
name :: Device -> IO (Either String String)
name d = resultIfOk `fmap` cuDeviceGetName d

{# fun unsafe cuDeviceGetName
  { allocaS-  `String'& peekS*
  , useDevice `Device'         } -> `Status' cToEnum #}
  where
    len            = 512
    allocaS a      = allocaBytes len $ \p -> a (p, cIntConv len)
    peekS s _      = peekCString s

-- |
-- Return the properties of the selected device
--
props :: Device -> IO (Either String DeviceProperties)
props d = resultIfOk `fmap` cuDeviceGetProperties d

{# fun unsafe cuDeviceGetProperties
  { alloca-   `DeviceProperties' peek*
  , useDevice `Device'                 } -> `Status' cToEnum #}

-- |
-- Total memory available on the device (bytes)
--
totalMem :: Device -> IO (Either String Int)
totalMem d = resultIfOk `fmap` cuDeviceTotalMem d

{# fun unsafe cuDeviceTotalMem
  { alloca-   `Int' peekIntConv*
  , useDevice `Device'           } -> `Status' cToEnum #}