Fix #3: Fix spelling of "Quarts" to "Quartz" and deprecate misspelt functions

* applicationGetUseQuartsAccelerators deprecated in favour of applicationGetUseQuartzAccelerators
* applicationSetUseQuartsAccelerators deprecated in favour of applicationSetUseQuartzAccelerators

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) SourceBuffer
--
--  Author : Peter Gavin
--  derived from sourceview bindings by Axel Simon and Duncan Coutts
--
--  Created: 18 December 2008
--
--  Copyright (C) 2003-2008 Peter Gavin, Duncan Coutts, Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.OSX.Application (
  Application,
  ApplicationClass,
  castToApplication,
  gTypeApplication,
  toApplication,

  applicationNew,
  applicationReady,
  applicationSetUseQuartsAccelerators,
  applicationSetUseQuartzAccelerators,
  applicationGetUseQuartsAccelerators,
  applicationGetUseQuartzAccelerators,
  applicationSetMenuBar,
  applicationSyncMenuBar,
  applicationInsertAppMenuItem,
  applicationSetWindowMenu,
  applicationSetHelpMenu,
  GtkosxApplicationAttentionType(..),
  applicationSetDockMenu,
  applicationSetDockIconPixbuf,
  applicationSetDockIconResource,
  AttentionRequestID(..),
  applicationAttentionRequest,
  applicationCancelAttentionRequest,
  applicationGetBundlePath,
  applicationGetResourcePath,
  applicationGetExecutablePath,
  applicationGetBundleId,
  applicationGetBundleInfo,
  didBecomeActive,
  willResignActive,
  blockTermination,
  willTerminate,
  openFile
 ) where

