gstreamer: more docs in M.S.G.Core.Caps

gstreamer: more docs in M.S.G.Core.Caps

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GStreamer, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GStreamer documentation.
--
--  |
--  Maintainer  : gtk2hs-devel@lists.sourceforge.net
--  Stability   : alpha
--  Portability : portable (depends on GHC)
--
--  A structure describing sets of media formats.
module Media.Streaming.GStreamer.Core.Caps (

-- * Detail
  -- | 'Caps' (short for /capabilities/) are lightweight objects
  --   describing media types. They are composed of arrays of
  --   'Structure's.
  --
  --   'Caps' are exposed on 'PadTemplate's to describe all the
  --   possible types a given 'Pad' can handle. They are also stored
  --   in the 'Registry' along with the description of an 'Element'.
  --
  --   'Caps' can be retrieved from an 'Element'\'s 'Pad's using the
  --   'padGetCaps' function. The returned 'Caps' describes the possible
  --   types that the pad can handle or produce at runtime.
  --
  --   'Caps' are also attached to 'Buffers' to describe the type of
  --   the contained data using the function 'bufferSetCaps'. 'Caps'
  --   attached to a buffer allow for format negotiation upstream and
  --   downstream.
  --
  --   'Caps' are /fixed/ when they have no properties with ranges or
  --   lists. Use 'capsIsFixed' to test for fixed caps. Only fixed
  --   caps may be set on a 'Pad' or 'Buffer'.

-- * Types
  Caps,
  capsNone,
  capsAny,

-- * Caps Operations
  capsSize,
  capsGetStructure,
  capsIsEmpty,
  capsIsFixed,
  capsIsEqual,
  capsIsEqualFixed,
  capsIsAlwaysCompatible,
  capsIsSubset,
  capsIntersect,
  capsUnion,
  capsSubtract,
  capsNormalize,
  capsFromString,
  capsToString,

-- * Caps Mutation
  CapsM,
  capsCreate,
  capsModify,
  capsAppendStructure,
  capsMergeStructure,
  capsRemoveStructure,
  capsTruncate

  ) where

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

