[project @ 2002-07-17 16:07:50 by juhp] Export timeoutAdd, timeoutRemove, idleAdd, idleRemove and HandlerId.

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry General initialization@
--
--  Author : Manuel M. T. Chakravarty
--  Created: 8 December 1998
--
--  Version $Revision: 1.4 $ from $Date: 2002/07/17 16:07:50 $
--
--  Copyright (c) [2000..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@ --------------------------------------------------------------
--
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------
--
--  * quitAddDestroy, quitAdd, quitRemove, inputAdd, inputRemove
--
{-# OPTIONS -optc-include gtk/gtk.h #-}
module General(
  setLocale,
--  getDefaultLanguage,
  init,
  eventsPending,
  main,
  mainLevel,
  mainQuit,
  mainIteration,
  grabAdd,
  grabGetCurrent,
  grabRemove,
  mkDestructor,
  DestroyNotify,
  timeoutAdd,
  timeoutRemove,
  idleAdd,
  idleRemove,
  HandlerId
  ) where

import Prelude
       hiding   (init)
import System   (getProgName, getArgs, ExitCode(ExitSuccess, ExitFailure))
import Monad	(liftM, mapM)
import Foreign
import UTFCForeign
import IOExts	(newIORef, readIORef, writeIORef)
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Enums    (InputCondition(..))

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

-- @method setLocale@ Ensure that the current locale is read.
--
setLocale :: IO String
setLocale  = do
  strPtr <- {#call unsafe set_locale#}
  str <- peekCString strPtr
  destruct strPtr
  return str

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

-- @method init@ initialize GTK+
--
-- * extracts all GTK+ specific arguments from the given options list
--
init :: Maybe (String, [String]) -> IO (String, [String])
init Nothing = do
  prog <- getProgName
  args <- getArgs
  init $ Just (prog, args)
init (Just (prog, args)) = do
  let allArgs = (prog:args)
      argc    = length allArgs
  withMany withCString allArgs $ \addrs  ->
    withArray	       addrs   $ \argv ->
    withObject	       argv    $ \argvp ->
    withObject	       argc    $ \argcp ->
    do
--      {#call unsafe init#} argcp argvp
      {#call unsafe init#} (castPtr argcp) (castPtr argvp)
      argc'   <- peek argcp
      argv'   <- peek argvp
      addrs'  <- peekArray argc' argv'
      _:args' <- mapM peekCString addrs'  -- drop the program name
      return (prog, args')

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

-- @method main@ GTK+'s main event loop
--
main :: IO ()
main  = {#call main#}

-- @method mainLevel@ Inquire the main level
--
mainLevel :: IO Int
mainLevel  = liftM (toEnum.fromEnum) {#call unsafe main_level#}

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

-- @method mainIteration@ process events
--
mainIteration :: IO Bool
mainIteration  = liftM toBool {#call main_iteration#}

-- @method mainIterationDo@ process events
--
mainIterationDo :: Bool -> IO Bool
mainIterationDo blocking =
  liftM toBool $ {#call main_iteration_do#} (fromBool blocking)

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

-- @method grabGetCurrent@ 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)

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

{#pointer Function#}

foreign export dynamic mkHandler :: IO {#type gint#} -> IO Function

{#pointer DestroyNotify#}

foreign export dynamic mkDestructor :: IO () -> IO DestroyNotify

type HandlerId = {#type guint#}

-- Turn a function into a function pointer and a destructor pointer.
--
makeCallback :: IO {#type gint#} -> IO (Function, DestroyNotify)
makeCallback fun = do
  funPtr <- mkHandler fun
  dRef <- newIORef nullFunPtr
  dPtr <- mkDestructor $ do
    freeHaskellFunPtr funPtr
    dPtr <- readIORef dRef
    freeHaskellFunPtr dPtr
  writeIORef dRef dPtr
  return (funPtr, dPtr)

-- @method timeoutAdd@ Register a function that is to be called after
-- @ref arg interval@ ms have been elapsed.
--
-- * If the function returns False it will be removed.
--
timeoutAdd :: IO Bool -> Int -> IO HandlerId
timeoutAdd fun msec = do
  (funPtr, dPtr) <- makeCallback (liftM fromBool fun)
  {#call unsafe timeout_add_full#} (fromIntegral msec) funPtr nullFunPtr
    nullPtr dPtr

-- @method timeoutRemove@ Remove a previously added timeout handler by its
-- @ref type TimeoutId@.
--
timeoutRemove :: HandlerId -> IO ()
timeoutRemove  = {#call unsafe timeout_remove#}

-- @method idleAdd@ Add a callback that is called whenever the system is idle.
--
-- * A priority can be specified.
--
idleAdd :: IO Bool -> Int -> IO HandlerId
idleAdd fun pri = do
  (funPtr, dPtr) <- makeCallback (liftM fromBool fun)
  {#call unsafe idle_add_full#} (fromIntegral pri) funPtr nullFunPtr
    nullPtr dPtr

-- @method idleRemove@ Remove a previously added idle handler by its
-- @ref arg TimeoutId@.
--
idleRemove :: HandlerId -> IO ()
idleRemove  = {#call unsafe idle_remove#}

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry General initialization@
--
--  Author : Manuel M. T. Chakravarty
--  Created: 8 December 1998
--
--  Version $Revision: 1.3 $ from $Date: 2002/07/08 09:13:09 $
--
--  Copyright (c) [2000..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@ --------------------------------------------------------------
--
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------
--
--  * quitAddDestroy, quitAdd, quitRemove, timeoutAdd, timeoutRemove, idleAdd,
--    idleRemove, inputAdd, inputRemove
--
{-# OPTIONS -optc-include gtk/gtk.h #-}
module General(
  setLocale,
--  getDefaultLanguage,
  init,
  eventsPending,
  main,
  mainLevel,
  mainQuit,
  mainIteration,
  grabAdd,
  grabGetCurrent,
  grabRemove,
  mkDestructor,
  DestroyNotify
  ) where

import Prelude
       hiding   (init)
import System   (getProgName, getArgs, ExitCode(ExitSuccess, ExitFailure))
import Monad	(liftM, mapM)
import Foreign
import UTFCForeign
import IOExts	(newIORef, readIORef, writeIORef)
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Enums    (InputCondition(..))

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

-- @method setLocale@ Ensure that the current locale is read.
--
setLocale :: IO String
setLocale  = do
  strPtr <- {#call unsafe set_locale#}
  str <- peekCString strPtr
  destruct strPtr
  return str

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

-- @method init@ initialize GTK+
--
-- * extracts all GTK+ specific arguments from the given options list
--
init :: Maybe (String, [String]) -> IO (String, [String])
init Nothing = do
  prog <- getProgName
  args <- getArgs
  init $ Just (prog, args)
init (Just (prog, args)) = do
  let allArgs = (prog:args)
      argc    = length allArgs
  withMany withCString allArgs $ \addrs  ->
    withArray	       addrs   $ \argv ->
    withObject	       argv    $ \argvp ->
    withObject	       argc    $ \argcp ->
    do
--      {#call unsafe init#} argcp argvp
      {#call unsafe init#} (castPtr argcp) (castPtr argvp)
      argc'   <- peek argcp
      argv'   <- peek argvp
      addrs'  <- peekArray argc' argv'
      _:args' <- mapM peekCString addrs'  -- drop the program name
      return (prog, args')

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

-- @method main@ GTK+'s main event loop
--
main :: IO ()
main  = {#call main#}

-- @method mainLevel@ Inquire the main level
--
mainLevel :: IO Int
mainLevel  = liftM (toEnum.fromEnum) {#call unsafe main_level#}

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

-- @method mainIteration@ process events
--
mainIteration :: IO Bool
mainIteration  = liftM toBool {#call main_iteration#}

-- @method mainIterationDo@ process events
--
mainIterationDo :: Bool -> IO Bool
mainIterationDo blocking =
  liftM toBool $ {#call main_iteration_do#} (fromBool blocking)

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

-- @method grabGetCurrent@ 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)

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

{#pointer Function#}

foreign export dynamic mkHandler :: IO {#type gint#} -> IO Function

{#pointer DestroyNotify#}

foreign export dynamic mkDestructor :: IO () -> IO DestroyNotify

type HandlerId = {#type guint#}

-- Turn a function into a function pointer and a destructor pointer.
--
makeCallback :: IO {#type gint#} -> IO (Function, DestroyNotify)
makeCallback fun = do
  funPtr <- mkHandler fun
  dRef <- newIORef nullFunPtr
  dPtr <- mkDestructor $ do
    freeHaskellFunPtr funPtr
    dPtr <- readIORef dRef
    freeHaskellFunPtr dPtr
  writeIORef dRef dPtr
  return (funPtr, dPtr)

-- @method timeoutAdd@ Register a function that is to be called after
-- @ref arg interval@ ms have been elapsed.
--
-- * If the function returns False it will be removed.
--
timeoutAdd :: IO Bool -> Int -> IO HandlerId
timeoutAdd fun msec = do
  (funPtr, dPtr) <- makeCallback (liftM fromBool fun)
  {#call unsafe timeout_add_full#} (fromIntegral msec) funPtr nullFunPtr
    nullPtr dPtr

-- @method timeoutRemove@ Remove a previously added timeout handler by its
-- @ref type TimeoutId@.
--
timeoutRemove :: HandlerId -> IO ()
timeoutRemove  = {#call unsafe timeout_remove#}

-- @method idleAdd@ Add a callback that is called whenever the system is idle.
--
-- * A priority can be specified.
--
idleAdd :: IO Bool -> Int -> IO HandlerId
idleAdd fun pri = do
  (funPtr, dPtr) <- makeCallback (liftM fromBool fun)
  {#call unsafe idle_add_full#} (fromIntegral pri) funPtr nullFunPtr
    nullPtr dPtr

-- @method idleRemove@ Remove a previously added idle handler by its
-- @ref arg TimeoutId@.
--
idleRemove :: HandlerId -> IO ()
idleRemove  = {#call unsafe idle_remove#}


MPICH2: peek/poke of MPI_Status

MPICH2: peek/poke of MPI_Status

{-# LANGUAGE ForeignFunctionInterface #-}

#include <mpi.h>

module Control.Parallel.MPI.Status (Status (..), StatusPtr) where

import C2HS
import Control.Monad (liftM)
import Control.Applicative ((<$>), (<*>))

{# context prefix = "MPI" #}

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
#ifdef MPICH2
    -- MPICH2 and OpenMPI use different names for the status struct
    -- fields AND different order of fields
    <$> liftM cIntConv ({#get MPI_Status->count #} p)
    <*> liftM cIntConv ({#get MPI_Status->cancelled #} p)
    <*> liftM cIntConv ({#get MPI_Status->MPI_SOURCE #} p)
    <*> liftM cIntConv ({#get MPI_Status->MPI_TAG #} p)
    <*> liftM cIntConv ({#get MPI_Status->MPI_ERROR #} p)
#else
    <$> 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)
#endif
  poke p x = do
#ifdef MPICH2
    -- MPICH2 and OpenMPI use different names for the status struct
    -- fields AND different order of fields
    {#set MPI_Status.count #} p (cIntConv $ status_count x)
    {#set MPI_Status.cancelled #} p (cIntConv $ status_cancelled x)
    {#set MPI_Status.MPI_SOURCE #} p (cIntConv $ status_source x)
    {#set MPI_Status.MPI_TAG #} p (cIntConv $ status_tag x)
    {#set MPI_Status.MPI_ERROR #} p (cIntConv $ status_error x)
#else
    {#set MPI_Status.MPI_SOURCE #} p (cIntConv $ status_source x)
    {#set MPI_Status.MPI_TAG #} 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)
#endif

{-# LANGUAGE ForeignFunctionInterface #-}

#include <mpi.h>

module Control.Parallel.MPI.Status (Status (..), StatusPtr) where

import C2HS
import Control.Monad (liftM)
import Control.Applicative ((<$>), (<*>))

{# context prefix = "MPI" #}

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_TAG #} 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)


Add writeAttr for Enums.

Add writeAttr for Enums.

This is needed for MessageDialog.

darcs-hash:20061020162336-91c87-d1e7973b7b240916e6ddf32eaa79aab8a8c8ba31.gz

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GObject Properties
--
--  Author : Duncan Coutts
--
--  Created: 16 April 2005
--
--  Version $Revision: 1.8 $ from $Date: 2005/08/29 11:15:58 $
--
--  Copyright (C) 2005 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Functions for getting and setting GObject properties
--
module System.Glib.Properties (
  -- * per-type functions for getting and setting GObject properties
  objectSetPropertyInt,
  objectGetPropertyInt,
  objectSetPropertyUInt,
  objectGetPropertyUInt,
  objectSetPropertyBool,
  objectGetPropertyBool,
  objectSetPropertyEnum,
  objectGetPropertyEnum,
  objectSetPropertyFlags,
  objectGetPropertyFlags,
  objectSetPropertyFloat,
  objectGetPropertyFloat,
  objectSetPropertyDouble,
  objectGetPropertyDouble,
  objectSetPropertyString,
  objectGetPropertyString,
  objectSetPropertyMaybeString,
  objectGetPropertyMaybeString,
  objectSetPropertyBoxedOpaque,
  objectGetPropertyBoxedOpaque,
  objectSetPropertyBoxedStorable,
  objectGetPropertyBoxedStorable,
  objectSetPropertyGObject,
  objectGetPropertyGObject,

  -- * constructors for attributes backed by GObject properties
  newAttrFromIntProperty,
  readAttrFromIntProperty,
  newAttrFromUIntProperty,
  writeAttrFromUIntProperty,
  newAttrFromBoolProperty,
  newAttrFromFloatProperty,
  newAttrFromDoubleProperty,
  newAttrFromEnumProperty,
  readAttrFromEnumProperty,
  writeAttrFromEnumProperty,
  newAttrFromFlagsProperty,
  newAttrFromStringProperty,
  readAttrFromStringProperty,
  writeAttrFromStringProperty,
  writeAttrFromMaybeStringProperty,
  newAttrFromMaybeStringProperty,
  newAttrFromBoxedOpaqueProperty,
  writeAttrFromBoxedOpaqueProperty,
  newAttrFromBoxedStorableProperty,
  newAttrFromObjectProperty,
  writeAttrFromObjectProperty,
  ) where

import Monad (liftM)

import System.Glib.FFI
import System.Glib.Flags	(Flags, fromFlags, toFlags)
import System.Glib.UTFString
{#import System.Glib.Types#}
{#import System.Glib.GValue#}	(GValue(GValue), valueInit, allocaGValue)
import System.Glib.GObject	(makeNewGObject)
import qualified System.Glib.GTypeConstants as GType
import System.Glib.GType
import System.Glib.GValueTypes
import System.Glib.Attributes	(Attr, ReadAttr, WriteAttr, ReadWriteAttr,
				newAttr, readAttr, writeAttr)

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

objectSetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> a -> IO ()) -> String -> gobj -> a -> IO ()
objectSetPropertyInternal gtype valueSet prop obj val =
  withCString prop $ \propPtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  valueSet gvalue val
  {# call g_object_set_property #}
    (toGObject obj)
    propPtr
    gvalue

objectGetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> IO a) -> String -> gobj -> IO a
objectGetPropertyInternal gtype valueGet prop obj =
  withCString prop $ \propPtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  {# call unsafe g_object_get_property #}
    (toGObject obj)
    propPtr
    gvalue
  valueGet gvalue

objectSetPropertyInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()
objectSetPropertyInt = objectSetPropertyInternal GType.int valueSetInt

objectGetPropertyInt :: GObjectClass gobj => String -> gobj -> IO Int
objectGetPropertyInt = objectGetPropertyInternal GType.int valueGetInt

objectSetPropertyUInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()
objectSetPropertyUInt = objectSetPropertyInternal GType.uint (\gv v -> valueSetUInt gv (fromIntegral v))

objectGetPropertyUInt :: GObjectClass gobj => String -> gobj -> IO Int
objectGetPropertyUInt = objectGetPropertyInternal GType.uint (\gv -> liftM fromIntegral $ valueGetUInt gv)

objectSetPropertyBool :: GObjectClass gobj => String -> gobj -> Bool -> IO ()
objectSetPropertyBool = objectSetPropertyInternal GType.bool valueSetBool

objectGetPropertyBool :: GObjectClass gobj => String -> gobj -> IO Bool
objectGetPropertyBool = objectGetPropertyInternal GType.bool valueGetBool

objectSetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> enum -> IO ()
objectSetPropertyEnum gtype = objectSetPropertyInternal gtype valueSetEnum

objectGetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> IO enum
objectGetPropertyEnum gtype = objectGetPropertyInternal gtype valueGetEnum

objectSetPropertyFlags :: (GObjectClass gobj, Flags flag) => String -> gobj -> [flag] -> IO ()
objectSetPropertyFlags = objectSetPropertyInternal GType.flags valueSetFlags

objectGetPropertyFlags :: (GObjectClass gobj, Flags flag) => String -> gobj -> IO [flag]
objectGetPropertyFlags = objectGetPropertyInternal GType.flags valueGetFlags

objectSetPropertyFloat :: GObjectClass gobj => String -> gobj -> Float -> IO ()
objectSetPropertyFloat = objectSetPropertyInternal GType.float valueSetFloat

objectGetPropertyFloat :: GObjectClass gobj => String -> gobj -> IO Float
objectGetPropertyFloat = objectGetPropertyInternal GType.float valueGetFloat

objectSetPropertyDouble :: GObjectClass gobj => String -> gobj -> Double -> IO ()
objectSetPropertyDouble = objectSetPropertyInternal GType.double valueSetDouble

objectGetPropertyDouble :: GObjectClass gobj => String -> gobj -> IO Double
objectGetPropertyDouble = objectGetPropertyInternal GType.double valueGetDouble

objectSetPropertyString :: GObjectClass gobj => String -> gobj -> String -> IO ()
objectSetPropertyString = objectSetPropertyInternal GType.string valueSetString

objectGetPropertyString :: GObjectClass gobj => String -> gobj -> IO String
objectGetPropertyString = objectGetPropertyInternal GType.string valueGetString

objectSetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> Maybe String -> IO ()
objectSetPropertyMaybeString = objectSetPropertyInternal GType.string valueSetMaybeString

objectGetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> IO (Maybe String)
objectGetPropertyMaybeString = objectGetPropertyInternal GType.string valueGetMaybeString

objectSetPropertyBoxedOpaque :: GObjectClass gobj => (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GType -> String -> gobj -> boxed -> IO ()
objectSetPropertyBoxedOpaque with gtype = objectSetPropertyInternal gtype (valueSetBoxed with)

objectGetPropertyBoxedOpaque :: GObjectClass gobj => (Ptr boxed -> IO boxed) -> GType -> String -> gobj -> IO boxed
objectGetPropertyBoxedOpaque peek gtype = objectGetPropertyInternal gtype (valueGetBoxed peek)

objectSetPropertyBoxedStorable :: (GObjectClass gobj, Storable boxed) => GType -> String -> gobj -> boxed -> IO ()
objectSetPropertyBoxedStorable = objectSetPropertyBoxedOpaque with

objectGetPropertyBoxedStorable :: (GObjectClass gobj, Storable boxed) => GType -> String -> gobj -> IO boxed
objectGetPropertyBoxedStorable = objectGetPropertyBoxedOpaque peek

objectSetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> gobj' -> IO ()
objectSetPropertyGObject gtype = objectSetPropertyInternal gtype valueSetGObject

objectGetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> IO gobj'
objectGetPropertyGObject gtype = objectGetPropertyInternal gtype valueGetGObject

-- Convenience functions to make attribute implementations in the other modules
-- shorter and more easily extensible.
--

newAttrFromIntProperty :: GObjectClass gobj => String -> Attr gobj Int
newAttrFromIntProperty propName =
  newAttr (objectGetPropertyInt propName) (objectSetPropertyInt propName)

readAttrFromIntProperty :: GObjectClass gobj => String -> ReadAttr gobj Int
readAttrFromIntProperty propName =
  readAttr (objectGetPropertyInt propName)

newAttrFromUIntProperty :: GObjectClass gobj => String -> Attr gobj Int
newAttrFromUIntProperty propName =
  newAttr (objectGetPropertyUInt propName) (objectSetPropertyUInt propName)

writeAttrFromUIntProperty :: GObjectClass gobj => String -> WriteAttr gobj Int
writeAttrFromUIntProperty propName =
  writeAttr (objectSetPropertyUInt propName)

newAttrFromBoolProperty :: GObjectClass gobj => String -> Attr gobj Bool
newAttrFromBoolProperty propName =
  newAttr (objectGetPropertyBool propName) (objectSetPropertyBool propName)

newAttrFromFloatProperty :: GObjectClass gobj => String -> Attr gobj Float
newAttrFromFloatProperty propName =
  newAttr (objectGetPropertyFloat propName) (objectSetPropertyFloat propName)

newAttrFromDoubleProperty :: GObjectClass gobj => String -> Attr gobj Double
newAttrFromDoubleProperty propName =
  newAttr (objectGetPropertyDouble propName) (objectSetPropertyDouble propName)

newAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> Attr gobj enum
newAttrFromEnumProperty propName gtype =
  newAttr (objectGetPropertyEnum gtype propName) (objectSetPropertyEnum gtype propName)

readAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> ReadAttr gobj enum
readAttrFromEnumProperty propName gtype =
  readAttr (objectGetPropertyEnum gtype propName)

writeAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> WriteAttr gobj enum
writeAttrFromEnumProperty propName gtype =
  writeAttr (objectSetPropertyEnum gtype propName)

newAttrFromFlagsProperty :: (GObjectClass gobj, Flags flag) => String -> Attr gobj [flag]
newAttrFromFlagsProperty propName =
  newAttr (objectGetPropertyFlags propName) (objectSetPropertyFlags propName)

newAttrFromStringProperty :: GObjectClass gobj => String -> Attr gobj String
newAttrFromStringProperty propName =
  newAttr (objectGetPropertyString propName) (objectSetPropertyString propName)

readAttrFromStringProperty :: GObjectClass gobj => String -> ReadAttr gobj String
readAttrFromStringProperty propName =
  readAttr (objectGetPropertyString propName)

writeAttrFromStringProperty :: GObjectClass gobj => String -> WriteAttr gobj String
writeAttrFromStringProperty propName =
  writeAttr (objectSetPropertyString propName)

writeAttrFromMaybeStringProperty :: GObjectClass gobj => String -> WriteAttr gobj (Maybe String)
writeAttrFromMaybeStringProperty propName =
  writeAttr (objectSetPropertyMaybeString propName)

newAttrFromMaybeStringProperty :: GObjectClass gobj => String -> Attr gobj (Maybe String)
newAttrFromMaybeStringProperty propName =
  newAttr (objectGetPropertyMaybeString propName) (objectSetPropertyMaybeString propName)

newAttrFromBoxedOpaqueProperty :: GObjectClass gobj => (Ptr boxed -> IO boxed) -> (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> String -> GType -> Attr gobj boxed
newAttrFromBoxedOpaqueProperty peek with propName gtype =
  newAttr (objectGetPropertyBoxedOpaque peek gtype propName) (objectSetPropertyBoxedOpaque with gtype propName)

writeAttrFromBoxedOpaqueProperty :: GObjectClass gobj => (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> String -> GType -> WriteAttr gobj boxed
writeAttrFromBoxedOpaqueProperty with propName gtype =
  writeAttr (objectSetPropertyBoxedOpaque with gtype propName)

newAttrFromBoxedStorableProperty :: (GObjectClass gobj, Storable boxed) => String -> GType -> Attr gobj boxed
newAttrFromBoxedStorableProperty propName gtype =
  newAttr (objectGetPropertyBoxedStorable gtype propName) (objectSetPropertyBoxedStorable gtype propName)

newAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj', GObjectClass gobj'') => String -> GType -> ReadWriteAttr gobj gobj' gobj''
newAttrFromObjectProperty propName gtype =
  newAttr (objectGetPropertyGObject gtype propName) (objectSetPropertyGObject gtype propName)

writeAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj') => String -> GType -> WriteAttr gobj gobj'
writeAttrFromObjectProperty propName gtype =
  writeAttr (objectSetPropertyGObject gtype propName)

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GObject Properties
--
--  Author : Duncan Coutts
--
--  Created: 16 April 2005
--
--  Version $Revision: 1.8 $ from $Date: 2005/08/29 11:15:58 $
--
--  Copyright (C) 2005 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Functions for getting and setting GObject properties
--
module System.Glib.Properties (
  -- * per-type functions for getting and setting GObject properties
  objectSetPropertyInt,
  objectGetPropertyInt,
  objectSetPropertyUInt,
  objectGetPropertyUInt,
  objectSetPropertyBool,
  objectGetPropertyBool,
  objectSetPropertyEnum,
  objectGetPropertyEnum,
  objectSetPropertyFlags,
  objectGetPropertyFlags,
  objectSetPropertyFloat,
  objectGetPropertyFloat,
  objectSetPropertyDouble,
  objectGetPropertyDouble,
  objectSetPropertyString,
  objectGetPropertyString,
  objectSetPropertyMaybeString,
  objectGetPropertyMaybeString,
  objectSetPropertyBoxedOpaque,
  objectGetPropertyBoxedOpaque,
  objectSetPropertyBoxedStorable,
  objectGetPropertyBoxedStorable,
  objectSetPropertyGObject,
  objectGetPropertyGObject,

  -- * constructors for attributes backed by GObject properties
  newAttrFromIntProperty,
  readAttrFromIntProperty,
  newAttrFromUIntProperty,
  writeAttrFromUIntProperty,
  newAttrFromBoolProperty,
  newAttrFromFloatProperty,
  newAttrFromDoubleProperty,
  newAttrFromEnumProperty,
  readAttrFromEnumProperty,
  newAttrFromFlagsProperty,
  newAttrFromStringProperty,
  readAttrFromStringProperty,
  writeAttrFromStringProperty,
  writeAttrFromMaybeStringProperty,
  newAttrFromMaybeStringProperty,
  newAttrFromBoxedOpaqueProperty,
  writeAttrFromBoxedOpaqueProperty,
  newAttrFromBoxedStorableProperty,
  newAttrFromObjectProperty,
  writeAttrFromObjectProperty,
  ) where

import Monad (liftM)

import System.Glib.FFI
import System.Glib.Flags	(Flags, fromFlags, toFlags)
import System.Glib.UTFString
{#import System.Glib.Types#}
{#import System.Glib.GValue#}	(GValue(GValue), valueInit, allocaGValue)
import System.Glib.GObject	(makeNewGObject)
import qualified System.Glib.GTypeConstants as GType
import System.Glib.GType
import System.Glib.GValueTypes
import System.Glib.Attributes	(Attr, ReadAttr, WriteAttr, ReadWriteAttr,
				newAttr, readAttr, writeAttr)

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

objectSetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> a -> IO ()) -> String -> gobj -> a -> IO ()
objectSetPropertyInternal gtype valueSet prop obj val =
  withCString prop $ \propPtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  valueSet gvalue val
  {# call g_object_set_property #}
    (toGObject obj)
    propPtr
    gvalue

objectGetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> IO a) -> String -> gobj -> IO a
objectGetPropertyInternal gtype valueGet prop obj =
  withCString prop $ \propPtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  {# call unsafe g_object_get_property #}
    (toGObject obj)
    propPtr
    gvalue
  valueGet gvalue

objectSetPropertyInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()
objectSetPropertyInt = objectSetPropertyInternal GType.int valueSetInt

objectGetPropertyInt :: GObjectClass gobj => String -> gobj -> IO Int
objectGetPropertyInt = objectGetPropertyInternal GType.int valueGetInt

objectSetPropertyUInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()
objectSetPropertyUInt = objectSetPropertyInternal GType.uint (\gv v -> valueSetUInt gv (fromIntegral v))

objectGetPropertyUInt :: GObjectClass gobj => String -> gobj -> IO Int
objectGetPropertyUInt = objectGetPropertyInternal GType.uint (\gv -> liftM fromIntegral $ valueGetUInt gv)

objectSetPropertyBool :: GObjectClass gobj => String -> gobj -> Bool -> IO ()
objectSetPropertyBool = objectSetPropertyInternal GType.bool valueSetBool

objectGetPropertyBool :: GObjectClass gobj => String -> gobj -> IO Bool
objectGetPropertyBool = objectGetPropertyInternal GType.bool valueGetBool

objectSetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> enum -> IO ()
objectSetPropertyEnum gtype = objectSetPropertyInternal gtype valueSetEnum

objectGetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> IO enum
objectGetPropertyEnum gtype = objectGetPropertyInternal gtype valueGetEnum

objectSetPropertyFlags :: (GObjectClass gobj, Flags flag) => String -> gobj -> [flag] -> IO ()
objectSetPropertyFlags = objectSetPropertyInternal GType.flags valueSetFlags

objectGetPropertyFlags :: (GObjectClass gobj, Flags flag) => String -> gobj -> IO [flag]
objectGetPropertyFlags = objectGetPropertyInternal GType.flags valueGetFlags

objectSetPropertyFloat :: GObjectClass gobj => String -> gobj -> Float -> IO ()
objectSetPropertyFloat = objectSetPropertyInternal GType.float valueSetFloat

objectGetPropertyFloat :: GObjectClass gobj => String -> gobj -> IO Float
objectGetPropertyFloat = objectGetPropertyInternal GType.float valueGetFloat

objectSetPropertyDouble :: GObjectClass gobj => String -> gobj -> Double -> IO ()
objectSetPropertyDouble = objectSetPropertyInternal GType.double valueSetDouble

objectGetPropertyDouble :: GObjectClass gobj => String -> gobj -> IO Double
objectGetPropertyDouble = objectGetPropertyInternal GType.double valueGetDouble

objectSetPropertyString :: GObjectClass gobj => String -> gobj -> String -> IO ()
objectSetPropertyString = objectSetPropertyInternal GType.string valueSetString

objectGetPropertyString :: GObjectClass gobj => String -> gobj -> IO String
objectGetPropertyString = objectGetPropertyInternal GType.string valueGetString

objectSetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> Maybe String -> IO ()
objectSetPropertyMaybeString = objectSetPropertyInternal GType.string valueSetMaybeString

objectGetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> IO (Maybe String)
objectGetPropertyMaybeString = objectGetPropertyInternal GType.string valueGetMaybeString

objectSetPropertyBoxedOpaque :: GObjectClass gobj => (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GType -> String -> gobj -> boxed -> IO ()
objectSetPropertyBoxedOpaque with gtype = objectSetPropertyInternal gtype (valueSetBoxed with)

objectGetPropertyBoxedOpaque :: GObjectClass gobj => (Ptr boxed -> IO boxed) -> GType -> String -> gobj -> IO boxed
objectGetPropertyBoxedOpaque peek gtype = objectGetPropertyInternal gtype (valueGetBoxed peek)

objectSetPropertyBoxedStorable :: (GObjectClass gobj, Storable boxed) => GType -> String -> gobj -> boxed -> IO ()
objectSetPropertyBoxedStorable = objectSetPropertyBoxedOpaque with

objectGetPropertyBoxedStorable :: (GObjectClass gobj, Storable boxed) => GType -> String -> gobj -> IO boxed
objectGetPropertyBoxedStorable = objectGetPropertyBoxedOpaque peek

objectSetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> gobj' -> IO ()
objectSetPropertyGObject gtype = objectSetPropertyInternal gtype valueSetGObject

objectGetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> IO gobj'
objectGetPropertyGObject gtype = objectGetPropertyInternal gtype valueGetGObject

-- Convenience functions to make attribute implementations in the other modules
-- shorter and more easily extensible.
--

newAttrFromIntProperty :: GObjectClass gobj => String -> Attr gobj Int
newAttrFromIntProperty propName =
  newAttr (objectGetPropertyInt propName) (objectSetPropertyInt propName)

readAttrFromIntProperty :: GObjectClass gobj => String -> ReadAttr gobj Int
readAttrFromIntProperty propName =
  readAttr (objectGetPropertyInt propName)

newAttrFromUIntProperty :: GObjectClass gobj => String -> Attr gobj Int
newAttrFromUIntProperty propName =
  newAttr (objectGetPropertyUInt propName) (objectSetPropertyUInt propName)

writeAttrFromUIntProperty :: GObjectClass gobj => String -> WriteAttr gobj Int
writeAttrFromUIntProperty propName =
  writeAttr (objectSetPropertyUInt propName)

newAttrFromBoolProperty :: GObjectClass gobj => String -> Attr gobj Bool
newAttrFromBoolProperty propName =
  newAttr (objectGetPropertyBool propName) (objectSetPropertyBool propName)

newAttrFromFloatProperty :: GObjectClass gobj => String -> Attr gobj Float
newAttrFromFloatProperty propName =
  newAttr (objectGetPropertyFloat propName) (objectSetPropertyFloat propName)

newAttrFromDoubleProperty :: GObjectClass gobj => String -> Attr gobj Double
newAttrFromDoubleProperty propName =
  newAttr (objectGetPropertyDouble propName) (objectSetPropertyDouble propName)

newAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> Attr gobj enum
newAttrFromEnumProperty propName gtype =
  newAttr (objectGetPropertyEnum gtype propName) (objectSetPropertyEnum gtype propName)

readAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> ReadAttr gobj enum
readAttrFromEnumProperty propName gtype =
  readAttr (objectGetPropertyEnum gtype propName)

newAttrFromFlagsProperty :: (GObjectClass gobj, Flags flag) => String -> Attr gobj [flag]
newAttrFromFlagsProperty propName =
  newAttr (objectGetPropertyFlags propName) (objectSetPropertyFlags propName)

newAttrFromStringProperty :: GObjectClass gobj => String -> Attr gobj String
newAttrFromStringProperty propName =
  newAttr (objectGetPropertyString propName) (objectSetPropertyString propName)

readAttrFromStringProperty :: GObjectClass gobj => String -> ReadAttr gobj String
readAttrFromStringProperty propName =
  readAttr (objectGetPropertyString propName)

writeAttrFromStringProperty :: GObjectClass gobj => String -> WriteAttr gobj String
writeAttrFromStringProperty propName =
  writeAttr (objectSetPropertyString propName)

writeAttrFromMaybeStringProperty :: GObjectClass gobj => String -> WriteAttr gobj (Maybe String)
writeAttrFromMaybeStringProperty propName =
  writeAttr (objectSetPropertyMaybeString propName)

newAttrFromMaybeStringProperty :: GObjectClass gobj => String -> Attr gobj (Maybe String)
newAttrFromMaybeStringProperty propName =
  newAttr (objectGetPropertyMaybeString propName) (objectSetPropertyMaybeString propName)

newAttrFromBoxedOpaqueProperty :: GObjectClass gobj => (Ptr boxed -> IO boxed) -> (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> String -> GType -> Attr gobj boxed
newAttrFromBoxedOpaqueProperty peek with propName gtype =
  newAttr (objectGetPropertyBoxedOpaque peek gtype propName) (objectSetPropertyBoxedOpaque with gtype propName)

writeAttrFromBoxedOpaqueProperty :: GObjectClass gobj => (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> String -> GType -> WriteAttr gobj boxed
writeAttrFromBoxedOpaqueProperty with propName gtype =
  writeAttr (objectSetPropertyBoxedOpaque with gtype propName)

newAttrFromBoxedStorableProperty :: (GObjectClass gobj, Storable boxed) => String -> GType -> Attr gobj boxed
newAttrFromBoxedStorableProperty propName gtype =
  newAttr (objectGetPropertyBoxedStorable gtype propName) (objectSetPropertyBoxedStorable gtype propName)

newAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj', GObjectClass gobj'') => String -> GType -> ReadWriteAttr gobj gobj' gobj''
newAttrFromObjectProperty propName gtype =
  newAttr (objectGetPropertyGObject gtype propName) (objectSetPropertyGObject gtype propName)

writeAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj') => String -> GType -> WriteAttr gobj gobj'
writeAttrFromObjectProperty propName gtype =
  writeAttr (objectSetPropertyGObject gtype propName)


Cleaned up description of the Matrix datatype.

darcs-hash:20070503171920-b99d0-11a9d7b6b60428b2f07b04b53c73dbee828c50a7.gz

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Cairo.Matrix
-- Copyright   :  (c) Paolo Martini 2005
-- License     :  BSD-style (see cairo/COPYRIGHT)
--
-- Maintainer  :  p.martini@neuralnoise.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Matrix math
-----------------------------------------------------------------------------

module Graphics.Rendering.Cairo.Matrix (
    Matrix(Matrix)
  , MatrixPtr
  , identity
  , translate
  , scale
  , rotate
  , transformDistance
  , transformPoint
  , scalarMultiply
  , adjoint
  , invert
  ) where

import Foreign hiding (rotate)
import CForeign

-- | Representation of a 2-D affine transformation.
--
--  The Matrix type represents a 2x2 transformation matrix along with a
--  translation vector. @Matrix a1 a2 b1 b2 c1 c2@ describes the
--  transformation of a point with coordinates x,y that is defined by
--
--  >   / x' \  =  / a1 b1 \  / x \  + / c1 \
--  >   \ y' /     \ a2 b2 /  \ y /    \ c2 /
--
--  or
--
--  >   x' =  a1 * x + b1 * y + c1
--  >   y' =  a2 * x + b2 * y + c2

data Matrix = Matrix { xx :: !Double, yx :: !Double,
                       xy :: !Double, yy :: !Double,
                       x0 :: !Double, y0 :: !Double }
  deriving (Show, Eq)

{#pointer *cairo_matrix_t as MatrixPtr -> Matrix#}

instance Storable Matrix where
  sizeOf _ = {#sizeof cairo_matrix_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    xx <- {#get cairo_matrix_t->xx#} p
    yx <- {#get cairo_matrix_t->yx#} p
    xy <- {#get cairo_matrix_t->xy#} p
    yy <- {#get cairo_matrix_t->yy#} p
    x0 <- {#get cairo_matrix_t->x0#} p
    y0 <- {#get cairo_matrix_t->y0#} p
    return $ Matrix (realToFrac xx) (realToFrac yx)
                    (realToFrac xy) (realToFrac yy)
                    (realToFrac x0) (realToFrac y0)

  poke p (Matrix xx yx xy yy x0 y0) = do
    {#set cairo_matrix_t->xx#} p (realToFrac xx)
    {#set cairo_matrix_t->yx#} p (realToFrac yx)
    {#set cairo_matrix_t->xy#} p (realToFrac xy)
    {#set cairo_matrix_t->yy#} p (realToFrac yy)
    {#set cairo_matrix_t->x0#} p (realToFrac x0)
    {#set cairo_matrix_t->y0#} p (realToFrac y0)
    return ()

instance Num Matrix where
  (*) (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
    Matrix (xx * xx' + yx * xy')
           (xx * yx' + yx * yy')
           (xy * xx' + yy * xy')
           (xy * yx' + yy * yy')
           (x0 * xx' + y0 * xy' + x0')
           (x0 * yx' + y0 * yy' + y0')

  (+) = pointwise2 (+)
  (-) = pointwise2 (-)

  negate = pointwise negate
  abs    = pointwise abs
  signum = pointwise signum

  -- this definition of fromInteger means that 2*m = scale 2 m
  -- and it means 1 = identity
  fromInteger n = Matrix (fromInteger n) 0 0 (fromInteger n) 0 0

{-# INLINE pointwise #-}
pointwise f (Matrix xx yx xy yy x0 y0) =
  Matrix (f xx) (f yx) (f xy) (f yy) (f x0) (f y0)

{-# INLINE pointwise2 #-}
pointwise2 f (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
  Matrix (f xx xx') (f yx yx') (f xy xy') (f yy yy') (f x0 x0') (f y0 y0')

identity :: Matrix
identity = Matrix 1 0 0 1 0 0

translate :: Double -> Double -> Matrix -> Matrix
translate tx ty m = m * (Matrix 1 0 0 1 tx ty)

scale :: Double -> Double -> Matrix -> Matrix
scale sx sy m = m * (Matrix sx 0 0 sy 0 0)

rotate :: Double -> Matrix -> Matrix
rotate r m = m * (Matrix c s (-s) c 0 0)
  where s = sin r
        c = cos r

transformDistance :: Matrix -> (Double,Double) -> (Double,Double)
transformDistance (Matrix xx yx xy yy _ _) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy
        newY = yx * dx + yy * dy

transformPoint :: Matrix -> (Double,Double) -> (Double,Double)
transformPoint (Matrix xx yx xy yy x0 y0) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy + x0
        newY = yx * dx + yy * dy + y0

scalarMultiply :: Double -> Matrix -> Matrix
scalarMultiply scalar = pointwise (*scalar)

adjoint :: Matrix -> Matrix
adjoint (Matrix a b c d tx ty) =
  Matrix d (-b) (-c) a (c*ty - d*tx) (b*tx - a*ty)

invert :: Matrix -> Matrix
invert m@(Matrix xx yx xy yy _ _) = scalarMultiply (recip det) $ adjoint m
  where det = xx*yy - yx*xy

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Cairo.Matrix
-- Copyright   :  (c) Paolo Martini 2005
-- License     :  BSD-style (see cairo/COPYRIGHT)
--
-- Maintainer  :  p.martini@neuralnoise.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Matrix math
-----------------------------------------------------------------------------

module Graphics.Rendering.Cairo.Matrix (
    Matrix(Matrix)
  , MatrixPtr
  , identity
  , translate
  , scale
  , rotate
  , transformDistance
  , transformPoint
  , scalarMultiply
  , adjoint
  , invert
  ) where

import Foreign hiding (rotate)
import CForeign

-- | Representation of a 2-D affine transformation as a matrix.
--
-- The 'Matrix' type actually represents as 3x3 matrix but with some elements
-- are constant and so are not included. Specifically if we assume that our
-- coordinates are row vectors then correspondence is:
--
-- >    Matrix xx yx xy yy x0 y0
-- > ==
-- >    / xx yx 0 \
-- >    | xy yy 0 |
-- >    \ x0 y0 1 /
--
-- and the matrix operates on @(x,y)@ coordinates:
--
-- > (x y 1) / xx yx 0 \  = (x' y' 1)
-- >         | xy yy 0 |  where x' = xx * x + xy * y + x0
-- >         \ x0 y0 1 /        y' = yx * x + yy * y + y0
--
data Matrix = Matrix { xx :: !Double, yx :: !Double,
                       xy :: !Double, yy :: !Double,
                       x0 :: !Double, y0 :: !Double }
  deriving (Show, Eq)

{#pointer *cairo_matrix_t as MatrixPtr -> Matrix#}

instance Storable Matrix where
  sizeOf _ = {#sizeof cairo_matrix_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    xx <- {#get cairo_matrix_t->xx#} p
    yx <- {#get cairo_matrix_t->yx#} p
    xy <- {#get cairo_matrix_t->xy#} p
    yy <- {#get cairo_matrix_t->yy#} p
    x0 <- {#get cairo_matrix_t->x0#} p
    y0 <- {#get cairo_matrix_t->y0#} p
    return $ Matrix (realToFrac xx) (realToFrac yx)
                    (realToFrac xy) (realToFrac yy)
                    (realToFrac x0) (realToFrac y0)

  poke p (Matrix xx yx xy yy x0 y0) = do
    {#set cairo_matrix_t->xx#} p (realToFrac xx)
    {#set cairo_matrix_t->yx#} p (realToFrac yx)
    {#set cairo_matrix_t->xy#} p (realToFrac xy)
    {#set cairo_matrix_t->yy#} p (realToFrac yy)
    {#set cairo_matrix_t->x0#} p (realToFrac x0)
    {#set cairo_matrix_t->y0#} p (realToFrac y0)
    return ()

instance Num Matrix where
  (*) (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
    Matrix (xx * xx' + yx * xy')
           (xx * yx' + yx * yy')
           (xy * xx' + yy * xy')
           (xy * yx' + yy * yy')
           (x0 * xx' + y0 * xy' + x0')
           (x0 * yx' + y0 * yy' + y0')

  (+) = pointwise2 (+)
  (-) = pointwise2 (-)

  negate = pointwise negate
  abs    = pointwise abs
  signum = pointwise signum

  -- this definition of fromInteger means that 2*m = scale 2 m
  -- and it means 1 = identity
  fromInteger n = Matrix (fromInteger n) 0 0 (fromInteger n) 0 0

{-# INLINE pointwise #-}
pointwise f (Matrix xx yx xy yy x0 y0) =
  Matrix (f xx) (f yx) (f xy) (f yy) (f x0) (f y0)

{-# INLINE pointwise2 #-}
pointwise2 f (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
  Matrix (f xx xx') (f yx yx') (f xy xy') (f yy yy') (f x0 x0') (f y0 y0')

identity :: Matrix
identity = Matrix 1 0 0 1 0 0

translate :: Double -> Double -> Matrix -> Matrix
translate tx ty m = m * (Matrix 1 0 0 1 tx ty)

scale :: Double -> Double -> Matrix -> Matrix
scale sx sy m = m * (Matrix sx 0 0 sy 0 0)

rotate :: Double -> Matrix -> Matrix
rotate r m = m * (Matrix c s (-s) c 0 0)
  where s = sin r
        c = cos r

transformDistance :: Matrix -> (Double,Double) -> (Double,Double)
transformDistance (Matrix xx yx xy yy _ _) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy
        newY = yx * dx + yy * dy

transformPoint :: Matrix -> (Double,Double) -> (Double,Double)
transformPoint (Matrix xx yx xy yy x0 y0) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy + x0
        newY = yx * dx + yy * dy + y0

scalarMultiply :: Double -> Matrix -> Matrix
scalarMultiply scalar = pointwise (*scalar)

adjoint :: Matrix -> Matrix
adjoint (Matrix a b c d tx ty) =
  Matrix d (-b) (-c) a (c*ty - d*tx) (b*tx - a*ty)

invert :: Matrix -> Matrix
invert m@(Matrix xx yx xy yy _ _) = scalarMultiply (recip det) $ adjoint m
  where det = xx*yy - yx*xy


Made properties pure

Made properties pure

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns#-}
#include "cvWrapLeo.h"
module CV.Video where
{#import CV.Image#}

import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import Foreign.C.Types
import Foreign.C.String
import System.IO.Unsafe

{#pointer *CvCapture as Capture foreign newtype#}

foreign import ccall "& wrapReleaseCapture" releaseCapture :: FinalizerPtr Capture
-- NOTE: This use of foreignPtr is quite likely to cause trouble by retaining
--       videos longer than necessary.

captureFromFile fn = withCString fn $ \cfn -> do
                      ptr <- {#call cvCreateFileCapture#} cfn
                      fptr <- newForeignPtr releaseCapture ptr
                      return . Capture $ fptr

dropFrame cap = withCapture cap $ \ccap -> {#call cvGrabFrame#} ccap >> return ()

getFrame cap = withCapture cap $ \ccap -> do
                p_frame <- {#call cvQueryFrame#} ccap
                creatingImage $ ensure32F p_frame -- NOTE: This works because Image module has generated wrappers for ensure32F

cvCAP_PROP_FRAME_COUNT = 7
cvCAP_POS_FRAMES = 1
getNumberOfFrames cap = unsafePerformIO $
                         {#call cvGetCaptureProperty#}
                           cap cvCAP_PROP_FRAME_COUNT
getFrameNumber cap = unsafePerformIO $
                      {#call cvGetCaptureProperty#}
                         cap cvCAP_POS_FRAMES

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns#-}
#include "cvWrapLeo.h"
module CV.Video where
{#import CV.Image#}

import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import Foreign.C.Types
import Foreign.C.String
import System.IO.Unsafe

{#pointer *CvCapture as Capture foreign newtype#}

foreign import ccall "& wrapReleaseCapture" releaseCapture :: FinalizerPtr Capture
-- NOTE: This use of foreignPtr is quite likely to cause trouble by retaining
--       videos longer than necessary.

captureFromFile fn = withCString fn $ \cfn -> do
                      ptr <- {#call cvCreateFileCapture#} cfn
                      fptr <- newForeignPtr releaseCapture ptr
                      return . Capture $ fptr

dropFrame cap = withCapture cap $ \ccap -> {#call cvGrabFrame#} ccap >> return ()

getFrame cap = withCapture cap $ \ccap -> do
                p_frame <- {#call cvQueryFrame#} ccap
                creatingImage $ ensure32F p_frame -- NOTE: This works because Image module has generated wrappers for ensure32F

cvCAP_PROP_FRAME_COUNT = 7
cvCAP_POS_FRAMES = 1
getNumberOfFrames cap = {#call cvGetCaptureProperty#}
                         cap cvCAP_PROP_FRAME_COUNT
getFrameNumber cap = {#call cvGetCaptureProperty#}
                         cap cvCAP_POS_FRAMES


Missing link

Missing link

-- -*-haskell-*-
--  GIMP Toolkit (GTK) General
--
--  Author : Axel Simon, Manuel M. T. Chakravarty
--
--  Created: 8 December 1998
--
--  Copyright (C) 2000..2005 Axel Simon, Manuel M. T. Chakravarty
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- TODO
--
-- quitAddDestroy, quitAdd, quitRemove
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- library initialization, main event loop, and events
--
module Graphics.UI.Gtk.General.General (
--  getDefaultLanguage,
  -- * Initialisation
  initGUI,

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

  -- * Main event loop
  mainGUI,
  mainQuit,

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

  -- * Grab widgets
  grabAdd,
  grabGetCurrent,
  grabRemove,

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

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

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

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

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

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

  unsafeInitGUIForThreadedRTS

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

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

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

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

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

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

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

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

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

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

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

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

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

-- -*-haskell-*-
--  GIMP Toolkit (GTK) General
--
--  Author : Axel Simon, Manuel M. T. Chakravarty
--
--  Created: 8 December 1998
--
--  Copyright (C) 2000..2005 Axel Simon, Manuel M. T. Chakravarty
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- TODO
--
-- quitAddDestroy, quitAdd, quitRemove
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- library initialization, main event loop, and events
--
module Graphics.UI.Gtk.General.General (
--  getDefaultLanguage,
  -- * Initialisation
  initGUI,

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

  -- * Main event loop
  mainGUI,
  mainQuit,

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

  -- * Grab widgets
  grabAdd,
  grabGetCurrent,
  grabRemove,

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

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

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

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

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

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

  unsafeInitGUIForThreadedRTS

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

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

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

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

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

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

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

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

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

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

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

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

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


Remove unnecessary pointer dereference.

Remove unnecessary pointer dereference.

{-# LANGUAGE CPP, RankNTypes, UndecidableInstances, GADTs, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Graphics.UI.FLTK.LowLevel.Group
    (
    -- * Constructor
     groupNew,
     groupCustom,
     groupSetCurrent,
     groupCurrent,
     -- * Hierarchy
     --
     -- $hierarchy

     -- * Group functions
     --
     -- $groupfunctions
    )
where
#include "Fl_ExportMacros.h"
#include "Fl_Types.h"
#include "Fl_WidgetC.h"
#include "Fl_GroupC.h"
import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum)
import Graphics.UI.FLTK.LowLevel.Dispatch
import qualified Data.Text as T
import Graphics.UI.FLTK.LowLevel.Fl_Types
import Graphics.UI.FLTK.LowLevel.Utils
import Graphics.UI.FLTK.LowLevel.Hierarchy
import Graphics.UI.FLTK.LowLevel.Widget

{# fun Fl_Group_set_current as groupSetCurrent' { id `Ptr ()' } -> `()' #}
{# fun Fl_Group_current as groupCurrent' {} -> `Ptr ()' id #}

groupSetCurrent :: (Parent a Group) => Maybe (Ref a) -> IO ()
groupSetCurrent group = withMaybeRef group $ \groupPtr -> groupSetCurrent' groupPtr

groupCurrent :: IO (Maybe (Ref Group))
groupCurrent = groupCurrent' >>= toMaybeRef

{# fun Fl_Group_New as groupNew' {  `Int',`Int', `Int', `Int'} -> `Ptr ()' id #}
{# fun Fl_Group_New_WithLabel as groupNewWithLabel' { `Int',`Int',`Int',`Int',unsafeToCString `T.Text'} -> `Ptr ()' id #}
groupNew :: Rectangle -> Maybe T.Text -> IO (Ref Group)
groupNew rectangle label' =
    let (x_pos, y_pos, width, height) = fromRectangle rectangle
    in case label' of
        (Just l') -> groupNewWithLabel' x_pos y_pos width height l' >>= toRef
        Nothing -> groupNew' x_pos y_pos width height >>= toRef

{# fun Fl_OverriddenGroup_New_WithLabel as overriddenGroupNewWithLabel' { `Int',`Int',`Int',`Int',unsafeToCString `T.Text', id `Ptr ()'} -> `Ptr ()' id #}
{# fun Fl_OverriddenGroup_New as overriddenGroupNew' { `Int',`Int',`Int',`Int', id `Ptr ()'} -> `Ptr ()' id #}
groupCustom :: Rectangle -> Maybe T.Text -> Maybe (Ref Group -> IO ()) -> CustomWidgetFuncs Group -> IO (Ref Group)
groupCustom rectangle l' draw' funcs' =
  widgetMaker rectangle l' draw' (Just funcs') overriddenGroupNew' overriddenGroupNewWithLabel'

{# fun Fl_Group_Destroy as groupDestroy' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Destroy ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> groupDestroy' groupPtr

{# fun Fl_Group_draw_child as drawChild' { id `Ptr ()',id `Ptr ()' } -> `()' #}
instance (Parent a Widget, impl ~ (Ref a -> IO ())) => Op (DrawChild ()) Group orig impl where
  runOp _ _ group widget = withRef group $ \groupPtr -> withRef widget $ \widgetPtr -> drawChild' groupPtr widgetPtr

{# fun Fl_Group_draw_children as drawChildren' { id `Ptr ()' } -> `()' #}
instance (impl ~ (IO ())) => Op (DrawChildren ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> drawChildren' groupPtr

{# fun Fl_Group_draw_outside_label as drawOutsideLabel' { id `Ptr ()',id `Ptr ()' } -> `()' #}
instance (Parent a Widget, impl ~ (Ref a -> IO ())) => Op (DrawOutsideLabel ()) Group orig impl where
  runOp _ _ group widget = withRef group $ \groupPtr -> withRef widget $ \widgetPtr -> drawOutsideLabel' groupPtr widgetPtr

{# fun Fl_Group_update_child as updateChild' { id `Ptr ()',id `Ptr ()' } -> `()' #}
instance (Parent a Widget, impl ~ (Ref a -> IO ())) => Op (UpdateChild ()) Group orig impl where
  runOp _ _ group widget = withRef group $ \groupPtr -> withRef widget $ \widgetPtr -> updateChild' groupPtr widgetPtr

{# fun Fl_Group_begin as begin' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Begin ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> begin' groupPtr

{# fun Fl_Group_end as end' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ (IO ())) => Op (End ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> end' groupPtr

instance (
           Match obj ~ FindOp orig orig (Begin ()),
           Match obj ~ FindOp orig orig (End ()),
           Op (Begin ()) obj orig (IO ()),
           Op (End ()) obj orig (IO ()),
           impl ~ (IO () -> IO ())
         ) => Op (Within ()) Group orig impl where
  runOp _ _ group action = do
    () <- begin (castTo group :: Ref orig)
    action
    end (castTo group :: Ref orig)

{# fun Fl_Group_find as find' { id `Ptr ()',id `Ptr ()' } -> `Int' #}
instance (Parent a Widget, impl ~ (Ref a ->  IO (Int))) => Op (Find ()) Group orig impl where
  runOp _ _ group w = withRef group $ \groupPtr -> withRef w $ \wPtr -> find' groupPtr wPtr

{# fun Fl_Group_add as add' { id `Ptr ()',id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (Parent a Widget, impl ~ (Ref a->  IO ())) => Op (Add ()) Group orig impl where
  runOp _ _ group w = withRef group $ \groupPtr -> withRef w $ \wPtr -> add' groupPtr wPtr

{# fun Fl_Group_insert as insert' { id `Ptr ()',id `Ptr ()',`Int' } -> `()' supressWarningAboutRes #}
instance (Parent a Widget, impl ~ (Ref a-> Int ->  IO ())) => Op (Insert ()) Group orig impl where
  runOp _ _ group w i = withRef group $ \groupPtr -> withRef w $ \wPtr -> insert' groupPtr wPtr i

{# fun Fl_Group_remove_index as removeIndex' { id `Ptr ()',`Int' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( Int ->  IO ())) => Op (RemoveIndex ()) Group orig impl where
  runOp _ _ group index' = withRef group $ \groupPtr -> removeIndex' groupPtr index'

{# fun Fl_Group_remove_widget as removeWidget' { id `Ptr ()',id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (Parent a Widget, impl ~ (Ref a ->  IO ())) => Op (RemoveWidget ()) Group orig impl where
  runOp _ _ group w = withRef group $ \groupPtr -> withRef w $ \wPtr -> removeWidget' groupPtr wPtr

{# fun Fl_Group_clear as clear' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ (IO ())) => Op (Clear ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> clear' groupPtr

{# fun Fl_Group_set_resizable as setResizable' { id `Ptr ()',id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (Parent a Widget, impl ~ (Maybe ( Ref a ) -> IO ())) => Op (SetResizable ()) Group orig impl where
  runOp _ _ group o = withRef group $ \groupPtr -> withMaybeRef o $ \oPtr -> setResizable' groupPtr oPtr

instance (impl ~ IO ()) => Op (SetNotResizable ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> setResizable' groupPtr nullPtr

{# fun Fl_Group_resizable as resizable' { id `Ptr ()' } -> `Ptr ()' id #}
instance (impl ~ ( IO (Maybe (Ref Widget)))) => Op (GetResizable ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> resizable' groupPtr >>= toMaybeRef

{# fun Fl_Group_add_resizable as addResizable' { id `Ptr ()',id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (Parent a Widget, impl ~ (Ref a ->  IO ())) => Op (AddResizable ()) Group orig impl where
  runOp _ _ group o = withRef group $ \groupPtr -> withRef o $ \oPtr -> addResizable' groupPtr oPtr

{# fun Fl_Group_init_sizes as initSizes' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (InitSizes ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> initSizes' groupPtr

{# fun Fl_Group_children as children' { id `Ptr ()' } -> `Int' #}
instance (impl ~ ( IO (Int))) => Op (Children ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> children' groupPtr

{# fun Fl_Group_set_clip_children as setClipChildren' { id `Ptr ()', cFromBool `Bool' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Bool ->  IO ())) => Op (SetClipChildren ()) Group orig impl where
  runOp _ _ group c = withRef group $ \groupPtr -> setClipChildren' groupPtr c

{# fun Fl_Group_clip_children as clipChildren' { id `Ptr ()' } -> `Bool' cToBool #}
instance (impl ~ ( IO (Bool))) => Op (ClipChildren ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> clipChildren' groupPtr

{# fun Fl_Group_focus as focus' { id `Ptr ()',id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (Parent a Widget, impl ~ (Ref a ->  IO ())) => Op (Focus ()) Group orig impl where
  runOp _ _ group w = withRef group $ \groupPtr -> withRef w $ \wPtr -> focus' groupPtr wPtr

{# fun Fl_Group__ddfdesign_kludge as ddfdesignKludge' { id `Ptr ()' } -> `Ptr ()' id #}
instance (impl ~ (IO (Maybe (Ref Widget)))) => Op (DdfdesignKludge ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> ddfdesignKludge' groupPtr >>= toMaybeRef

{# fun Fl_Group_insert_with_before as insertWithBefore' { id `Ptr ()',id `Ptr ()',id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (Parent a Widget, impl ~ (Ref a -> Ref b ->  IO ())) => Op (InsertWithBefore ()) Group orig impl where
  runOp _ _ self w before = withRef self $ \selfPtr -> withRef w $ \wPtr -> withRef before $ \beforePtr -> insertWithBefore' selfPtr wPtr beforePtr

{# fun Fl_Group_array as array' { id `Ptr ()' } -> `Ptr (Ptr ())' id#}
instance (impl ~ (IO [Ref Widget])) => Op (GetArray ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> do
                    childArrayPtr <- array' groupPtr
                    numChildren <- children group
                    arrayToRefs childArrayPtr numChildren

{# fun Fl_Group_child as child' { id `Ptr ()',`Int' } -> `Ptr ()' id #}
instance (impl ~ (Int ->  IO (Maybe (Ref Widget)))) => Op (GetChild ()) Group orig impl where
  runOp _ _ self n = withRef self $ \selfPtr -> child' selfPtr n >>= toMaybeRef

-- $groupfunctions
-- @
-- add:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a-> 'IO' ()
--
-- addResizable:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a -> 'IO' ()
--
-- begin :: 'Ref' 'Group' -> 'IO' ()
--
-- children :: 'Ref' 'Group' -> 'IO' ('Int')
--
-- clear :: 'Ref' 'Group' -> 'IO' ()
--
-- clipChildren :: 'Ref' 'Group' -> 'IO' ('Bool')
--
-- ddfdesignKludge :: 'Ref' 'Group' -> 'IO' ('Maybe' ('Ref' 'Widget'))
--
-- destroy :: 'Ref' 'Group' -> 'IO' ()
--
-- drawChild:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a -> 'IO' ()
--
-- drawChildren :: 'Ref' 'Group' -> 'IO' ()
--
-- drawOutsideLabel:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a -> 'IO' ()
--
-- end :: 'Ref' 'Group' -> 'IO' ()
--
-- find:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a -> 'IO' ('Int')
--
-- focus:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a -> 'IO' ()
--
-- getArray :: 'Ref' 'Group' -> 'IO' ['Ref' 'Widget']
--
-- getChild :: 'Ref' 'Group' -> 'Int' -> 'IO' ('Maybe' ('Ref' 'Widget'))
--
-- getResizable :: 'Ref' 'Group' -> 'IO' ('Maybe' ('Ref' 'Widget'))
--
-- initSizes :: 'Ref' 'Group' -> 'IO' ()
--
-- insert:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a-> 'Int' -> 'IO' ()
--
-- insertWithBefore:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a -> 'Ref' b -> 'IO' ()
--
-- removeIndex :: 'Ref' 'Group' -> 'Int' -> 'IO' ()
--
-- removeWidget:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a -> 'IO' ()
--
-- setClipChildren :: 'Ref' 'Group' -> 'Bool' -> 'IO' ()
--
-- setNotResizable :: 'Ref' 'Group' -> 'IO' ()
--
-- setResizable:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Maybe' ( 'Ref' a ) -> 'IO' ()
--
-- updateChild:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a -> 'IO' ()
-- @

-- $hierarchy
-- @
-- "Graphics.UI.FLTK.LowLevel.Widget"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Group"
-- @

{-# LANGUAGE CPP, RankNTypes, UndecidableInstances, GADTs, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Graphics.UI.FLTK.LowLevel.Group
    (
    -- * Constructor
     groupNew,
     groupCustom,
     groupSetCurrent,
     groupCurrent,
     -- * Hierarchy
     --
     -- $hierarchy

     -- * Group functions
     --
     -- $groupfunctions
    )
where
#include "Fl_ExportMacros.h"
#include "Fl_Types.h"
#include "Fl_WidgetC.h"
#include "Fl_GroupC.h"
import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum)
import Graphics.UI.FLTK.LowLevel.Dispatch
import qualified Data.Text as T
import Graphics.UI.FLTK.LowLevel.Fl_Types
import Graphics.UI.FLTK.LowLevel.Utils
import Graphics.UI.FLTK.LowLevel.Hierarchy
import Graphics.UI.FLTK.LowLevel.Widget

{# fun Fl_Group_set_current as groupSetCurrent' { id `Ptr ()' } -> `()' #}
{# fun Fl_Group_current as groupCurrent' {} -> `Ptr ()' id #}

groupSetCurrent :: (Parent a Group) => Maybe (Ref a) -> IO ()
groupSetCurrent group = withMaybeRef group $ \groupPtr -> groupSetCurrent' groupPtr

groupCurrent :: IO (Maybe (Ref Group))
groupCurrent = groupCurrent' >>= toMaybeRef

{# fun Fl_Group_New as groupNew' {  `Int',`Int', `Int', `Int'} -> `Ptr ()' id #}
{# fun Fl_Group_New_WithLabel as groupNewWithLabel' { `Int',`Int',`Int',`Int',unsafeToCString `T.Text'} -> `Ptr ()' id #}
groupNew :: Rectangle -> Maybe T.Text -> IO (Ref Group)
groupNew rectangle label' =
    let (x_pos, y_pos, width, height) = fromRectangle rectangle
    in case label' of
        (Just l') -> groupNewWithLabel' x_pos y_pos width height l' >>= toRef
        Nothing -> groupNew' x_pos y_pos width height >>= toRef

{# fun Fl_OverriddenGroup_New_WithLabel as overriddenGroupNewWithLabel' { `Int',`Int',`Int',`Int',unsafeToCString `T.Text', id `Ptr ()'} -> `Ptr ()' id #}
{# fun Fl_OverriddenGroup_New as overriddenGroupNew' { `Int',`Int',`Int',`Int', id `Ptr ()'} -> `Ptr ()' id #}
groupCustom :: Rectangle -> Maybe T.Text -> Maybe (Ref Group -> IO ()) -> CustomWidgetFuncs Group -> IO (Ref Group)
groupCustom rectangle l' draw' funcs' =
  widgetMaker rectangle l' draw' (Just funcs') overriddenGroupNew' overriddenGroupNewWithLabel'

{# fun Fl_Group_Destroy as groupDestroy' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Destroy ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> groupDestroy' groupPtr

{# fun Fl_Group_draw_child as drawChild' { id `Ptr ()',id `Ptr ()' } -> `()' #}
instance (Parent a Widget, impl ~ (Ref a -> IO ())) => Op (DrawChild ()) Group orig impl where
  runOp _ _ group widget = withRef group $ \groupPtr -> withRef widget $ \widgetPtr -> drawChild' groupPtr widgetPtr

{# fun Fl_Group_draw_children as drawChildren' { id `Ptr ()' } -> `()' #}
instance (impl ~ (IO ())) => Op (DrawChildren ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> drawChildren' groupPtr

{# fun Fl_Group_draw_outside_label as drawOutsideLabel' { id `Ptr ()',id `Ptr ()' } -> `()' #}
instance (Parent a Widget, impl ~ (Ref a -> IO ())) => Op (DrawOutsideLabel ()) Group orig impl where
  runOp _ _ group widget = withRef group $ \groupPtr -> withRef widget $ \widgetPtr -> drawOutsideLabel' groupPtr widgetPtr

{# fun Fl_Group_update_child as updateChild' { id `Ptr ()',id `Ptr ()' } -> `()' #}
instance (Parent a Widget, impl ~ (Ref a -> IO ())) => Op (UpdateChild ()) Group orig impl where
  runOp _ _ group widget = withRef group $ \groupPtr -> withRef widget $ \widgetPtr -> updateChild' groupPtr widgetPtr

{# fun Fl_Group_begin as begin' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Begin ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> begin' groupPtr

{# fun Fl_Group_end as end' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ (IO ())) => Op (End ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> end' groupPtr

instance (
           Match obj ~ FindOp orig orig (Begin ()),
           Match obj ~ FindOp orig orig (End ()),
           Op (Begin ()) obj orig (IO ()),
           Op (End ()) obj orig (IO ()),
           impl ~ (IO () -> IO ())
         ) => Op (Within ()) Group orig impl where
  runOp _ _ group action = withRef group $ \groupPtr -> do
    () <- begin (castTo group :: Ref orig)
    action
    end (castTo group :: Ref orig)

{# fun Fl_Group_find as find' { id `Ptr ()',id `Ptr ()' } -> `Int' #}
instance (Parent a Widget, impl ~ (Ref a ->  IO (Int))) => Op (Find ()) Group orig impl where
  runOp _ _ group w = withRef group $ \groupPtr -> withRef w $ \wPtr -> find' groupPtr wPtr

{# fun Fl_Group_add as add' { id `Ptr ()',id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (Parent a Widget, impl ~ (Ref a->  IO ())) => Op (Add ()) Group orig impl where
  runOp _ _ group w = withRef group $ \groupPtr -> withRef w $ \wPtr -> add' groupPtr wPtr

{# fun Fl_Group_insert as insert' { id `Ptr ()',id `Ptr ()',`Int' } -> `()' supressWarningAboutRes #}
instance (Parent a Widget, impl ~ (Ref a-> Int ->  IO ())) => Op (Insert ()) Group orig impl where
  runOp _ _ group w i = withRef group $ \groupPtr -> withRef w $ \wPtr -> insert' groupPtr wPtr i

{# fun Fl_Group_remove_index as removeIndex' { id `Ptr ()',`Int' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( Int ->  IO ())) => Op (RemoveIndex ()) Group orig impl where
  runOp _ _ group index' = withRef group $ \groupPtr -> removeIndex' groupPtr index'

{# fun Fl_Group_remove_widget as removeWidget' { id `Ptr ()',id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (Parent a Widget, impl ~ (Ref a ->  IO ())) => Op (RemoveWidget ()) Group orig impl where
  runOp _ _ group w = withRef group $ \groupPtr -> withRef w $ \wPtr -> removeWidget' groupPtr wPtr

{# fun Fl_Group_clear as clear' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ (IO ())) => Op (Clear ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> clear' groupPtr

{# fun Fl_Group_set_resizable as setResizable' { id `Ptr ()',id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (Parent a Widget, impl ~ (Maybe ( Ref a ) -> IO ())) => Op (SetResizable ()) Group orig impl where
  runOp _ _ group o = withRef group $ \groupPtr -> withMaybeRef o $ \oPtr -> setResizable' groupPtr oPtr

instance (impl ~ IO ()) => Op (SetNotResizable ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> setResizable' groupPtr nullPtr

{# fun Fl_Group_resizable as resizable' { id `Ptr ()' } -> `Ptr ()' id #}
instance (impl ~ ( IO (Maybe (Ref Widget)))) => Op (GetResizable ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> resizable' groupPtr >>= toMaybeRef

{# fun Fl_Group_add_resizable as addResizable' { id `Ptr ()',id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (Parent a Widget, impl ~ (Ref a ->  IO ())) => Op (AddResizable ()) Group orig impl where
  runOp _ _ group o = withRef group $ \groupPtr -> withRef o $ \oPtr -> addResizable' groupPtr oPtr

{# fun Fl_Group_init_sizes as initSizes' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (InitSizes ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> initSizes' groupPtr

{# fun Fl_Group_children as children' { id `Ptr ()' } -> `Int' #}
instance (impl ~ ( IO (Int))) => Op (Children ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> children' groupPtr

{# fun Fl_Group_set_clip_children as setClipChildren' { id `Ptr ()', cFromBool `Bool' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Bool ->  IO ())) => Op (SetClipChildren ()) Group orig impl where
  runOp _ _ group c = withRef group $ \groupPtr -> setClipChildren' groupPtr c

{# fun Fl_Group_clip_children as clipChildren' { id `Ptr ()' } -> `Bool' cToBool #}
instance (impl ~ ( IO (Bool))) => Op (ClipChildren ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> clipChildren' groupPtr

{# fun Fl_Group_focus as focus' { id `Ptr ()',id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (Parent a Widget, impl ~ (Ref a ->  IO ())) => Op (Focus ()) Group orig impl where
  runOp _ _ group w = withRef group $ \groupPtr -> withRef w $ \wPtr -> focus' groupPtr wPtr

{# fun Fl_Group__ddfdesign_kludge as ddfdesignKludge' { id `Ptr ()' } -> `Ptr ()' id #}
instance (impl ~ (IO (Maybe (Ref Widget)))) => Op (DdfdesignKludge ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> ddfdesignKludge' groupPtr >>= toMaybeRef

{# fun Fl_Group_insert_with_before as insertWithBefore' { id `Ptr ()',id `Ptr ()',id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (Parent a Widget, impl ~ (Ref a -> Ref b ->  IO ())) => Op (InsertWithBefore ()) Group orig impl where
  runOp _ _ self w before = withRef self $ \selfPtr -> withRef w $ \wPtr -> withRef before $ \beforePtr -> insertWithBefore' selfPtr wPtr beforePtr

{# fun Fl_Group_array as array' { id `Ptr ()' } -> `Ptr (Ptr ())' id#}
instance (impl ~ (IO [Ref Widget])) => Op (GetArray ()) Group orig impl where
  runOp _ _ group = withRef group $ \groupPtr -> do
                    childArrayPtr <- array' groupPtr
                    numChildren <- children group
                    arrayToRefs childArrayPtr numChildren

{# fun Fl_Group_child as child' { id `Ptr ()',`Int' } -> `Ptr ()' id #}
instance (impl ~ (Int ->  IO (Maybe (Ref Widget)))) => Op (GetChild ()) Group orig impl where
  runOp _ _ self n = withRef self $ \selfPtr -> child' selfPtr n >>= toMaybeRef

-- $groupfunctions
-- @
-- add:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a-> 'IO' ()
--
-- addResizable:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a -> 'IO' ()
--
-- begin :: 'Ref' 'Group' -> 'IO' ()
--
-- children :: 'Ref' 'Group' -> 'IO' ('Int')
--
-- clear :: 'Ref' 'Group' -> 'IO' ()
--
-- clipChildren :: 'Ref' 'Group' -> 'IO' ('Bool')
--
-- ddfdesignKludge :: 'Ref' 'Group' -> 'IO' ('Maybe' ('Ref' 'Widget'))
--
-- destroy :: 'Ref' 'Group' -> 'IO' ()
--
-- drawChild:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a -> 'IO' ()
--
-- drawChildren :: 'Ref' 'Group' -> 'IO' ()
--
-- drawOutsideLabel:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a -> 'IO' ()
--
-- end :: 'Ref' 'Group' -> 'IO' ()
--
-- find:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a -> 'IO' ('Int')
--
-- focus:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a -> 'IO' ()
--
-- getArray :: 'Ref' 'Group' -> 'IO' ['Ref' 'Widget']
--
-- getChild :: 'Ref' 'Group' -> 'Int' -> 'IO' ('Maybe' ('Ref' 'Widget'))
--
-- getResizable :: 'Ref' 'Group' -> 'IO' ('Maybe' ('Ref' 'Widget'))
--
-- initSizes :: 'Ref' 'Group' -> 'IO' ()
--
-- insert:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a-> 'Int' -> 'IO' ()
--
-- insertWithBefore:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a -> 'Ref' b -> 'IO' ()
--
-- removeIndex :: 'Ref' 'Group' -> 'Int' -> 'IO' ()
--
-- removeWidget:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a -> 'IO' ()
--
-- setClipChildren :: 'Ref' 'Group' -> 'Bool' -> 'IO' ()
--
-- setNotResizable :: 'Ref' 'Group' -> 'IO' ()
--
-- setResizable:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Maybe' ( 'Ref' a ) -> 'IO' ()
--
-- updateChild:: ('Parent' a 'Widget') => 'Ref' 'Group' -> 'Ref' a -> 'IO' ()
-- @

-- $hierarchy
-- @
-- "Graphics.UI.FLTK.LowLevel.Widget"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Group"
-- @