import Control.Monad	(liftM)
import Data.Maybe    (fromMaybe)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GObject              (objectNew, makeNewGObject)
{#import System.Glib.Properties#}
import System.Glib.Attributes
{#import Graphics.UI.Gtk.OSX.Types#}
{#import Graphics.UI.Gtk.OSX.Signals#}

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

-- methods

applicationNew :: IO Application
applicationNew = makeNewGObject mkApplication $ liftM castPtr $
    objectNew gTypeApplication []

-- |
--
applicationReady :: ApplicationClass self => self -> IO ()
applicationReady self =
    {#call unsafe gtkosx_application_ready#} (toApplication self)

-- |
--
applicationSetUseQuartzAccelerators :: ApplicationClass self => self -> Bool -> IO ()
applicationSetUseQuartzAccelerators self b =
    {#call unsafe gtkosx_application_set_use_quartz_accelerators#} (toApplication self) (fromBool b)
applicationSetUseQuartsAccelerators :: ApplicationClass self => self -> Bool -> IO ()
applicationSetUseQuartsAccelerators = applicationSetUseQuartzAccelerators
{-# DEPRECATED applicationSetUseQuartsAccelerators "instead of 'applicationSetUseQuartsAccelerators' use 'applicationSetUseQuartzAccelerators'" #-}

-- |
--
applicationGetUseQuartzAccelerators :: ApplicationClass self => self -> IO Bool
applicationGetUseQuartzAccelerators self = liftM toBool $
    {#call unsafe gtkosx_application_use_quartz_accelerators#} (toApplication self)
applicationGetUseQuartsAccelerators :: ApplicationClass self => self -> IO Bool
applicationGetUseQuartsAccelerators = applicationGetUseQuartzAccelerators
{-# DEPRECATED applicationGetUseQuartsAccelerators "instead of 'applicationGetUseQuartsAccelerators' use 'applicationGetUseQuartzAccelerators'" #-}

-- |
--
applicationSetMenuBar :: (ApplicationClass self, MenuShellClass menu) => self -> menu -> IO ()
applicationSetMenuBar self menu =
    {#call unsafe gtkosx_application_set_menu_bar#} (toApplication self) (toMenuShell menu)

-- |
--
applicationSyncMenuBar :: ApplicationClass self => self -> IO ()
applicationSyncMenuBar self =
    {#call unsafe gtkosx_application_sync_menubar#} (toApplication self)

-- |
--
applicationInsertAppMenuItem :: (ApplicationClass self, WidgetClass menu_item) => self -> menu_item -> Int -> IO ()
applicationInsertAppMenuItem self menu_item index =
    {#call unsafe gtkosx_application_insert_app_menu_item#} (toApplication self) (toWidget menu_item) (fromIntegral index)

-- |
--
applicationSetWindowMenu :: (ApplicationClass self, MenuItemClass menuItem)
    => self -> menuItem -> IO ()
applicationSetWindowMenu self menuItem =
    {#call unsafe gtkosx_application_set_window_menu#} (toApplication self) (toMenuItem menuItem)

-- |
--
applicationSetHelpMenu :: (ApplicationClass self, MenuItemClass menuItem)
    => self -> menuItem -> IO ()
applicationSetHelpMenu self menuItem =
    {#call unsafe gtkosx_application_set_help_menu#} (toApplication self) (toMenuItem menuItem)

{#enum GtkosxApplicationAttentionType {underscoreToCase} deriving (Eq,Show)#}

-- |
--
applicationSetDockMenu :: (ApplicationClass self, MenuShellClass menu) => self -> menu -> IO ()
applicationSetDockMenu self menu =
    {#call unsafe gtkosx_application_set_dock_menu#} (toApplication self) (toMenuShell menu)

-- |
--
applicationSetDockIconPixbuf :: (ApplicationClass self, PixbufClass pixbuf) => self -> Maybe pixbuf -> IO ()
applicationSetDockIconPixbuf self mbPixbuf =
    {#call unsafe gtkosx_application_set_dock_icon_pixbuf#} (toApplication self)
        (maybe (Pixbuf nullForeignPtr) toPixbuf mbPixbuf)

-- |
--
applicationSetDockIconResource :: (ApplicationClass self, GlibString string)
    => self -> string -> string -> string -> IO ()
applicationSetDockIconResource self name rType subdir =
    withUTFString name $ \namePtr ->
    withUTFString rType $ \typePtr ->
    withUTFString subdir $ \subdirPtr ->
    {#call unsafe gtkosx_application_set_dock_icon_resource#} (toApplication self) namePtr typePtr subdirPtr

newtype AttentionRequestID = AttentionRequestID CInt

-- |
--
applicationAttentionRequest :: ApplicationClass self => self -> GtkosxApplicationAttentionType -> IO AttentionRequestID
applicationAttentionRequest self rType = liftM AttentionRequestID $
    {#call unsafe gtkosx_application_attention_request#} (toApplication self) (fromIntegral $ fromEnum rType)

-- |
--
applicationCancelAttentionRequest :: ApplicationClass self => self -> AttentionRequestID -> IO ()
applicationCancelAttentionRequest self (AttentionRequestID id) =
    {#call unsafe gtkosx_application_cancel_attention_request#} (toApplication self) id

-- |
--
applicationGetBundlePath :: GlibString string => IO string
applicationGetBundlePath =
    {#call unsafe gtkosx_application_get_bundle_path#} >>= peekUTFString

-- |
--
applicationGetResourcePath :: GlibString string => IO string
applicationGetResourcePath =
    {#call unsafe gtkosx_application_get_resource_path#} >>= peekUTFString

-- |
--
applicationGetExecutablePath :: GlibString string => IO string
applicationGetExecutablePath =
    {#call unsafe gtkosx_application_get_executable_path#} >>= peekUTFString

-- |
--
applicationGetBundleId :: GlibString string => IO string
applicationGetBundleId =
    {#call unsafe gtkosx_application_get_bundle_id#} >>= peekUTFString

-- |
--
applicationGetBundleInfo :: GlibString string => string -> IO string
applicationGetBundleInfo key =
    withUTFString key $ \keyPtr ->
    {#call unsafe gtkosx_application_get_bundle_info#} keyPtr >>= peekUTFString

-- |
--
didBecomeActive :: ApplicationClass self => Signal self (IO ())
didBecomeActive = Signal (connect_NONE__NONE "NSApplicationDidBecomeActive")

-- |
--
willResignActive :: ApplicationClass self => Signal self (IO ())
willResignActive = Signal (connect_NONE__NONE "NSApplicationWillResignActive")

-- |
--
blockTermination :: ApplicationClass self => Signal self (IO Bool)
blockTermination = Signal (connect_NONE__BOOL "NSApplicationBlockTermination")

-- |
--
willTerminate :: ApplicationClass self => Signal self (IO ())
willTerminate = Signal (connect_NONE__NONE "NSApplicationWillTerminate")

-- |
--
openFile :: (ApplicationClass self, GlibString string) => Signal self (string -> IO ())
openFile = Signal (connect_GLIBSTRING__NONE "NSApplicationOpenFile")

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) SourceBuffer
--
--  Author : Peter Gavin
--  derived from sourceview bindings by Axel Simon and Duncan Coutts
--
--  Created: 18 December 2008
--
--  Copyright (C) 2003-2008 Peter Gavin, Duncan Coutts, Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.OSX.Application (
  Application,
  ApplicationClass,
  castToApplication,
  gTypeApplication,
  toApplication,

  applicationNew,
  applicationReady,
  applicationSetUseQuartsAccelerators,
  applicationGetUseQuartsAccelerators,
  applicationSetMenuBar,
  applicationSyncMenuBar,
  applicationInsertAppMenuItem,
  applicationSetWindowMenu,
  applicationSetHelpMenu,
  GtkosxApplicationAttentionType(..),
  applicationSetDockMenu,
  applicationSetDockIconPixbuf,
  applicationSetDockIconResource,
  AttentionRequestID(..),
  applicationAttentionRequest,
  applicationCancelAttentionRequest,
  applicationGetBundlePath,
  applicationGetResourcePath,
  applicationGetExecutablePath,
  applicationGetBundleId,
  applicationGetBundleInfo,
  didBecomeActive,
  willResignActive,
  blockTermination,
  willTerminate,
  openFile
 ) where

import Control.Monad	(liftM)
import Data.Maybe    (fromMaybe)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GObject              (objectNew, makeNewGObject)
{#import System.Glib.Properties#}
import System.Glib.Attributes
{#import Graphics.UI.Gtk.OSX.Types#}
{#import Graphics.UI.Gtk.OSX.Signals#}

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

-- methods

applicationNew :: IO Application
applicationNew = makeNewGObject mkApplication $ liftM castPtr $
    objectNew gTypeApplication []

-- |
--
applicationReady :: ApplicationClass self => self -> IO ()
applicationReady self =
    {#call unsafe gtkosx_application_ready#} (toApplication self)

-- |
--
applicationSetUseQuartsAccelerators :: ApplicationClass self => self -> Bool -> IO ()
applicationSetUseQuartsAccelerators self b =
    {#call unsafe gtkosx_application_set_use_quartz_accelerators#} (toApplication self) (fromBool b)

-- |
--
applicationGetUseQuartsAccelerators :: ApplicationClass self => self -> IO Bool
applicationGetUseQuartsAccelerators self = liftM toBool $
    {#call unsafe gtkosx_application_use_quartz_accelerators#} (toApplication self)

-- |
--
applicationSetMenuBar :: (ApplicationClass self, MenuShellClass menu) => self -> menu -> IO ()
applicationSetMenuBar self menu =
    {#call unsafe gtkosx_application_set_menu_bar#} (toApplication self) (toMenuShell menu)

-- |
--
applicationSyncMenuBar :: ApplicationClass self => self -> IO ()
applicationSyncMenuBar self =
    {#call unsafe gtkosx_application_sync_menubar#} (toApplication self)

-- |
--
applicationInsertAppMenuItem :: (ApplicationClass self, WidgetClass menu_item) => self -> menu_item -> Int -> IO ()
applicationInsertAppMenuItem self menu_item index =
    {#call unsafe gtkosx_application_insert_app_menu_item#} (toApplication self) (toWidget menu_item) (fromIntegral index)

-- |
--
applicationSetWindowMenu :: (ApplicationClass self, MenuItemClass menuItem)
    => self -> menuItem -> IO ()
applicationSetWindowMenu self menuItem =
    {#call unsafe gtkosx_application_set_window_menu#} (toApplication self) (toMenuItem menuItem)

-- |
--
applicationSetHelpMenu :: (ApplicationClass self, MenuItemClass menuItem)
    => self -> menuItem -> IO ()
applicationSetHelpMenu self menuItem =
    {#call unsafe gtkosx_application_set_help_menu#} (toApplication self) (toMenuItem menuItem)

{#enum GtkosxApplicationAttentionType {underscoreToCase} deriving (Eq,Show)#}

-- |
--
applicationSetDockMenu :: (ApplicationClass self, MenuShellClass menu) => self -> menu -> IO ()
applicationSetDockMenu self menu =
    {#call unsafe gtkosx_application_set_dock_menu#} (toApplication self) (toMenuShell menu)

-- |
--
applicationSetDockIconPixbuf :: (ApplicationClass self, PixbufClass pixbuf) => self -> Maybe pixbuf -> IO ()
applicationSetDockIconPixbuf self mbPixbuf =
    {#call unsafe gtkosx_application_set_dock_icon_pixbuf#} (toApplication self)
        (maybe (Pixbuf nullForeignPtr) toPixbuf mbPixbuf)

-- |
--
applicationSetDockIconResource :: (ApplicationClass self, GlibString string)
    => self -> string -> string -> string -> IO ()
applicationSetDockIconResource self name rType subdir =
    withUTFString name $ \namePtr ->
    withUTFString rType $ \typePtr ->
    withUTFString subdir $ \subdirPtr ->
    {#call unsafe gtkosx_application_set_dock_icon_resource#} (toApplication self) namePtr typePtr subdirPtr

newtype AttentionRequestID = AttentionRequestID CInt

-- |
--
applicationAttentionRequest :: ApplicationClass self => self -> GtkosxApplicationAttentionType -> IO AttentionRequestID
applicationAttentionRequest self rType = liftM AttentionRequestID $
    {#call unsafe gtkosx_application_attention_request#} (toApplication self) (fromIntegral $ fromEnum rType)

-- |
--
applicationCancelAttentionRequest :: ApplicationClass self => self -> AttentionRequestID -> IO ()
applicationCancelAttentionRequest self (AttentionRequestID id) =
    {#call unsafe gtkosx_application_cancel_attention_request#} (toApplication self) id

-- |
--
applicationGetBundlePath :: GlibString string => IO string
applicationGetBundlePath =
    {#call unsafe gtkosx_application_get_bundle_path#} >>= peekUTFString

-- |
--
applicationGetResourcePath :: GlibString string => IO string
applicationGetResourcePath =
    {#call unsafe gtkosx_application_get_resource_path#} >>= peekUTFString

-- |
--
applicationGetExecutablePath :: GlibString string => IO string
applicationGetExecutablePath =
    {#call unsafe gtkosx_application_get_executable_path#} >>= peekUTFString

-- |
--
applicationGetBundleId :: GlibString string => IO string
applicationGetBundleId =
    {#call unsafe gtkosx_application_get_bundle_id#} >>= peekUTFString

-- |
--
applicationGetBundleInfo :: GlibString string => string -> IO string
applicationGetBundleInfo key =
    withUTFString key $ \keyPtr ->
    {#call unsafe gtkosx_application_get_bundle_info#} keyPtr >>= peekUTFString

-- |
--
didBecomeActive :: ApplicationClass self => Signal self (IO ())
didBecomeActive = Signal (connect_NONE__NONE "NSApplicationDidBecomeActive")

-- |
--
willResignActive :: ApplicationClass self => Signal self (IO ())
willResignActive = Signal (connect_NONE__NONE "NSApplicationWillResignActive")

-- |
--
blockTermination :: ApplicationClass self => Signal self (IO Bool)
blockTermination = Signal (connect_NONE__BOOL "NSApplicationBlockTermination")

-- |
--
willTerminate :: ApplicationClass self => Signal self (IO ())
willTerminate = Signal (connect_NONE__NONE "NSApplicationWillTerminate")

-- |
--
openFile :: (ApplicationClass self, GlibString string) => Signal self (string -> IO ())
openFile = Signal (connect_GLIBSTRING__NONE "NSApplicationOpenFile")


Some more commit functions

Some more commit functions

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}

#include "git2.h"

module Git2 where

import Data.ByteString
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO.Unsafe

type OffT    = {#type git_off_t#}
type TimeT   = {#type git_time_t#}
type CPtr    = Ptr ()
type Ptr2Int = CPtr -> IO CInt

newtype ObjDB      = ObjDB CPtr
newtype Repository = Repository CPtr
newtype Index      = Index CPtr
newtype Blob       = Blob CPtr
newtype ObjID      = ObjID CPtr
newtype Commit     = Commit CPtr
newtype Signature  = Signature CPtr
newtype Tree       = Tree CPtr

defaultPort :: String
defaultPort = "9418" -- TODO: Import from net.h?

{#enum define Direction { GIT_DIR_FETCH as Fetch
                        , GIT_DIR_PUSH as Push}#}

{-
#define GIT_STATUS_CURRENT        0
/** Flags for index status */
#define GIT_STATUS_INDEX_NEW      (1 << 0)
#define GIT_STATUS_INDEX_MODIFIED (1 << 1)
#define GIT_STATUS_INDEX_DELETED  (1 << 2)

/** Flags for worktree status */
#define GIT_STATUS_WT_NEW         (1 << 3)
#define GIT_STATUS_WT_MODIFIED    (1 << 4)
#define GIT_STATUS_WT_DELETED     (1 << 5)

// TODO Ignored files not handled yet
#define GIT_STATUS_IGNORED        (1 << 6)
-}

{-
{#enum define Status { GIT_STATUS_CURRENT as Current
                     , GIT_STATUS_INDEX_NEW as NewIndex
                     , GIT_STATUS_INDEX_MODIFIED as ModifiedIndex
                     , GIT_STATUS_INDEX_DELETED as DeletedIndex
                     , GIT_STATUS_WT_NEW as NewWorkTree
                     , GIT_STATUS_WT_MODIFIED as ModifiedWorkTree
                     , GIT_STATUS_WT_DELETED as DeletedWorkTree
                     , GIT_STATUS_IGNORED as Ignored}#}
-}

{#enum git_otype as OType {underscoreToCase}#}
{#enum git_rtype as RType {underscoreToCase}#}
{#enum git_repository_pathid as RepositoryPathID {underscoreToCase}#}
{#enum git_error as GitError {underscoreToCase}#}
{#enum git_odb_streammode as ODBStreamMode {underscoreToCase}#}

deriving instance Show GitError

-------------------------------------------------------------------------------
-- BEGIN: blob.h
-------------------------------------------------------------------------------

{-
/**
 * Get a read-only buffer with the raw content of a blob.
 *
 * A pointer to the raw content of a blob is returned;
 * this pointer is owned internally by the object and shall
 * not be free'd. The pointer may be invalidated at a later
 * time.
 *
 * @param blob pointer to the blob
 * @return the pointer; NULL if the blob has no contents
 */
GIT_EXTERN(const void *) git_blob_rawcontent(git_blob *blob);
-}
-- TODO: Could the next two be made "pure"
-- TODO: Figure out what this function should return...
rawBlobContent :: Blob -> IO CPtr
rawBlobContent (Blob b) = {#call git_blob_rawcontent#} b

rawBlobSize :: Blob -> IO Int
rawBlobSize (Blob b) = return . fromIntegral =<< {#call git_blob_rawsize#} b

blobFromFile :: ObjID -> Repository -> String -> IO (Maybe GitError)
blobFromFile (ObjID obj) (Repository repo) path = do
  pathStr  <- newCString path
  res      <- {#call git_blob_create_fromfile #} obj repo pathStr
  retMaybeRes res

retMaybeRes :: CInt -> IO (Maybe GitError)
retMaybeRes res | res == 0  = return Nothing
                | otherwise = return $ Just . toEnum . fromIntegral $ res

-- TODO: CPtr here?
blobFromBuffer :: ObjID -> Repository -> CPtr -> IO (Maybe GitError)
blobFromBuffer (ObjID objId) (Repository repo) buf = do
  res <- {#call git_blob_create_frombuffer#} objId repo buf
                                             (fromIntegral $ sizeOf buf)
  retMaybeRes res

-------------------------------------------------------------------------------
-- END: blob.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: commit.h
-------------------------------------------------------------------------------

commitId :: Commit -> ObjID
commitId (Commit c) = unsafePerformIO $
  return . ObjID =<< {#call unsafe git_commit_id#} c

shortCommitMsg :: Commit -> String
shortCommitMsg (Commit c) = unsafePerformIO $
  peekCString =<< {#call unsafe git_commit_message_short#} c

commitMsg :: Commit -> String
commitMsg (Commit c) = unsafePerformIO $
  peekCString =<< {#call unsafe git_commit_message#} c

commitTime :: Commit -> TimeT
commitTime (Commit c) = unsafePerformIO $
  return =<< {#call unsafe git_commit_time#} c

timeOffset :: Commit -> Int
timeOffset (Commit c) = unsafePerformIO $
  return . fromIntegral =<< {#call unsafe git_commit_time_offset#} c

committer :: Commit -> Signature
committer (Commit c) = unsafePerformIO $
  return . Signature =<< {#call unsafe git_commit_committer#} c

author :: Commit -> Signature
author (Commit c) = unsafePerformIO $
  return . Signature =<< {#call unsafe git_commit_author#} c

tree :: Commit -> IO (Either GitError Tree)
tree (Commit c) = alloca $ \tree -> do
  res <- {#call git_commit_tree#} tree c
  retEither res $ fmap (Right . Tree) $ peek tree

{-
/**
 * Get the id of the tree pointed to by a commit. This differs from
 * `git_commit_tree` in that no attempts are made to fetch an object
 * from the ODB.
 *
 * @param commit a previously loaded commit.
 * @return the id of tree pointed to by commit.
 */
GIT_EXTERN(const git_oid *) git_commit_tree_oid(git_commit *commit);

/**
 * Get the number of parents of this commit
 *
 * @param commit a previously loaded commit.
 * @return integer of count of parents
 */
GIT_EXTERN(unsigned int) git_commit_parentcount(git_commit *commit);
-}

parent :: Commit -> Int -> IO (Either GitError Commit)
parent (Commit c) n = alloca $ \parent -> do
  res <- {#call git_commit_parent#} parent c (fromIntegral n)
  retEither res $ fmap (Right . Commit) $ peek parent

{-
/**
 * Get the oid of a specified parent for a commit. This is different from
 * `git_commit_parent`, which will attempt to load the parent commit from
 * the ODB.
 *
 * @param commit a previously loaded commit.
 * @param n the position of the parent (from 0 to `parentcount`)
 * @return the id of the parent, NULL on error.
 */
GIT_EXTERN(const git_oid *) git_commit_parent_oid(git_commit *commit, unsigned int n);

/**
 * Create a new commit in the repository using `git_object`
 * instances as parameters.
 *
 * @param oid Pointer where to store the OID of the
 *	newly created commit
 *
 * @param repo Repository where to store the commit
 *
 * @param update_ref If not NULL, name of the reference that
 *	will be updated to point to this commit. If the reference
 *	is not direct, it will be resolved to a direct reference.
 *	Use "HEAD" to update the HEAD of the current branch and
 *	make it point to this commit
 *
 * @param author Signature representing the author and the authory
 *	time of this commit
 *
 * @param committer Signature representing the committer and the
 *  commit time of this commit
 *
 * @param message Full message for this commit
 *
 * @param tree An instance of a `git_tree` object that will
 * be used as the tree for the commit. This tree object must
 * also be owned by the given `repo`.
 *
 * @param parent_count Number of parents for this commit
 *
 * @param parents[] Array of `parent_count` pointers to `git_commit`
 * objects that will be used as the parents for this commit. This
 * array may be NULL if `parent_count` is 0 (root commit). All the
 * given commits must be owned by the `repo`.
 *
 * @return 0 on success; error code otherwise
 *	The created commit will be written to the Object Database and
 *	the given reference will be updated to point to it
 */
GIT_EXTERN(int) git_commit_create(
		git_oid *oid,
		git_repository *repo,
		const char *update_ref,
		const git_signature *author,
		const git_signature *committer,
		const char *message,
		const git_tree *tree,
		int parent_count,
		const git_commit *parents[]);

/**
 * Create a new commit in the repository using a variable
 * argument list.
 *
 * The parents for the commit are specified as a variable
 * list of pointers to `const git_commit *`. Note that this
 * is a convenience method which may not be safe to export
 * for certain languages or compilers
 *
 * All other parameters remain the same
 *
 * @see git_commit_create
 */
GIT_EXTERN(int) git_commit_create_v(
		git_oid *oid,
		git_repository *repo,
		const char *update_ref,
		const git_signature *author,
		const git_signature *committer,
		const char *message,
		const git_tree *tree,
		int parent_count,
		...);
-}

-------------------------------------------------------------------------------
-- END: commit.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: repositoy.h
-------------------------------------------------------------------------------

repoIs :: Ptr2Int -> Repository -> IO Bool
repoIs ffi (Repository ptr) = return . toBool =<< ffi ptr

openRepo :: String -> IO (Either GitError Repository)
openRepo path = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_open#} pprepo pstr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDir :: String -> String -> String -> String
               -> IO (Either GitError Repository)
openRepoObjDir dir objDir idxFile workTree = alloca $ \pprepo -> do
  dirStr  <- newCString dir
  objDStr <- newCString objDir
  idxFStr <- newCString idxFile
  wtrStr  <- newCString workTree
  res     <- {#call git_repository_open2#} pprepo dirStr objDStr idxFStr wtrStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDb :: String -> ObjDB -> String -> String
              -> IO (Either GitError Repository)
openRepoObjDb dir (ObjDB db) idxFile workTree = alloca $ \pprepo -> do
  dirStr  <- newCString dir
  idxFStr <- newCString idxFile
  wtrStr  <- newCString workTree
  res     <- {#call git_repository_open3#} pprepo dirStr db idxFStr wtrStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

discover :: String -> Bool -> String -> IO (Either GitError String)
discover startPath acrossFs ceilingDirs = alloca $ \path -> do
  spStr  <- newCString startPath
  cdsStr <- newCString ceilingDirs
  res    <- {#call git_repository_discover#} path (fromIntegral $ sizeOf path)
                                             spStr (fromBool acrossFs) cdsStr
  retEither res $ fmap Right $ peekCString path

database :: Repository -> IO ObjDB
database (Repository r) = return . ObjDB =<< {#call git_repository_database#} r

index :: Repository -> IO (Either GitError Index)
index (Repository r) = alloca $ \idx -> do
  res  <- {#call git_repository_index#} idx r
  retEither res $ fmap (Right . Index) $ peek idx

free :: Repository -> IO ()
free (Repository r) = {#call git_repository_free#} r

init :: String -> Bool -> IO (Either GitError Repository)
init path isBare = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_init#} pprepo pstr (fromBool isBare)
  retEither res $ fmap (Right . Repository) $ peek pprepo

retEither :: CInt -> IO (Either GitError a) -> IO (Either GitError a)
retEither res f | res == 0  = f
                | otherwise = return . Left . toEnum . fromIntegral $ res

isHeadDetached :: Repository -> IO Bool
isHeadDetached = repoIs {#call git_repository_head_detached#}

isHeadOrphan :: Repository -> IO Bool
isHeadOrphan = repoIs {#call git_repository_head_orphan#}

isEmpty :: Repository -> IO Bool
isEmpty = repoIs {#call git_repository_is_empty#}

path :: Repository -> RepositoryPathID -> IO String
path (Repository r) pathID = peekCString =<< {#call git_repository_path#} r p
  where p = fromIntegral $ fromEnum pathID

isBare :: Repository -> IO Bool
isBare = repoIs {#call git_repository_is_bare#}

-------------------------------------------------------------------------------
-- END: repository.h
-------------------------------------------------------------------------------

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}

#include "git2.h"

module Git2 where

import Data.ByteString
import Foreign
import Foreign.C.String
import Foreign.C.Types
import System.IO.Unsafe

type OffT    = {#type git_off_t#}
type TimeT   = {#type git_time_t#}
type CPtr    = Ptr ()
type Ptr2Int = CPtr -> IO CInt

newtype ObjDB      = ObjDB CPtr
newtype Repository = Repository CPtr
newtype Index      = Index CPtr
newtype Blob       = Blob CPtr
newtype ObjID      = ObjID CPtr
newtype Commit     = Commit CPtr
newtype Signature  = Signature CPtr

defaultPort :: String
defaultPort = "9418" -- TODO: Import from net.h?

{#enum define Direction { GIT_DIR_FETCH as Fetch
                        , GIT_DIR_PUSH as Push}#}

{-
#define GIT_STATUS_CURRENT        0
/** Flags for index status */
#define GIT_STATUS_INDEX_NEW      (1 << 0)
#define GIT_STATUS_INDEX_MODIFIED (1 << 1)
#define GIT_STATUS_INDEX_DELETED  (1 << 2)

/** Flags for worktree status */
#define GIT_STATUS_WT_NEW         (1 << 3)
#define GIT_STATUS_WT_MODIFIED    (1 << 4)
#define GIT_STATUS_WT_DELETED     (1 << 5)

// TODO Ignored files not handled yet
#define GIT_STATUS_IGNORED        (1 << 6)
-}

{-
{#enum define Status { GIT_STATUS_CURRENT as Current
                     , GIT_STATUS_INDEX_NEW as NewIndex
                     , GIT_STATUS_INDEX_MODIFIED as ModifiedIndex
                     , GIT_STATUS_INDEX_DELETED as DeletedIndex
                     , GIT_STATUS_WT_NEW as NewWorkTree
                     , GIT_STATUS_WT_MODIFIED as ModifiedWorkTree
                     , GIT_STATUS_WT_DELETED as DeletedWorkTree
                     , GIT_STATUS_IGNORED as Ignored}#}
-}

{#enum git_otype as OType {underscoreToCase}#}
{#enum git_rtype as RType {underscoreToCase}#}
{#enum git_repository_pathid as RepositoryPathID {underscoreToCase}#}
{#enum git_error as GitError {underscoreToCase}#}
{#enum git_odb_streammode as ODBStreamMode {underscoreToCase}#}

deriving instance Show GitError

-------------------------------------------------------------------------------
-- BEGIN: blob.h
-------------------------------------------------------------------------------

{-
/**
 * Get a read-only buffer with the raw content of a blob.
 *
 * A pointer to the raw content of a blob is returned;
 * this pointer is owned internally by the object and shall
 * not be free'd. The pointer may be invalidated at a later
 * time.
 *
 * @param blob pointer to the blob
 * @return the pointer; NULL if the blob has no contents
 */
GIT_EXTERN(const void *) git_blob_rawcontent(git_blob *blob);
-}
-- TODO: Could the next two be made "pure"
-- TODO: Figure out what this function should return...
rawBlobContent :: Blob -> IO CPtr
rawBlobContent (Blob b) = {#call git_blob_rawcontent#} b

rawBlobSize :: Blob -> IO Int
rawBlobSize (Blob b) = return . fromIntegral =<< {#call git_blob_rawsize#} b

blobFromFile :: ObjID -> Repository -> String -> IO (Maybe GitError)
blobFromFile (ObjID obj) (Repository repo) path = do
  pathStr  <- newCString path
  res      <- {#call git_blob_create_fromfile #} obj repo pathStr
  retMaybeRes res

retMaybeRes :: CInt -> IO (Maybe GitError)
retMaybeRes res | res == 0  = return Nothing
                | otherwise = return $ Just . toEnum . fromIntegral $ res

blobFromBuffer :: ObjID -> Repository -> CPtr -> IO (Maybe GitError)
blobFromBuffer (ObjID objId) (Repository repo) buf = do
  res <- {#call git_blob_create_frombuffer#} objId repo buf
                                             (fromIntegral $ sizeOf buf)
  retMaybeRes res

-------------------------------------------------------------------------------
-- END: blob.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: commit.h
-------------------------------------------------------------------------------

commitId :: Commit -> ObjID
commitId (Commit c) = unsafePerformIO $
  return . ObjID =<< {#call unsafe git_commit_id#} c

shortCommitMsg :: Commit -> String
shortCommitMsg (Commit c) = unsafePerformIO $
  peekCString =<< {#call unsafe git_commit_message_short#} c

commitMsg :: Commit -> String
commitMsg (Commit c) = unsafePerformIO $
  peekCString =<< {#call unsafe git_commit_message#} c

commitTime :: Commit -> TimeT
commitTime (Commit c) = unsafePerformIO $
  return =<< {#call unsafe git_commit_time#} c

timeOffset :: Commit -> Int
timeOffset (Commit c) = unsafePerformIO $
  return . fromIntegral =<< {#call unsafe git_commit_time_offset#} c

committer :: Commit -> Signature
committer (Commit c) = unsafePerformIO $
  return . Signature =<< {#call unsafe git_commit_committer#} c

author :: Commit -> Signature
author (Commit c) = unsafePerformIO $
  return . Signature =<< {#call unsafe git_commit_author#} c

{-
/**
 * Get the tree pointed to by a commit.
 *
 * @param tree_out pointer where to store the tree object
 * @param commit a previously loaded commit.
 * @return 0 on success; error code otherwise
 */
GIT_EXTERN(int) git_commit_tree(git_tree **tree_out, git_commit *commit);

/**
 * Get the id of the tree pointed to by a commit. This differs from
 * `git_commit_tree` in that no attempts are made to fetch an object
 * from the ODB.
 *
 * @param commit a previously loaded commit.
 * @return the id of tree pointed to by commit.
 */
GIT_EXTERN(const git_oid *) git_commit_tree_oid(git_commit *commit);

/**
 * Get the number of parents of this commit
 *
 * @param commit a previously loaded commit.
 * @return integer of count of parents
 */
GIT_EXTERN(unsigned int) git_commit_parentcount(git_commit *commit);

/**
 * Get the specified parent of the commit.
 *
 * @param parent Pointer where to store the parent commit
 * @param commit a previously loaded commit.
 * @param n the position of the parent (from 0 to `parentcount`)
 * @return 0 on success; error code otherwise
 */
GIT_EXTERN(int) git_commit_parent(git_commit **parent, git_commit *commit, unsigned int n);

/**
 * Get the oid of a specified parent for a commit. This is different from
 * `git_commit_parent`, which will attempt to load the parent commit from
 * the ODB.
 *
 * @param commit a previously loaded commit.
 * @param n the position of the parent (from 0 to `parentcount`)
 * @return the id of the parent, NULL on error.
 */
GIT_EXTERN(const git_oid *) git_commit_parent_oid(git_commit *commit, unsigned int n);

/**
 * Create a new commit in the repository using `git_object`
 * instances as parameters.
 *
 * @param oid Pointer where to store the OID of the
 *	newly created commit
 *
 * @param repo Repository where to store the commit
 *
 * @param update_ref If not NULL, name of the reference that
 *	will be updated to point to this commit. If the reference
 *	is not direct, it will be resolved to a direct reference.
 *	Use "HEAD" to update the HEAD of the current branch and
 *	make it point to this commit
 *
 * @param author Signature representing the author and the authory
 *	time of this commit
 *
 * @param committer Signature representing the committer and the
 *  commit time of this commit
 *
 * @param message Full message for this commit
 *
 * @param tree An instance of a `git_tree` object that will
 * be used as the tree for the commit. This tree object must
 * also be owned by the given `repo`.
 *
 * @param parent_count Number of parents for this commit
 *
 * @param parents[] Array of `parent_count` pointers to `git_commit`
 * objects that will be used as the parents for this commit. This
 * array may be NULL if `parent_count` is 0 (root commit). All the
 * given commits must be owned by the `repo`.
 *
 * @return 0 on success; error code otherwise
 *	The created commit will be written to the Object Database and
 *	the given reference will be updated to point to it
 */
GIT_EXTERN(int) git_commit_create(
		git_oid *oid,
		git_repository *repo,
		const char *update_ref,
		const git_signature *author,
		const git_signature *committer,
		const char *message,
		const git_tree *tree,
		int parent_count,
		const git_commit *parents[]);

/**
 * Create a new commit in the repository using a variable
 * argument list.
 *
 * The parents for the commit are specified as a variable
 * list of pointers to `const git_commit *`. Note that this
 * is a convenience method which may not be safe to export
 * for certain languages or compilers
 *
 * All other parameters remain the same
 *
 * @see git_commit_create
 */
GIT_EXTERN(int) git_commit_create_v(
		git_oid *oid,
		git_repository *repo,
		const char *update_ref,
		const git_signature *author,
		const git_signature *committer,
		const char *message,
		const git_tree *tree,
		int parent_count,
		...);
-}

-------------------------------------------------------------------------------
-- END: commit.h
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
-- BEGIN: repositoy.h
-------------------------------------------------------------------------------

repoIs :: Ptr2Int -> Repository -> IO Bool
repoIs ffi (Repository ptr) = return . toBool =<< ffi ptr

openRepo :: String -> IO (Either GitError Repository)
openRepo path = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_open#} pprepo pstr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDir :: String -> String -> String -> String
               -> IO (Either GitError Repository)
openRepoObjDir dir objDir idxFile workTree = alloca $ \pprepo -> do
  dirStr  <- newCString dir
  objDStr <- newCString objDir
  idxFStr <- newCString idxFile
  wtrStr  <- newCString workTree
  res     <- {#call git_repository_open2#} pprepo dirStr objDStr idxFStr wtrStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDb :: String -> ObjDB -> String -> String
              -> IO (Either GitError Repository)
openRepoObjDb dir (ObjDB db) idxFile workTree = alloca $ \pprepo -> do
  dirStr  <- newCString dir
  idxFStr <- newCString idxFile
  wtrStr  <- newCString workTree
  res     <- {#call git_repository_open3#} pprepo dirStr db idxFStr wtrStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

discover :: String -> Bool -> String -> IO (Either GitError String)
discover startPath acrossFs ceilingDirs = alloca $ \path -> do
  spStr  <- newCString startPath
  cdsStr <- newCString ceilingDirs
  res    <- {#call git_repository_discover#} path (fromIntegral $ sizeOf path)
                                             spStr (fromBool acrossFs) cdsStr
  retEither res $ fmap Right $ peekCString path

database :: Repository -> IO ObjDB
database (Repository r) = return . ObjDB =<< {#call git_repository_database#} r

index :: Repository -> IO (Either GitError Index)
index (Repository r) = alloca $ \idx -> do
  res  <- {#call git_repository_index#} idx r
  retEither res $ fmap (Right . Index) $ peek idx

free :: Repository -> IO ()
free (Repository r) = {#call git_repository_free#} r

init :: String -> Bool -> IO (Either GitError Repository)
init path isBare = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_init#} pprepo pstr (fromBool isBare)
  retEither res $ fmap (Right . Repository) $ peek pprepo

retEither :: CInt -> IO (Either GitError a) -> IO (Either GitError a)
retEither res f | res == 0  = f
                | otherwise = return . Left . toEnum . fromIntegral $ res

isHeadDetached :: Repository -> IO Bool
isHeadDetached = repoIs {#call git_repository_head_detached#}

isHeadOrphan :: Repository -> IO Bool
isHeadOrphan = repoIs {#call git_repository_head_orphan#}

isEmpty :: Repository -> IO Bool
isEmpty = repoIs {#call git_repository_is_empty#}

path :: Repository -> RepositoryPathID -> IO String
path (Repository r) pathID = peekCString =<< {#call git_repository_path#} r p
  where p = fromIntegral $ fromEnum pathID

isBare :: Repository -> IO Bool
isBare = repoIs {#call git_repository_is_bare#}

-------------------------------------------------------------------------------
-- END: repository.h
-------------------------------------------------------------------------------


[project @ 2002-07-04 10:44:47 by as49] Realized that the onDestroy should actually be bound to the destroy of GtkObject, not to the destroy-event of GtkWidget.

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Widget class@
--
--  Author : Axel Simon
--
--  Created: 27 April 2001
--
--  Version $Revision: 1.4 $ from $Date: 2002/07/04 10:44:47 $
--
--  Copyright (c) 2001 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@ --------------------------------------------------------------
--
--  * Widget is the base class of all widgets. It provides the methods to
--    attach and detach signals.
--
-- @documentation@ ------------------------------------------------------------
--
--  * This modules reexports everything a normal widget needs from GObject
--    and Object.
--
--- TODO ----------------------------------------------------------------------
--
--  * unimplemented methods that seem to be useful in user programs:
--      widgetSizeRequest, widgetAddAccelerator, widgetRemoveAccrelerator,
--	widgetAcceleratorSignal, widgetIntersect, widgetGrabDefault,
--	widgetGetPointer, widgetPath, widgetClassPath, getCompositeName,
--	widgetSetCompositeName,
--	widgetModifyStyle, widgetGetModifierStyle, widgetModifyFg,
--	widgetModifyBG, widgetModifyText, widgetModifyBase, widgetModifyFont,
--	widgetPango*, widgetSetAdjustments
--
--
--  * implement the following methods in GtkWindow object:
--      widget_set_uposition, widget_set_usize
--
--  * implement the following methods in GtkDrawingArea object:
--      widgetQueueDrawArea, widgetSetDoubleBufferd, widgetRegionIntersect
--
module Widget(
  Widget,
  WidgetClass,
  castToWidget,
  Allocation,
  Requisition(..),
  Rectangle(..),
  widgetShow,			-- Showing and hiding a widget.
  widgetShowNow,
  widgetHide,
  widgetShowAll,
  widgetHideAll,
  widgetDestroy,
  widgetQueueDraw,		-- Functions to be used with DrawingArea.
  widgetHasIntersection,
  widgetActivate,		-- Manipulate widget state.
  widgetSetSensitivity,
  widgetIsFocus,
  widgetGrabFocus,
  widgetSetAppPaintable,
  widgetSetName,		-- Naming, Themes
  widgetGetName,
  widgetGetToplevel,		-- Widget browsing.
  widgetIsAncestor,
  widgetReparent,
  TextDirection(..),
  widgetSetDirection,		-- General Setup.
  widgetGetDirection,
--  widgetLockAccelerators,
--  widgetUnlockAccelerators,
  Event(..),
  onButtonPress,
  afterButtonPress,
  onButtonRelease,
  afterButtonRelease,
  onClient,
  afterClient,
  onConfigure,
  afterConfigure,
  onDelete,
  afterDelete,
  onDestroyEvent,		-- you probably want onDestroy
  afterDestroyEvent,
  onDirectionChanged,
  afterDirectionChanged,
  onEnterNotify,
  afterEnterNotify,
  onLeaveNotify,
  afterLeaveNotify,
  onExpose,
  afterExpose,
  onFocusIn,
  afterFocusIn,
  onFocusOut,
  afterFocusOut,
  onGrabFocus,
  afterGrabFocus,
  onDestroy,
  afterDestroy,
  onHide,
  afterHide,
  onHierarchyChanged,
  afterHierarchyChanged,
  onKeyPress,
  afterKeyPress,
  onKeyRelease,
  afterKeyRelease,
  onMnemonicActivate,
  afterMnemonicActivate,
  onMotionNotify,
  afterMotionNotify,
  onParentSet,
  afterParentSet,
  onPopupMenu,
  afterPopupMenu,
  onProximityIn,
  afterProximityIn,
  onProximityOut,
  afterProximityOut,
  onScroll,
  afterScroll,
  onShow,
  afterShow,
  onSizeAllocate,
  afterSizeAllocate,
  onSizeRequest,
  afterSizeRequest,
  StateType(..),
  onStateChanged,
  afterStateChanged,
  onUnmap,
  afterUnmap,
  onUnrealize,
  afterUnrealize,
  onVisibilityNotify,
  afterVisibilityNotify,
  onWindowState,
  afterWindowState
  ) where

import Monad	(liftM, unless)
import UTFCForeign
import Foreign
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import GdkEnums
import Structs	(Allocation, Rectangle(..), Requisition(..))
import Events	(Event(..), marshalEvent)
import Enums	(StateType(..), TextDirection(..))

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

-- methods

-- @method widgetShow@ Queue a show request.
--
-- * Flags a widget to be displayed. Any widget that isn't shown will not
--   appear on the screen. If you want to show all the widgets in a container,
--   it's easier to call @ref method widgetShowAll@ on the container, instead
--   of individually showing the widgets. Note that you have to show the
--   containers containing a widget, in addition to the widget itself, before
--   it will appear onscreen. When a toplevel container is shown, it is
--   immediately realized and mapped; other shown widgets are realized and
--   mapped when their toplevel container is realized and mapped.
--
widgetShow :: WidgetClass w => w -> IO ()
widgetShow  = {#call widget_show#}.toWidget

-- @method widgetShowNow@ Queue a show event and wait for it to be executed.
--
-- * If the widget is an unmapped toplevel widget (i.e. a @ref arg Window@
--   that has not yet been shown), enter the main loop and wait for the window
--   to actually be mapped. Be careful; because the main loop is running,
--   anything can happen during this function.
--
widgetShowNow :: WidgetClass w => w -> IO ()
widgetShowNow  = {#call widget_show_now#}.toWidget

-- @method widgetHide@ Queue a hide request.
--
-- * Reverses the effects of @ref method widgetShow@, causing the widget to be
--   hidden (make invisible to the user).
--
widgetHide :: WidgetClass w => w -> IO ()
widgetHide  = {#call widget_hide#}.toWidget

-- @method widgetShowAll@ Show this and all child widgets.
--
widgetShowAll :: WidgetClass w => w -> IO ()
widgetShowAll  = {#call widget_show_all#}.toWidget

-- @method widgetHideAll@ Hide this and all child widgets.
--
widgetHideAll :: WidgetClass w => w -> IO ()
widgetHideAll  = {#call widget_hide_all#}.toWidget

-- @method widgetDestroy@ Destroy a widget.
--
-- * The @ref method widgetDestroy@ function is used to shutdown an object,
--   i.e. a widget will be removed from the screen and unrealized. Resources
--   will be freed when all references are released.
--
widgetDestroy :: WidgetClass obj => obj -> IO ()
widgetDestroy  = {#call widget_destroy#}.toWidget

-- Functions to be used with DrawingArea.

-- @method widgetQueueDraw@ Send a redraw request to a widget.
--
widgetQueueDraw :: WidgetClass w => w -> IO ()
widgetQueueDraw  = {#call widget_queue_draw#}.toWidget

-- @method widgetHasIntersection@ Check if the widget intersects with a given
-- area.
--
widgetHasIntersection :: WidgetClass w => w -> Rectangle -> IO Bool
widgetHasIntersection w r =
  liftM toBool $
  withObject r $ \r' ->
  {#call unsafe widget_intersect#} (toWidget w) (castPtr r') (castPtr nullPtr)

-- Manipulate widget state.

-- @method widgetActivate@ Activate the widget (e.g. clicking a button).
--
widgetActivate :: WidgetClass w => w -> IO Bool
widgetActivate w = liftM toBool $ {#call widget_activate#} (toWidget w)

-- @method widgetSetSensitivity@ Set the widgets sensitivity (Grayed or
-- Usable).
--
widgetSetSensitivity :: WidgetClass w => w -> Bool -> IO ()
widgetSetSensitivity w b =
  {#call widget_set_sensitive#} (toWidget w) (fromBool b)

-- @method widgetIsFocus@ Set and query the input focus of a widget.
--
widgetIsFocus :: WidgetClass w => w -> IO Bool
widgetIsFocus w = liftM toBool $
  {#call unsafe widget_is_focus#} (toWidget w)

widgetGrabFocus :: WidgetClass w => w -> IO ()
widgetGrabFocus = {#call widget_grab_focus#}.toWidget

-- @method widgetSetAppPaintable@ Sets some weired flag in the widget.
--
widgetSetAppPaintable :: WidgetClass w => w -> Bool -> IO ()
widgetSetAppPaintable w p =
  {#call widget_set_app_paintable#} (toWidget w) (fromBool p)

-- @method widgetSetName@ Set the name of a widget.
--
widgetSetName :: WidgetClass w => w -> String -> IO ()
widgetSetName w name =
  withCString name ({#call widget_set_name#} (toWidget w))

-- @method widgetGetName@ Get the name of a widget.
--
widgetGetName :: WidgetClass w => w -> IO String
widgetGetName w = {#call unsafe widget_get_name#} (toWidget w) >>=
		  peekCString

-- @method widgetAddEvents@ Enable event signals.
--
widgetAddEvents :: WidgetClass w => w -> [EventMask] -> IO ()
widgetAddEvents w em =
  {#call widget_add_events#} (toWidget w) (fromIntegral $ fromFlags em)

-- @method widgetGetEvents@ Get enabled event signals.
--
widgetGetEvents :: WidgetClass w => w -> IO [EventMask]
widgetGetEvents w = liftM (toFlags.fromIntegral) $
  {#call unsafe widget_get_events#} (toWidget w)

-- @method widgetSetExtensionEvents@ Set extension events.
--
widgetSetExtensionEvents :: WidgetClass w => w -> [ExtensionMode] -> IO ()
widgetSetExtensionEvents w em =
  {#call widget_set_extension_events#} (toWidget w)
    (fromIntegral $ fromFlags em)

-- @method widgetGetExtensionEvents@ Get extension events.
--
widgetGetExtensionEvents :: WidgetClass w => w -> IO [ExtensionMode]
widgetGetExtensionEvents w = liftM (toFlags.fromIntegral) $
  {#call widget_get_extension_events#} (toWidget w)

-- Widget browsing.

-- @method widgetGetToplevel@ Retrieves the topmost widget in this tree.
--
widgetGetToplevel :: WidgetClass w => w -> IO Widget
widgetGetToplevel w = makeNewObject mkWidget $
  {#call unsafe widget_get_toplevel#} (toWidget w)

-- @method widgetIsAncestor@ Return True if the second widget is (possibly
-- indirectly) held by the first.
--
widgetIsAncestor :: (WidgetClass w, WidgetClass anc) => anc -> w -> IO Bool
widgetIsAncestor anc w = liftM toBool $
 {#call unsafe widget_is_ancestor#} (toWidget w) (toWidget anc)

-- @method widgetReparent@ Move a widget to a new parent.
--
widgetReparent :: (WidgetClass w, WidgetClass par) => w -> par -> IO ()
widgetReparent w par =
  {#call widget_reparent#} (toWidget w) (toWidget par)

-- @method widgetSetDirection@ Setting packaging and writing direction.
--
widgetSetDirection :: WidgetClass w => w -> TextDirection -> IO ()
widgetSetDirection w td =
  {#call widget_set_direction#} (toWidget w) ((fromIntegral.fromEnum) td)

-- @method widgetGetDirection@ Retrieve the default direction of text writing.
--
widgetGetDirection :: WidgetClass w => w -> IO TextDirection
widgetGetDirection w = liftM (toEnum.fromIntegral) $
  {#call widget_get_direction#} (toWidget w)

-- Accelerator handling.

-- @dunno@Lock accelerators.
-- *  @literal@
--widgetLockAccelerators :: WidgetClass w => w -> IO ()
--widgetLockAccelerators = {#call unsafe widget_lock_accelerators#}.toWidget

-- @dunno@Unlock accelerators.
-- *  @literal@
--widgetUnlockAccelerators :: WidgetClass w => w -> IO ()
--widgetUnlockAccelerators = {#call widget_unlock_accelerators#}.toWidget

-- signals

-- Because there are so many similar signals (those that take an Event and
-- return a Bool) we will abstract out the skeleton. As some of these events
-- are emitted at a high rate often a bit has to be set to enable emission.
event :: WidgetClass w => SignalName -> [EventMask] ->
  ConnectAfter -> w -> (Event -> IO Bool) -> IO (ConnectId w)
event name eMask after obj fun = do
  id <- connect_BOXED__BOOL name marshalEvent after obj fun
  widgetAddEvents obj eMask
  return id

-- @signal connectToButtonPress@ A Button was pressed.
--
-- * This widget is part of a button which was just pressed. The event passed
--   to the user function is a @ref arg Button@ event.
--
onButtonPress, afterButtonPress :: WidgetClass w => w -> (Event -> IO Bool) ->
                                   IO (ConnectId w)
onButtonPress = event "button_press_event" [ButtonPressMask] False
afterButtonPress = event "button_press_event" [ButtonPressMask] True

-- @signal connectToButtonRelease@ A Butten was released.
--
onButtonRelease, afterButtonRelease :: WidgetClass w => w ->
                                       (Event -> IO Bool) -> IO (ConnectId w)
onButtonRelease = event "button_release_event" [ButtonReleaseMask] False
afterButtonRelease = event "button_release_event" [ButtonReleaseMask] True

-- @signal connectToClient@
--
onClient, afterClient :: WidgetClass w => w -> (Event -> IO Bool) ->
                         IO (ConnectId w)
onClient = event "client_event" [] False
afterClient = event "client_event" [] True

-- @signal connectToConfigure@ The widget's status has changed.
--
onConfigure, afterConfigure :: WidgetClass w => w -> (Event -> IO Bool) ->
                               IO (ConnectId w)
onConfigure = event "configure_event" []  False
afterConfigure = event "configure_event" []  True

-- @signal connectToDelete@ This signal is emitted when the close icon on the
-- surrounding window is pressed. The default action is to emit the
-- @ref arg destroy@ signal.
--
onDelete, afterDelete :: WidgetClass w => w -> (Event -> IO Bool) ->
                         IO (ConnectId w)
onDelete = event "delete_event" [] False
afterDelete = event "delete_event" [] True

-- @signal connectToDestroyEvent@ The widget will be destroyed.
--
-- * The widget received a destroy event from the window manager.
--
onDestroyEvent, afterDestroyEvent :: WidgetClass w =>
				     w -> (Event -> IO Bool) ->
				     IO (ConnectId w)
onDestroyEvent = event "destroy_event" [] False
afterDestroyEvent = event "destroy_event" [] True

-- @signal connectToDirectionChanged@ The default text direction was changed.
--
onDirectionChanged, afterDirectionChanged :: WidgetClass w => w ->
                                             (Event -> IO Bool) ->
                                             IO (ConnectId w)
onDirectionChanged = event "direction_changed" [] False
afterDirectionChanged = event "direction_changed" [] True

-- @signal connectToEnterNotify@ Mouse cursor entered widget.
--
onEnterNotify, afterEnterNotify :: WidgetClass w => w -> (Event -> IO Bool) ->
                                   IO (ConnectId w)
onEnterNotify = event "enter_notify_event" [EnterNotifyMask] False
afterEnterNotify = event "enter_notify_event" [EnterNotifyMask] True

-- @signal connectToLeaveNotify@ Mouse cursor leaves widget.
--
onLeaveNotify, afterLeaveNotify :: WidgetClass w => w -> (Event -> IO Bool) ->
                                   IO (ConnectId w)
onLeaveNotify = event "leave_notify_event" [LeaveNotifyMask] False
afterLeaveNotify = event "leave_notify_event" [LeaveNotifyMask] True

-- @signal connectToExpose@ Instructs the widget to redraw.
--
onExpose, afterExpose :: WidgetClass w => w -> (Event -> IO Bool) ->
                         IO (ConnectId w)
onExpose = event "expose_event" [] False
afterExpose = event "expose_event" [] True

-- @signal connectToFocusIn@ Widget gains input focus.
--
onFocusIn, afterFocusIn :: WidgetClass w => w -> (Event -> IO Bool) ->
                           IO (ConnectId w)
onFocusIn = event "focus_in_event" [FocusChangeMask] False
afterFocusIn = event "focus_in_event" [FocusChangeMask] True

-- @signal connectToFocusOut@ Widget looses input focus.
--
onFocusOut, afterFocusOut :: WidgetClass w => w -> (Event -> IO Bool) ->
                             IO (ConnectId w)
onFocusOut = event "focus_out_event" [FocusChangeMask] False
afterFocusOut = event "focus_out_event" [FocusChangeMask] True

-- @signal connectToGrabFocus@ The widget is about to receive all events.
--
-- * It is possible to redirect all input events to one widget to force the
--   user to use only this widget. Such a situation is initiated by
--   @ref arg addGrab@.
--
onGrabFocus, afterGrabFocus :: WidgetClass w => w -> (Event -> IO Bool) ->
                               IO (ConnectId w)
onGrabFocus = event "grab_focus" [] False
afterGrabFocus = event "grab_focus" [] True

-- @signal connectToDestroy@ The widget will be destroyed.
--
-- * This is the last signal this widget will receive.
--
onDestroy, afterDestroy :: WidgetClass w => w -> (IO ()) ->
                           IO (ConnectId w)
onDestroy = connect_NONE__NONE "destroy" False
afterDestroy = connect_NONE__NONE "destroy" True

-- @signal connectToHide@ The widget was asked to hide itself.
--
-- * This signal is emitted each time @ref arg widgetHide@ is called. Use
--   @ref method connectToUnmap@ when your application needs to be informed
--   when the widget is actually removed from screen.
--
onHide, afterHide :: WidgetClass w => w -> IO () -> IO (ConnectId w)
onHide = connect_NONE__NONE "hide" False
afterHide = connect_NONE__NONE "hide" True

-- @signal connectToHierarchyChanged@ The toplevel window changed.
--
-- * When a subtree of widgets is removed or added from a tree with a toplevel
--   window this signal is emitted. It is emitted on each widget in the
--   detached or attached subtree.
--
onHierarchyChanged, afterHierarchyChanged :: WidgetClass w => w -> IO () ->
                                             IO (ConnectId w)
onHierarchyChanged = connect_NONE__NONE "hierarchy_changed" False
afterHierarchyChanged = connect_NONE__NONE "hierarchy_changed" True

-- @signal connectToKeyPress@ A key was pressed.
--
onKeyPress, afterKeyPress :: WidgetClass w => w -> (Event -> IO Bool) ->
                             IO (ConnectId w)
onKeyPress = event "key_press_event" [KeyPressMask] False
afterKeyPress = event "key_press_event" [KeyPressMask] True

-- @signal connectToKeyRelease@ A key was released.
--
onKeyRelease, afterKeyRelease :: WidgetClass w => w -> (Event -> IO Bool) ->
                                 IO (ConnectId w)
onKeyRelease = event "key_release_event" [KeyReleaseMask] False
afterKeyRelease = event "key_release_event" [KeyReleaseMask] True

-- @signal connectToMnemonicActivate@
--
onMnemonicActivate, afterMnemonicActivate :: WidgetClass w => w ->
                                             (Bool -> IO Bool) ->
                                             IO (ConnectId w)
onMnemonicActivate = connect_BOOL__BOOL "mnemonic_activate" False
afterMnemonicActivate = connect_BOOL__BOOL "mnemonic_activate" True

-- @signal connectToMotionNotify@ Track mouse movements.
--
-- * If @ref arg hint@ is False, a callback for every movement of the mouse is
--   generated. To avoid a backlog of mouse messages, it is usually sufficient
--   to sent @ref arg hint@ to True, generating only one event. The
--   application now has to state that it is ready for the next message by
--   calling @ref arg gdkWindowGetPointer@.
--
onMotionNotify, afterMotionNotify :: WidgetClass w => w -> Bool ->
                                     (Event -> IO Bool) ->
                                     IO (ConnectId w)
onMotionNotify w hint = event "motion_notify_event"
  (if hint then [PointerMotionHintMask] else [PointerMotionMask]) False w
afterMotionNotify w hint = event "motion_notify_event"
  (if hint then [PointerMotionHintMask] else [PointerMotionMask]) True w

-- @signal connectToParentSet@
--
onParentSet, afterParentSet :: (WidgetClass w, WidgetClass old) => w ->
                               (old -> IO ()) -> IO (ConnectId w)
onParentSet = connect_OBJECT__NONE "parent_set"  False
afterParentSet = connect_OBJECT__NONE "parent_set"  True

-- @signal connectToPopupMenu@
--
onPopupMenu, afterPopupMenu :: WidgetClass w => w -> IO () -> IO (ConnectId w)
onPopupMenu = connect_NONE__NONE "popup_menu" False
afterPopupMenu = connect_NONE__NONE "popup_menu" True

-- @signal connectToProximityIn@ The input device became active.
--
-- * This event indicates that a pen of a graphics tablet or similar device is
--   now touching the tablet.
--
onProximityIn, afterProximityIn :: WidgetClass w => w -> (Event -> IO Bool) ->
                                   IO (ConnectId w)
onProximityIn = event "proximity_in_event" [ProximityInMask] False
afterProximityIn = event "proximity_in_event" [ProximityInMask] True

-- @signal connectToProximityOut@ The input device became inactive.
--
-- * The pen was removed from the graphics tablet's surface.
--
onProximityOut, afterProximityOut :: WidgetClass w => w ->
                                     (Event -> IO Bool) -> IO (ConnectId w)
onProximityOut = event "proximity_out_event" [ProximityOutMask] False
afterProximityOut = event "proximity_out_event" [ProximityOutMask] True

-- @signal connectToScroll@ The mouse wheel has turned.
--
-- * The @ref arg Event@ is always @ref arg Scroll@.
--
onScroll, afterScroll :: WidgetClass w => w -> (Event -> IO Bool) ->
                         IO (ConnectId w)
onScroll = event "scroll_event" [ScrollMask] False
afterScroll = event "scroll_event" [ScrollMask] True

-- @signal connectToShow@ The widget was asked to show itself.
--
-- * This signal is emitted each time @ref arg widgetShow@ is called. Use
--   @ref method connectToMap@ when your application needs to be informed when
--   the widget is actually shown.
--
onShow, afterShow :: WidgetClass w => w -> IO () -> IO (ConnectId w)
onShow = connect_NONE__NONE "show" False
afterShow = connect_NONE__NONE "show" True

-- @signal connectToSizeAllocate@ Inform widget about the size it has.
--
-- * After querying a widget for the size it wants to have (through emitting
--   the @ref arg sizeRequest@ signal) a container will emit this signal to
--   inform the widget about the real size it should occupy.
--
onSizeAllocate, afterSizeAllocate :: WidgetClass w => w ->
                                     (Allocation -> IO ()) -> IO (ConnectId w)
onSizeAllocate = connect_BOXED__NONE "size_allocate" peek False
afterSizeAllocate = connect_BOXED__NONE "size_allocate" peek True

-- @signal connectToSizeRequest@ Query the widget for the size it likes to
-- have.
--
-- * A parent container emits this signal to its child to query the needed
--   height and width of the child. There is not guarantee that the widget
--   will actually get this area.
--
onSizeRequest, afterSizeRequest :: WidgetClass w => w -> (IO Requisition) ->
                                   IO (ConnectId w)
onSizeRequest w fun = connect_PTR__NONE "size_request" False w (\rqPtr -> do
  req <- fun
  unless (rqPtr==nullPtr) $ poke rqPtr req)
afterSizeRequest w fun = connect_PTR__NONE "size_request" True w (\rqPtr -> do
  req <- fun
  unless (rqPtr==nullPtr) $ poke rqPtr req)

-- @signal connectToStateChanged@
--
onStateChanged, afterStateChanged :: WidgetClass w => w ->
                                     (StateType -> IO ()) -> IO (ConnectId w)
onStateChanged = connect_ENUM__NONE "state_changed" False
afterStateChanged = connect_ENUM__NONE "state_changed" True

-- @signal connectToUnmap@ The widget was removed from screen.
--
onUnmap, afterUnmap :: WidgetClass w => w -> IO () -> IO (ConnectId w)
onUnmap = connect_NONE__NONE "unmap" False
afterUnmap = connect_NONE__NONE "unmap" True

-- @signal connectToUnrealize@ This widget's drawing area is about to be
-- destroyed.
--
onUnrealize, afterUnrealize :: WidgetClass w => w -> IO () -> IO (ConnectId w)
onUnrealize = connect_NONE__NONE "unrealize" False
afterUnrealize = connect_NONE__NONE "unrealize" True

-- @signal connectToVisibilityNotify@
--
onVisibilityNotify, afterVisibilityNotify :: WidgetClass w => w ->
                                             (Event -> IO Bool) ->
                                             IO (ConnectId w)
onVisibilityNotify =
  event "visibility_notify_event" [VisibilityNotifyMask] False
afterVisibilityNotify =
  event "visibility_notify_event" [VisibilityNotifyMask] True

-- @signal connectToWindowState@
--
onWindowState, afterWindowState :: WidgetClass w => w -> (Event -> IO Bool) ->
                                   IO (ConnectId w)
onWindowState = event "window_state_event" [] False
afterWindowState = event "window_state_event" [] True

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Widget class@
--
--  Author : Axel Simon
--
--  Created: 27 April 2001
--
--  Version $Revision: 1.3 $ from $Date: 2002/05/24 09:43:24 $
--
--  Copyright (c) 2001 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@ --------------------------------------------------------------
--
--  * Widget is the base class of all widgets. It provides the methods to
--    attach and detach signals.
--
-- @documentation@ ------------------------------------------------------------
--
--  * This modules reexports everything a normal widget needs from GObject
--    and Object.
--
--- TODO ----------------------------------------------------------------------
--
--  * unimplemented methods that seem to be useful in user programs:
--      widgetSizeRequest, widgetAddAccelerator, widgetRemoveAccrelerator,
--	widgetAcceleratorSignal, widgetIntersect, widgetGrabDefault,
--	widgetGetPointer, widgetPath, widgetClassPath, getCompositeName,
--	widgetSetCompositeName,
--	widgetModifyStyle, widgetGetModifierStyle, widgetModifyFg,
--	widgetModifyBG, widgetModifyText, widgetModifyBase, widgetModifyFont,
--	widgetPango*, widgetSetAdjustments
--
--
--  * implement the following methods in GtkWindow object:
--      widget_set_uposition, widget_set_usize
--
--  * implement the following methods in GtkDrawingArea object:
--      widgetQueueDrawArea, widgetSetDoubleBufferd, widgetRegionIntersect
--
module Widget(
  Widget,
  WidgetClass,
  castToWidget,
  Allocation,
  Requisition(..),
  Rectangle(..),
  widgetShow,			-- Showing and hiding a widget.
  widgetShowNow,
  widgetHide,
  widgetShowAll,
  widgetHideAll,
  widgetDestroy,
  widgetQueueDraw,		-- Functions to be used with DrawingArea.
  widgetHasIntersection,
  widgetActivate,		-- Manipulate widget state.
  widgetSetSensitivity,
  widgetIsFocus,
  widgetGrabFocus,
  widgetSetAppPaintable,
  widgetSetName,		-- Naming, Themes
  widgetGetName,
  widgetGetToplevel,		-- Widget browsing.
  widgetIsAncestor,
  widgetReparent,
  TextDirection(..),
  widgetSetDirection,		-- General Setup.
  widgetGetDirection,
--  widgetLockAccelerators,
--  widgetUnlockAccelerators,
  Event(..),
  onButtonPress,
  afterButtonPress,
  onButtonRelease,
  afterButtonRelease,
  onClient,
  afterClient,
  onConfigure,
  afterConfigure,
  onDelete,
  afterDelete,
  onDestroy,
  afterDestroy,
  onDirectionChanged,
  afterDirectionChanged,
  onEnterNotify,
  afterEnterNotify,
  onLeaveNotify,
  afterLeaveNotify,
  onExpose,
  afterExpose,
  onFocusIn,
  afterFocusIn,
  onFocusOut,
  afterFocusOut,
  onGrabFocus,
  afterGrabFocus,
  onHide,
  afterHide,
  onHierarchyChanged,
  afterHierarchyChanged,
  onKeyPress,
  afterKeyPress,
  onKeyRelease,
  afterKeyRelease,
  onMnemonicActivate,
  afterMnemonicActivate,
  onMotionNotify,
  afterMotionNotify,
  onParentSet,
  afterParentSet,
  onPopupMenu,
  afterPopupMenu,
  onProximityIn,
  afterProximityIn,
  onProximityOut,
  afterProximityOut,
  onScroll,
  afterScroll,
  onShow,
  afterShow,
  onSizeAllocate,
  afterSizeAllocate,
  onSizeRequest,
  afterSizeRequest,
  StateType(..),
  onStateChanged,
  afterStateChanged,
  onUnmap,
  afterUnmap,
  onUnrealize,
  afterUnrealize,
  onVisibilityNotify,
  afterVisibilityNotify,
  onWindowState,
  afterWindowState
  ) where

import Monad	(liftM, unless)
import UTFCForeign
import Foreign
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import GdkEnums
import Structs	(Allocation, Rectangle(..), Requisition(..))
import Events	(Event(..), marshalEvent)
import Enums	(StateType(..), TextDirection(..))

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

-- methods

-- @method widgetShow@ Queue a show request.
--
-- * Flags a widget to be displayed. Any widget that isn't shown will not
--   appear on the screen. If you want to show all the widgets in a container,
--   it's easier to call @ref method widgetShowAll@ on the container, instead
--   of individually showing the widgets. Note that you have to show the
--   containers containing a widget, in addition to the widget itself, before
--   it will appear onscreen. When a toplevel container is shown, it is
--   immediately realized and mapped; other shown widgets are realized and
--   mapped when their toplevel container is realized and mapped.
--
widgetShow :: WidgetClass w => w -> IO ()
widgetShow  = {#call widget_show#}.toWidget

-- @method widgetShowNow@ Queue a show event and wait for it to be executed.
--
-- * If the widget is an unmapped toplevel widget (i.e. a @ref arg Window@
--   that has not yet been shown), enter the main loop and wait for the window
--   to actually be mapped. Be careful; because the main loop is running,
--   anything can happen during this function.
--
widgetShowNow :: WidgetClass w => w -> IO ()
widgetShowNow  = {#call widget_show_now#}.toWidget

-- @method widgetHide@ Queue a hide request.
--
-- * Reverses the effects of @ref method widgetShow@, causing the widget to be
--   hidden (make invisible to the user).
--
widgetHide :: WidgetClass w => w -> IO ()
widgetHide  = {#call widget_hide#}.toWidget

-- @method widgetShowAll@ Show this and all child widgets.
--
widgetShowAll :: WidgetClass w => w -> IO ()
widgetShowAll  = {#call widget_show_all#}.toWidget

-- @method widgetHideAll@ Hide this and all child widgets.
--
widgetHideAll :: WidgetClass w => w -> IO ()
widgetHideAll  = {#call widget_hide_all#}.toWidget

-- @method widgetDestroy@ Destroy a widget.
--
-- * The @ref method widgetDestroy@ function is used to shutdown an object,
--   i.e. a widget will be removed from the screen and unrealized. Resources
--   will be freed when all references are released.
--
widgetDestroy :: WidgetClass obj => obj -> IO ()
widgetDestroy  = {#call widget_destroy#}.toWidget

-- Functions to be used with DrawingArea.

-- @method widgetQueueDraw@ Send a redraw request to a widget.
--
widgetQueueDraw :: WidgetClass w => w -> IO ()
widgetQueueDraw  = {#call widget_queue_draw#}.toWidget

-- @method widgetHasIntersection@ Check if the widget intersects with a given
-- area.
--
widgetHasIntersection :: WidgetClass w => w -> Rectangle -> IO Bool
widgetHasIntersection w r =
  liftM toBool $
  withObject r $ \r' ->
  {#call unsafe widget_intersect#} (toWidget w) (castPtr r') (castPtr nullPtr)

-- Manipulate widget state.

-- @method widgetActivate@ Activate the widget (e.g. clicking a button).
--
widgetActivate :: WidgetClass w => w -> IO Bool
widgetActivate w = liftM toBool $ {#call widget_activate#} (toWidget w)

-- @method widgetSetSensitivity@ Set the widgets sensitivity (Grayed or
-- Usable).
--
widgetSetSensitivity :: WidgetClass w => w -> Bool -> IO ()
widgetSetSensitivity w b =
  {#call widget_set_sensitive#} (toWidget w) (fromBool b)

-- @method widgetIsFocus@ Set and query the input focus of a widget.
--
widgetIsFocus :: WidgetClass w => w -> IO Bool
widgetIsFocus w = liftM toBool $
  {#call unsafe widget_is_focus#} (toWidget w)

widgetGrabFocus :: WidgetClass w => w -> IO ()
widgetGrabFocus = {#call widget_grab_focus#}.toWidget

-- @method widgetSetAppPaintable@ Sets some weired flag in the widget.
--
widgetSetAppPaintable :: WidgetClass w => w -> Bool -> IO ()
widgetSetAppPaintable w p =
  {#call widget_set_app_paintable#} (toWidget w) (fromBool p)

-- @method widgetSetName@ Set the name of a widget.
--
widgetSetName :: WidgetClass w => w -> String -> IO ()
widgetSetName w name =
  withCString name ({#call widget_set_name#} (toWidget w))

-- @method widgetGetName@ Get the name of a widget.
--
widgetGetName :: WidgetClass w => w -> IO String
widgetGetName w = {#call unsafe widget_get_name#} (toWidget w) >>=
		  peekCString

-- @method widgetAddEvents@ Enable event signals.
--
widgetAddEvents :: WidgetClass w => w -> [EventMask] -> IO ()
widgetAddEvents w em =
  {#call widget_add_events#} (toWidget w) (fromIntegral $ fromFlags em)

-- @method widgetGetEvents@ Get enabled event signals.
--
widgetGetEvents :: WidgetClass w => w -> IO [EventMask]
widgetGetEvents w = liftM (toFlags.fromIntegral) $
  {#call unsafe widget_get_events#} (toWidget w)

-- @method widgetSetExtensionEvents@ Set extension events.
--
widgetSetExtensionEvents :: WidgetClass w => w -> [ExtensionMode] -> IO ()
widgetSetExtensionEvents w em =
  {#call widget_set_extension_events#} (toWidget w)
    (fromIntegral $ fromFlags em)

-- @method widgetGetExtensionEvents@ Get extension events.
--
widgetGetExtensionEvents :: WidgetClass w => w -> IO [ExtensionMode]
widgetGetExtensionEvents w = liftM (toFlags.fromIntegral) $
  {#call widget_get_extension_events#} (toWidget w)

-- Widget browsing.

-- @method widgetGetToplevel@ Retrieves the topmost widget in this tree.
--
widgetGetToplevel :: WidgetClass w => w -> IO Widget
widgetGetToplevel w = makeNewObject mkWidget $
  {#call unsafe widget_get_toplevel#} (toWidget w)

-- @method widgetIsAncestor@ Return True if the second widget is (possibly
-- indirectly) held by the first.
--
widgetIsAncestor :: (WidgetClass w, WidgetClass anc) => anc -> w -> IO Bool
widgetIsAncestor anc w = liftM toBool $
 {#call unsafe widget_is_ancestor#} (toWidget w) (toWidget anc)

-- @method widgetReparent@ Move a widget to a new parent.
--
widgetReparent :: (WidgetClass w, WidgetClass par) => w -> par -> IO ()
widgetReparent w par =
  {#call widget_reparent#} (toWidget w) (toWidget par)

-- @method widgetSetDirection@ Setting packaging and writing direction.
--
widgetSetDirection :: WidgetClass w => w -> TextDirection -> IO ()
widgetSetDirection w td =
  {#call widget_set_direction#} (toWidget w) ((fromIntegral.fromEnum) td)

-- @method widgetGetDirection@ Retrieve the default direction of text writing.
--
widgetGetDirection :: WidgetClass w => w -> IO TextDirection
widgetGetDirection w = liftM (toEnum.fromIntegral) $
  {#call widget_get_direction#} (toWidget w)

-- Accelerator handling.

-- @dunno@Lock accelerators.
-- *  @literal@
--widgetLockAccelerators :: WidgetClass w => w -> IO ()
--widgetLockAccelerators = {#call unsafe widget_lock_accelerators#}.toWidget

-- @dunno@Unlock accelerators.
-- *  @literal@
--widgetUnlockAccelerators :: WidgetClass w => w -> IO ()
--widgetUnlockAccelerators = {#call widget_unlock_accelerators#}.toWidget

-- signals

-- Because there are so many similar signals (those that take an Event and
-- return a Bool) we will abstract out the skeleton. As some of these events
-- are emitted at a high rate often a bit has to be set to enable emission.
event :: WidgetClass w => SignalName -> [EventMask] ->
  ConnectAfter -> w -> (Event -> IO Bool) -> IO (ConnectId w)
event name eMask after obj fun = do
  id <- connect_BOXED__BOOL name marshalEvent after obj fun
  widgetAddEvents obj eMask
  return id

-- @signal connectToButtonPress@ A Button was pressed.
--
-- * This widget is part of a button which was just pressed. The event passed
--   to the user function is a @ref arg Button@ event.
--
onButtonPress, afterButtonPress :: WidgetClass w => w -> (Event -> IO Bool) ->
                                   IO (ConnectId w)
onButtonPress = event "button_press_event" [ButtonPressMask] False
afterButtonPress = event "button_press_event" [ButtonPressMask] True

-- @signal connectToButtonRelease@ A Butten was released.
--
onButtonRelease, afterButtonRelease :: WidgetClass w => w ->
                                       (Event -> IO Bool) -> IO (ConnectId w)
onButtonRelease = event "button_release_event" [ButtonReleaseMask] False
afterButtonRelease = event "button_release_event" [ButtonReleaseMask] True

-- @signal connectToClient@
--
onClient, afterClient :: WidgetClass w => w -> (Event -> IO Bool) ->
                         IO (ConnectId w)
onClient = event "client_event" [] False
afterClient = event "client_event" [] True

-- @signal connectToConfigure@ The widget's status has changed.
--
onConfigure, afterConfigure :: WidgetClass w => w -> (Event -> IO Bool) ->
                               IO (ConnectId w)
onConfigure = event "configure_event" []  False
afterConfigure = event "configure_event" []  True

-- @signal connectToDelete@ This signal is emitted when the close icon on the
-- surrounding window is pressed. The default action is to emit the
-- @ref arg destroy@ signal.
--
onDelete, afterDelete :: WidgetClass w => w -> (Event -> IO Bool) ->
                         IO (ConnectId w)
onDelete = event "delete_event" [] False
afterDelete = event "delete_event" [] True

-- @signal connectToDestroy@ The widget will be destroyed.
--
-- * This is the last signal this widget will receive.
--
onDestroy, afterDestroy :: WidgetClass w => w -> (Event -> IO Bool) ->
                           IO (ConnectId w)
onDestroy = event "destroy_event" [] False
afterDestroy = event "destroy_event" [] True

-- @signal connectToDirectionChanged@ The default text direction was changed.
--
onDirectionChanged, afterDirectionChanged :: WidgetClass w => w ->
                                             (Event -> IO Bool) ->
                                             IO (ConnectId w)
onDirectionChanged = event "direction_changed" [] False
afterDirectionChanged = event "direction_changed" [] True

-- @signal connectToEnterNotify@ Mouse cursor entered widget.
--
onEnterNotify, afterEnterNotify :: WidgetClass w => w -> (Event -> IO Bool) ->
                                   IO (ConnectId w)
onEnterNotify = event "enter_notify_event" [EnterNotifyMask] False
afterEnterNotify = event "enter_notify_event" [EnterNotifyMask] True

-- @signal connectToLeaveNotify@ Mouse cursor leaves widget.
--
onLeaveNotify, afterLeaveNotify :: WidgetClass w => w -> (Event -> IO Bool) ->
                                   IO (ConnectId w)
onLeaveNotify = event "leave_notify_event" [LeaveNotifyMask] False
afterLeaveNotify = event "leave_notify_event" [LeaveNotifyMask] True

-- @signal connectToExpose@ Instructs the widget to redraw.
--
onExpose, afterExpose :: WidgetClass w => w -> (Event -> IO Bool) ->
                         IO (ConnectId w)
onExpose = event "expose_event" [] False
afterExpose = event "expose_event" [] True

-- @signal connectToFocusIn@ Widget gains input focus.
--
onFocusIn, afterFocusIn :: WidgetClass w => w -> (Event -> IO Bool) ->
                           IO (ConnectId w)
onFocusIn = event "focus_in_event" [FocusChangeMask] False
afterFocusIn = event "focus_in_event" [FocusChangeMask] True

-- @signal connectToFocusOut@ Widget looses input focus.
--
onFocusOut, afterFocusOut :: WidgetClass w => w -> (Event -> IO Bool) ->
                             IO (ConnectId w)
onFocusOut = event "focus_out_event" [FocusChangeMask] False
afterFocusOut = event "focus_out_event" [FocusChangeMask] True

-- @signal connectToGrabFocus@ The widget is about to receive all events.
--
-- * It is possible to redirect all input events to one widget to force the
--   user to use only this widget. Such a situation is initiated by
--   @ref arg addGrab@.
--
onGrabFocus, afterGrabFocus :: WidgetClass w => w -> (Event -> IO Bool) ->
                               IO (ConnectId w)
onGrabFocus = event "grab_focus" [] False
afterGrabFocus = event "grab_focus" [] True

-- @signal connectToHide@ The widget was asked to hide itself.
--
-- * This signal is emitted each time @ref arg widgetHide@ is called. Use
--   @ref method connectToUnmap@ when your application needs to be informed
--   when the widget is actually removed from screen.
--
onHide, afterHide :: WidgetClass w => w -> IO () -> IO (ConnectId w)
onHide = connect_NONE__NONE "hide" False
afterHide = connect_NONE__NONE "hide" True

-- @signal connectToHierarchyChanged@ The toplevel window changed.
--
-- * When a subtree of widgets is removed or added from a tree with a toplevel
--   window this signal is emitted. It is emitted on each widget in the
--   detached or attached subtree.
--
onHierarchyChanged, afterHierarchyChanged :: WidgetClass w => w -> IO () ->
                                             IO (ConnectId w)
onHierarchyChanged = connect_NONE__NONE "hierarchy_changed" False
afterHierarchyChanged = connect_NONE__NONE "hierarchy_changed" True

-- @signal connectToKeyPress@ A key was pressed.
--
onKeyPress, afterKeyPress :: WidgetClass w => w -> (Event -> IO Bool) ->
                             IO (ConnectId w)
onKeyPress = event "key_press_event" [KeyPressMask] False
afterKeyPress = event "key_press_event" [KeyPressMask] True

-- @signal connectToKeyRelease@ A key was released.
--
onKeyRelease, afterKeyRelease :: WidgetClass w => w -> (Event -> IO Bool) ->
                                 IO (ConnectId w)
onKeyRelease = event "key_release_event" [KeyReleaseMask] False
afterKeyRelease = event "key_release_event" [KeyReleaseMask] True

-- @signal connectToMnemonicActivate@
--
onMnemonicActivate, afterMnemonicActivate :: WidgetClass w => w ->
                                             (Bool -> IO Bool) ->
                                             IO (ConnectId w)
onMnemonicActivate = connect_BOOL__BOOL "mnemonic_activate" False
afterMnemonicActivate = connect_BOOL__BOOL "mnemonic_activate" True

-- @signal connectToMotionNotify@ Track mouse movements.
--
-- * If @ref arg hint@ is False, a callback for every movement of the mouse is
--   generated. To avoid a backlog of mouse messages, it is usually sufficient
--   to sent @ref arg hint@ to True, generating only one event. The
--   application now has to state that it is ready for the next message by
--   calling @ref arg gdkWindowGetPointer@.
--
onMotionNotify, afterMotionNotify :: WidgetClass w => w -> Bool ->
                                     (Event -> IO Bool) ->
                                     IO (ConnectId w)
onMotionNotify w hint = event "motion_notify_event"
  (if hint then [PointerMotionHintMask] else [PointerMotionMask]) False w
afterMotionNotify w hint = event "motion_notify_event"
  (if hint then [PointerMotionHintMask] else [PointerMotionMask]) True w

-- @signal connectToParentSet@
--
onParentSet, afterParentSet :: (WidgetClass w, WidgetClass old) => w ->
                               (old -> IO ()) -> IO (ConnectId w)
onParentSet = connect_OBJECT__NONE "parent_set"  False
afterParentSet = connect_OBJECT__NONE "parent_set"  True

-- @signal connectToPopupMenu@
--
onPopupMenu, afterPopupMenu :: WidgetClass w => w -> IO () -> IO (ConnectId w)
onPopupMenu = connect_NONE__NONE "popup_menu" False
afterPopupMenu = connect_NONE__NONE "popup_menu" True

-- @signal connectToProximityIn@ The input device became active.
--
-- * This event indicates that a pen of a graphics tablet or similar device is
--   now touching the tablet.
--
onProximityIn, afterProximityIn :: WidgetClass w => w -> (Event -> IO Bool) ->
                                   IO (ConnectId w)
onProximityIn = event "proximity_in_event" [ProximityInMask] False
afterProximityIn = event "proximity_in_event" [ProximityInMask] True

-- @signal connectToProximityOut@ The input device became inactive.
--
-- * The pen was removed from the graphics tablet's surface.
--
onProximityOut, afterProximityOut :: WidgetClass w => w ->
                                     (Event -> IO Bool) -> IO (ConnectId w)
onProximityOut = event "proximity_out_event" [ProximityOutMask] False
afterProximityOut = event "proximity_out_event" [ProximityOutMask] True

-- @signal connectToScroll@ The mouse wheel has turned.
--
-- * The @ref arg Event@ is always @ref arg Scroll@.
--
onScroll, afterScroll :: WidgetClass w => w -> (Event -> IO Bool) ->
                         IO (ConnectId w)
onScroll = event "scroll_event" [ScrollMask] False
afterScroll = event "scroll_event" [ScrollMask] True

-- @signal connectToShow@ The widget was asked to show itself.
--
-- * This signal is emitted each time @ref arg widgetShow@ is called. Use
--   @ref method connectToMap@ when your application needs to be informed when
--   the widget is actually shown.
--
onShow, afterShow :: WidgetClass w => w -> IO () -> IO (ConnectId w)
onShow = connect_NONE__NONE "show" False
afterShow = connect_NONE__NONE "show" True

-- @signal connectToSizeAllocate@ Inform widget about the size it has.
--
-- * After querying a widget for the size it wants to have (through emitting
--   the @ref arg sizeRequest@ signal) a container will emit this signal to
--   inform the widget about the real size it should occupy.
--
onSizeAllocate, afterSizeAllocate :: WidgetClass w => w ->
                                     (Allocation -> IO ()) -> IO (ConnectId w)
onSizeAllocate = connect_BOXED__NONE "size_allocate" peek False
afterSizeAllocate = connect_BOXED__NONE "size_allocate" peek True

-- @signal connectToSizeRequest@ Query the widget for the size it likes to
-- have.
--
-- * A parent container emits this signal to its child to query the needed
--   height and width of the child. There is not guarantee that the widget
--   will actually get this area.
--
onSizeRequest, afterSizeRequest :: WidgetClass w => w -> (IO Requisition) ->
                                   IO (ConnectId w)
onSizeRequest w fun = connect_PTR__NONE "size_request" False w (\rqPtr -> do
  req <- fun
  unless (rqPtr==nullPtr) $ poke rqPtr req)
afterSizeRequest w fun = connect_PTR__NONE "size_request" True w (\rqPtr -> do
  req <- fun
  unless (rqPtr==nullPtr) $ poke rqPtr req)

-- @signal connectToStateChanged@
--
onStateChanged, afterStateChanged :: WidgetClass w => w ->
                                     (StateType -> IO ()) -> IO (ConnectId w)
onStateChanged = connect_ENUM__NONE "state_changed" False
afterStateChanged = connect_ENUM__NONE "state_changed" True

-- @signal connectToUnmap@ The widget was removed from screen.
--
onUnmap, afterUnmap :: WidgetClass w => w -> IO () -> IO (ConnectId w)
onUnmap = connect_NONE__NONE "unmap" False
afterUnmap = connect_NONE__NONE "unmap" True

-- @signal connectToUnrealize@ This widget's drawing area is about to be
-- destroyed.
--
onUnrealize, afterUnrealize :: WidgetClass w => w -> IO () -> IO (ConnectId w)
onUnrealize = connect_NONE__NONE "unrealize" False
afterUnrealize = connect_NONE__NONE "unrealize" True

-- @signal connectToVisibilityNotify@
--
onVisibilityNotify, afterVisibilityNotify :: WidgetClass w => w ->
                                             (Event -> IO Bool) ->
                                             IO (ConnectId w)
onVisibilityNotify =
  event "visibility_notify_event" [VisibilityNotifyMask] False
afterVisibilityNotify =
  event "visibility_notify_event" [VisibilityNotifyMask] True

-- @signal connectToWindowState@
--
onWindowState, afterWindowState :: WidgetClass w => w -> (Event -> IO Bool) ->
                                   IO (ConnectId w)
onWindowState = event "window_state_event" [] False
afterWindowState = event "window_state_event" [] True