import Control.Monad (liftM)
import Control.Monad.Reader
import System.Glib.FFI
import System.Glib.UTFString
{#import Media.Streaming.GStreamer.Core.Types#}

-- | A 'Caps' that represents an undefined media type.
capsNone :: Caps
capsNone =
    unsafePerformIO $ {# call caps_new_empty #} >>= takeCaps

-- | A 'Caps' that represents all possible media types.
capsAny :: Caps
capsAny =
    unsafePerformIO $ {# call caps_new_any #} >>= takeCaps

-- | Get the number of structures contained in the 'Caps'.
capsSize :: Caps -- ^ @caps@ - a 'Caps'
         -> Word -- ^ the number of structures contained in the 'Caps'
capsSize caps =
    fromIntegral $ unsafePerformIO $ {# call caps_get_size #} caps

-- | Get the 'Structure' at the given index.
capsGetStructure :: Caps            -- ^ @caps@ - a 'Caps'
                 -> Word            -- ^ @index@ - the index of the 'Structure'
                 -> Maybe Structure -- ^ the 'Structure' at the given index, or 'Nothing'
                                    --   if @index@ is invalid
capsGetStructure caps index =
    unsafePerformIO $
        {# call caps_get_structure #} caps (fromIntegral index) >>=
            maybePeek peekStructure

-- | Create a new 'Caps' containing only the 'Structure' at the given
--   index of the caps.
capsCopyNth :: Caps       -- ^ @caps@ - a 'Caps'
            -> Word       -- ^ @index@ - the index of the 'Structure'
            -> Maybe Caps -- ^ the new 'Caps', or 'Nothing'
                          --   if @index@ is invalid
capsCopyNth caps index =
    unsafePerformIO $
        {# call caps_copy_nth #} caps (fromIntegral index) >>=
            maybePeek takeCaps

-- | Determine whether @caps@ represents no media formats.
capsIsEmpty :: Caps -- ^ @caps@ - a 'Caps'
            -> Bool -- ^ 'True' if @caps@ is empty, otherwise 'False'
capsIsEmpty caps =
    toBool $ unsafePerformIO $
        {# call caps_is_empty #} caps

-- | Determine whether the @caps@ is fixed; that is, if it has exactly
--   one structure, and each field in the structure describes a fixed type.
capsIsFixed :: Caps -- ^ @caps@ - a 'Caps'
            -> Bool -- ^ 'True' if @caps@ is fixed, otherwise 'False'
capsIsFixed caps =
    toBool $ unsafePerformIO $
        {# call caps_is_fixed #} caps

-- | Returns 'True' if the caps represent the same set of capabilities.
--
--   This function does not work reliably if optional properties for
--   'Caps' are included on one 'Caps' but omitted on the other.
capsIsEqual :: Caps -- ^ @caps1@ - the first 'Caps'
            -> Caps -- ^ @caps2@ - the second 'Caps'
            -> Bool -- ^ 'True' if both 'Caps' represent the same set
                    --   of capabilities.
capsIsEqual caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_equal #} caps1 caps2

instance Eq Caps where
    (==) = capsIsEqual

-- | Returns 'True' if the caps are equal.  The caps must both be
--   fixed.
capsIsEqualFixed :: Caps -- ^ @caps1@ - the first 'Caps'
                 -> Caps -- ^ @caps2@ - the second 'Caps'
                 -> Bool -- ^ 'True' if both 'Caps' represent the same set
                         --   of capabilities
capsIsEqualFixed caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_equal_fixed #} caps1 caps2

-- | Returns 'True' if every media format in the first caps is also
--   contained by the second. That is, the first is a subset of the
--   second.
capsIsAlwaysCompatible :: Caps -- ^ @caps1@ - the first 'Caps'
                       -> Caps -- ^ @caps2@ - the second 'Caps'
                       -> Bool -- ^ 'True' if @caps1@ is a subset of @caps2@, otherwise 'False'
capsIsAlwaysCompatible caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_always_compatible #} caps1 caps2

-- | Returns 'True' if all caps represented by the first argument are
--   also represented by the second.
--
--   This function does not work reliably if optional properties for
--   caps are included on one caps and omitted on the other.
capsIsSubset :: Caps -- ^ @caps1@ - the first 'Caps'
             -> Caps -- ^ @caps2@ - the second 'Caps'
             -> Bool -- ^ 'True' if @caps1@ is a subset of @caps2@, otherwise 'False'
capsIsSubset caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_subset #} caps1 caps2

-- | Creates a new caps containing all the formats that are common to
--   both of the caps.
capsIntersect :: Caps -- ^ @caps1@ - the first 'Caps'
              -> Caps -- ^ @caps2@ - the second 'Caps'
              -> Caps -- ^ a new 'Caps' containing all capabilities present
                      --   in both @caps1@ and @caps2@
capsIntersect caps1 caps2 =
    unsafePerformIO $
        {# call caps_intersect #} caps1 caps2 >>=
            takeCaps

-- | Creates a new caps containing all the formats that are common to
--   either of the caps. If either of the structures are equivalient
--   to 'capsAny', the result will be 'capsAny'.
capsUnion :: Caps -- ^ @caps1@ - the first 'Caps'
          -> Caps -- ^ @caps2@ - the second 'Caps'
          -> Caps -- ^ a new 'Caps' containing all capabilities present
                  --   in either @caps1@ and @caps2@
capsUnion caps1 caps2 =
    unsafePerformIO $
        {# call caps_union #} caps1 caps2 >>=
            takeCaps

-- | Creates a new caps containing all the formats that are in the
--   first but not the second.
capsSubtract :: Caps -- ^ @caps1@ - the first 'Caps'
             -> Caps -- ^ @caps2@ - the second 'Caps'
             -> Caps -- ^ a new 'Caps' containing all capabilities present
                     --   in @caps1@ but not @caps2@
capsSubtract caps1 caps2 =
    unsafePerformIO $
        {# call caps_subtract #} caps1 caps2 >>=
            takeCaps

-- | Creates a new caps that represents the same set of formats as the
--   argument, but that contains no lists.
capsNormalize :: Caps -- ^ @caps@ - a 'Caps'
              -> Caps -- ^ the new, normalized 'Caps'
capsNormalize caps =
    unsafePerformIO $
        {# call caps_normalize #} caps >>= takeCaps

-- | Converts the argument to a string representation. The string can
--   be converted back to a caps using 'capsFromString'.
capsToString :: Caps   -- ^ @caps@ - a 'Caps'
             -> String -- ^ the string representation of 'Caps'
capsToString caps =
    unsafePerformIO $
        {# call caps_to_string #} caps >>= readUTFString

-- | Read a caps from a string.
capsFromString :: String     -- ^ @string@ - the string representation of a 'Caps'
               -> Maybe Caps -- ^ the new 'Caps', or 'Nothing' if @string@ is invalid
capsFromString string =
    unsafePerformIO $
        withUTFString string {# call caps_from_string #} >>=
            maybePeek takeCaps

-- | A 'Monad' for sequencing modifications to a 'Caps'.
newtype CapsM a =
    CapsM (ReaderT (Ptr Caps) IO a)
    deriving (Functor, Monad)

askCapsPtr :: CapsM (Ptr Caps)
askCapsPtr = CapsM $ ask

marshalCapsModify :: IO (Ptr Caps)
                  -> CapsM a
                  -> (Caps, a)
marshalCapsModify mkCaps (CapsM action) =
    unsafePerformIO $
        do ptr <- mkCaps
           result <- runReaderT action ptr
           caps <- takeCaps ptr
           return (caps, result)

-- | Create a caps and mutate it according to the given action.
capsCreate :: CapsM a   -- ^ @mutate@ - the mutating action
           -> (Caps, a) -- ^ the new 'Caps' and the action's result
capsCreate mutate =
    marshalCapsModify
        {# call caps_new_empty #}
        mutate

-- | Copy a caps and mutate it according to the given action.
capsModify :: Caps      -- ^ @caps@ - the 'Caps' to modify
           -> CapsM a   -- ^ @mutate@ - the mutating action
           -> (Caps, a) -- ^ the new 'Caps' and the action's result
capsModify caps mutate =
    marshalCapsModify ({# call caps_copy #} caps) mutate

-- | Append the given structure to the current caps.
capsAppendStructure :: Structure -- ^ @structure@ - the 'Structure' to append to the current 'Caps'
                    -> CapsM ()
capsAppendStructure structure = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ withStructure structure $ \structurePtr ->
      do structurePtr' <- gst_structure_copy structurePtr
         gst_caps_append_structure capsPtr structurePtr
  where _ = {# call caps_append_structure #}
        _ = {# call structure_copy #}

-- | Append the structure to the current caps, if it is not already
--   expressed by the caps.
capsMergeStructure :: Structure -- ^ @structure@ - the 'Structure' to merge with the current 'Caps'
                   -> CapsM ()
capsMergeStructure structure = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ withStructure structure $ \structurePtr ->
      do structurePtr' <- gst_structure_copy structurePtr
         gst_caps_merge_structure capsPtr structurePtr
  where _ = {# call caps_merge_structure #}
        _ = {# call structure_copy #}

-- | Removes the structure at the given index from the current caps.
capsRemoveStructure :: Word     -- ^ @idx@ - the index of the 'Structure' to remove
                    -> CapsM ()
capsRemoveStructure idx = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ gst_caps_remove_structure capsPtr $ fromIntegral idx
  where _ = {# call caps_remove_structure #}

-- | Discard all but the first structure from the current caps.
capsTruncate :: CapsM ()
capsTruncate = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ gst_caps_truncate capsPtr
  where _ = {# call caps_truncate #}

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GStreamer, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GStreamer documentation.
--
--  |
--  Maintainer  : gtk2hs-devel@lists.sourceforge.net
--  Stability   : alpha
--  Portability : portable (depends on GHC)
--
--  A structure describing sets of media formats.
module Media.Streaming.GStreamer.Core.Caps (

-- * Detail
  -- | 'Caps' (short for /capabilities/) are lightweight objects
  --   describing media types. They are composed of arrays of
  --   'Structure's.
  --
  --   'Caps' are exposed on 'PadTemplate's to describe all the
  --   possible types a given 'Pad' can handle. They are also stored
  --   in the 'Registry' along with the description of an 'Element'.
  --
  --   'Caps' can be retrieved from an 'Element'\'s 'Pad's using the
  --   'padGetCaps' function. The returned 'Caps' describes the possible
  --   types that the pad can handle or produce at runtime.
  --
  --   'Caps' are also attached to 'Buffers' to describe the type of
  --   the contained data using the function 'bufferSetCaps'. 'Caps'
  --   attached to a buffer allow for format negotiation upstream and
  --   downstream.
  --
  --   'Caps' are /fixed/ when they have no properties with ranges or
  --   lists. Use 'capsIsFixed' to test for fixed caps. Only fixed
  --   caps may be set on a 'Pad' or 'Buffer'.

-- * Types
  Caps,
  capsNone,
  capsAny,

-- * Caps Operations
  capsSize,
  capsGetStructure,
  capsIsEmpty,
  capsIsFixed,
  capsIsEqual,
  capsIsEqualFixed,
  capsIsAlwaysCompatible,
  capsIsSubset,
  capsIntersect,
  capsUnion,
  capsSubtract,
  capsNormalize,
  capsFromString,
  capsToString,

-- * Caps Mutation
  CapsM,
  capsCreate,
  capsModify,
  capsAppendStructure,
  capsMergeStructure,
  capsRemoveStructure,
  capsTruncate

  ) where

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

import Control.Monad (liftM)
import Control.Monad.Reader
import System.Glib.FFI
import System.Glib.UTFString
{#import Media.Streaming.GStreamer.Core.Types#}

-- | A 'Caps' that represents an undefined media type.
capsNone :: Caps
capsNone =
    unsafePerformIO $ {# call caps_new_empty #} >>= takeCaps

-- | A 'Caps' that represents all possible media types.
capsAny :: Caps
capsAny =
    unsafePerformIO $ {# call caps_new_any #} >>= takeCaps

-- | Returns the number of structures contained in the 'Caps'.
capsSize :: Caps
         -> Word
capsSize caps =
    fromIntegral $ unsafePerformIO $ {# call caps_get_size #} caps

-- | Returns the 'Structure' at the given index.
capsGetStructure :: Caps
                 -> Word
                 -> Maybe Structure
capsGetStructure caps index =
    unsafePerformIO $
        {# call caps_get_structure #} caps (fromIntegral index) >>=
            maybePeek peekStructure

-- | Returns a new 'Caps' containing only the 'Structure' at the given
--   index of the caps.
capsCopyNth :: Caps
            -> Word
            -> Maybe Caps
capsCopyNth caps index =
    unsafePerformIO $
        {# call caps_copy_nth #} caps (fromIntegral index) >>=
            maybePeek takeCaps

-- | Returns 'True' if the caps represents no media formats.
capsIsEmpty :: Caps
            -> Bool
capsIsEmpty caps =
    toBool $ unsafePerformIO $
        {# call caps_is_empty #} caps

-- | Returns 'True' if the caps is fixed.
capsIsFixed :: Caps
            -> Bool
capsIsFixed caps =
    toBool $ unsafePerformIO $
        {# call caps_is_fixed #} caps

-- | Returns 'True' if the caps represent the same set of capabilities.
capsIsEqual :: Caps
            -> Caps
            -> Bool
capsIsEqual caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_equal #} caps1 caps2

instance Eq Caps where
    (==) = capsIsEqual

-- | Returns 'True' if the caps are equal.  The caps must both be
--   fixed.
capsIsEqualFixed :: Caps
                 -> Caps
                 -> Bool
capsIsEqualFixed caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_equal_fixed #} caps1 caps2

-- | Returns 'True' if every media format in the first caps is also
--   contained by the second. That is, the first is a subset of the
--   second.
capsIsAlwaysCompatible :: Caps
                       -> Caps
                       -> Bool
capsIsAlwaysCompatible caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_always_compatible #} caps1 caps2

-- | Returns 'True' if all caps represented by the first argument are
--   also represented by the second.
--
--   This function does not work reliably if optional properties for
--   caps are included on one caps and omitted on the other.
capsIsSubset :: Caps
             -> Caps
             -> Bool
capsIsSubset caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_subset #} caps1 caps2

-- | Creates a new caps containing all the formats that are common to
--   both of the caps.
capsIntersect :: Caps
              -> Caps
              -> Caps
capsIntersect caps1 caps2 =
    unsafePerformIO $
        {# call caps_intersect #} caps1 caps2 >>=
            takeCaps

-- | Creates a new caps containing all the formats that are common to
--   either of the caps. If either of the structures are equivalient
--   to 'capsAny', the result will be 'capsAny'.
capsUnion :: Caps
          -> Caps
          -> Caps
capsUnion caps1 caps2 =
    unsafePerformIO $
        {# call caps_union #} caps1 caps2 >>=
            takeCaps

-- | Creates a new caps containing all the formats that are in the
--   first but not the second.
capsSubtract :: Caps
             -> Caps
             -> Caps
capsSubtract caps1 caps2 =
    unsafePerformIO $
        {# call caps_subtract #} caps1 caps2 >>=
            takeCaps

-- | Creates a new caps that represents the same set of formats as the
--   argument, but that contains no lists.
capsNormalize :: Caps
              -> Caps
capsNormalize caps =
    unsafePerformIO $
        {# call caps_normalize #} caps >>= takeCaps

-- | Converts the argument to a string representation. The string can
--   be converted back to a caps using 'capsFromString'.
capsToString :: Caps
             -> String
capsToString caps =
    unsafePerformIO $
        {# call caps_to_string #} caps >>= readUTFString

-- | Read a caps from a string.
capsFromString :: String
               -> Maybe Caps
capsFromString string =
    unsafePerformIO $
        withUTFString string {# call caps_from_string #} >>=
            maybePeek takeCaps

-- | A 'Monad' for sequencing modifications to a 'Caps'.
newtype CapsM a =
    CapsM (ReaderT (Ptr Caps) IO a)
    deriving (Functor, Monad)

askCapsPtr :: CapsM (Ptr Caps)
askCapsPtr = CapsM $ ask

marshalCapsModify :: IO (Ptr Caps)
                  -> CapsM a
                  -> (Caps, a)
marshalCapsModify mkCaps (CapsM action) =
    unsafePerformIO $
        do ptr <- mkCaps
           result <- runReaderT action ptr
           caps <- takeCaps ptr
           return (caps, result)

-- | Create a caps and mutate it according to the given action.
capsCreate :: CapsM a
           -> (Caps, a)
capsCreate action =
    marshalCapsModify
        {# call caps_new_empty #}
        action

-- | Copy a caps and mutate it according to the given action.
capsModify :: Caps
           -> CapsM a
           -> (Caps, a)
capsModify caps action =
    marshalCapsModify ({# call caps_copy #} caps) action

-- | Append the given structure to the current caps.
capsAppendStructure :: Structure
                    -> CapsM ()
capsAppendStructure structure = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ withStructure structure $ \structurePtr ->
      do structurePtr' <- gst_structure_copy structurePtr
         gst_caps_append_structure capsPtr structurePtr
  where _ = {# call caps_append_structure #}
        _ = {# call structure_copy #}

-- | Append the structure to the current caps, if it is not already
--   expressed by the caps.
capsMergeStructure :: Structure
                   -> CapsM ()
capsMergeStructure structure = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ withStructure structure $ \structurePtr ->
      do structurePtr' <- gst_structure_copy structurePtr
         gst_caps_merge_structure capsPtr structurePtr
  where _ = {# call caps_merge_structure #}
        _ = {# call structure_copy #}

-- | Removes the structure at the given index from the current caps.
capsRemoveStructure :: Word
                    -> CapsM ()
capsRemoveStructure idx = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ gst_caps_remove_structure capsPtr $ fromIntegral idx
  where _ = {# call caps_remove_structure #}

-- | Discard all but the first structure from the current caps.
capsTruncate :: CapsM ()
capsTruncate = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ gst_caps_truncate capsPtr
  where _ = {# call caps_truncate #}


Add mutex functions to Gtk and remove the funky threaded intialisation function.

-- -*-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,
  threadsEnter,
  threadsLeave,

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

unsafeInitGUIForThreadedRTS = initGUI

-- We compile this module using -#includ"gtk/wingtk.h" to bypass the win32 abi
-- check however we do not compile users programs with this header 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.\"@
--
--
-- * If you want to use Gtk2Hs and in a multi-threaded application 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'. See also 'threadsEnter'.
--
initGUI :: IO [String]
initGUI = do
  when rtsSupportsBoundThreads initialiseGThreads
  threadsEnter
  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 ()

-- | Acquired the global Gtk lock.
--
-- * During normal operation, this lock is held by the thread from which all
--   interaction with Gtk is performed. When calling 'mainGUI', the thread will
--   release this global lock before it waits for user interaction. During this
--   time it is, in principle, possible to use a different OS thread (any other
--   Haskell thread that is bound to the Gtk OS thread will be blocked anyway)
--   to interact with Gtk by explicitly acquiring the lock, calling Gtk functions
--   and releasing the lock. However, the Gtk functions that are called from this
--   different thread may not trigger any calls to the OS since this will
--   lead to a crash on Windows (the Win32 API can only be used from a single
--   thread). Since it is very hard to tell which function only interacts on
--   Gtk data structures and which function call actual OS functions, it
--   is best not to use this feature at all. A better way to perform updates
--   in the background is to spawn a Haskell thread and to perform the update
--   to Gtk widgets using 'postGUIAsync' or 'postGUISync'. These will execute
--   their arguments from the main loop, that is, from the OS thread of Gtk,
--   thereby ensuring that any Gtk and OS function can be called.
--
{#fun unsafe gdk_threads_enter as threadsEnter {} -> `()' #}

-- | Release the global Gtk lock.
--
-- * The use of this function is not recommended. See 'threadsEnter'.
--
{#fun unsafe gdk_threads_leave as threadsLeave {} -> `()' #}

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


unfortunately need to export the accessor; must fix this!

Ignore-this: 5b262b31d6c264545674ca68dcd5e446

darcs-hash:20091124051426-9241b-46bae7fda937489831cc5b30c8881a2ca61839c1.gz

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- 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(..), Attribute(..),

    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 Attribute
    { 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
      }

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

-- |
-- Initialise the CUDA driver API. Fills in the `flags' parameter with the
-- required zero value. Must be called before any other driver function.
--
initialise :: IO (Maybe String)
initialise =  nothingIfOk `fmap` cuInit 0

{# fun unsafe cuInit
  { cIntConv `Int' } -> `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 -> Attribute -> IO (Either String Int)
attribute d a = resultIfOk `fmap` cuDeviceGetAttribute a d

{# fun unsafe cuDeviceGetAttribute
  { alloca-   `Int'       peekIntConv*
  , cFromEnum `Attribute'
  , 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 #-}
--------------------------------------------------------------------------------
-- |
-- 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, DeviceProperties(..), Attribute(..),

    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 Attribute
    { 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
      }

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

-- |
-- Initialise the CUDA driver API. Fills in the `flags' parameter with the
-- required zero value. Must be called before any other driver function.
--
initialise :: IO (Maybe String)
initialise =  nothingIfOk `fmap` cuInit 0

{# fun unsafe cuInit
  { cIntConv `Int' } -> `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 -> Attribute -> IO (Either String Int)
attribute d a = resultIfOk `fmap` cuDeviceGetAttribute a d

{# fun unsafe cuDeviceGetAttribute
  { alloca-   `Int'       peekIntConv*
  , cFromEnum `Attribute'
  , 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 #}


removed phantom type from Datasource

removed phantom type from Datasource


fixed memory leak

fixed memory leak