gtk2hs-commit — Mailing list for Darcs commit messages.

[Gtk2hs-commit] gtk2hs/gtk/multiline TextIter.chs.pp,NONE,1.1 TextTag.chs.pp,NONE,1.1 TextIter.chs.cpp,1.1,NONE TextTag.chs.cpp,1.1,NONE

[Axel S. <as...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/gtk/multiline
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2280/gtk/multiline

Added Files:
	TextIter.chs.pp TextTag.chs.pp 
Removed Files:
	TextIter.chs.cpp TextTag.chs.cpp 
Log Message:
Renamed files that need CPP pre-processing to .chs.pp instead of .chs.cpp
since the latter makes automake think we are compiling C++.



--- TextTag.chs.cpp DELETED ---

--- NEW FILE: TextTag.chs.pp ---
-- -*-haskell-*-
-- GIMP Toolkit (GTK) Widget TextTag
--
--  Author : Duncan Coutts
--  Created: 4 August 2004
--
--  Copyright (c) 2004 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 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
--  Library General Public License for more details.
--
-- |
--
-- A tag that can be applied to text in a "TextBuffer".
--
-- TODO
--
-- * accessor functions for TextAttributes

module TextTag(
  TextTag,
  TextTagClass,
  castToTextTag,
  TagName,
  textTagNew,
  textTagSetPriority,
  textTagGetPriority,
  TextAttributes(..),
  textAttributesNew,
  makeNewTextAttributes,  --internal
  ) where

import Monad	(liftM)
import FFI

import GObject	(makeNewGObject)
{#import Hierarchy#}
{#import Signal#}

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

type TagName = String

-- TextTag methods

-- | Creates a 'TextTag'.
--
textTagNew :: TagName -> IO TextTag
textTagNew name =
  withCString name $ \strPtr ->
  makeNewGObject mkTextTag $ {#call unsafe text_tag_new#} strPtr

-- | Get the tag priority.
--
textTagGetPriority :: TextTagClass obj => obj -> IO Int
textTagGetPriority obj = liftM fromIntegral $
  {#call unsafe text_tag_get_priority#} (toTextTag obj)

-- | Sets the priority of a 'TextTag'.
--
-- Valid priorities are start at 0 and go to one less than
-- 'textTagTableGetSize'. Each tag in a table has a unique priority; setting the
-- priority of one tag shifts the priorities of all the other tags in the table
-- to maintain a unique priority for each tag. Higher priority tags \"win\" if
-- two tags both set the same text attribute. When adding a tag to a tag table,
-- it will be assigned the highest priority in the table by default; so normally
-- the precedence of a set of tags is the order in which they were added to the
-- table, or created with 'textBufferCreateTag', which adds the tag to the
-- buffer's table automatically.
--
textTagSetPriority :: TextTagClass obj => obj -> Int -> IO ()
textTagSetPriority obj priority =
  {#call text_tag_set_priority#} (toTextTag obj) (fromIntegral priority)


-- TextAttributes methods

{#pointer * TextAttributes foreign newtype#}

-- | Creates a 'TextAttributes', which describes a set of properties on some
-- text.
--
textAttributesNew :: IO TextAttributes
textAttributesNew =
  {#call unsafe text_attributes_new#} >>= makeNewTextAttributes

makeNewTextAttributes :: Ptr TextAttributes -> IO TextAttributes
makeNewTextAttributes ptr =
  liftM TextAttributes $ newForeignPtr ptr (text_attributes_unref ptr)

#if __GLASGOW_HASKELL__>=600
                                                                                
foreign import ccall unsafe "&gtk_text_attributes_unref"
  text_attributes_unref' :: FinalizerPtr TextAttributes
                                                                                
text_attributes_unref :: Ptr TextAttributes -> FinalizerPtr TextAttributes
text_attributes_unref _ = text_attributes_unref'
                                                                                
#elif __GLASGOW_HASKELL__>=504
                                                                                
foreign import ccall unsafe "gtk_text_attributes_unref"
  text_attributes_unref :: Ptr TextAttributes -> IO ()
                                                                                
#else
                                                                                
foreign import ccall "gtk_text_attributes_unref" unsafe
  text_attributes_unref :: Ptr TextAttributes -> IO ()
                                                                                
#endif

--- TextIter.chs.cpp DELETED ---

--- NEW FILE: TextIter.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) TextIter TextBuffer
--
--  Author : Axel Simon
--          
--  Created: 23 February 2002
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:15 $
--
--  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.
--
-- |
--
-- An iterator is an abstract datatype representing a pointer into a 
-- 'TextBuffer'.
--
-- * The following functions do not make sense due to Haskell's wide character
--   representation of Unicode:
--     gtk_text_iter_get_line_index
--     gtk_text_iter_get_visible_line_index
--     gtk_text_iter_get_bytes_in_line
--     gtk_text_iter_set_line_index
--     gtk_text_iter_set_visible_line_index
--
-- * The functions gtk_text_iter_in_range and gtk_text_iter_order are not bound
--   because they are only convenience functions which can replaced by calls
--   to textIterCompare.
--
-- * All offsets are counted from 0.
--
-- TODO
--
-- * Bind the following function when GSList is bound:
--     gtk_text_iter_get_marks
--     gtk_text_iter_get_toggled_tags
--     gtk_text_iter_get_tags
--
-- * Bind the following functions when we are sure about anchors 
--   (see 'TextBuffer'):
--     gtk_text_iter_get_anchor
--
-- * Bind TextAttribute functions when I am clear how to model them. 
--     gtk_text_iter_get_attribute
--
-- * Forward exceptions in the two callback functions.
--
module TextIter(
  TextIter(TextIter),
  mkTextIter,
  makeEmptyTextIter,	-- for internal use only
  textIterGetBuffer,
  textIterCopy,
  textIterGetOffset,
  textIterGetLine,
  textIterGetLineOffset,
  textIterGetVisibleLineOffset,
  textIterGetChar,
  textIterGetSlice,
  textIterGetText,
  textIterGetVisibleSlice,
  textIterGetVisibleText,
  textIterGetPixbuf,
  textIterBeginsTag,
  textIterEndsTag,
  textIterTogglesTag,
  textIterHasTag,
  textIterEditable,
  textIterCanInsert,
  textIterStartsWord,
  textIterEndsWord,
  textIterInsideWord,
  textIterStartsLine,
  textIterEndsLine,
  textIterStartsSentence,
  textIterEndsSentence,
  textIterInsideSentence,
  textIterIsCursorPosition,
  textIterGetCharsInLine,
  textIterIsEnd,
  textIterIsStart,
  textIterForwardChar,
  textIterBackwardChar,
  textIterForwardChars,
  textIterBackwardChars,
  textIterForwardLine,
  textIterBackwardLine,
  textIterForwardLines,
  textIterBackwardLines,
  textIterForwardWordEnds,
  textIterBackwardWordStarts,
  textIterForwardWordEnd,
  textIterBackwardWordStart,
  textIterForwardCursorPosition,
  textIterBackwardCursorPosition,
  textIterForwardCursorPositions,
  textIterBackwardCursorPositions,
  textIterForwardSentenceEnds,
  textIterBackwardSentenceStarts,
  textIterForwardSentenceEnd,
  textIterBackwardSentenceStart,
  textIterSetOffset,
  textIterSetLine,
  textIterSetLineOffset,
  textIterSetVisibleLineOffset,
  textIterForwardToEnd,
  textIterForwardToLineEnd,
  textIterForwardToTagToggle,
  textIterBackwardToTagToggle,
  textIterForwardFindChar,
  textIterBackwardFindChar,
  textIterForwardSearch,
  textIterBackwardSearch,
  textIterEqual,
  textIterCompare
  ) where

import Monad	(liftM)
import Maybe	(fromMaybe)
import Char	(chr)
import FFI
import GObject	(makeNewGObject)
{#import Hierarchy#}
{#import Signal#}
import Structs  (textIterSize)
import Enums	(TextSearchFlags, Flags(fromFlags))

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

-- methods

{#pointer *TextIter foreign newtype #}

-- Create a TextIter from a pointer.
--
mkTextIter :: Ptr TextIter -> IO TextIter
mkTextIter iterPtr = liftM TextIter $ 
  newForeignPtr iterPtr (text_iter_free iterPtr)

#if __GLASGOW_HASKELL__>=600

foreign import ccall unsafe "&gtk_text_iter_free"
  text_iter_free' :: FinalizerPtr TextIter

text_iter_free :: Ptr TextIter -> FinalizerPtr TextIter
text_iter_free _ = text_iter_free'

#elif __GLASGOW_HASKELL__>=504

foreign import ccall unsafe "gtk_text_iter_free"
  text_iter_free :: Ptr TextIter -> IO ()

#else

foreign import ccall "gtk_text_iter_free" unsafe
  text_iter_free :: Ptr TextIter -> IO ()

#endif

-- Allocate memory to be filled with a TextIter.
--
makeEmptyTextIter :: IO TextIter
makeEmptyTextIter = do
  iterPtr <- mallocBytes textIterSize
  liftM TextIter $ newForeignPtr iterPtr (text_iter_free iterPtr)

-- | Return the 'TextBuffer' this iterator
-- is associated with.
--
textIterGetBuffer :: TextIter -> IO TextBuffer
textIterGetBuffer ti = makeNewGObject mkTextBuffer $
  {#call unsafe text_iter_get_buffer#} ti

-- | Copy the iterator.
--
textIterCopy :: TextIter -> IO TextIter
textIterCopy ti = do
  iterPtr <- {#call unsafe text_iter_copy#} ti
  liftM TextIter $ newForeignPtr iterPtr (text_iter_free iterPtr)

-- | Extract the offset relative to the beginning of
-- the buffer.
--
textIterGetOffset :: TextIter -> IO Int
textIterGetOffset ti = liftM fromIntegral $
  {#call unsafe text_iter_get_offset#} ti

-- | Extract the line of the buffer.
--
textIterGetLine :: TextIter -> IO Int
textIterGetLine ti = liftM fromIntegral $
  {#call unsafe text_iter_get_line#} ti

-- | Extract the offset relative to the beginning
-- of the line.
--
textIterGetLineOffset :: TextIter -> IO Int
textIterGetLineOffset ti = liftM fromIntegral $
  {#call unsafe text_iter_get_line_offset#} ti

-- | Extract the offset relative to the
-- beginning of the line skipping invisible parts of the line.
--
textIterGetVisibleLineOffset :: TextIter -> IO Int
textIterGetVisibleLineOffset ti = liftM fromIntegral $
  {#call unsafe text_iter_get_visible_line_offset#} ti

-- | Return the character at this iterator.
--
textIterGetChar :: TextIter -> IO (Maybe Char)
textIterGetChar ti = do
  (res::Int) <- liftM fromIntegral $ {#call unsafe text_iter_get_char#} ti
  return $ if res==0 then Nothing else Just (chr res)

-- | Return the text in a given range.
--
-- * Pictures (and other objects) are represented by 0xFFFC.
--
textIterGetSlice :: TextIter -> TextIter -> IO String
textIterGetSlice end start = do
  cStr <- {#call text_iter_get_slice#} start end
  str <- peekUTFString cStr
  {#call unsafe g_free#} (castPtr cStr)
  return str

-- | Return the text in a given range.
--
-- * Pictures (and other objects) are stripped form the output.
--
textIterGetText :: TextIter -> TextIter -> IO String
textIterGetText start end = do
  cStr <- {#call text_iter_get_text#} start end
  str <- peekUTFString cStr
  {#call unsafe g_free#} (castPtr cStr)
  return str

-- | Return the visible text in a given range.
--
-- * Pictures (and other objects) are represented by 0xFFFC.
--
textIterGetVisibleSlice :: TextIter -> TextIter -> IO String
textIterGetVisibleSlice start end = do
  cStr <- {#call text_iter_get_visible_slice#} start end
  str <- peekUTFString cStr
  {#call unsafe g_free#} (castPtr cStr)
  return str

-- | Return the visible text in a given range.
--
-- * Pictures (and other objects) are stripped form the output.
--
textIterGetVisibleText :: TextIter -> TextIter -> IO String
textIterGetVisibleText start end = do
  cStr <- {#call text_iter_get_visible_text#} start end
  str <- peekUTFString cStr
  {#call unsafe g_free#} (castPtr cStr)
  return str

-- | Get the 'Pixbuf' under the iterator.
--
textIterGetPixbuf :: TextIter -> IO (Maybe Pixbuf)
textIterGetPixbuf it = do
  pbPtr <- {#call unsafe text_iter_get_pixbuf#} it
  if pbPtr==nullPtr then return Nothing else liftM Just $
    makeNewGObject mkPixbuf (return pbPtr)


-- | Query whether a 'TextIter' is at the
-- start of a 'TextTag'.
--
textIterBeginsTag :: TextIter -> TextTag -> IO Bool
textIterBeginsTag ti tt = liftM toBool $
  {#call unsafe text_iter_begins_tag#} ti tt


-- | Query whether a 'TextIter' is at the end
-- of a 'TextTag'.
--
textIterEndsTag :: TextIter -> TextTag -> IO Bool
textIterEndsTag ti tt = liftM toBool $
  {#call unsafe text_iter_ends_tag#} ti tt

-- | Query if the 'TextIter' is at the
-- beginning or the end of a 'TextTag'.
--
textIterTogglesTag :: TextIter -> TextTag -> IO Bool
textIterTogglesTag ti tt = liftM toBool $
  {#call unsafe text_iter_toggles_tag#} ti tt

-- | Check if 'TextIter' is within a range
-- tagged with tag.
--
textIterHasTag :: TextIter -> TextTag -> IO Bool
textIterHasTag ti tt = liftM toBool $
  {#call unsafe text_iter_has_tag#} ti tt

-- | Check if 'TextIter' is within an
-- editable region.
--
-- * If no tags that affect editability are attached to the current position
--   @def@ will be returned.
--
-- * This function cannot be used to decide whether text can be inserted at
--   'TextIter'. Use the 'textIterCanInsert' function for
--   this purpose.
--
textIterEditable :: TextIter -> Bool -> IO Bool
textIterEditable ti def = liftM toBool $ 
  {#call unsafe text_iter_editable#} ti (fromBool def)

-- | Check if new text can be inserted at
-- 'TextIter'.
--
-- * Use 'textBufferInsertInteractive' if you want to insert text
--   depending on the current editable status.
--
textIterCanInsert :: TextIter -> Bool -> IO Bool
textIterCanInsert ti def = liftM toBool $ 
  {#call unsafe text_iter_can_insert#} ti (fromBool def)

-- | Determine if 'TextIter' begins a new
-- natural-language word.
--
textIterStartsWord :: TextIter -> IO Bool
textIterStartsWord ti = liftM toBool $ {#call unsafe text_iter_starts_word#} ti


-- | Determine if 'TextIter' ends a new
-- natural-language word.
--
textIterEndsWord :: TextIter -> IO Bool
textIterEndsWord ti = liftM toBool $ {#call unsafe text_iter_ends_word#} ti

-- | Determine if 'TextIter' is inside a
-- word.
--
textIterInsideWord :: TextIter -> IO Bool
textIterInsideWord ti = liftM toBool $ {#call unsafe text_iter_inside_word#} ti

-- | Determine if 'TextIter' begins a new
-- line.
--
textIterStartsLine :: TextIter -> IO Bool
textIterStartsLine ti = liftM toBool $ {#call unsafe text_iter_starts_line#} ti

-- | Determine if 'TextIter' point to the
-- beginning of a line delimiter.
--
-- * Returns False if 'TextIter' points to the \n in a \r\n sequence.
--
textIterEndsLine :: TextIter -> IO Bool
textIterEndsLine ti = liftM toBool $ {#call unsafe text_iter_ends_line#} ti

-- | Determine if 'TextIter' starts a
-- sentence.
--
textIterStartsSentence :: TextIter -> IO Bool
textIterStartsSentence ti = liftM toBool $ 
  {#call unsafe text_iter_starts_sentence#} ti

-- | Determine if 'TextIter' ends a
-- sentence.
--
textIterEndsSentence :: TextIter -> IO Bool
textIterEndsSentence ti = liftM toBool $ 
  {#call unsafe text_iter_ends_sentence#} ti

-- | Determine if 'TextIter' is inside
-- a sentence.
--
textIterInsideSentence :: TextIter -> IO Bool
textIterInsideSentence ti = liftM toBool $ 
  {#call unsafe text_iter_inside_sentence#} ti

-- | Determine if 'TextIter' is at a
-- cursor position.
--
textIterIsCursorPosition :: TextIter -> IO Bool
textIterIsCursorPosition ti = liftM toBool $ 
  {#call unsafe text_iter_is_cursor_position#} ti

-- | Return number of characters in this line.
--
-- * The return value includes delimiters.
--
textIterGetCharsInLine :: TextIter -> IO Int
textIterGetCharsInLine ti = liftM fromIntegral $
  {#call unsafe text_iter_get_chars_in_line#} ti

-- | Get the text attributes at the iterator.
--
-- * The @ta@ argument gives the default values if no specific 
--   attributes are set at that specific location.
--
-- * The function returns @Nothing@ if the text at the iterator has 
--   the same attributes.
textIterGetAttributes = undefined

-- | Determine if 'TextIter' is at the end of
-- the buffer.
--
textIterIsEnd :: TextIter -> IO Bool
textIterIsEnd ti = liftM toBool $ 
  {#call unsafe text_iter_is_end#} ti

-- | Determine if 'TextIter' is at the
-- beginning of the buffer.
--
textIterIsStart :: TextIter -> IO Bool
textIterIsStart ti = liftM toBool $ 
  {#call unsafe text_iter_is_start#} ti

-- | Move 'TextIter' forwards.
--
-- * Retuns True if the iterator is pointing to a character.
--
textIterForwardChar :: TextIter -> IO Bool
textIterForwardChar ti = liftM toBool $ 
  {#call unsafe text_iter_forward_char#} ti

-- | Move 'TextIter' backwards.
--
-- * Retuns True if the movement was possible.
--
textIterBackwardChar :: TextIter -> IO Bool
textIterBackwardChar ti = liftM toBool $ 
  {#call unsafe text_iter_backward_char#} ti

-- | Move 'TextIter' forwards by
-- @n@ characters.
--
-- * Retuns True if the iterator is pointing to a new character (and False if
--   the iterator points to a picture or has not moved).
--
textIterForwardChars :: TextIter -> Int -> IO Bool
textIterForwardChars ti n = liftM toBool $ 
  {#call unsafe text_iter_forward_chars#} ti (fromIntegral n)

-- | Move 'TextIter' backwards by
-- @n@ characters.
--
-- * Retuns True if the iterator is pointing to a new character (and False if
--   the iterator points to a picture or has not moved).
--
textIterBackwardChars :: TextIter -> Int -> IO Bool
textIterBackwardChars ti n = liftM toBool $ 
  {#call unsafe text_iter_backward_chars#} ti (fromIntegral n)


-- | Move 'TextIter' forwards.
--
-- * Retuns True if the iterator is pointing to a new line (and False if the
--   iterator points to a picture or has not moved).
--
-- * If 'TextIter' is on the first line, it will be moved to the
--   beginning of the buffer.
--
textIterForwardLine :: TextIter -> IO Bool
textIterForwardLine ti = liftM toBool $ 
  {#call unsafe text_iter_forward_line#} ti

-- | Move 'TextIter' backwards.
--
-- * Retuns True if the iterator is pointing to a new line (and False if the
--   iterator points to a picture or has not moved).
--
-- * If 'TextIter' is on the first line, it will be moved to the end
--   of the buffer.
--
textIterBackwardLine :: TextIter -> IO Bool
textIterBackwardLine ti = liftM toBool $ 
  {#call unsafe text_iter_backward_line#} ti


-- | Move 'TextIter' forwards by
-- @n@ lines.
--
-- * Retuns True if the iterator is pointing to a new line (and False if the
--   iterator points to a picture or has not moved).
--
-- * If 'TextIter' is on the first line, it will be moved to the
--   beginning of the buffer.
--
-- * @n@ can be negative.
--
textIterForwardLines :: TextIter -> Int -> IO Bool
textIterForwardLines ti n = liftM toBool $ 
  {#call unsafe text_iter_forward_lines#} ti (fromIntegral n)

-- | Move 'TextIter' backwards by
-- @n@ lines.
--
-- * Retuns True if the iterator is pointing to a new line (and False if the
--   iterator points to a picture or has not moved).
--
-- * If 'TextIter' is on the first line, it will be moved to the end
--   of the buffer.
--
-- * @n@ can be negative.
--
textIterBackwardLines :: TextIter -> Int -> IO Bool
textIterBackwardLines ti n = liftM toBool $ 
  {#call unsafe text_iter_backward_lines#} ti (fromIntegral n)

-- | Move 'TextIter' forwards by
-- @n@ word ends.
--
-- * Retuns True if the iterator is pointing to a new word end.
--
textIterForwardWordEnds :: TextIter -> Int -> IO Bool
textIterForwardWordEnds ti n = liftM toBool $ 
  {#call unsafe text_iter_forward_word_ends#} ti (fromIntegral n)

-- | Move 'TextIter' backwards by
-- @n@ word beginnings.
--
-- * Retuns True if the iterator is pointing to a new word start.
--
textIterBackwardWordStarts :: TextIter -> Int -> IO Bool
textIterBackwardWordStarts ti n = liftM toBool $ 
  {#call unsafe text_iter_backward_word_starts#} ti (fromIntegral n)

-- | Move 'TextIter' forwards to the
-- next word end.
--
-- * Retuns True if the iterator has moved to a new word end.
--
textIterForwardWordEnd :: TextIter -> IO Bool
textIterForwardWordEnd ti = liftM toBool $ 
  {#call unsafe text_iter_forward_word_end#} ti

-- | Move 'TextIter' backwards to
-- the next word beginning.
--
-- * Retuns True if the iterator has moved to a new word beginning.
--
textIterBackwardWordStart :: TextIter -> IO Bool
textIterBackwardWordStart ti = liftM toBool $ 
  {#call unsafe text_iter_backward_word_start#} ti

-- | Move 'TextIter' forwards to
-- the next cursor position.
--
-- * Some characters are composed of two Unicode codes. This function ensures
--   that 'TextIter' does not point inbetween such double characters.
--
-- * Returns True if 'TextIter' moved and points to a character (not
--   to an object).
--
textIterForwardCursorPosition :: TextIter -> IO Bool
textIterForwardCursorPosition ti = liftM toBool $
  {#call unsafe text_iter_forward_cursor_position#} ti

-- | Move 'TextIter' backwards
-- to the next cursor position.
--
-- * Some characters are composed of two Unicode codes. This function ensures
--   that 'TextIter' does not point inbetween such double characters.
--
-- * Returns True if 'TextIter' moved and points to a character (not
--   to an object).
--
textIterBackwardCursorPosition :: TextIter -> IO Bool
textIterBackwardCursorPosition ti = liftM toBool $
  {#call unsafe text_iter_backward_cursor_position#} ti

-- | Move 'TextIter' forwards
-- by @n@ cursor positions.
--
-- * Returns True if 'TextIter' moved and points to a character (not
--   to an object).
--
textIterForwardCursorPositions :: TextIter -> Int -> IO Bool
textIterForwardCursorPositions ti n = liftM toBool $ 
  {#call unsafe text_iter_forward_cursor_positions#} ti (fromIntegral n)

-- | Move 'TextIter' backwards
-- by @n@ cursor positions.
--
-- * Returns True if 'TextIter' moved and points to a character (not
--   to an object).
--
textIterBackwardCursorPositions :: TextIter -> Int -> IO Bool
textIterBackwardCursorPositions ti n = liftM toBool $ 
  {#call unsafe text_iter_backward_cursor_positions#} ti (fromIntegral n)


-- | Move 'TextIter' forwards by
-- @n@ sentence ends.
--
-- * Retuns True if the iterator is pointing to a new sentence end.
--
textIterForwardSentenceEnds :: TextIter -> Int -> IO Bool
textIterForwardSentenceEnds ti n = liftM toBool $ 
  {#call unsafe text_iter_forward_sentence_ends#} ti (fromIntegral n)

-- | Move 'TextIter' backwards
-- by @n@ sentence beginnings.
--
-- * Retuns True if the iterator is pointing to a new sentence start.
--
textIterBackwardSentenceStarts :: TextIter -> Int -> IO Bool
textIterBackwardSentenceStarts ti n = liftM toBool $ 
  {#call unsafe text_iter_backward_sentence_starts#} ti (fromIntegral n)

-- | Move 'TextIter' forwards to
-- the next sentence end.
--
-- * Retuns True if the iterator has moved to a new sentence end.
--
textIterForwardSentenceEnd :: TextIter -> IO Bool
textIterForwardSentenceEnd ti = liftM toBool $ 
  {#call unsafe text_iter_forward_sentence_end#} ti

-- | Move 'TextIter' backwards
-- to the next sentence beginning.
--
-- * Retuns True if the iterator has moved to a new sentence beginning.
--
textIterBackwardSentenceStart :: TextIter -> IO Bool
textIterBackwardSentenceStart ti = liftM toBool $ 
  {#call unsafe text_iter_backward_sentence_start#} ti

-- | Set 'TextIter' to an offset within the
-- buffer.
--
textIterSetOffset :: TextIter -> Int -> IO ()
textIterSetOffset ti n = 
  {#call unsafe text_iter_set_offset#} ti (fromIntegral n)

-- | Set 'TextIter' to a line within the
-- buffer.
--
textIterSetLine :: TextIter -> Int -> IO ()
textIterSetLine ti n = 
  {#call unsafe text_iter_set_line#} ti (fromIntegral n)

-- | Set 'TextIter' to an offset within
-- the line.
--
textIterSetLineOffset :: TextIter -> Int -> IO ()
textIterSetLineOffset ti n = 
  {#call unsafe text_iter_set_line_offset#} ti (fromIntegral n)

-- | Set 'TextIter' to an visible
-- character within the line.
--
textIterSetVisibleLineOffset :: TextIter -> Int -> IO ()
textIterSetVisibleLineOffset ti n = 
  {#call unsafe text_iter_set_visible_line_offset#} ti (fromIntegral n)

-- | Moves 'TextIter' to the end of the
-- buffer.
--
textIterForwardToEnd :: TextIter -> IO ()
textIterForwardToEnd ti = {#call unsafe text_iter_forward_to_end#} ti

-- | Moves 'TextIter' to the end of
-- the line.
--
-- * Returns True if 'TextIter' moved to a new location which is not
--   the buffer end iterator.
--
textIterForwardToLineEnd :: TextIter -> IO Bool
textIterForwardToLineEnd ti = liftM toBool $
  {#call unsafe text_iter_forward_to_line_end#} ti

-- | Moves 'TextIter' forward to
-- the next change of a 'TextTag'.
--
-- * If Nothing is supplied, any 'TextTag' will be matched.
--
-- * Returns True if there was a tag toggle after 'TextIter'.
--
textIterForwardToTagToggle :: TextIter -> Maybe TextTag -> IO Bool
textIterForwardToTagToggle ti tt = liftM toBool $
  {#call unsafe text_iter_forward_to_tag_toggle#} ti 
    (fromMaybe (mkTextTag nullForeignPtr) tt)

-- | Moves 'TextIter' backward to
-- the next change of a 'TextTag'.
--
-- * If Nothing is supplied, any 'TextTag' will be matched.
--
-- * Returns True if there was a tag toggle before 'TextIter'.
--
textIterBackwardToTagToggle :: TextIter -> Maybe TextTag -> IO Bool
textIterBackwardToTagToggle ti tt = liftM toBool $
  {#call unsafe text_iter_backward_to_tag_toggle#} ti 
    (fromMaybe (mkTextTag nullForeignPtr) tt)

-- Setup a callback for a predicate function.
--
type TextCharPredicateCB = Char -> Bool

{#pointer TextCharPredicate#}

foreign import ccall "wrapper" mkTextCharPredicate ::
  ({#type gunichar#} -> Ptr () -> {#type gboolean#}) -> IO TextCharPredicate

-- | Move 'TextIter' forward until a
-- predicate function returns True.
--
-- * If @pred@ returns True before @limit@ is reached, the
--   search is stopped and the return value is True.
--
-- * If @limit@ is Nothing, the search stops at the end of the buffer.
--
textIterForwardFindChar :: TextIter -> (Char -> Bool) -> Maybe TextIter ->
                           IO Bool
textIterForwardFindChar ti pred limit = do
  fPtr <- mkTextCharPredicate (\c _ -> fromBool $ pred (chr (fromIntegral c)))
  res <- liftM toBool $ {#call text_iter_forward_find_char#} 
    ti fPtr nullPtr (fromMaybe (TextIter nullForeignPtr) limit)
  freeHaskellFunPtr fPtr
  return res

-- | Move 'TextIter' backward until a
-- predicate function returns True.
--
-- * If @pred@ returns True before @limit@ is reached, the
--   search is stopped and the return value is True.
--
-- * If @limit@ is Nothing, the search stops at the end of the buffer.
--
textIterBackwardFindChar :: TextIter -> (Char -> Bool) -> Maybe TextIter ->
                            IO Bool
textIterBackwardFindChar ti pred limit = do
  fPtr <- mkTextCharPredicate (\c _ -> fromBool $ pred (chr (fromIntegral c)))
  res <- liftM toBool $ {#call text_iter_backward_find_char#} 
    ti fPtr nullPtr (fromMaybe (TextIter nullForeignPtr) limit)
  freeHaskellFunPtr fPtr
  return res

-- | Search forward for a specific string.
--
-- * If specified, the last character which is tested against that start of
--   the search pattern will be @limit@.
--
-- * 'TextSearchFlags' may be empty.
--
-- * Returns the start and end position of the string found.
--
textIterForwardSearch :: TextIter -> String -> [TextSearchFlags] ->
                         Maybe TextIter -> IO (Maybe (TextIter, TextIter))
textIterForwardSearch ti str flags limit = do
  start  <- makeEmptyTextIter
  end <- makeEmptyTextIter
  found <- liftM toBool $ withUTFString str $ \cStr ->
    {#call unsafe text_iter_forward_search#} ti cStr 
    ((fromIntegral.fromFlags) flags) start end 
    (fromMaybe (TextIter nullForeignPtr) limit)
  return $ if found then Just (start,end) else Nothing

-- | Search backward for a specific string.
--
-- * If specified, the last character which is tested against that start of
--   the search pattern will be @limit@.
--
-- * 'TextSearchFlags' my be empty.
--
-- * Returns the start and end position of the string found.
--
textIterBackwardSearch :: TextIter -> String -> [TextSearchFlags] ->
                          Maybe TextIter -> IO (Maybe (TextIter, TextIter))
textIterBackwardSearch ti str flags limit = do
  start  <- makeEmptyTextIter
  end <- makeEmptyTextIter
  found <- liftM toBool $ withUTFString str $ \cStr ->
    {#call unsafe text_iter_backward_search#} ti cStr 
    ((fromIntegral.fromFlags) flags) start end 
    (fromMaybe (TextIter nullForeignPtr) limit)
  return $ if found then Just (start,end) else Nothing

-- | Compare two 'TextIter' for equality.
--
-- * 'TextIter' could be in class Eq and Ord if there is a guarantee
--   that each iterator is copied before it is modified in place. This is done
--   the next abstraction layer.
--
textIterEqual :: TextIter -> TextIter -> IO Bool
textIterEqual ti2 ti1 = liftM toBool $ {#call unsafe text_iter_equal#} ti1 ti2

-- | Compare two 'TextIter'.
--
-- * 'TextIter' could be in class Eq and Ord if there is a guarantee
--   that each iterator is copied before it is modified in place. This could
--   be done the next abstraction layer.
--
textIterCompare :: TextIter -> TextIter -> IO Ordering
textIterCompare ti2 ti1 = do
  res <- {#call unsafe text_iter_compare#} ti1 ti2
  return $ case res of
    (-1)   -> LT
    0	   -> EQ
    1	   -> GT

[Gtk2hs-commit] gtk2hs/gtk/misc Calendar.chs.pp,NONE,1.1 EventBox.chs.pp,NONE,1.1 FileChooserWidget.chs.pp,NONE,1.1 Tooltips.chs.pp,NONE,1.1 Calendar.chs.cpp,1.1,NONE EventBox.chs.cpp,1.1,NONE FileChooserWidget.chs.cpp,1.1,NONE Tooltips.chs.cpp,1.1,NONE

[Axel S. <as...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/gtk/misc
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2280/gtk/misc

Added Files:
	Calendar.chs.pp EventBox.chs.pp FileChooserWidget.chs.pp 
	Tooltips.chs.pp 
Removed Files:
	Calendar.chs.cpp EventBox.chs.cpp FileChooserWidget.chs.cpp 
	Tooltips.chs.cpp 
Log Message:
Renamed files that need CPP pre-processing to .chs.pp instead of .chs.cpp
since the latter makes automake think we are compiling C++.



--- EventBox.chs.cpp DELETED ---

--- Calendar.chs.cpp DELETED ---

--- Tooltips.chs.cpp DELETED ---

--- NEW FILE: EventBox.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget EventBox
--
--  Author : Axel Simon
--          
--  Created: 23 May 2001
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:15 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
-- |
--
-- This container can be used to receive 'Event's for a widget
-- that has no window on its own.
--
-- TODO
--
-- * check: Is this widget useful?
--
module EventBox(
  EventBox,
  EventBoxClass,
  castToEventBox,
  eventBoxNew
#if GTK_CHECK_VERSION(2,4,0)
 ,eventBoxSetVisibleWindow,
  eventBoxGetVisibleWindow,
  eventBoxSetAboveChild,
  eventBoxGetAboveChild
#endif
  ) where

import Monad	(liftM)
import FFI

import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}

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

-- methods

-- | Create a new 'EventBox'.
--
eventBoxNew :: IO EventBox
eventBoxNew  = makeNewObject mkEventBox $ 
  liftM castPtr {#call unsafe event_box_new#}

#if GTK_CHECK_VERSION(2,4,0)
-- | Set whether the event box uses a visible or invisible child window. The
-- default is to use visible windows. The C documentation for details of what
-- difference this makes.
--
eventBoxSetVisibleWindow :: EventBox -> Bool -> IO ()
eventBoxSetVisibleWindow ebox visible =
  {#call event_box_set_visible_window#} ebox (fromBool visible)

-- | Returns whether the event box has a visible window.
--
eventBoxGetVisibleWindow :: EventBox -> IO Bool
eventBoxGetVisibleWindow ebox =
  liftM toBool $ {#call unsafe event_box_get_visible_window#} ebox

-- | Set whether the event box window is positioned above the windows of its
-- child, as opposed to below it. 
--
-- * If the window is above, all events inside the event box will go to the
-- event box. If the window is below, events in windows of child widgets will
-- first got to that widget, and then to its parents.
--
eventBoxSetAboveChild :: EventBox -> Bool -> IO ()
eventBoxSetAboveChild ebox above =
  {#call event_box_set_above_child#} ebox (fromBool above)

-- | Returns whether the event box window is above or below the windows of its
-- child. See 'eventBoxSetAboveChild' for details.
--
eventBoxGetAboveChild :: EventBox -> IO Bool
eventBoxGetAboveChild ebox =
  liftM toBool $ {#call unsafe event_box_get_above_child#} ebox
#endif

--- FileChooserWidget.chs.cpp DELETED ---

--- NEW FILE: Calendar.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget Calendar
--
--  Author : Axel Simon
--          
--  Created: 23 May 2001
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:15 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
-- |
--
-- This widget shows a calendar.
--
module Calendar(
  Calendar,
  CalendarClass,
  castToCalendar,
  calendarNew,
  calendarSelectMonth,
  calendarSelectDay,
  calendarMarkDay,
  calendarUnmarkDay,
  calendarClearMarks,
  calendarDisplayOptions,
#if GTK_CHECK_VERSION(2,4,0)
  calendarSetDisplayOptions,
  calendarGetDisplayOptions,
#endif
  calendarGetDate,
  onDaySelected,
  afterDaySelected,
  onDaySelectedDoubleClick,
  afterDaySelectedDoubleClick,
  onMonthChanged,
  afterMonthChanged,
  onNextMonth,
  afterNextMonth,
  onNextYear,
  afterNextYear,
  onPrevMonth,
  afterPrevMonth,
  onPrevYear,
  afterPrevYear
  ) where

import Monad	(liftM)
import FFI

import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Enums	(CalendarDisplayOptions(..), fromFlags, toFlags)

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

-- methods

-- | Create a new calendar widget.
--
-- * No sensible date will be set.
--
calendarNew :: IO Calendar
calendarNew  = makeNewObject mkCalendar $ 
  liftM castPtr {#call unsafe calendar_new#}

-- | Flip the page to a month , 0 is January,.., 11
-- is December.
--
-- * Returns True if the operation succeeded.
--
calendarSelectMonth :: CalendarClass c => c -> Int -> Int -> IO Bool
calendarSelectMonth cal month year = liftM toBool $
  {#call calendar_select_month#} (toCalendar cal) (fromIntegral month)
  (fromIntegral year)

-- | Shift to a day, counted form 1 to 31 (depending
-- on the month of course).
--
calendarSelectDay :: CalendarClass c => c -> Int -> IO ()
calendarSelectDay cal day = 
  {#call calendar_select_day#} (toCalendar cal) (fromIntegral day)

-- | Mark (select) a day in the current month.
--
-- * Returns True if the argument was within bounds and the day was previously
--   deselected.
--
calendarMarkDay :: CalendarClass c => c -> Int -> IO Bool
calendarMarkDay cal day = liftM toBool $
  {#call calendar_mark_day#} (toCalendar cal) (fromIntegral day)

-- | Unmark (deselect) a day in the current month.
--
-- * Returns True if the argument was within bounds and the day was previously
--   selected.
--
calendarUnmarkDay :: CalendarClass c => c -> Int -> IO Bool
calendarUnmarkDay cal day = liftM toBool $
  {#call calendar_unmark_day#} (toCalendar cal) (fromIntegral day)

-- | Unmark every day in the current page.
--
calendarClearMarks :: CalendarClass c => c -> IO ()
calendarClearMarks cal = {#call calendar_clear_marks#} (toCalendar cal)

#if GTK_CHECK_VERSION(2,4,0)
-- | Specifies how the calendar should be displayed.
--
calendarSetDisplayOptions :: CalendarClass c => c
                          -> [CalendarDisplayOptions] -> IO ()
calendarSetDisplayOptions cal opts =
  {#call calendar_set_display_options#} (toCalendar cal)
    ((fromIntegral.fromFlags) opts)

-- | Returns the current display options for the calendar.
--
calendarGetDisplayOptions :: CalendarClass c => c
                          -> IO [CalendarDisplayOptions]
calendarGetDisplayOptions cal = liftM (toFlags.fromIntegral) $
  {#call calendar_get_display_options#} (toCalendar cal)

-- | Depreciaded, use 'calendarSetDisplayOptions'.
--
calendarDisplayOptions :: CalendarClass c => c
                       -> [CalendarDisplayOptions] -> IO ()
calendarDisplayOptions = calendarSetDisplayOptions
#else

-- | Specifies how the calendar should be displayed.
--
calendarDisplayOptions :: CalendarClass c => c -> [CalendarDisplayOptions] ->
                          IO ()
calendarDisplayOptions cal opts = {#call calendar_display_options#}
  (toCalendar cal) ((fromIntegral.fromFlags) opts)
#endif

-- | Retrieve the currently selected date.
--
-- * Returns (year, month, day) of the selection.
--
calendarGetDate :: CalendarClass c => c -> IO (Int,Int,Int)
calendarGetDate cal = alloca $ \yearPtr -> alloca $ \monthPtr -> 
  alloca $ \dayPtr -> do
    {#call unsafe calendar_get_date#} (toCalendar cal) yearPtr monthPtr dayPtr
    year  <- liftM fromIntegral $ peek yearPtr
    month <- liftM fromIntegral $ peek monthPtr
    day	  <- liftM fromIntegral	$ peek dayPtr
    return (year,month,day)

-- | Freeze the calender for several update operations.
--
calendarFreeze :: CalendarClass c => c -> IO a -> IO a
calendarFreeze cal update = do
  {#call unsafe calendar_freeze#} (toCalendar cal)
  res <- update
  {#call calendar_thaw#} (toCalendar cal)
  return res

-- signals

-- | Emitted when a day was selected.
--
onDaySelected, afterDaySelected :: CalendarClass c => c -> IO () ->
                                   IO (ConnectId c)
onDaySelected = connect_NONE__NONE "day-selected" False
afterDaySelected = connect_NONE__NONE "day-selected" True

-- | Emitted when a day received a
-- double click.
--
onDaySelectedDoubleClick, afterDaySelectedDoubleClick :: CalendarClass c => 
                                                         c -> IO () ->
                                                         IO (ConnectId c)
onDaySelectedDoubleClick = 
  connect_NONE__NONE "day-selected-double-click" False
afterDaySelectedDoubleClick = 
  connect_NONE__NONE "day-selected-double-click" True

-- | The month changed.
--
onMonthChanged, afterMonthChanged :: CalendarClass c => c -> IO () ->
                                     IO (ConnectId c)
onMonthChanged = connect_NONE__NONE "month-changed" False
afterMonthChanged = connect_NONE__NONE "month-changed" True

-- | The next month was selected.
--
onNextMonth, afterNextMonth :: CalendarClass c => c -> IO () ->
                               IO (ConnectId c)
onNextMonth = connect_NONE__NONE "next-month" False
afterNextMonth = connect_NONE__NONE "next-month" True

-- | The next year was selected.
--
onNextYear, afterNextYear :: CalendarClass c => c -> IO () -> IO (ConnectId c)
onNextYear = connect_NONE__NONE "next-year" False
afterNextYear = connect_NONE__NONE "next-year" True

-- | The previous month was selected.
--
onPrevMonth, afterPrevMonth :: CalendarClass c => c -> IO () ->
                               IO (ConnectId c)
onPrevMonth = connect_NONE__NONE "prev-month" False
afterPrevMonth = connect_NONE__NONE "prev-month" True

-- | The previous year was selected.
--
onPrevYear, afterPrevYear :: CalendarClass c => c -> IO () -> IO (ConnectId c)
onPrevYear = connect_NONE__NONE "prev-year" False
afterPrevYear = connect_NONE__NONE "prev-year" True

  

--- NEW FILE: Tooltips.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget Tooltips
--
--  Author : Axel Simon
--          
--  Created: 23 May 2001
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:15 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
-- |
--
-- Tooltips are the messages that appear next to a widget when the mouse
-- pointer is held over it for a short amount of time. They are especially
-- helpful for adding more verbose descriptions of things such as buttons
-- in a toolbar. 
--
-- An individual tooltip belongs to a group of tooltips. A group is created
-- with a call to 'tooltipsNew'. Every tooltip in the group can 
-- then be turned off with a call to 'tooltipsDisable' and enabled with 
-- 'tooltipsEnable'.
--
#ifndef DISABLE_DEPRECATED
-- The length of time the user must keep the mouse over a widget before the tip
-- is shown, can be altered with 'tooltipsSetDelay'. This is set on a 'per group
-- of tooltips' basis.
--
#endif
-- To assign a tip to a particular widget, 'tooltipsSetTip' is used.
--
-- To associate 'Tooltips' to a widget it is has to have its own 'DrawWindow'.
-- Otherwise the widget must be set into an 'EventBox'.
--
module Tooltips(
  Tooltips,
  TooltipsClass,
  castToTooltips,
  tooltipsNew,
  tooltipsEnable,
  tooltipsDisable,
#ifndef DISABLE_DEPRECATED
  tooltipsSetDelay,
#endif
  tooltipsSetTip,
  tooltipsDataGet
  ) where

import Monad	(liftM)
import FFI

import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}

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

-- methods

-- | Create a new goup of 'Tooltips'.
--
tooltipsNew :: IO Tooltips
tooltipsNew  = makeNewObject mkTooltips $ 
  liftM castPtr {#call unsafe tooltips_new#}

-- | Display the help the 'Tooltips' group
-- provides.
--
tooltipsEnable :: TooltipsClass t => t -> IO ()
tooltipsEnable t = {#call unsafe tooltips_enable#} (toTooltips t)

-- | Disable 'Tooltips' group.
--
-- * Causes all tooltips in tooltips to become inactive. Any widgets that have
--   tips associated with that group will no longer display their tips until
--   they are enabled again with 'tooltipsEnable'.
--
tooltipsDisable :: TooltipsClass t => t -> IO ()
tooltipsDisable t = {#call unsafe tooltips_disable#} (toTooltips t)

#ifndef DISABLE_DEPRECATED
-- | Sets the time between the user moving the mouse
-- over a widget and the widget's tooltip appearing.
--
-- * The @time@ parameter is in ms.
--
tooltipsSetDelay :: TooltipsClass t => t -> Int -> IO ()
tooltipsSetDelay t time = {#call unsafe tooltips_set_delay#}
  (toTooltips t) (fromIntegral time)
#endif

-- | Adds a tooltip containing the message tipText to
-- the specified GtkWidget.
--
-- * The @tipPrivate@ parameter is meant to give a thorough
--   explaination. This might someday be accessible to a questionmark cursor
--   (like MS Windows).
--
tooltipsSetTip :: (TooltipsClass t, WidgetClass w) => t -> w -> String ->
                  String -> IO ()
tooltipsSetTip t w tipText tipPrivate = 
  withUTFString tipPrivate $ \priPtr ->
  withUTFString tipText $ \txtPtr ->
  {#call unsafe tooltips_set_tip#} (toTooltips t) (toWidget w) txtPtr priPtr

{#pointer * TooltipsData#}

-- | Retrieves any 'Tooltips' previously associated with the given widget.
--
tooltipsDataGet :: WidgetClass w => w -> IO (Maybe (Tooltips, String, String))
tooltipsDataGet w = do
  tipDataPtr <- {#call unsafe tooltips_data_get#} (toWidget w)
  if tipDataPtr == nullPtr
    then return Nothing
    else do --next line is a hack, tooltips struct member is at offset 0
	   tooltips <- makeNewObject mkTooltips (return $ castPtr tipDataPtr)
           tipText  <- {#get TooltipsData->tip_text#} tipDataPtr
                   >>= peekUTFString
           tipPrivate <- {#get TooltipsData->tip_private#} tipDataPtr
                     >>= peekUTFString
           return $ Just $ (tooltips, tipText, tipPrivate)


--- NEW FILE: FileChooserWidget.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) entry Widget FileChooserWidget
--
--  Author : Duncan Coutts
--  Created: 24 April 2004
--
--  Copyright (c) 2004 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 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
--  Library General Public License for more details.
--
-- |
--
--  The file chooser dialog and widget is a replacement
--  for the old "FileSel"ection dialog. It provides a better user
--  interface and an improved API.
--
-- * This is the widget variant of the "FileChooser"
--
-- * Added in GTK+ 2.4
--
module FileChooserWidget (
#if GTK_CHECK_VERSION(2,4,0)
  FileChooserWidgetClass,
  FileChooserWidget,
  FileChooserAction,
  fileChooserWidgetNew,
  fileChooserWidgetNewWithBackend,
#endif
) where

#if GTK_CHECK_VERSION(2,4,0)

import Monad (liftM)
import FFI
import Object
{#import Hierarchy#}
{#import FileChooser#} (FileChooserAction)

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

-- The FileChooserWidget implements the FileChooser interface
-- which we model in Haskell as another instance decleration
instance FileChooserClass FileChooserWidget

fileChooserWidgetNew ::  FileChooserAction -> IO FileChooserWidget
fileChooserWidgetNew action =
  makeNewObject mkFileChooserWidget $ liftM castPtr $
  {# call unsafe gtk_file_chooser_widget_new #}
    (fromIntegral $ fromEnum action)

fileChooserWidgetNewWithBackend ::  FileChooserAction -> String -> IO FileChooserWidget
fileChooserWidgetNewWithBackend action backend =
  makeNewObject mkFileChooserWidget $ liftM castPtr $
  withCString backend $ \strPtr ->
  {# call unsafe gtk_file_chooser_widget_new_with_backend #}
    (fromIntegral $ fromEnum action) strPtr

#endif

[Gtk2hs-commit] gtk2hs/gtk/layout Alignment.chs.pp,NONE,1.1 Expander.chs.pp,NONE,1.1 Notebook.chs.pp,NONE,1.1 Alignment.chs.cpp,1.1,NONE Expander.chs.cpp,1.1,NONE Notebook.chs.cpp,1.1,NONE

[Axel S. <as...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/gtk/layout
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2280/gtk/layout

Added Files:
	Alignment.chs.pp Expander.chs.pp Notebook.chs.pp 
Removed Files:
	Alignment.chs.cpp Expander.chs.cpp Notebook.chs.cpp 
Log Message:
Renamed files that need CPP pre-processing to .chs.pp instead of .chs.cpp
since the latter makes automake think we are compiling C++.



--- Notebook.chs.cpp DELETED ---

--- NEW FILE: Notebook.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget Notebook
--
--  Author : Axel Simon
--          
--  Created: 15 May 2001
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:15 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
-- |
--
-- This widget can display several pages of widgets. Each page can be selected
-- by a tab at the top of the widget. It is useful in dialogs where a lot of
-- information has to be displayed.
--
-- TODO
--
-- * The signals focus-tab and select-page are not bound because it is unclear
--   what they mean. As far as I can see they are not emitted anywhere.
--
module Notebook(
  Notebook,
  NotebookClass,
  castToNotebook,
  notebookNew,
  notebookAppendPage,
  notebookAppendPageMenu,
  notebookPrependPage,
  notebookPrependPageMenu,
  notebookInsertPage,
  notebookInsertPageMenu,
  notebookRemovePage,
  notebookPageNum,
  notebookSetCurrentPage,
  notebookNextPage,
  notebookPrevPage,
  notebookReorderChild,
  PositionType(..),
  notebookSetTabPos,
  notebookGetTabPos,
  notebookSetShowTabs,
  notebookGetShowTabs,
  notebookSetShowBorder,
  notebookSetScrollable,
  notebookGetScrollable,
#ifndef DISABLE_DEPRECATED
  notebookSetTabBorder,
  notebookSetTabHBorder,
  notebookSetTabVBorder,
#endif
  notebookSetPopup,
  notebookGetCurrentPage,
  notebookSetMenuLabel,
  notebookGetMenuLabel,
  notebookSetMenuLabelText,
  notebookGetMenuLabelText,
  notebookGetNthPage,
#if GTK_CHECK_VERSION(2,2,0)
  notebookGetNPages,
#endif
  notebookGetTabLabel,
  notebookGetTabLabelText,
  Packing(..), PackType(..),
  notebookQueryTabLabelPacking,
  notebookSetTabLabelPacking,
#ifndef DISABLE_DEPRECATED
  notebookSetHomogeneousTabs,
#endif
  notebookSetTabLabel,
  notebookSetTabLabelText,
  onSwitchPage,
  afterSwitchPage
  ) where

import Monad	(liftM)
import Maybe	(maybe)
import FFI

import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Label	(labelNew)
import Enums	(Packing(..), PackType(..), PositionType(..))

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

-- methods

-- | Create a new notebook.
--
notebookNew :: IO Notebook
notebookNew  = makeNewObject mkNotebook $ 
  liftM castPtr {#call unsafe notebook_new#}

#if GTK_CHECK_VERSION(2,4,0)
-- | Insert a new tab to the right of the existing tabs.
--
-- * The given label will be used for the label widget of the new tab. In case
-- the context menu is enabled, this name will also appear in the popup menu. If
-- you want to specify something else to go in the tab, use
-- 'notebookAppendPageMenu'.
--
-- * Returns index (starting from 0) of the appended page in the notebook, or -1
-- if the function fails.
--
-- * This function returned @()@ in Gtk version 2.2.X and earlier
--
notebookAppendPage :: (NotebookClass nb, WidgetClass child) => nb
                   -> child   -- ^ Widget to use as the contents of the page
                   -> String  -- ^ Label for the page.
                   -> IO Int
notebookAppendPage nb child tabLabel = do
  tab <- labelNew (Just tabLabel)
  liftM fromIntegral $
    {#call notebook_append_page#} (toNotebook nb) (toWidget child) 
      (toWidget tab)

#else
-- | Insert a new tab to the right of the existing tabs.
--
-- * The given label will be used for the label widget of the new tab. In case
-- the context popup menu is enabled, this name will also appear in the menu. If
-- you want to specify something else to go in the tab, use
-- 'notebookAppendPageMenu'.
--
-- * This function returns @Int@ in Gtk version 2.4.0 and later.
--
notebookAppendPage :: (NotebookClass nb, WidgetClass child) => nb
                   -> child   -- ^ Widget to use as the contents of the page
                   -> String  -- ^ Label for the page.
                   -> IO ()
notebookAppendPage nb child tabLabel = do
  tab <- labelNew (Just tabLabel)
  {#call notebook_append_page#} (toNotebook nb) (toWidget child) (toWidget tab)
#endif

#if GTK_CHECK_VERSION(2,4,0)
-- | Insert a new tab to the right of the existing tabs.
--
-- Like 'notebookAppendPage' but allows any widget to be used for the label of
-- the new tab and then entry in the page-switch popup menu.
--
-- * Returns the index (starting from 0) of the appended page in the notebook,
-- or -1 if the function fails.
--
-- * This function returned @()@ in Gtk version 2.2.X and earlier
--
notebookAppendPageMenu :: (NotebookClass nb, WidgetClass child,
   WidgetClass tab, WidgetClass menu) => nb
  -> child  -- ^ Widget to use as the contents of the page
  -> tab    -- ^ Tab label widget for the page.
  -> menu   -- ^ Menu entry for this tab (usually a 'Label' widget).
  -> IO Int
notebookAppendPageMenu nb child tabWidget menuWidget = liftM fromIntegral $
  {#call notebook_append_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menuWidget)

#else
-- | Insert a new tab to the right of the existing tabs.
--
-- Like 'notebookAppendPage' but allows any widget to be used for the label of
-- the new tab and then entry in the page-switch popup menu.
--
-- * This function returns @Int@ in Gtk version 2.4.0 and later
--
notebookAppendPageMenu :: (NotebookClass nb, WidgetClass child,
   WidgetClass tab, WidgetClass menu) => nb
  -> child  -- ^ Widget to use as the contents of the page
  -> tab    -- ^ Tab label widget for the page.
  -> menu   -- ^ Menu entry for this tab (usually a 'Label' widget).
  -> IO ()
notebookAppendPageMenu nb child tabWidget menuWidget =
  {#call notebook_append_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menuWidget)
#endif

#if GTK_CHECK_VERSION(2,4,0)
-- | Insert a new tab to the left of the existing tabs.
--
-- * The given label will be used for the label widget of the new tab. In case
-- the context menu is enabled, this name will also appear in the popup menu. If
-- you want to specify something else to go in the tab, use
-- 'notebookPrependPageMenu'.
--
-- * Returns index (starting from 0) of the prepended page in the notebook, or -1
-- if the function fails.
--
-- * This function returned @()@ in Gtk version 2.2.X and earlier
--
notebookPrependPage :: (NotebookClass nb, WidgetClass child) => nb
                   -> child   -- ^ Widget to use as the contents of the page
                   -> String  -- ^ Label for the page.
                   -> IO Int
notebookPrependPage nb child tabLabel = do
  tab <- labelNew (Just tabLabel)
  liftM fromIntegral $
    {#call notebook_prepend_page#} (toNotebook nb) (toWidget child) 
      (toWidget tab)

#else
-- | Insert a new tab to the left of the existing tabs.
--
-- * The given label will be used for the label widget of the new tab. In case
-- the context popup menu is enabled, this name will also appear in the menu. If
-- you want to specify something else to go in the tab, use
-- 'notebookPrependPageMenu'.
--
-- * This function returns @Int@ in Gtk version 2.4.0 and later.
--
notebookPrependPage :: (NotebookClass nb, WidgetClass child) => nb
                   -> child   -- ^ Widget to use as the contents of the page
                   -> String  -- ^ Label for the page.
                   -> IO ()
notebookPrependPage nb child tabLabel = do
  tab <- labelNew (Just tabLabel)
  {#call notebook_prepend_page#} (toNotebook nb) (toWidget child) 
    (toWidget tab)
#endif

#if GTK_CHECK_VERSION(2,4,0)
-- | Insert a new tab to the left of the existing tabs.
--
-- Like 'notebookPrependPage' but allows any widget to be used for the label of
-- the new tab and then entry in the page-switch popup menu.
--
-- * Returns the index (starting from 0) of the prepended page in the notebook,
-- or -1 if the function fails.
--
-- * This function returned @()@ in Gtk version 2.2.X and earlier
--
notebookPrependPageMenu :: (NotebookClass nb, WidgetClass child,
   WidgetClass tab, WidgetClass menu) => nb
  -> child  -- ^ Widget to use as the contents of the page
  -> tab    -- ^ Tab label widget for the page.
  -> menu   -- ^ Menu entry for this tab (usually a 'Label' widget).
  -> IO Int
notebookPrependPageMenu nb child tabWidget menuWidget = liftM fromIntegral $
  {#call notebook_prepend_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menuWidget)

#else
-- | Insert a new tab to the left of the existing tabs.
--
-- Like 'notebookPrependPage' but allows any widget to be used for the label of
-- the new tab and then entry in the page-switch popup menu.
--
-- * This function returns @Int@ in Gtk version 2.4.0 and later
--
notebookPrependPageMenu :: (NotebookClass nb, WidgetClass child,
   WidgetClass tab, WidgetClass menu) => nb
  -> child  -- ^ Widget to use as the contents of the page
  -> tab    -- ^ Tab label widget for the page.
  -> menu   -- ^ Menu entry for this tab (usually a 'Label' widget).
  -> IO ()
notebookPrependPageMenu nb child tabWidget menuWidget =
  {#call notebook_prepend_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menuWidget)
#endif

#if GTK_CHECK_VERSION(2,4,0)
-- | Insert a new tab at the specified position. That is between @pos@ and
-- @pos@+1, or -1 to append the page after all other pages.
--
-- * The given label will be used for the label widget of the new tab. In case
-- the context menu is enabled, this name will also appear in the popup menu. If
-- you want to specify something else to go in the tab, use
-- 'notebookInsertPageMenu'.
--
-- * Returns index (starting from 0) of the inserted page in the notebook, or -1
-- if the function fails.
--
-- * This function returned @()@ in Gtk version 2.2.X and earlier
--
notebookInsertPage :: (NotebookClass nb, WidgetClass child) => nb
                   -> child  -- ^ Widget to use as the contents of the page
                   -> String -- ^ Label for the page.
                   -> Int    -- ^ Position for the new page.
                   -> IO Int
notebookInsertPage nb child tabLabel pos = do
  tab <- labelNew (Just tabLabel)
  liftM fromIntegral $
    {#call notebook_insert_page#} (toNotebook nb) (toWidget child) 
      (toWidget tab) (fromIntegral pos)

#else
-- | Insert a new tab at the specified position. That is between @pos@ and
-- @pos@+1, or -1 to append the page after all other pages.
--
-- * The given label will be used for the label widget of the new tab. In case
-- the context menu is enabled, this name will also appear in the popup menu. If
-- you want to specify something else to go in the tab, use
-- 'notebookInsertPageMenu'.
--
-- * This function returns @Int@ in Gtk version 2.4.0 and later.
--
notebookInsertPage :: (NotebookClass nb, WidgetClass child) => nb
                   -> child  -- ^ Widget to use as the contents of the page
                   -> String -- ^ Label for the page.
                   -> Int    -- ^ Position for the new page.
                   -> IO ()
notebookInsertPage nb child tabLabel pos = do
  tab <- labelNew (Just tabLabel)
  {#call notebook_insert_page#} (toNotebook nb) (toWidget child) 
    (toWidget tab) (fromIntegral pos)
#endif

#if GTK_CHECK_VERSION(2,4,0)
-- | Insert a new tab at the specified position. That is between @pos@ and
-- @pos@+1, or -1 to append the page after all other pages.
--
-- Like 'notebookInsertPage' but allows any widget to be used for the label of
-- the new tab and then entry in the page-switch popup menu.
--
-- * Returns the index (starting from 0) of the inserted page in the notebook,
-- or -1 if the function fails.
--
-- * This function returned @()@ in Gtk version 2.2.X and earlier
--
notebookInsertPageMenu ::(NotebookClass nb, WidgetClass child, 
   WidgetClass tab, WidgetClass menu) => nb
  -> child  -- ^ Widget to use as the contents of the page
  -> tab    -- ^ Tab label widget for the page.
  -> menu   -- ^ Menu entry for this tab (usually a 'Label' widget).
  -> Int    -- ^ Position for the new page.
  -> IO Int
notebookInsertPageMenu nb child tabWidget menuWidget pos = liftM fromIntegral $
  {#call notebook_insert_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menuWidget) (fromIntegral pos)

#else
-- | Insert a new tab at the specified position. That is between @pos@ and
-- @pos@+1, or -1 to append the page after all other pages.
--
-- Like 'notebookInsertPage' but allows any widget to be used for the label of
-- the new tab and then entry in the page-switch popup menu.
--
-- * This function returns @Int@ in Gtk version 2.4.0 and later
--
notebookInsertPageMenu ::(NotebookClass nb, WidgetClass child, 
   WidgetClass tab, WidgetClass menu) => nb
  -> child  -- ^ Widget to use as the contents of the page
  -> tab    -- ^ Tab label widget for the page.
  -> menu   -- ^ Menu entry for this tab (usually a 'Label' widget).
  -> Int    -- ^ Position for the new page.
  -> IO ()
notebookInsertPageMenu nb child tabWidget menuWidget pos =
  {#call notebook_insert_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menuWidget) (fromIntegral pos)
#endif

-- | Remove a specific page from the notebook, counting from 0.
--
notebookRemovePage :: NotebookClass nb => nb -> Int -> IO ()
notebookRemovePage nb pos = 
  {#call notebook_remove_page#} (toNotebook nb) (fromIntegral pos)

-- | Query the page the child widget is contained in.
--
-- * The function returns the page number if the child was found, Nothing
--   otherwise.
--
notebookPageNum :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                   IO (Maybe Int)
notebookPageNum nb child = 
  liftM (\page -> if page==(-1) then Nothing else Just (fromIntegral page)) $
  {#call unsafe notebook_page_num#} (toNotebook nb) (toWidget child)

-- | Move to the specified page of the notebook.
--
-- * If the position is out of range (e.g. negative) select the last page.
--
notebookSetCurrentPage :: NotebookClass nb => nb -> Int -> IO ()
notebookSetCurrentPage nb pos =
  {#call notebook_set_current_page#} (toNotebook nb) (fromIntegral pos)

-- | Move to the right neighbour of the current page.
--
-- * Nothing happens if there is no such page.
--
notebookNextPage :: NotebookClass nb => nb -> IO ()
notebookNextPage nb = {#call notebook_next_page#} (toNotebook nb)

-- | Move to the left neighbour of the current page.
--
-- * Nothing happens if there is no such page.
--
notebookPrevPage :: NotebookClass nb => nb -> IO ()
notebookPrevPage nb = {#call notebook_prev_page#} (toNotebook nb)

-- | Move a page withing the notebook.
--
notebookReorderChild :: (NotebookClass nb, WidgetClass w) => nb -> w -> Int ->
                        IO ()
notebookReorderChild nb child pos = {#call notebook_reorder_child#}
  (toNotebook nb) (toWidget child) (fromIntegral pos)

-- | Specify at which border the tabs should be drawn.
--
notebookSetTabPos :: NotebookClass nb => nb -> PositionType -> IO ()
notebookSetTabPos nb pt = {#call notebook_set_tab_pos#}
  (toNotebook nb) ((fromIntegral.fromEnum) pt)

-- | Gets the edge at which the tabs for switching pages in the notebook are
-- drawn.
--
notebookGetTabPos :: NotebookClass nb => nb -> IO PositionType
notebookGetTabPos nb = liftM (toEnum.fromIntegral) $
  {#call unsafe notebook_get_tab_pos#} (toNotebook nb)

-- | Show or hide the tabs of a notebook.
--
notebookSetShowTabs :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetShowTabs nb showTabs = {#call notebook_set_show_tabs#}
  (toNotebook nb) (fromBool showTabs)

-- | Returns whether the tabs of the notebook are shown.
--
notebookGetShowTabs :: NotebookClass nb => nb -> IO Bool
notebookGetShowTabs nb =
  liftM toBool $ {#call unsafe notebook_get_show_tabs#} (toNotebook nb)

-- | In case the tabs are not shown, specify whether to draw a border around
-- the notebook.
--
notebookSetShowBorder :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetShowBorder nb showBorder = {#call notebook_set_show_border#}
  (toNotebook nb) (fromBool showBorder)

-- | Returns whether a bevel will be drawn around the notebook pages.
--
notebookGetShowBorder :: NotebookClass nb => nb -> IO Bool
notebookGetShowBorder nb =
  liftM toBool $ {#call unsafe notebook_get_show_border#} (toNotebook nb)

-- | Set whether scroll bars will be added in case the notebook has too many
-- tabs to fit the widget size.
--
notebookSetScrollable :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetScrollable nb scrollable = {#call unsafe notebook_set_scrollable#}
  (toNotebook nb) (fromBool scrollable)

-- | Returns whether the tab label area has arrows for scrolling.
--
notebookGetScrollable :: NotebookClass nb => nb -> IO Bool
notebookGetScrollable nb = liftM toBool $
  {#call unsafe notebook_get_scrollable#} (toNotebook nb)

#ifndef DISABLE_DEPRECATED
-- | Set the width of the borders of the tab labels.
--
-- * Sets both vertical and horizontal widths.
--
notebookSetTabBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabBorder nb width = {#call notebook_set_tab_border#}
  (toNotebook nb) (fromIntegral width)

-- | Set the width of the borders of the tab labels.
--
-- * Sets horizontal widths.
--
notebookSetTabHBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabHBorder nb width = {#call notebook_set_tab_hborder#}
  (toNotebook nb) (fromIntegral width)

-- | Set the width of the borders of the tab labels.
--
-- * Sets vertical widths.
--
notebookSetTabVBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabVBorder nb width = {#call notebook_set_tab_vborder#}
  (toNotebook nb) (fromIntegral width)
#endif

-- | Enable or disable context menus with all tabs in it.
--
notebookSetPopup :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetPopup nb enable = (if enable 
  then {#call notebook_popup_enable#} else {#call notebook_popup_disable#})
  (toNotebook nb)

-- | Query the currently selected page.
--
-- * Returns -1 if notebook has no pages.
--
notebookGetCurrentPage :: NotebookClass nb => nb -> IO Int
notebookGetCurrentPage nb = liftM fromIntegral $
  {#call unsafe notebook_get_current_page#} (toNotebook nb)

-- | Changes the menu label for the page containing the given child widget.
--
notebookSetMenuLabel :: (NotebookClass nb, WidgetClass ch, WidgetClass label)
                     => nb -> ch -> Maybe label -> IO ()
notebookSetMenuLabel nb child label =
  {#call notebook_set_menu_label#} (toNotebook nb) (toWidget child)
    (maybe (Widget nullForeignPtr) toWidget label)

-- | Extract the menu label from the given @child@.
--
-- * Returns Nothing if @child@ was not found.
--
notebookGetMenuLabel :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                        IO (Maybe Label)
notebookGetMenuLabel nb child = do
  wPtr <- {#call unsafe notebook_get_menu_label#} 
    (toNotebook nb) (toWidget child)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkLabel $ return $ castPtr wPtr

-- | Creates a new label and sets it as the menu label of the given child
-- widget.
--
notebookSetMenuLabelText :: (NotebookClass nb, WidgetClass ch)
                         => nb -> ch -> String -> IO ()
notebookSetMenuLabelText nb child label =
  withUTFString label $ \labelPtr ->
  {#call notebook_set_menu_label_text#} (toNotebook nb)
    (toWidget child) labelPtr

-- | Retrieves the text of the menu label for the page containing the given
-- child widget.
--
notebookGetMenuLabelText :: (NotebookClass nb, WidgetClass ch)
                         => nb -> ch -> IO (Maybe String)
notebookGetMenuLabelText nb child = do
  labelPtr <- {#call unsafe notebook_get_menu_label_text#} (toNotebook nb)
    (toWidget child)
  maybePeek peekUTFString labelPtr

-- | Retrieve the child widget at the given position (starting from 0).
--
-- * Returns Nothing if the index is out of bounds.
--
notebookGetNthPage :: NotebookClass nb => nb -> Int -> IO (Maybe Widget)
notebookGetNthPage nb pos = do
  wPtr <- {#call unsafe notebook_get_nth_page#} 
    (toNotebook nb) (fromIntegral pos)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkWidget $ return wPtr

#if GTK_CHECK_VERSION(2,2,0)

-- | Get the number of pages in a notebook.
--
-- * Only available in Gtk 2.2 and higher.
--
notebookGetNPages :: NotebookClass nb => nb -> IO Int
notebookGetNPages nb = liftM fromIntegral $
  {#call unsafe notebook_get_n_pages#} (toNotebook nb)

#endif

-- | Extract the tab label from the given @child@.
--
-- * Nothing is returned if no tab label has specifically been set for the
-- child.
--
notebookGetTabLabel :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                       IO (Maybe Widget)
notebookGetTabLabel nb child = do
  wPtr <- {#call unsafe notebook_get_tab_label#} 
    (toNotebook nb) (toWidget child)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkWidget $ return wPtr

-- | Retrieves the text of the tab label for the page containing the given child
-- widget.
--
notebookGetTabLabelText :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                       IO (Maybe String)
notebookGetTabLabelText nb child = do
  labelPtr <- {#call unsafe notebook_get_tab_label_text#} (toNotebook nb)
    (toWidget child)
  maybePeek peekUTFString labelPtr

-- | Query the packing attributes of the given child.
--
notebookQueryTabLabelPacking :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                                IO (Packing,PackType)
notebookQueryTabLabelPacking nb child = 
  alloca $ \expPtr -> alloca $ \fillPtr -> alloca $ \packPtr -> do
    {#call unsafe notebook_query_tab_label_packing#} (toNotebook nb)
      (toWidget child) expPtr fillPtr packPtr
    expand <- liftM toBool $ peek expPtr
    fill <- liftM toBool $ peek fillPtr
    pt <- liftM (toEnum.fromIntegral) $ peek packPtr
    return (if fill then PackGrow else 
             (if expand then PackRepel else PackNatural),
	    pt)

-- | Set the packing attributes of the given child.
--
notebookSetTabLabelPacking :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                              Packing -> PackType -> IO ()
notebookSetTabLabelPacking nb child pack pt = 
  {#call notebook_set_tab_label_packing#} (toNotebook nb) (toWidget child)
    (fromBool $ pack/=PackNatural) (fromBool $ pack==PackGrow) 
    ((fromIntegral.fromEnum) pt)

#ifndef DISABLE_DEPRECATED
-- | Sets whether the tabs must have all the same size or not.
--
notebookSetHomogeneousTabs :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetHomogeneousTabs nb hom = {#call notebook_set_homogeneous_tabs#}
  (toNotebook nb) (fromBool hom)
#endif

-- | Set a new tab label for a given page.
--
notebookSetTabLabel :: (NotebookClass nb, WidgetClass ch, WidgetClass tab) => 
                       nb -> ch -> tab -> IO ()
notebookSetTabLabel nb child tab = {#call notebook_set_tab_label#}
  (toNotebook nb) (toWidget child) (toWidget tab)

-- | Creates a new label and sets it as the tab label for the given page.
--
notebookSetTabLabelText :: (NotebookClass nb, WidgetClass ch) => 
                       nb -> ch -> String -> IO ()
notebookSetTabLabelText nb child label =
  withUTFString label $ \labelPtr ->
  {#call notebook_set_tab_label_text#} (toNotebook nb) (toWidget child) labelPtr


-- signals

-- | This signal is emitted when a new page is
-- selected.
--
onSwitchPage, afterSwitchPage :: NotebookClass nb => nb -> (Int -> IO ()) ->
                                 IO (ConnectId nb)
onSwitchPage nb fun = connect_BOXED_WORD__NONE "switch-page" 
		      (const $ return ()) False nb 
		      (\_ page -> fun (fromIntegral page))
afterSwitchPage nb fun = connect_BOXED_WORD__NONE "switch-page" 
			 (const $ return ()) True nb 
			 (\_ page -> fun (fromIntegral page))


 

--- NEW FILE: Expander.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget Expander
--
--  Author : Duncan Coutts
--  Created: 24 April 2004
--
--  Copyright (c) 2004 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 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
--  Library General Public License for more details.
--
-- |
--
-- An Expander allows the user to hide or show its child by clicking on an
-- expander triangle similar to the triangles used in a TreeView.
--
-- Normally you use an expander as you would use any other descendant of GtkBin
-- you create the child widget and use containerAdd to add it to the expander.
-- When the expander is toggled, it will take care of showing and hiding the
-- child automatically.
--
-- * Added in GTK+ 2.4
--
module Expander (
#if GTK_CHECK_VERSION(2,4,0)
  Expander,
  ExpanderClass,
  expanderNew,
  expanderNewWithMnemonic,
  expanderSetExpanded,
  expanderGetExpanded,
  expanderSetSpacing,
  expanderGetSpacing,
  expanderSetLabel,
  expanderGetLabel,
  expanderSetUseUnderline,
  expanderGetUseUnderline,
  expanderSetUseMarkup,
  expanderGetUseMarkup,
  expanderSetLabelWidget,
  expanderGetLabelWidget,
  onActivate,
  afterActivate
#endif
) where

#if GTK_CHECK_VERSION(2,4,0)

import Monad (liftM)
import FFI
import Object
{#import Hierarchy#}
import Signal

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

expanderNew :: String -> IO Expander
expanderNew label = 
 makeNewObject mkExpander $ liftM castPtr $
 withUTFString label $ \strPtr ->
 {# call gtk_expander_new #} strPtr

expanderNewWithMnemonic :: String -> IO Expander
expanderNewWithMnemonic label =
 makeNewObject mkExpander $ liftM castPtr $
 withUTFString label $ \strPtr -> 
 {# call gtk_expander_new_with_mnemonic #} strPtr

expanderSetExpanded :: Expander -> Bool -> IO ()
expanderSetExpanded expander expanded = 
 {# call gtk_expander_set_expanded #} expander (fromBool expanded)

expanderGetExpanded :: Expander -> IO Bool
expanderGetExpanded expander = liftM toBool $
 {# call gtk_expander_get_expanded #} expander

expanderSetSpacing :: Expander -> Int -> IO ()
expanderSetSpacing expander spacing = 
 {# call gtk_expander_set_spacing #} expander (fromIntegral spacing)

expanderGetSpacing :: Expander -> IO Int
expanderGetSpacing expander = liftM fromIntegral $
 {# call gtk_expander_get_spacing #} expander

expanderSetLabel :: Expander -> String -> IO ()
expanderSetLabel expander label =
 withUTFString label $ \strPtr ->
 {# call gtk_expander_set_label #} expander strPtr

expanderGetLabel :: Expander -> IO String
expanderGetLabel expander = do
 strPtr <- {# call gtk_expander_get_label #} expander
 peekUTFString strPtr

expanderSetUseUnderline :: Expander -> Bool -> IO ()
expanderSetUseUnderline expander useUnderline = 
 {# call gtk_expander_set_use_underline #} expander (fromBool useUnderline)

expanderGetUseUnderline :: Expander -> IO Bool
expanderGetUseUnderline expander = liftM toBool $
 {# call gtk_expander_get_use_underline #} expander

expanderSetUseMarkup :: Expander -> Bool -> IO ()
expanderSetUseMarkup expander useMarkup = 
 {# call gtk_expander_set_use_markup #} expander (fromBool useMarkup)

expanderGetUseMarkup :: Expander -> IO Bool
expanderGetUseMarkup expander = liftM toBool $
 {# call gtk_expander_get_use_markup #} expander

expanderSetLabelWidget :: WidgetClass widget => Expander -> widget -> IO ()
expanderSetLabelWidget expander widget = 
 {# call gtk_expander_set_label_widget #} expander (toWidget widget)

expanderGetLabelWidget :: Expander -> IO Widget
expanderGetLabelWidget expander = 
 makeNewObject mkWidget $
 {# call gtk_expander_get_label_widget #} expander

onActivate :: Expander -> IO () -> IO (ConnectId Expander)
afterActivate :: Expander -> IO () -> IO (ConnectId Expander)
onActivate = connect_NONE__NONE "activate" False
afterActivate = connect_NONE__NONE "activate" True

#endif

--- Alignment.chs.cpp DELETED ---

--- Expander.chs.cpp DELETED ---

--- NEW FILE: Alignment.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget Alignment
--
--  Author : Axel Simon
--          
--  Created: 15 May 2001
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:15 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
-- |
--
module Alignment(
  Alignment,
  AlignmentClass,
  castToAlignment,
  alignmentNew,
  alignmentSet
#if GTK_CHECK_VERSION(2,4,0)
 ,alignmentSetPadding,
  alignmentGetPadding
#endif
  ) where

import Monad	(liftM)
import FFI

import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}

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

-- methods

-- | Create an alignment widget. This widget tells
-- its child widget how to use the given space.
--
alignmentNew :: Float -> Float -> Float -> Float -> IO Alignment
alignmentNew yscale xalign yalign xscale = makeNewObject mkAlignment $
  liftM castPtr $ {#call unsafe alignment_new#} (realToFrac xalign) 
  (realToFrac yalign) (realToFrac xscale) (realToFrac yscale)


-- | Change the space use behaviour of an 'Alignment'.
--
alignmentSet :: AlignmentClass al => al -> Float -> Float -> Float -> Float ->
                IO ()
alignmentSet al xalign yalign xscale yscale = {#call alignment_set#}
  (toAlignment al) (realToFrac xalign) (realToFrac yalign)
  (realToFrac xscale) (realToFrac yscale)

#if GTK_CHECK_VERSION(2,4,0)
-- | Sets the padding on the different sides of the widget.
--
alignmentSetPadding :: AlignmentClass al => al -> Int -> Int -> Int -> Int ->
                       IO ()
alignmentSetPadding al top bottom left right =
  {# call gtk_alignment_set_padding #} (toAlignment al)
    (fromIntegral top) (fromIntegral bottom)
    (fromIntegral left) (fromIntegral right)

-- | Gets the padding on the different sides of the widget.
--
alignmentGetPadding :: AlignmentClass al => al -> IO (Int, Int, Int, Int)
alignmentGetPadding al =
  alloca $ \topPtr -> alloca $ \bottomPtr ->
  alloca $ \leftPtr -> alloca $ \rightPtr -> do
  {# call gtk_alignment_get_padding #} (toAlignment al)
    topPtr bottomPtr leftPtr rightPtr
  top    <- peek topPtr
  bottom <- peek bottomPtr
  left   <- peek leftPtr
  right  <- peek rightPtr
  return (fromIntegral top, fromIntegral bottom
         ,fromIntegral left, fromIntegral right)
  
#endif

[Gtk2hs-commit] gtk2hs/gtk/glib GError.chs.pp,NONE,1.1 GObject.chs.pp,NONE,1.1 GError.chs.cpp,1.1,NONE GObject.chs.cpp,1.1,NONE

[Axel S. <as...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/gtk/glib
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2280/gtk/glib

Added Files:
	GError.chs.pp GObject.chs.pp 
Removed Files:
	GError.chs.cpp GObject.chs.cpp 
Log Message:
Renamed files that need CPP pre-processing to .chs.pp instead of .chs.cpp
since the latter makes automake think we are compiling C++.



--- NEW FILE: GError.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) GError API
--
--  Author : Duncan Coutts
--  Created: 2 July 2004
--
--  Copyright (c) 2004 Duncan Coutts
--  parts derived from Structs.hsc Copyright (c) 1999..2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 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
--  Library General Public License for more details.
--
-- |
--
--  Error Reporting, glib's system for reporting errors.
--
--  'GError's are used by glib to report recoverable runtime errors.
--
--  This module provides functions for checking glib\/gtk functions that report
--  'GError's. It also provides functions for throwing and catching 'GError's as
--  Haskell exceptions.
--

module GError (

  -- * Data types
  --
  GError(..),
  GErrorDomain,
  GErrorCode,
  GErrorMessage,
  
  -- * Catching GError exceptions
  -- | To catch GError exceptions thrown by gtk2hs functions use the catchGError*
  --   or handleGError* functions. They work in a similar way to the standard
  --   'Control.Exception.catch' and 'Control.Exception.handle' functions.
  --
  --   'catchGError'\/'handleGError' catches all GError exceptions, you provide a
  --   handler function that gets given the GError if an exception was thrown. This
  --   is the most general but is probably not what you want most of the time. It
  --   just gives you the raw error code rather than a Haskell enumeration of the
  --   error codes. Most of the time you will only want to catch a specific error
  --   or any error from a specific error domain. To catch just a single specific
  --   error use 'catchGErrorJust'\/'handleGErrorJust'. To catch any error in a 
  --   particular error domain use 'catchGErrorJustDomain'\/'handleGErrorJustDomain'
  --
  catchGError,
  catchGErrorJust,
  catchGErrorJustDomain,
  
  handleGError,
  handleGErrorJust,
  handleGErrorJustDomain,
  
  failOnGError,
  throwGError,

  -- * Checking for GErrors returned by glib\/gtk functions
  -- | * Note, these functions are only useful to implementors
  --
  --   If you are wrapping a new API that reports 'GError's you should probably use
  --   'propagateGError' to convert the GError into an exception. You should also
  --   note in the documentation for the function that it throws GError exceptions
  --   and the Haskell enumeration for the expected glib GError domain(s), so that
  --   users know what exceptions they might want to catch.
  --
  --   If you think it is more appropriate to use an alternate return value (eg
  --   Either\/Maybe) then you should use 'checkGError' or 'checkGErrorWithCont'.

  GErrorClass(..),
  propagateGError,
  checkGError,
  checkGErrorWithCont
  
  ) where

import FFI
import Monad (when)

import Control.Exception
import Data.Dynamic

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

-- | A GError consists of a domain, code and a human readable message.
data GError = GError !GErrorDomain !GErrorCode !GErrorMessage
# if __GLASGOW_HASKELL__>=600
  deriving Typeable
#else
{-# NOINLINE gerrorTypeRep #-}
gerrorTypeRep :: TypeRep
gerrorTypeRep = mkAppTy (mkTyCon "Graphics.UI.Gtk.GError.GError") []
instance Typeable GError where
  typeOf _ = gerrorTypeRep
#endif

type GQuark = {#type GQuark #}

-- | A code used to identify the \'namespace\' of the error. Within each error
--   domain all the error codes are defined in an enumeration. Each gtk\/gnome
--   module that uses GErrors has its own error domain. The rationale behind
--   using error domains is so that each module can organise its own error codes
--   without having to coordinate on a global error code list.
type GErrorDomain  = GQuark

-- | A code to identify a specific error within a given 'GErrorDomain'. Most of
--   time you will not need to deal with this raw code since there is an
--   enumeration type for each error domain. Of course which enumeraton to use
--   depends on the error domain, but if you use 'catchGErrorJustDomain' or
--   'handleGErrorJustDomain', this is worked out for you automatically.
type GErrorCode = Int

-- | A human readable error message.
type GErrorMessage = String
                                                                                           
instance Storable GError where
  sizeOf _ = {#sizeof GError #}
  alignment _ = alignment (undefined:: GQuark)
  peek ptr = do
    (domain  :: GQuark)         <- {#get GError->domain  #} ptr
    (code    :: {#type gint #}) <- {#get GError->code    #} ptr
    (msgPtr  :: CString)        <- {#get GError->message #} ptr
    msg <- peekUTFString msgPtr
    return $ GError (fromIntegral domain) (fromIntegral code) msg
  poke _ = error "GError::poke: not implemented"

-- | Each error domain's error enumeration type should be an instance of this
--   class. This class helps to hide the raw error and domain codes from the
--   user. This interface should be implemented by calling the approrpiate
--   @{error_domain}_error_quark@. It is safe to use 'unsafePerformIO' for this.
--
-- Example for 'PixbufError':
--
-- > instance GErrorClass PixbufError where
-- >   gerrorDomain _ = unsafePerformIO {#call unsafe pixbuf_error_quark#}
--
class Enum err => GErrorClass err where
  gerrorDomain :: err -> GErrorDomain -- ^ This must not use the value of its parameter
                                      --   so that it is safe to pass 'undefined'.

-- | Glib functions which report 'GError's take as a parameter a @GError **error@.
--   Use this function to supply such a parameter. It checks if an error was
--   reported and if so throws it as a Haskell exception.
--   
-- Example of use:
--
-- > propagateGError $ \gerrorPtr ->
-- > {# call g_some_function_that_might_return_an_error #} a b gerrorPtr
--
propagateGError :: (Ptr (Ptr ()) -> IO a) -> IO a
propagateGError action = checkGError action throwGError

-- | Like 'propagateGError' but instead of throwing the GError as an exception
--   handles the error immediately using the supplied error handler.
--
-- Example of use:
--
-- > checkGError
-- >   (\gerrorPtr -> {# call g_some_function_that_might_return_an_error #} a b gerrorPtr)
-- >   (\(GError domain code msg) -> ...)
--
checkGError :: (Ptr (Ptr ()) -> IO a) -> (GError -> IO a) -> IO a
checkGError action handler =
  alloca $ \(errPtrPtr  :: Ptr (Ptr GError)) -> do
  poke errPtrPtr nullPtr
  result <- action (castPtr errPtrPtr)
  errPtr <- peek errPtrPtr
  if errPtr == nullPtr
    then return result
    else do gerror <- peek errPtr
            {# call unsafe g_error_free #} (castPtr errPtr)
            handler gerror

-- | Like 'checkGError' but with an extra continuation applied to the result.
--   This can be useful when something needs to be done after making the call
--   to the function that can raise an error but is should only be done if there
--   was no error.
--
-- Example of use:
--
-- > checkGErrorWithCont (\gerrorPtr ->
-- >   {# call g_some_function_that_might_return_an_error #} a b gerrorPtr)
-- > (\(GError domain code msg) -> ...) -- what to do in case of error
-- > (\result -> ...)                   -- what to do after if no error
--
checkGErrorWithCont :: (Ptr (Ptr ()) -> IO b) -> (GError -> IO a) -> (b -> IO a) -> IO a
checkGErrorWithCont action handler cont =
  alloca $ \(errPtrPtr  :: Ptr (Ptr GError)) -> do
  poke errPtrPtr nullPtr
  result <- action (castPtr errPtrPtr)
  errPtr <- peek errPtrPtr
  if errPtr == nullPtr
    then cont result
    else do gerror <- peek errPtr
            {# call unsafe g_error_free #} (castPtr errPtr)
            handler gerror

-- | Use this if you need to explicitly throw a GError or re-throw an existing
--   GError that you do not wish to handle.
throwGError :: GError -> IO a
throwGError gerror = evaluate (throwDyn gerror)

-- | This will catch any GError exception. The handler function will receive the
--   raw GError. This is probably only useful when you want to take some action
--   that does not depend on which GError exception has occured, otherwise it
--   would be better to use either 'catchGErrorJust' or 'catchGErrorJustDomain'.
--   For example:
--
-- > catchGError
-- >   (do ...
-- >       ...)
-- >   (\(GError dom code msg) -> fail msg)
--   
catchGError :: IO a            -- ^ The computation to run
            -> (GError -> IO a) -- ^ Handler to invoke if an exception is raised
            -> IO a
catchGError action handler = catchDyn action handler

-- | This will catch just a specific GError exception. If you need to catch a
--   range of related errors, 'catchGErrorJustDomain' is probably more
--   appropriate. Example:
--
-- > do image <- catchGErrorJust PixbufErrorCorruptImage
-- >               loadImage
-- >               (\errorMessage -> do log errorMessage
-- >                                    return mssingImagePlaceholder)
--
catchGErrorJust :: GErrorClass err => err  -- ^ The error to catch
                -> IO a                    -- ^ The computation to run
                -> (GErrorMessage -> IO a) -- ^ Handler to invoke if an exception is raised
                -> IO a
catchGErrorJust code action handler = catchGError action handler'
  where handler' gerror@(GError domain code' msg)
          | fromIntegral domain == gerrorDomain code
           && code' == fromEnum code   = handler msg
          | otherwise                  = throwGError gerror

-- | Catch all GErrors from a particular error domain. The handler function
--   should just deal with one error enumeration type. If you need to catch
--   errors from more than one error domain, use this function twice with an
--   appropriate handler functions for each.
--
-- > catchGErrorJustDomain
-- >   loadImage
-- >   (\err message -> case err of
-- >       PixbufErrorCorruptImage -> ...
-- >       PixbufErrorInsufficientMemory -> ...
-- >       PixbufErrorUnknownType -> ...
-- >       _ -> ...)
--
catchGErrorJustDomain :: GErrorClass err => IO a        -- ^ The computation to run
                      -> (err -> GErrorMessage -> IO a) -- ^ Handler to invoke if an exception is raised
                      -> IO a
catchGErrorJustDomain action (handler :: err -> GErrorMessage -> IO a) =
    catchGError action handler'
  where handler' gerror@(GError domain code msg)
          | fromIntegral domain == gerrorDomain (undefined::err) = handler (toEnum code) msg
          | otherwise                                            = throwGError gerror

-- | A verson of 'catchGError' with the arguments swapped around.
--
-- > handleGError (\(GError dom code msg) -> ...) $
-- >   ...
--   
handleGError :: (GError -> IO a) -> IO a -> IO a
handleGError = flip catchGError

-- | A verson of 'handleGErrorJust' with the arguments swapped around.
handleGErrorJust :: GErrorClass err => err -> (GErrorMessage -> IO a) -> IO a -> IO a
handleGErrorJust code = flip (catchGErrorJust code)

-- | A verson of 'handleGErrorJustDomain' with the arguments swapped around.
handleGErrorJustDomain :: GErrorClass err => (err -> GErrorMessage -> IO a) -> IO a -> IO a
handleGErrorJustDomain = flip catchGErrorJustDomain

-- | Catch all GError exceptions and convert them into a general failure.
failOnGError :: IO a -> IO a
failOnGError action = catchGError action (\(GError dom code msg) -> fail msg)

--- GObject.chs.cpp DELETED ---

--- NEW FILE: GObject.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget GObject
--
--  Author : Axel Simon
--          
--  Created: 9 April 2001
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:14 $
--
--  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.
--
-- |
--
-- Implements the base GObject class to satisfy the type checker.
--
module GObject(
  objectNew,
  objectRef,
  objectUnref,
  makeNewGObject,
  GWeakNotify,
  mkDestructor,
  objectWeakref,
  objectWeakunref
  ) where


import Monad (liftM)
import FFI
import LocalData (newIORef, readIORef, writeIORef)
import Hierarchy (GObjectClass, GObject(..),
                  mkGObject, toGObject, unGObject)
import GValue (GValue)
import GType  (GType)
import GParameter

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

{# pointer *GParameter as GParm -> GParameter #}

-- construct a new object (should rairly be used directly)
--
objectNew :: GType -> [(String, GValue)] -> IO (Ptr GObject)
objectNew objType parameters =
  liftM castPtr $ --caller must makeNewGObject as we don't know
                  --if it this a GObject or a GtkObject
  withArray (map GParameter parameters) $ \paramArrayPtr ->
  {# call g_object_newv #} objType
  (fromIntegral $ length parameters) paramArrayPtr

-- increase the reference counter of an object
--
objectRef :: GObjectClass obj => Ptr obj -> IO ()
objectRef obj = do
  {#call unsafe object_ref#} (castPtr obj)
  return ()

-- decrease the reference counter of an object
--
#if __GLASGOW_HASKELL__>=600

foreign import ccall unsafe "&g_object_unref"
  object_unref' :: FinalizerPtr a

objectUnref :: Ptr a -> FinalizerPtr a
objectUnref _ = object_unref'

#elif __GLASGOW_HASKELL__>=504

foreign import ccall unsafe "g_object_unref"
  objectUnref :: Ptr a -> IO ()

#else

foreign import ccall "g_object_unref" unsafe
  objectUnref :: Ptr a -> IO ()

#endif


-- This is a convenience function to generate an object that does not
-- derive from Object. It adds objectUnref as finalizer.
--
-- * The constr argument is the contructor of the specific object.
--
makeNewGObject :: GObjectClass obj => 
  (ForeignPtr obj -> obj) -> IO (Ptr obj) -> IO obj
makeNewGObject constr generator = do
  objPtr <- generator
  objectRef objPtr
  obj <- newForeignPtr objPtr (objectUnref objPtr)
  return $ constr obj

{#pointer GWeakNotify#}

foreign import ccall "wrapper" mkDestructor :: IO () -> IO GWeakNotify

-- | attach a callback that will be called after the
-- destroy hooks have been called
--
objectWeakref :: GObjectClass o => o -> IO () -> IO GWeakNotify
objectWeakref obj uFun = do
  funPtrContainer <- newIORef nullFunPtr
  uFunPtr <- mkDestructor $ do
    uFun
    funPtr <- readIORef funPtrContainer
    freeHaskellFunPtr funPtr
  writeIORef funPtrContainer uFunPtr
  withForeignPtr ((castForeignPtr.unGObject.toGObject) obj) $ \objPtr ->
    {#call unsafe object_weak_ref#} objPtr uFunPtr nullPtr
  return uFunPtr

-- | detach a weak destroy callback function
--
objectWeakunref :: GObjectClass o => o -> GWeakNotify -> IO ()
objectWeakunref obj fun = 
  withForeignPtr ((castForeignPtr.unGObject.toGObject) obj) $ \objPtr ->
    {#call unsafe object_weak_unref#} objPtr fun nullPtr
  


  

--- GError.chs.cpp DELETED ---

[Gtk2hs-commit] gtk2hs/gtk/general Enums.chs.pp,NONE,1.1 IconFactory.chs.pp,NONE,1.1 Enums.chs.cpp,1.1,NONE IconFactory.chs.cpp,1.1,NONE

[Axel S. <as...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/gtk/general
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2280/gtk/general

Added Files:
	Enums.chs.pp IconFactory.chs.pp 
Removed Files:
	Enums.chs.cpp IconFactory.chs.cpp 
Log Message:
Renamed files that need CPP pre-processing to .chs.pp instead of .chs.cpp
since the latter makes automake think we are compiling C++.



--- Enums.chs.cpp DELETED ---

--- NEW FILE: IconFactory.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) IconFactory
--
--  Author : Axel Simon
--          
--  Created: 24 May 2001
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:14 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
-- |
--
-- This module provides access to IconFactory, IconSet and IconSource.
--
-- TODO
--
-- * The following functions are not bound:
--   iconFactoryLookup, iconFactoryLookupDefault
--   It is not a good idea to lookup an IconSet directly. If an Icon needs to
--   be displayed it happends always in the context of a widget. The best
--   practice is to get the widgets Style and call styleLookupIconSet.
--
module IconFactory(
  IconFactory,
  iconFactoryNew,
  iconFactoryAdd,
  iconFactoryAddDefault,
  iconFactoryLookup,
  iconFactoryLookupDefault,
  iconFactoryRemoveDefault,
  IconSet,
  iconSetNew,
  iconSetNewFromPixbuf,
  iconSetAddSource,
  iconSetRenderIcon,
  iconSetGetSizes,
  IconSource,
  iconSourceNew,
  TextDirection(..),
  iconSourceGetDirection,
  iconSourceSetDirection,
  iconSourceResetDirection,
  iconSourceGetFilename,
  iconSourceSetFilename,
  iconSourceGetPixbuf,
  iconSourceSetPixbuf,
  iconSourceGetSize,
  iconSourceSetSize,
  iconSourceResetSize,
  StateType(..),
  iconSourceGetState,
  iconSourceSetState,
  iconSourceResetState,
  IconSize,
  iconSizeMenu,
  iconSizeSmallToolbar,
  iconSizeLargeToolbar,
  iconSizeButton,
  iconSizeDialog,
  iconSizeCheck,
  iconSizeRegister,
  iconSizeRegisterAlias,
  iconSizeFromName,
  iconSizeGetName
  ) where

import Monad	(liftM)
import FFI
import GObject	(makeNewGObject)
{#import Hierarchy#}
{#import Signal#}
import Enums	(TextDirection(..), StateType(..))
import Structs	(IconSize, iconSizeInvalid, iconSizeMenu, iconSizeSmallToolbar,
		 iconSizeLargeToolbar, iconSizeButton, iconSizeDialog)

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

{#pointer *IconSource foreign newtype#}

{#pointer *IconSet foreign newtype#}

-- methods


-- | Add an IconSet to an IconFactory.
--
-- * In order to use the new stock object, the factory as to be added to the
--   default factories by iconFactoryAddDefault.
--
iconFactoryAdd :: IconFactory -> String -> IconSet -> IO ()
iconFactoryAdd i stockId iconSet = withUTFString stockId $ \strPtr ->
  {#call unsafe icon_factory_add#} i strPtr iconSet

-- | Add all entries of the IconFactory to the
-- applications stock object database.
--
iconFactoryAddDefault :: IconFactory -> IO ()
iconFactoryAddDefault  = {#call unsafe icon_factory_add_default#}

-- | Looks up the stock id in the icon factory, returning an icon set if found,
-- otherwise Nothing.
--
-- * For display to the user, you should use 'styleLookupIconSet' on the "Style"
-- for the widget that will display the icon, instead of using this function
-- directly, so that themes are taken into account.
--
iconFactoryLookup :: IconFactory -> String -> IO (Maybe IconSet)
iconFactoryLookup i stockId =
  withUTFString stockId $ \strPtr -> do
  iconSetPtr <- {#call unsafe icon_factory_lookup#} i strPtr
  if iconSetPtr == nullPtr then return Nothing else liftM (Just . IconSet) $
    newForeignPtr iconSetPtr (icon_set_unref iconSetPtr)

-- | Looks for an icon in the list of default icon factories.
--
-- * For display to the user, you should use 'styleLookupIconSet' on the "Style"
-- for the widget that will display the icon, instead of using this function
-- directly, so that themes are taken into account.
--
iconFactoryLookupDefault :: String -> IO (Maybe IconSet)
iconFactoryLookupDefault stockId =
  withUTFString stockId $ \strPtr -> do
  iconSetPtr <- {#call unsafe icon_factory_lookup_default#} strPtr
  if iconSetPtr == nullPtr then return Nothing else liftM (Just . IconSet) $
    newForeignPtr iconSetPtr (icon_set_unref iconSetPtr)

-- | Create a new IconFactory.
--
-- * An application should create a new 'IconFactory' and add all
--   needed icons.
--   By calling 'iconFactoryAddDefault' these icons become
--   available as stock objects and can easily be displayed by
--   'Image'. Furthermore, a theme can override the icons defined by
--   the application.
--
iconFactoryNew :: IO IconFactory
iconFactoryNew  = makeNewGObject mkIconFactory {#call unsafe icon_factory_new#}

-- | Remove an IconFactory from the
-- application's stock database.
--
iconFactoryRemoveDefault :: IconFactory -> IO ()
iconFactoryRemoveDefault  = {#call unsafe icon_factory_remove_default#}

-- | Add an 'IconSource' (an Icon with
-- attributes) to an 'IconSet'.
--
-- * If an icon is looked up in the IconSet @set@ the best matching
--   IconSource will be taken. It is therefore advisable to add a default
--   (wildcarded) icon, than can be used if no exact match is found.
--
iconSetAddSource :: IconSet -> IconSource -> IO ()
iconSetAddSource set source = {#call unsafe icon_set_add_source#} set source

iconSetRenderIcon :: WidgetClass widget => IconSet
                  -> TextDirection
                  -> StateType
                  -> IconSize
                  -> widget
                  -> IO Pixbuf
iconSetRenderIcon set dir state size widget = makeNewGObject mkPixbuf $
  {#call icon_set_render_icon#} set (Style nullForeignPtr)
    ((fromIntegral.fromEnum) dir) ((fromIntegral.fromEnum) state)
    ((fromIntegral.fromEnum) size) (toWidget widget) nullPtr

-- | Create a new IconSet.
--
-- * Each icon in an application is contained in an 'IconSet'. The
--   'IconSet' contains several variants ('IconSource's) to
--   accomodate for different sizes and states.
--
iconSetNew :: IO IconSet
iconSetNew  = do
  isPtr <- {#call unsafe icon_set_new#}
  liftM IconSet $ newForeignPtr isPtr (icon_set_unref isPtr)

-- | Creates a new 'IconSet' with the given pixbuf as the default\/fallback
-- source image. If you don't add any additional "IconSource" to the icon set,
-- all variants of the icon will be created from the pixbuf, using scaling,
-- pixelation, etc. as required to adjust the icon size or make the icon look
-- insensitive\/prelighted.
--
iconSetNewFromPixbuf :: Pixbuf -> IO IconSet
iconSetNewFromPixbuf pixbuf = do
  isPtr <- {#call unsafe icon_set_new_from_pixbuf#} pixbuf
  liftM IconSet $ newForeignPtr isPtr (icon_set_unref isPtr)

-- | Obtains a list of icon sizes this icon set can render.
--
iconSetGetSizes :: IconSet -> IO [IconSize]
iconSetGetSizes set =
  alloca $ \sizesArrPtr -> alloca $ \lenPtr -> do
  {#call unsafe icon_set_get_sizes#} set sizesArrPtr lenPtr
  len <- peek lenPtr
  sizesArr <- peek sizesArrPtr
  list <- peekArray (fromIntegral len) sizesArr
  {#call unsafe g_free#} (castPtr sizesArr)
  return $ map (toEnum.fromIntegral) list

#if __GLASGOW_HASKELL__>=600

foreign import ccall unsafe "&gtk_icon_set_unref"
  icon_set_unref' :: FinalizerPtr IconSet

icon_set_unref :: Ptr IconSet -> FinalizerPtr IconSet
icon_set_unref _ = icon_set_unref'

#elif __GLASGOW_HASKELL__>=504

foreign import ccall unsafe "gtk_icon_set_unref"
  icon_set_unref :: Ptr IconSet -> IO ()

#else

foreign import ccall "gtk_icon_set_unref" unsafe
  icon_set_unref :: Ptr IconSet -> IO ()

#endif


-- | Check if a given IconSize is registered.
--
-- * Useful if your application expects a theme to install a set with a
--   specific size. You can test if this actually happend and use another size
--   if not.
--
iconSizeCheck :: IconSize -> IO Bool
iconSizeCheck size = liftM toBool $
  {#call icon_size_lookup#} (fromIntegral size) nullPtr nullPtr

-- | Register a new IconSize.
--
iconSizeRegister :: Int -> String -> Int -> IO IconSize
iconSizeRegister height name width = liftM fromIntegral $
  withUTFString name $ \strPtr -> {#call unsafe icon_size_register#} 
  strPtr (fromIntegral width) (fromIntegral height)

-- | Register an additional alias for a name.
--
iconSizeRegisterAlias :: IconSize -> String -> IO ()
iconSizeRegisterAlias target alias = withUTFString alias $ \strPtr ->
  {#call unsafe icon_size_register_alias#} strPtr (fromIntegral target)

-- | Lookup an IconSize by name.
--
-- * This fixed value 'iconSizeInvalid' is returned if the name was
--   not found.
--
iconSizeFromName :: String -> IO IconSize
iconSizeFromName name = liftM fromIntegral $
  withUTFString name {#call unsafe icon_size_from_name#}

-- | Lookup the name of an IconSize.
--
-- * Returns @Nothing@ if the name was not found.
--
iconSizeGetName :: IconSize -> IO (Maybe String)
iconSizeGetName size = do
  strPtr <- {#call unsafe icon_size_get_name#} (fromIntegral size)
  if strPtr==nullPtr then return Nothing else liftM Just $ peekUTFString strPtr

-- | Retrieve the 'TextDirection' of
-- this IconSource.
--
-- * @Nothing@ is returned if no explicit direction was set.
--
iconSourceGetDirection :: IconSource -> IO (Maybe TextDirection)
iconSourceGetDirection is = do
  res <- {#call icon_source_get_direction_wildcarded#} is
  if (toBool res) then return Nothing else liftM (Just .toEnum.fromIntegral) $
    {#call unsafe icon_source_get_direction#} is

-- | Retrieve the filename this IconSource was
-- based on.
--
-- * Returns @Nothing@ if the IconSource was generated by a Pixbuf.
--
iconSourceGetFilename :: IconSource -> IO (Maybe String)
iconSourceGetFilename is = do
  strPtr <- {#call unsafe icon_source_get_filename#} is
  if strPtr==nullPtr then return Nothing else liftM Just $ peekUTFString strPtr

-- | Retrieve the 'IconSize' of this
-- IconSource.
--
-- * @Nothing@ is returned if no explicit size was set (i.e. this
--   'IconSource' matches all sizes).
--
iconSourceGetSize :: IconSource -> IO (Maybe IconSize)
iconSourceGetSize is = do
  res <- {#call unsafe icon_source_get_size_wildcarded#} is
  if (toBool res) then return Nothing else liftM (Just .fromIntegral) $
    {#call unsafe icon_source_get_size#} is

-- | Retrieve the 'StateType' of this
-- 'IconSource'.
--
-- * @Nothing@ is returned if the 'IconSource' matches all 
--   states.
--
iconSourceGetState :: IconSource -> IO (Maybe StateType)
iconSourceGetState is = do
  res <- {#call unsafe icon_source_get_state_wildcarded#} is
  if (toBool res) then return Nothing else liftM (Just .toEnum.fromIntegral) $
    {#call unsafe icon_source_get_state#} is

-- | Create a new IconSource.
--
-- * An IconSource is a single image that is usually added to an IconSet. Next
--   to the image it contains information about which state, text direction
--   and size it should apply.
--
iconSourceNew :: IO IconSource
iconSourceNew  = do
  isPtr <- {#call unsafe icon_source_new#}
  liftM IconSource $ newForeignPtr isPtr (icon_source_free isPtr)

#if __GLASGOW_HASKELL__>=600

foreign import ccall unsafe "&gtk_icon_source_free"
  icon_source_free' :: FinalizerPtr IconSource

icon_source_free :: Ptr IconSource -> FinalizerPtr IconSource
icon_source_free _ = icon_source_free'

#elif __GLASGOW_HASKELL__>=504

foreign import ccall unsafe "gtk_icon_source_free"
  icon_source_free :: Ptr IconSource -> IO ()

#else

foreign import ccall "gtk_icon_source_free" unsafe
  icon_source_free :: Ptr IconSource -> IO ()

#endif


-- | Mark this 'IconSource' that it
-- should only apply to the specified 'TextDirection'.
--
iconSourceSetDirection :: IconSource -> TextDirection -> IO ()
iconSourceSetDirection is td = do
  {#call unsafe icon_source_set_direction_wildcarded#} is (fromBool False)
  {#call unsafe icon_source_set_direction#} is ((fromIntegral.fromEnum) td)

-- | Reset the specific
-- 'TextDirection' set with 'iconSourceSetDirection'.
--
iconSourceResetDirection is =
  {#call unsafe icon_source_set_direction_wildcarded#} is (fromBool True)

-- | Load an icon picture from this filename.
--
iconSourceSetFilename :: IconSource -> FilePath -> IO ()
iconSourceSetFilename is name = 
  withUTFString name $ {#call unsafe icon_source_set_filename#} is

-- | Retrieves the source pixbuf, or Nothing if none is set.
--
iconSourceGetPixbuf :: IconSource -> IO (Maybe Pixbuf)
iconSourceGetPixbuf is = do
  pixbufPtr <- {#call unsafe icon_source_get_pixbuf#} is
  if pixbufPtr==nullPtr then return Nothing else liftM Just $
    makeNewGObject mkPixbuf (return pixbufPtr)

-- | Sets a pixbuf to use as a base image when creating icon variants for
-- 'IconSet'.
--
iconSourceSetPixbuf :: IconSource -> Pixbuf -> IO ()
iconSourceSetPixbuf is pb = do
  {#call icon_source_set_pixbuf#} is pb

-- | Set this 'IconSource' to a specific
-- size.
--
iconSourceSetSize :: IconSource -> IconSize -> IO ()
iconSourceSetSize is size = do
  {#call unsafe icon_source_set_size_wildcarded#} is (fromBool False)
  {#call unsafe icon_source_set_size#} is (fromIntegral size)

-- | Reset the 'IconSize' of this
-- 'IconSource' so that is matches anything.
--
iconSourceResetSize :: IconSource -> IO ()
iconSourceResetSize is = 
  {#call unsafe icon_source_set_size_wildcarded#} is (fromBool True)

-- | Mark this icon to be used only with this
-- specific state.
--
iconSourceSetState :: IconSource -> StateType -> IO ()
iconSourceSetState is state = do
  {#call unsafe icon_source_set_state_wildcarded#} is (fromBool False)
  {#call unsafe icon_source_set_state#} is ((fromIntegral.fromEnum) state)

-- | Reset the 'StateType' of this
-- 'IconSource' so that is matches anything.
--
iconSourceResetState :: IconSource -> IO ()
iconSourceResetState is = 
  {#call unsafe icon_source_set_state_wildcarded#} is (fromBool True)





--- NEW FILE: Enums.chs.pp ---
--  -*-haskell-*-
--  GIMP Toolkit (GTK) Enumerations
--
--  Author : Axel Simon, Manuel Chakravarty
--  Created: 13 Januar 1999
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:14 $
--
--  Copyright (c) [1999..2001] Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 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
--  Library General Public License for more details.
--
-- |
--
-- General enumeration types.
--
-- TODO
--
--  * Documentation
--
module Enums(
  AccelFlags(..),
  ArrowType(..),
  AttachOptions(..),
  Button(..),
  ButtonBoxStyle(..),
  CalendarDisplayOptions(..),
  Click(..),
  CornerType(..),
  CurveType(..),
  DeleteType(..),
  DirectionType(..),
  Justification(..),
#ifndef DISABLE_DEPRECATED
  MatchType(..),
#endif
  MenuDirectionType(..),
  MetricType(..),
  MovementStep(..),
  Orientation(..),
  Packing(..),
  PackType(..),
  PathPriorityType(..),
  PathType(..),
  PolicyType(..),
  PositionType(..),
  ProgressBarOrientation(..),
  ReliefStyle(..),
  ResizeMode(..),
  ScrollType(..),
  SelectionMode(..),
  ShadowType(..),
  StateType(..),
#ifndef DISABLE_DEPRECATED
  SubmenuDirection(..),
  SubmenuPlacement(..),
#endif
  SpinButtonUpdatePolicy(..),
  SpinType(..),
  TextDirection(..),
  TextSearchFlags(..),
  TextWindowType(..),
  ToolbarStyle(..),
  TreeViewColumnSizing(..),
  --TroughType(..),
  UpdateType(..),
  Visibility(..),
  WindowPosition(..),
  WindowType(..),
  WrapMode(..), 
  SortType(..),
  module GdkEnums
  ) where

import GdkEnums

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


-- | state of an accelerator
--
{#enum AccelFlags {underscoreToCase} deriving(Bounded)#}

instance Flags AccelFlags

-- | arrow directions for the arrow widget
--
{#enum ArrowType {underscoreToCase}#}

-- | child widget attach options for table containers
--
{#enum AttachOptions {underscoreToCase} deriving(Bounded)#}

instance Flags AttachOptions

-- | button number
--
data Button = LeftButton
	    | MiddleButton
	    | RightButton
	    | WheelUp
	    | WheelDown
	    | OtherButton

instance Enum Button where
  toEnum 1 = LeftButton
  toEnum 2 = MiddleButton
  toEnum 3 = RightButton
  toEnum 4 = WheelUp
  toEnum 5 = WheelDown
  toEnum _ = OtherButton
  fromEnum LeftButton   = 1
  fromEnum MiddleButton = 2
  fromEnum RightButton  = 3
  fromEnum WheelUp	= 4
  fromEnum WheelDown	= 5
  fromEnum OtherButton	= 6

-- | dictate the style that a ButtonBox uses to align it
-- contents
--
{#enum ButtonBoxStyle {underscoreToCase}#}

-- | Specify which items of a calendar should be
-- displayed.
--
{#enum CalendarDisplayOptions {underscoreToCase} deriving(Bounded)#}

instance Flags CalendarDisplayOptions

-- | type of mouse click
--
data Click = SingleClick
	   | DoubleClick
	   | TripleClick
	   | ReleaseClick

-- | specifies in which corner a child widget should be placed
--
{#enum CornerType {underscoreToCase}#}

-- | specifies how curves in the gamma widget (?) are drawn
--
{#enum CurveType {underscoreToCase}#}

-- | editing option
--
{#enum DeleteType {underscoreToCase}#}

-- | editing direction
--
{#enum DirectionType {underscoreToCase}#}

-- | justification for label and maybe other widgets
-- (text?)
--
{#enum Justification {underscoreToCase}#}

#ifndef DISABLE_DEPRECATED
-- | some kind of string search options
--
{#enum MatchType {underscoreToCase}#}
#endif

-- | From where was a menu item entered?
--
{#enum MenuDirectionType {underscoreToCase}#}

-- | units of measure
--
{#enum MetricType {underscoreToCase}#}

-- | movement in text widget
--
{#enum MovementStep {underscoreToCase}#}

-- | orientation is good
--
{#enum Orientation {underscoreToCase}#}

-- | packing parameters of a widget
--
data Packing = PackRepel
	     | PackGrow
	     | PackNatural
	     deriving (Enum,Eq)

-- packing of widgets at start or end in a box
--
{#enum PackType {underscoreToCase}#}

-- | priorities
--
{#enum PathPriorityType {underscoreToCase}#}

-- | widget identification path
--
{#enum PathType {underscoreToCase}#}

-- | Scrollbar policy types (for scrolled windows)
--
{#enum PolicyType {underscoreToCase}#}

-- | position a scale's value is drawn relative to the
-- trough
--
{#enum PositionType {underscoreToCase}#}

-- | Is the ProgressBar horizontally or vertically
-- directed?
--
{#enum ProgressBarOrientation {underscoreToCase}#}

-- | I don't have a clue.
--
{#enum ReliefStyle {underscoreToCase}#}

-- | resize mode, for containers
--
-- * 'ResizeParent' Pass resize request to the parent
--
-- * 'ResizeQueue' Queue resizes on this widget
--
-- * 'ResizeImmediate' Perform the resizes now
--
{#enum ResizeMode {underscoreToCase}#}

-- | scrolling type
--
{#enum ScrollType {underscoreToCase}#}

-- | mode in which selections can be performed
--
-- * There is a deprecated entry SelectionExtended which should have the same
--   value as SelectionMultiple. C2HS chokes on that construct.
--
data SelectionMode = SelectionNone
                   | SelectionSingle
                   | SelectionBrowse
                   | SelectionMultiple
                   deriving (Enum)
-- {#enum SelectionMode {underscoreToCase}#}

-- | shadow types
--
{#enum ShadowType {underscoreToCase}#}

-- | widget states
--
{#enum StateType {underscoreToCase}#}

#ifndef DISABLE_DEPRECATED
-- | Submenu direction policies
--
{#enum SubmenuDirection {underscoreToCase}#}

-- | Submenu placement policies
--
{#enum SubmenuPlacement {underscoreToCase}#}
#endif

-- | Whether to clamp or ignore illegal values.
--
{#enum SpinButtonUpdatePolicy {underscoreToCase}#}

-- | Spin a SpinButton with the following method.
--
{#enum SpinType {underscoreToCase}#}

-- | Is the text written from left to right or the awkward
-- way?
--
{#enum TextDirection {underscoreToCase}#}

-- | Specify the way the search function for
-- 'TextBuffer' works.
--
{#enum TextSearchFlags {underscoreToCase} deriving(Bounded)#}

instance Flags TextSearchFlags

-- | The window type for coordinate translation.
--
{#enum TextWindowType {underscoreToCase}#}

-- | Where to place the toolbar?
--
{#enum ToolbarStyle {underscoreToCase}#}

-- | Wether columns of a tree or list widget can be
-- resized.
--
{#enum TreeViewColumnSizing {underscoreToCase}#}

-- hm... text editing?
--{#enum TroughType {underscoreToCase}#}


-- | updating types for range widgets (determines when the
-- @\"connectToValueChanged\"@ signal is emitted by the widget)
--
{#enum UpdateType {underscoreToCase}#}

-- | visibility
--
{#enum Visibility {underscoreToCase}#}

-- | window position types
--
{#enum WindowPosition {underscoreToCase}#}

-- | interaction of a window with window manager
--
{#enum WindowType {underscoreToCase}#}

-- | Determine how lines are wrapped in a 'TextView'.
--
{#enum WrapMode {underscoreToCase}#}

-- sort in ascending or descending order (used in CList widget)
--
{#enum SortType {underscoreToCase}#}


--- IconFactory.chs.cpp DELETED ---

[Gtk2hs-commit] gtk2hs/gtk/gdk Drawable.chs.pp,NONE,1.1 Region.chs.pp,NONE,1.1 Drawable.chs.cpp,1.1,NONE Region.chs.cpp,1.1,NONE

[Axel S. <as...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/gtk/gdk
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2280/gtk/gdk

Added Files:
	Drawable.chs.pp Region.chs.pp 
Removed Files:
	Drawable.chs.cpp Region.chs.cpp 
Log Message:
Renamed files that need CPP pre-processing to .chs.pp instead of .chs.cpp
since the latter makes automake think we are compiling C++.



--- NEW FILE: Drawable.chs.pp ---
{-# OPTIONS -cpp #-}
--  -*-haskell-*-
--  GIMP Toolkit (GTK) Drawable
--
--  Author : Axel Simon
--  Created: 22 September 2002
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:14 $
--
--  Copyright (c) 2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 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
--  Library General Public License for more details.
--
-- |
--
-- Drawing primitives.
--
-- * This module defines drawing primitives that can operate on 
--   'DrawWindow's, 'Pixmap's and 
--   'Bitmap's.
--
-- TODO
--
-- * if gdk_visuals are implemented, do: get_visual
--
-- * if gdk_colormaps are implemented, do: set_colormap, get_colormap
--
-- * add draw_glyphs if we are desparate
--
module Drawable(
  Drawable,
  DrawableClass,
  castToDrawable,
  drawableGetDepth,
  drawableGetSize,
  drawableGetClipRegion,
  drawableGetVisibleRegion,
  Point,
  drawPoint,
  drawPoints,
  drawLine,
  drawLines,
#if GTK_CHECK_VERSION(2,2,0)
  Dither(..),
  drawPixbuf,
#endif
  drawSegments,
  drawRectangle,
  drawArc,
  drawPolygon,
  drawLayoutLine,
  drawLayoutLineWithColors,
  drawLayout,
  drawLayoutWithColors,
  drawDrawable) where

import Monad	(liftM)
import FFI

import GObject	(makeNewGObject)
import Structs  (Point)
{#import Hierarchy#}
{#import Region#}	(Region, makeNewRegion)
import Structs		(Color)
{#import PangoTypes#}
import GdkEnums         (Dither(..))

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

-- methods

-- | Get the size of pixels.
--
-- * Returns the number of bits which are use to store information on each
--   pixels in this 'Drawable'.
--
drawableGetDepth :: DrawableClass d => d -> IO Int
drawableGetDepth d = liftM fromIntegral $ 
		     {#call unsafe drawable_get_depth#} (toDrawable d)

-- | Retrieve the size of the 'Drawable'.
--
-- * The result might not be up-to-date if there are still resizing messages
--   to be processed.
--
drawableGetSize :: DrawableClass d => d -> IO (Int, Int)
drawableGetSize d = alloca $ \wPtr -> alloca $ \hPtr -> do
  {#call unsafe drawable_get_size#} (toDrawable d) wPtr hPtr
  (w::{#type gint#}) <- peek wPtr
  (h::{#type gint#}) <- peek hPtr
  return (fromIntegral w, fromIntegral h)

-- | Determine where not to draw.
--
-- * Computes the region of a drawable that potentially can be written
--   to by drawing primitives. This region will not take into account the
--   clip region for the GC, and may also not take into account other
--   factors such as if the window is obscured by other windows, but no
--   area outside of this region will be affected by drawing primitives.
--
drawableGetClipRegion :: DrawableClass d => d -> IO Region
drawableGetClipRegion d = do
  rPtr <- {#call unsafe drawable_get_clip_region#} (toDrawable d)
  makeNewRegion rPtr

-- | Determine what not to redraw.
--
-- * Computes the region of a drawable that is potentially visible.
-- This does not necessarily take into account if the window is obscured
-- by other windows, but no area outside of this region is visible.
--
drawableGetVisibleRegion :: DrawableClass d => d -> IO Region
drawableGetVisibleRegion d = do
  rPtr <- {#call unsafe drawable_get_visible_region#} (toDrawable d)
  makeNewRegion rPtr

-- | Draw a point into a 'Drawable'.
--
drawPoint :: DrawableClass d => d -> GC -> Point -> IO ()
drawPoint d gc (x,y) = {#call unsafe draw_point#} (toDrawable d)
  (toGC gc) (fromIntegral x) (fromIntegral y)


-- | Draw several points into a 'Drawable'.
--
-- * This function is more efficient than calling 'drawPoint' on
--   several points.
--
drawPoints :: DrawableClass d => d -> GC -> [Point] -> IO ()
drawPoints d gc []     = return ()
drawPoints d gc points = 
  withArray (concatMap (\(x,y) -> [fromIntegral x, fromIntegral y]) points) $
  \(aPtr :: Ptr {#type gint#}) -> {#call unsafe draw_points#} (toDrawable d)
    (toGC gc) (castPtr aPtr) (fromIntegral (length points))

-- | Draw a line into a 'Drawable'.
--
-- * The parameters are x1, y1, x2, y2.
--
-- * Drawing several separate lines can be done more efficiently by
--   'drawSegments'.
--
drawLine :: DrawableClass d => d -> GC -> Point -> Point -> IO ()
drawLine d gc (x1,y1) (x2,y2) = {#call unsafe draw_line#} (toDrawable d)
  (toGC gc) (fromIntegral x1) (fromIntegral y1) (fromIntegral x2) 
  (fromIntegral y2)

-- | Draw several lines.
--
-- * The function uses the current line width, dashing and especially the
--   joining specification in the graphics context (in contrast to
--   'drawSegments'.
--
drawLines :: DrawableClass d => d -> GC -> [Point] -> IO ()
drawLines d gc []     = return ()
drawLines d gc points =
  withArray (concatMap (\(x,y) -> [fromIntegral x, fromIntegral y]) points) $
  \(aPtr :: Ptr {#type gint#}) -> {#call unsafe draw_lines#} (toDrawable d)
    (toGC gc) (castPtr aPtr) (fromIntegral (length points))

#if GTK_CHECK_VERSION(2,2,0)
-- | Render a 'Pixbuf'.
--
-- * Renders a rectangular portion of a 'Pixbuf' to a
--   'Drawable'. The @srcX@, @srcY@,
--   @srcWidth@ and @srcHeight@ specify what part of the
--   'Pixbuf' should be rendered. The latter two values may be
--   @-1@ in which case the width and height are taken from
--   @pb@. The image is placed at @destX@, @destY@.
--   If you render parts of an image at a time, set @ditherX@ and
--   @ditherY@ to the origin of the image you are rendering.
--
-- * Since 2.2.
--
drawPixbuf :: DrawableClass d => d -> GC -> Pixbuf -> Int -> Int ->
				 Int -> Int -> Int -> Int -> Dither ->
				 Int -> Int -> IO ()
drawPixbuf d gc pb srcX srcY destX destY srcWidth srcHeight dither
  xDither yDither = {#call unsafe draw_pixbuf#} (toDrawable d)
    gc pb (fromIntegral srcX) (fromIntegral srcY) (fromIntegral destX)
    (fromIntegral destY) (fromIntegral srcWidth) (fromIntegral srcHeight)
    ((fromIntegral . fromEnum) dither) (fromIntegral xDither)
    (fromIntegral yDither)

#endif

-- | Draw several unconnected lines.
--
-- * This method draws several unrelated lines.
--
drawSegments :: DrawableClass d => d -> GC -> [(Point,Point)] -> IO ()
drawSegments d gc []  = return ()
drawSegments d gc pps = withArray (concatMap (\((x1,y1),(x2,y2)) -> 
  [fromIntegral x1, fromIntegral y1, fromIntegral x2, fromIntegral y2])
  pps) $ \(aPtr :: Ptr {#type gint#}) ->
    {#call unsafe draw_segments#} (toDrawable d) (toGC gc)
    (castPtr aPtr) (fromIntegral (length pps))

-- | Draw a rectangular object.
--
-- * Draws a rectangular outline or filled rectangle, using the
--   foreground color and other attributes of the 'GC'.
--
-- * A rectangle drawn filled is 1 pixel smaller in both dimensions
--   than a rectangle outlined. Calling 'drawRectangle' w gc
--   True 0 0 20 20 results in a filled rectangle 20 pixels wide and 20
--   pixels high. Calling 'drawRectangle' d gc False 0 0 20 20
--   results in an outlined rectangle with corners at (0, 0), (0, 20), (20,
--   20), and (20, 0), which makes it 21 pixels wide and 21 pixels high.
--
drawRectangle :: DrawableClass d => d -> GC -> Bool -> Int -> Int ->
				       Int -> Int -> IO ()
drawRectangle d gc filled x y width height = {#call unsafe draw_rectangle#}
  (toDrawable d) (toGC gc) (fromBool filled) (fromIntegral x)
  (fromIntegral y) (fromIntegral width) (fromIntegral height)

-- | Draws an arc or a filled 'pie slice'.
--
-- * The arc is defined by the bounding rectangle of the entire
--   ellipse, and the start and end angles of the part of the ellipse to be
--   drawn.
--
-- * The starting angle @aStart@ is relative to the 3 o'clock
--   position, counter-clockwise, in 1\/64ths of a degree. @aEnd@
--   is measured similarly, but relative to @aStart@.
--
drawArc :: DrawableClass d => d -> GC -> Bool -> Int -> Int ->
				 Int -> Int -> Int -> Int -> IO ()
drawArc d gc filled x y width height aStart aEnd =
  {#call unsafe draw_arc#} (toDrawable d) (toGC gc) (fromBool filled)
  (fromIntegral x) (fromIntegral y) (fromIntegral width) (fromIntegral height)
  (fromIntegral aStart) (fromIntegral aEnd)

-- | Draws an outlined or filled polygon.
--
-- * The polygon is closed automatically, connecting the last point to
--   the first point if necessary.
--
drawPolygon :: DrawableClass d => d -> GC -> Bool -> [Point] -> IO ()
drawPolygon _ _ _ [] = return ()
drawPolygon d gc filled points = 
  withArray (concatMap (\(x,y) -> [fromIntegral x, fromIntegral y]) points) $
  \(aPtr::Ptr {#type gint#}) -> {#call unsafe draw_polygon#} (toDrawable d)
  (toGC gc) (fromBool filled) (castPtr aPtr) (fromIntegral (length points))

-- | Draw a single line of text.
--
-- * The @x@ coordinate specifies the start of the string,
--   the @y@ coordinate specifies the base line.
--
drawLayoutLine :: DrawableClass d => d -> GC -> Int -> Int -> LayoutLine ->
				     IO ()
drawLayoutLine d gc x y text =
  {#call unsafe draw_layout_line#} (toDrawable d) (toGC gc)
    (fromIntegral x) (fromIntegral y) text

-- | Draw a single line of text.
--
-- * The @x@ coordinate specifies the start of the string,
--   the @y@ coordinate specifies the base line.
--
-- * If both colors are @Nothing@ this function will behave like
--   'drawLayoutLine' in that it uses the default colors from
--   the graphics context.
--
drawLayoutLineWithColors :: DrawableClass d => d -> GC -> Int -> Int ->
			    LayoutLine -> Maybe Color -> Maybe Color -> IO ()
drawLayoutLineWithColors d gc x y text foreground background = let
    withMB :: Storable a => Maybe a -> (Ptr a -> IO b) -> IO b
    withMB Nothing f = f nullPtr
    withMB (Just x) f = with x f
  in
    withMB foreground $ \fPtr -> withMB background $ \bPtr ->
    {#call unsafe draw_layout_line_with_colors#} (toDrawable d) (toGC gc)
      (fromIntegral x) (fromIntegral y) text (castPtr fPtr) (castPtr bPtr)


-- | Draw a paragraph of text.
--
-- * The @x@ and @y@ values specify the upper left
--   point of the layout. 
--
drawLayout :: DrawableClass d => d -> GC -> Int -> Int -> PangoLayout -> IO ()
drawLayout d gc x y text =
  {#call unsafe draw_layout#} (toDrawable d) (toGC gc)
    (fromIntegral x) (fromIntegral y) (toPangoLayout text)

-- | Draw a paragraph of text.
--
-- * The @x@ and @y@ values specify the upper left
--   point of the layout. 
--
-- * If both colors are @Nothing@ this function will behave like
--   'drawLayout' in that it uses the default colors from
--   the graphics context.
--
drawLayoutWithColors :: DrawableClass d => d -> GC -> Int -> Int ->
			PangoLayout -> Maybe Color -> Maybe Color -> IO ()
drawLayoutWithColors d gc x y text foreground background = let
    withMB :: Storable a => Maybe a -> (Ptr a -> IO b) -> IO b
    withMB Nothing f = f nullPtr
    withMB (Just x) f = with x f
  in
    withMB foreground $ \fPtr -> withMB background $ \bPtr ->
    {#call unsafe draw_layout_with_colors#} (toDrawable d) (toGC gc)
      (fromIntegral x) (fromIntegral y) (toPangoLayout text)
      (castPtr fPtr) (castPtr bPtr)


-- | Copies another 'Drawable'.
--
-- * Copies the (width,height) region of the @src@ at coordinates
--   (@xSrc@, @ySrc@) to coordinates (@xDest@,
--   @yDest@) in the @dest@. The @width@ and\/or
--   @height@ may be given as -1, in which case the entire source
--   drawable will be copied.
--
-- * Most fields in @gc@ are not used for this operation, but
--   notably the clip mask or clip region will be honored.  The source and
--   destination drawables must have the same visual and colormap, or
--   errors will result. (On X11, failure to match visual\/colormap results
--   in a BadMatch error from the X server.)  A common cause of this
--   problem is an attempt to draw a bitmap to a color drawable. The way to
--   draw a bitmap is to set the bitmap as a clip mask on your
--   'GC', then use 'drawRectangle' to draw a 
--   rectangle clipped to the bitmap.
--
drawDrawable :: (DrawableClass src, DrawableClass dest) => 
		dest -> GC -> src -> Int -> Int -> Int -> Int -> 
		Int -> Int -> IO ()
drawDrawable dest gc src xSrc ySrc xDest yDest width height =
  {#call unsafe draw_drawable#} (toDrawable dest) (toGC gc)
  (toDrawable src)
  (fromIntegral xSrc) (fromIntegral ySrc) (fromIntegral xDest)
  (fromIntegral yDest) (fromIntegral width) (fromIntegral height)



--- NEW FILE: Region.chs.pp ---
--  -*-haskell-*-
--  GIMP Toolkit (GTK) Region
--
--  Author : Axel Simon
--  Created: 22 September 2002
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:14 $
--
--  Copyright (c) 2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 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
--  Library General Public License for more details.
--
-- |
--
-- A set of rectangles describing areas to be redrawn.
--
-- * Regions consist of a set of non-overlapping rectangles. They are used to
--   specify the area of a window which needs updating.
--
-- TODO
--
-- * The Span functions and callbacks are not implemented since retrieving
--   a set of rectangles and working on them within Haskell seems to be easier.
--
module Region(
  makeNewRegion,
  Region(Region),
  regionNew,
  FillRule(..),
  regionPolygon,
  regionCopy,
  regionRectangle,
  regionGetClipbox,
  regionGetRectangles,
  regionEmpty,
  regionEqual,
  regionPointIn,
  OverlapType(..),
  regionRectIn,
  regionOffset,
  regionShrink,
  regionUnionWithRect,
  regionIntersect,
  regionUnion,
  regionSubtract,
  regionXor) where

import Monad	(liftM)
import FFI
import Structs	(Point, Rectangle(..))
import GdkEnums (FillRule(..), OverlapType(..))

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

{#pointer *GdkRegion as Region foreign newtype #}

-- Construct a region from a pointer.
--
makeNewRegion :: Ptr Region -> IO Region
makeNewRegion rPtr = do
  region <- newForeignPtr rPtr (region_destroy rPtr)
  return (Region region)

#if __GLASGOW_HASKELL__>=600

foreign import ccall unsafe "&gdk_region_destroy"
  region_destroy' :: FinalizerPtr Region

region_destroy :: Ptr Region -> FinalizerPtr Region
region_destroy _ = region_destroy'

#elif __GLASGOW_HASKELL__>=504

foreign import ccall unsafe "gdk_region_destroy"
  region_destroy :: Ptr Region -> IO ()

#else

foreign import ccall "gdk_region_destroy" unsafe
  region_destroy :: Ptr Region -> IO ()

#endif


-- | Create an empty region.
--
regionNew :: IO Region
regionNew = do
  rPtr <- {#call unsafe region_new#}
  makeNewRegion rPtr

-- | Convert a polygon into a 'Region'.
--
regionPolygon :: [Point] -> FillRule -> IO Region
regionPolygon points rule =
  withArray (concatMap (\(x,y) -> [fromIntegral x, fromIntegral y]) points) $
  \(aPtr :: Ptr {#type gint#}) -> do
    rPtr <- {#call unsafe region_polygon#} (castPtr aPtr) 
	    (fromIntegral (length points)) ((fromIntegral.fromEnum) rule)
    makeNewRegion rPtr

-- | Copy a 'Region'.
--
regionCopy :: Region -> IO Region
regionCopy r = do
  rPtr <- {#call unsafe region_copy#} r
  makeNewRegion rPtr

-- | Convert a rectangle to a 'Region'.
--
regionRectangle :: Rectangle -> IO Region
regionRectangle rect = withObject rect $ \rectPtr -> do
  regPtr <- {#call unsafe region_rectangle#} (castPtr rectPtr)
  makeNewRegion regPtr

-- | Smallest rectangle including the 
-- 'Region'.
--
regionGetClipbox :: Region -> IO Rectangle
regionGetClipbox r = alloca $ \rPtr -> do
  {#call unsafe region_get_clipbox#} r (castPtr rPtr)
  peek rPtr

-- | Turn the 'Region' into its rectangles.
--
-- * A 'Region' is a set of horizontal bands. Each band
--   consists of one or more rectangles of the same height. No rectangles
--   in a band touch.
--
regionGetRectangles :: Region -> IO [Rectangle]
regionGetRectangles r = 
  alloca $ \(aPtr :: Ptr Rectangle) -> 
  alloca $ \(iPtr :: Ptr {#type gint#}) -> do
    {#call unsafe region_get_rectangles#} r (castPtr aPtr) iPtr
    size <- peek iPtr
    regs <- peekArray (fromIntegral size) aPtr
    {#call unsafe g_free#} (castPtr aPtr)
    return regs

-- | Test if a 'Region' is empty.
--
regionEmpty :: Region -> IO Bool
regionEmpty r = liftM toBool $ {#call unsafe region_empty#} r

-- | Compares two 'Region's for equality.
--
regionEqual :: Region -> Region -> IO Bool
regionEqual r1 r2 = liftM toBool $ {#call unsafe region_equal#} r1 r2

-- | Checks if a point it is within a region.
--
regionPointIn :: Region -> Point -> IO Bool
regionPointIn r (x,y) = liftM toBool $ 
  {#call unsafe region_point_in#} r (fromIntegral x) (fromIntegral y)

-- | Check if a rectangle is within a region.
--
regionRectIn :: Region -> Rectangle -> IO OverlapType
regionRectIn reg rect = liftM (toEnum.fromIntegral) $ withObject rect $
  \rPtr -> {#call unsafe region_rect_in#} reg (castPtr rPtr)

-- | Move a region.
--
regionOffset :: Region -> Int -> Int -> IO ()
regionOffset r dx dy = 
  {#call unsafe region_offset#} r (fromIntegral dx) (fromIntegral dy)

-- | Move a region.
--
-- * Positive values shrink the region, negative values expand it.
--
regionShrink :: Region -> Int -> Int -> IO ()
regionShrink r dx dy = 
  {#call unsafe region_shrink#} r (fromIntegral dx) (fromIntegral dy)

-- | Updates the region to include the rectangle.
--
regionUnionWithRect :: Region -> Rectangle -> IO ()
regionUnionWithRect reg rect = withObject rect $ \rPtr ->
  {#call unsafe region_union_with_rect#} reg (castPtr rPtr)

-- | Intersects one region with another.
--
-- * Changes @reg1@ to include the common areas of @reg1@
--   and @reg2@.
--
regionIntersect :: Region -> Region -> IO ()
regionIntersect reg1 reg2 = {#call unsafe region_intersect#} reg1 reg2

-- | Unions one region with another.
--
-- * Changes @reg1@ to include @reg1@ and @reg2@.
--
regionUnion :: Region -> Region -> IO ()
regionUnion reg1 reg2 = {#call unsafe region_union#} reg1 reg2

-- | Removes pars of a 'Region'.
--
-- * Reduces the region @reg1@ so that is does not include any areas
--   of @reg2@.
--
regionSubtract :: Region -> Region -> IO ()
regionSubtract reg1 reg2 = {#call unsafe region_subtract#} reg1 reg2

-- | XORs two 'Region's.
--
-- * The exclusive or of two regions contains all areas which were not
--   overlapping. In other words, it is the union of the regions minus
--   their intersections.
--
regionXor :: Region -> Region -> IO ()
regionXor reg1 reg2 = {#call unsafe region_xor#} reg1 reg2



--- Drawable.chs.cpp DELETED ---

--- Region.chs.cpp DELETED ---

[Gtk2hs-commit] gtk2hs/gtk/abstract ButtonBox.chs.pp,NONE,1.1 FileChooser.chs.pp,NONE,1.1 Object.chs.pp,NONE,1.1 Paned.chs.pp,NONE,1.1 ButtonBox.chs.cpp,1.1,NONE FileChooser.chs.cpp,1.1,NONE Object.chs.cpp,1.1,NONE Paned.chs.cpp,1.1,NONE

[Axel S. <as...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/gtk/abstract
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2280/gtk/abstract

Added Files:
	ButtonBox.chs.pp FileChooser.chs.pp Object.chs.pp Paned.chs.pp 
Removed Files:
	ButtonBox.chs.cpp FileChooser.chs.cpp Object.chs.cpp 
	Paned.chs.cpp 
Log Message:
Renamed files that need CPP pre-processing to .chs.pp instead of .chs.cpp
since the latter makes automake think we are compiling C++.



--- NEW FILE: Object.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Object
--
--  Author : Axel Simon
--          
--  Created: 9 April 2001
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:13 $
--
--  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.
--
-- |
--
-- Widget representation
--
-- * Each widget is a represented as a purely abstract data type. It can only 
--   be accessed through and the special access functions that are defined
--   in each widget file.
--
module Object(
  Object,
  ObjectClass,
  castToObject,
  objectSink,
  makeNewObject,
  objectSetProperty,
  objectGetProperty
  ) where

import FFI

import GObject		(objectRef, objectUnref)
{#import Signal#}
{#import Hierarchy#}
{#import GValue#}
import StoreValue

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

-- methods

-- turn the initial floating state to sunk
--
-- * The floating\/sunk concept of a GTK object is not very useful to us.
--   The following procedure circumvents the whole subject and ensures 
--   proper cleanup:
--     on creation:      objectRef, objectSink
--     on finalization:  objectUnref
--
-- * This function cannot be bound by c2hs because it is not possible to
--   override the pointer hook.
objectSink :: ObjectClass obj => Ptr obj -> IO ()
objectSink = object_sink.castPtr

#if __GLASGOW_HASKELL__>=504

foreign import ccall unsafe "gtk_object_sink"
  object_sink :: Ptr Object -> IO ()

#else

foreign import ccall "gtk_object_sink" unsafe 
  object_sink :: Ptr Object -> IO ()

#endif

-- This is a convenience function to generate a new widget. It adds the
-- finalizer with the method described under objectSink.
--
-- * The constr argument is the contructor of the specific object.
--
makeNewObject :: ObjectClass obj => 
  (ForeignPtr obj -> obj) -> IO (Ptr obj) -> IO obj
makeNewObject constr generator = do
  objPtr <- generator
  objectRef objPtr
  obj <- newForeignPtr objPtr (objectUnref objPtr)
  objectSink objPtr
  return $ constr obj


-- Sets a specific attribute of this object.
--
-- * Most attributes in a widget can be set and retrieved by passing the
--   name (as a string) and the value to special set\/get functions. These
--   are undocumented because each derived objects implements custom (and
--   welltyped) set and get functions for most attributes.
--
objectSetProperty :: GObjectClass gobj => gobj -> String -> GenericValue -> 
					  IO ()
objectSetProperty obj prop val = alloca $ \vaPtr -> withUTFString prop $ 
  \sPtr -> poke vaPtr val >> {#call unsafe g_object_set_property#} 
  (toGObject obj) sPtr vaPtr >> valueUnset vaPtr
  

-- Gets a specific attribute of this object.
--
-- * See 'objectSetProperty'.
--
objectGetProperty :: GObjectClass gobj => gobj -> String -> 
					IO GenericValue
objectGetProperty obj prop = alloca $ \vaPtr -> withUTFString prop $ \str -> do
  {#call unsafe g_object_get_property#} (toGObject obj) str vaPtr
  res <- peek vaPtr
  valueUnset vaPtr
  return res


--- Paned.chs.cpp DELETED ---

--- FileChooser.chs.cpp DELETED ---

--- ButtonBox.chs.cpp DELETED ---

--- Object.chs.cpp DELETED ---

--- NEW FILE: Paned.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget Paned
--
--  Author : Axel Simon
--          
--  Created: 15 May 2001
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:13 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
-- |
--
-- This abstract widget provides a division line with a handle that can be
-- used by the user to divide the given space between two widgets. The two
-- concrete implementations are HPaned and VPaned.
--
module Paned(
  Paned,
  PanedClass,
  castToPaned,
  panedAdd1,
  panedAdd2,
  panedPack1,
  panedPack2,
  panedSetPosition,
  panedGetPosition
#if GTK_CHECK_VERSION(2,4,0)
 ,panedGetChild1,
  panedGetChild2
#endif
  ) where

import Monad	(liftM)
import FFI

import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}

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

-- methods

-- | Add a widget to the first (top or left) area.
--
-- * The widget does not expand if 'Paned' expands. It does not shrink either.
--
panedAdd1 :: (PanedClass p, WidgetClass w) => p -> w -> IO ()
panedAdd1 p w = {#call paned_add1#} (toPaned p) (toWidget w)

-- | Add a widget to the second (bottom or right) area.
--
-- * The widget does not expand if 'Paned' expands. But it does shrink.
--
panedAdd2 :: (PanedClass p, WidgetClass w) => p -> w -> IO ()
panedAdd2 p w = {#call paned_add2#} (toPaned p) (toWidget w)

-- | Add a widget to the first area and specify its resizing behaviour.
--
panedPack1 :: (PanedClass p, WidgetClass w) => p -> w -> Bool -> Bool -> IO ()
panedPack1 p w expand shrink = {#call paned_pack1#} 
  (toPaned p) (toWidget w) (fromBool expand) (fromBool shrink)

-- | Add a widget to the second area and specify its resizing behaviour.
--
panedPack2 :: (PanedClass p, WidgetClass w) => p -> w -> Bool -> Bool -> IO ()
panedPack2 p w expand shrink = {#call paned_pack2#} 
  (toPaned p) (toWidget w) (fromBool expand) (fromBool shrink)

-- | Set the gutter to the specified @position@ (in pixels).
--
panedSetPosition :: PanedClass p => p -> Int -> IO ()
panedSetPosition p position = 
  {#call paned_set_position#} (toPaned p) (fromIntegral position)

-- | Get the gutter position (in pixels).
--
panedGetPosition :: PanedClass p => p -> IO Int
panedGetPosition p = liftM fromIntegral $
  {#call unsafe paned_get_position#} (toPaned p)

#if GTK_CHECK_VERSION(2,4,0)
-- | Obtains the first child of the paned widget.
--
panedGetChild1 :: PanedClass p => p -> IO Widget
panedGetChild1 p =
  makeNewObject mkWidget $ {#call unsafe paned_get_child1#} (toPaned p)

-- | Obtains the second child of the paned widget.
--
panedGetChild2 :: PanedClass p => p -> IO Widget
panedGetChild2 p =
  makeNewObject mkWidget $ {#call unsafe paned_get_child2#} (toPaned p)
#endif

--- NEW FILE: FileChooser.chs.pp ---
-- GIMP Toolkit (GTK) Binding for Haskell: binding to GConf   -*-haskell-*-
--    for storing and retrieving configuartion information
--
--  Author : Duncan Coutts
--  Created: 24 April 2004
--
--  Copyright (c) 2004 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 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
--  Library General Public License for more details.
--
-- |
--
--  The file chooser dialog and widget is a replacement
--  for the old "FileSel"ection dialog. It provides a better user
--  interface and an improved API.
--
--  The FileChooser (as opposed to the dialog or widget) is the interface that
--  the "FileChooserDialog" and "FileChooserWidget" implement, all the operations
--  except construction are on this interface.
--
-- * Added in GTK+ 2.4
--
module FileChooser (
#if GTK_CHECK_VERSION(2,4,0)
  FileChooserClass,
  FileChooser,
  FileChooserAction(..),
  fileChooserSetAction,
  fileChooserGetAction,
  fileChooserSetLocalOnly,
  fileChooserGetLocalOnly,
  fileChooserSetSelectMultiple,
  fileChooserGetSelectMultiple,
  fileChooserSetCurrentName,
  fileChooserGetFilename,
  fileChooserSetFilename,
  fileChooserSelectFilename,
  fileChooserUnselectFilename,
  fileChooserSelectAll,
  fileChooserUnselectAll,
  fileChooserGetFilenames,
  fileChooserSetCurrentFolder,
  fileChooserGetCurrentFolder,
  fileChooserGetURI,
  fileChooserSetURI,
  fileChooserSelectURI,
  fileChooserUnselectURI,
  fileChooserGetURIs,
  fileChooserSetCurrentFolderURI,
  fileChooserGetCurrentFolderURI,
  fileChooserSetPreviewWidget,
  fileChooserGetPreviewWidget,
  fileChooserSetPreviewWidgetActive,
  fileChooserGetPreviewWidgetActive,
  fileChooserSetUsePreviewLabel,
  fileChooserGetUsePreviewLabel,
  fileChooserGetPreviewFilename,
  fileChooserGetPreviewURI,
  fileChooserSetExtraWidget,
  fileChooserGetExtraWidget,
  fileChooserAddFilter,
  fileChooserRemoveFilter,
  fileChooserListFilters,
  fileChooserSetFilter,
  fileChooserGetFilter,
  fileChooserAddShortcutFolder,
  fileChooserRemoveShortcutFolder,
  fileChooserlistShortcutFolders,
  fileChooserAddShortcutFolderURI,
  fileChooserRemoveShortcutFolderURI,
  fileChooserListShortcutFolderURIs,
  onCurrentFolderChanged,
  afterCurrentFolderChanged,
  onFileActivated,
  afterFileActivated,
--  onSelectionChanged,
--  afterSelectionChanged,
  onUpdatePreview,
  afterUpdatePreview
#endif
) where

#if GTK_CHECK_VERSION(2,4,0)

import Monad (liftM, when)
import FFI
{#import Hierarchy#}
import Object		(makeNewObject)
import Signal
{#import GList#}
import GError (propagateGError, GErrorDomain, GErrorClass(..))

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

{# enum FileChooserAction {underscoreToCase} #}
{# enum FileChooserError {underscoreToCase} #}

fileChooserErrorDomain :: GErrorDomain
fileChooserErrorDomain = unsafePerformIO {#call unsafe file_chooser_error_quark#}
                                                                                                         
instance GErrorClass FileChooserError where
  gerrorDomain _ = fileChooserErrorDomain

fileChooserSetAction :: FileChooserClass chooser => chooser -> FileChooserAction -> IO ()
fileChooserSetAction chooser action =
  {# call gtk_file_chooser_set_action #} (toFileChooser chooser)
    (fromIntegral $ fromEnum action)

fileChooserGetAction :: FileChooserClass chooser => chooser ->  IO FileChooserAction
fileChooserGetAction chooser = liftM (toEnum . fromIntegral) $
  {# call gtk_file_chooser_get_action #} (toFileChooser chooser)

fileChooserSetLocalOnly :: FileChooserClass chooser => chooser -> Bool -> IO ()
fileChooserSetLocalOnly chooser localOnly = 
  {# call gtk_file_chooser_set_local_only #} (toFileChooser chooser)
    (fromBool localOnly)

fileChooserGetLocalOnly :: FileChooserClass chooser => chooser -> IO Bool
fileChooserGetLocalOnly chooser = liftM toBool $
  {# call gtk_file_chooser_get_local_only #} (toFileChooser chooser)

fileChooserSetSelectMultiple :: FileChooserClass chooser => chooser -> Bool -> IO ()
fileChooserSetSelectMultiple chooser selectMultiple = 
  {# call gtk_file_chooser_set_select_multiple #} (toFileChooser chooser)
    (fromBool selectMultiple)

fileChooserGetSelectMultiple :: FileChooserClass chooser => chooser -> IO Bool
fileChooserGetSelectMultiple chooser = liftM toBool $
  {# call gtk_file_chooser_get_select_multiple #} (toFileChooser chooser)

fileChooserSetCurrentName :: FileChooserClass chooser => chooser -> String -> IO ()
fileChooserSetCurrentName chooser name =
  withCString name $ \strPtr ->
  {# call gtk_file_chooser_set_current_name #} (toFileChooser chooser) strPtr

fileChooserGetFilename :: FileChooserClass chooser => chooser -> IO (Maybe String)
fileChooserGetFilename chooser = do
  strPtr <- {# call gtk_file_chooser_get_filename #} (toFileChooser chooser)
  maybePeek readCString strPtr

fileChooserSetFilename :: FileChooserClass chooser => chooser -> String -> IO Bool
fileChooserSetFilename chooser filename = liftM toBool $
  withCString filename $ \strPtr ->
  {# call gtk_file_chooser_set_filename #} (toFileChooser chooser) strPtr

fileChooserSelectFilename :: FileChooserClass chooser => chooser -> String -> IO Bool
fileChooserSelectFilename chooser filename = liftM toBool $
  withCString filename $ \strPtr ->
  {# call gtk_file_chooser_select_filename #} (toFileChooser chooser) strPtr

fileChooserUnselectFilename :: FileChooserClass chooser => chooser -> String -> IO ()
fileChooserUnselectFilename chooser filename = 
  withCString filename $ \strPtr ->
  {# call gtk_file_chooser_unselect_filename #} (toFileChooser chooser) strPtr

fileChooserSelectAll :: FileChooserClass chooser => chooser -> IO ()
fileChooserSelectAll chooser = 
  {# call gtk_file_chooser_select_all #} (toFileChooser chooser)

fileChooserUnselectAll :: FileChooserClass chooser => chooser -> IO ()
fileChooserUnselectAll chooser = 
  {# call gtk_file_chooser_unselect_all #} (toFileChooser chooser)

fileChooserGetFilenames :: FileChooserClass chooser => chooser -> IO [String]
fileChooserGetFilenames chooser = do
  strList <- {# call gtk_file_chooser_get_filenames #} (toFileChooser chooser)
  fromStringGSList strList

fileChooserSetCurrentFolder :: FileChooserClass chooser => chooser -> String -> IO Bool
fileChooserSetCurrentFolder chooser foldername = liftM toBool $
  withCString foldername $ \strPtr ->
  {# call gtk_file_chooser_set_current_folder #} (toFileChooser chooser) strPtr

fileChooserGetCurrentFolder :: FileChooserClass chooser => chooser -> IO (Maybe String)
fileChooserGetCurrentFolder chooser = do
  strPtr <- {# call gtk_file_chooser_get_current_folder #} (toFileChooser chooser)
  maybePeek readCString strPtr

fileChooserGetURI :: FileChooserClass chooser => chooser -> IO (Maybe String)
fileChooserGetURI chooser = do
  strPtr <- {# call gtk_file_chooser_get_uri #} (toFileChooser chooser)
  maybePeek readCString strPtr

fileChooserSetURI :: FileChooserClass chooser => chooser -> String -> IO Bool
fileChooserSetURI chooser uri = liftM toBool $
  withCString uri $ \strPtr ->
  {# call gtk_file_chooser_set_uri #} (toFileChooser chooser) strPtr

fileChooserSelectURI :: FileChooserClass chooser => chooser -> String -> IO Bool
fileChooserSelectURI chooser uri = liftM toBool $
  withCString uri $ \strPtr ->
  {# call gtk_file_chooser_select_uri #} (toFileChooser chooser) strPtr

fileChooserUnselectURI :: FileChooserClass chooser => chooser -> String -> IO ()
fileChooserUnselectURI chooser uri = 
  withCString uri $ \strPtr ->
  {# call gtk_file_chooser_unselect_uri #} (toFileChooser chooser) strPtr

fileChooserGetURIs :: FileChooserClass chooser => chooser -> IO [String]
fileChooserGetURIs chooser = do
  strList <- {# call gtk_file_chooser_get_uris #} (toFileChooser chooser)
  fromStringGSList strList

fileChooserSetCurrentFolderURI :: FileChooserClass chooser => chooser -> String -> IO Bool
fileChooserSetCurrentFolderURI chooser uri = liftM toBool $
  withCString uri $ \strPtr ->
  {# call gtk_file_chooser_set_current_folder_uri #} (toFileChooser chooser) strPtr

fileChooserGetCurrentFolderURI :: FileChooserClass chooser => chooser -> IO String
fileChooserGetCurrentFolderURI chooser = do
  strPtr <- {# call gtk_file_chooser_get_current_folder_uri #} (toFileChooser chooser)
  readCString strPtr

fileChooserSetPreviewWidget :: (FileChooserClass chooser, WidgetClass widget) =>
                               chooser -> widget -> IO ()
fileChooserSetPreviewWidget chooser widget = 
  {# call gtk_file_chooser_set_preview_widget #} (toFileChooser chooser)
    (toWidget widget)

fileChooserGetPreviewWidget :: FileChooserClass chooser => chooser -> IO (Maybe Widget)
fileChooserGetPreviewWidget chooser = do
  ptr <- {# call gtk_file_chooser_get_preview_widget #} (toFileChooser chooser)
  maybePeek (makeNewObject mkWidget . return) ptr

fileChooserSetPreviewWidgetActive :: FileChooserClass chooser => chooser -> Bool -> IO ()
fileChooserSetPreviewWidgetActive chooser active = 
  {# call gtk_file_chooser_set_preview_widget_active #} (toFileChooser chooser)
    (fromBool active)

fileChooserGetPreviewWidgetActive :: FileChooserClass chooser => chooser -> IO Bool
fileChooserGetPreviewWidgetActive chooser = liftM toBool $
  {# call gtk_file_chooser_get_preview_widget_active #} (toFileChooser chooser)

fileChooserSetUsePreviewLabel :: FileChooserClass chooser => chooser -> Bool -> IO ()
fileChooserSetUsePreviewLabel chooser usePreview = 
  {# call gtk_file_chooser_set_use_preview_label #} (toFileChooser chooser)
    (fromBool usePreview)

fileChooserGetUsePreviewLabel :: FileChooserClass chooser => chooser -> IO Bool
fileChooserGetUsePreviewLabel chooser = liftM toBool $
  {# call gtk_file_chooser_get_use_preview_label #} (toFileChooser chooser)

fileChooserGetPreviewFilename :: FileChooserClass chooser => chooser -> IO (Maybe String)
fileChooserGetPreviewFilename chooser = do
  strPtr <- {# call gtk_file_chooser_get_preview_filename #} (toFileChooser chooser)
  maybePeek readCString strPtr

fileChooserGetPreviewURI :: FileChooserClass chooser => chooser -> IO (Maybe String)
fileChooserGetPreviewURI chooser = do
  strPtr <- {# call gtk_file_chooser_get_preview_uri #} (toFileChooser chooser)
  maybePeek readCString strPtr

fileChooserSetExtraWidget :: (FileChooserClass chooser, WidgetClass widget) =>
                             chooser -> widget -> IO ()
fileChooserSetExtraWidget chooser widget = 
  {# call gtk_file_chooser_set_extra_widget #} (toFileChooser chooser)
    (toWidget widget)

fileChooserGetExtraWidget :: FileChooserClass chooser => chooser -> IO (Maybe Widget)
fileChooserGetExtraWidget chooser = do
  ptr <- {# call gtk_file_chooser_get_extra_widget #} (toFileChooser chooser)
  maybePeek (makeNewObject mkWidget . return) ptr

fileChooserAddFilter :: FileChooserClass chooser => chooser -> FileFilter -> IO ()
fileChooserAddFilter chooser filter = 
  {# call gtk_file_chooser_add_filter #} (toFileChooser chooser) filter

fileChooserRemoveFilter :: FileChooserClass chooser => chooser -> FileFilter -> IO ()
fileChooserRemoveFilter chooser filter = 
  {# call gtk_file_chooser_remove_filter #} (toFileChooser chooser) filter

fileChooserListFilters :: FileChooserClass chooser => chooser -> IO [FileFilter]
fileChooserListFilters chooser = do
  filterList <- {# call gtk_file_chooser_list_filters #} (toFileChooser chooser)
  filterPtrs <- fromGSList filterList
  mapM (makeNewObject mkFileFilter . return) filterPtrs

fileChooserSetFilter :: FileChooserClass chooser => chooser -> FileFilter -> IO ()
fileChooserSetFilter chooser filter = 
  {# call gtk_file_chooser_set_filter #} (toFileChooser chooser) filter

fileChooserGetFilter :: FileChooserClass chooser => chooser -> IO (Maybe FileFilter)
fileChooserGetFilter chooser = do
  ptr <- {# call gtk_file_chooser_get_filter #} (toFileChooser chooser)
  maybePeek (makeNewObject mkFileFilter . return) ptr

fileChooserAddShortcutFolder :: FileChooserClass chooser => chooser -> String -> IO ()
fileChooserAddShortcutFolder chooser foldername =
  propagateGError $ \gerrorPtr ->
  withCString foldername $ \strPtr -> do
  {# call gtk_file_chooser_add_shortcut_folder #} (toFileChooser chooser)
    strPtr gerrorPtr
  return ()

fileChooserRemoveShortcutFolder :: FileChooserClass chooser => chooser -> String -> IO ()
fileChooserRemoveShortcutFolder chooser foldername =
  propagateGError $ \gerrorPtr ->
  withCString foldername $ \strPtr -> do
  {# call gtk_file_chooser_remove_shortcut_folder #} (toFileChooser chooser)
    strPtr gerrorPtr
  return ()

fileChooserlistShortcutFolders :: FileChooserClass chooser => chooser -> IO [String]
fileChooserlistShortcutFolders chooser = do
  strList <- {# call gtk_file_chooser_list_shortcut_folders #}
    (toFileChooser chooser)
  fromStringGSList strList

fileChooserAddShortcutFolderURI :: FileChooserClass chooser => chooser -> String -> IO ()
fileChooserAddShortcutFolderURI chooser folderuri =
  propagateGError $ \gerrorPtr ->
  withCString folderuri $ \strPtr -> do
  {# call gtk_file_chooser_add_shortcut_folder_uri #} (toFileChooser chooser)
    strPtr gerrorPtr
  return ()

fileChooserRemoveShortcutFolderURI :: FileChooserClass chooser => chooser -> String -> IO ()
fileChooserRemoveShortcutFolderURI chooser folderuri =
  propagateGError $ \gerrorPtr ->
  withCString folderuri $ \strPtr -> do
  {# call gtk_file_chooser_remove_shortcut_folder_uri #}
    (toFileChooser chooser) strPtr gerrorPtr
  return ()

fileChooserListShortcutFolderURIs :: FileChooserClass chooser => chooser -> IO [String]
fileChooserListShortcutFolderURIs chooser = do
  strList <- {# call gtk_file_chooser_list_shortcut_folder_uris #}
    (toFileChooser chooser)
  fromStringGSList strList

onCurrentFolderChanged, afterCurrentFolderChanged :: FileChooserClass c => c -> IO () -> IO (ConnectId c)
onCurrentFolderChanged = connect_NONE__NONE "current-folder-changed" False
afterCurrentFolderChanged = connect_NONE__NONE "current-folder-changed" True

onFileActivated, afterFileActivated :: FileChooserClass c => c -> IO () -> IO (ConnectId c)
onFileActivated = connect_NONE__NONE "file-activated" False
afterFileActivated = connect_NONE__NONE "file-activated" True

--onSelectionChanged, afterSelectionChanged :: FileChooserClass c => c -> IO () -> IO (ConnectId c)
--onSelectionChanged = connect_NONE__NONE "selection-changed" False
--afterSelectionChanged = connect_NONE__NONE "selection-changed" True

onUpdatePreview, afterUpdatePreview :: FileChooserClass c => c -> IO () -> IO (ConnectId c)
onUpdatePreview = connect_NONE__NONE "update-preview" False
afterUpdatePreview = connect_NONE__NONE "update-preview" True


------------------------------------------------------
-- Utility functions that really ought to go elsewhere

-- convenience functions for GSlists of strings
fromStringGSList :: GSList -> IO [String]
fromStringGSList strList = do
  strPtrs <- fromGSList strList
  mapM readCString strPtrs

toStringGSList :: [String] -> IO GSList
toStringGSList strs = do
  strPtrs <- mapM newCString strs
  toGSList strPtrs

#endif


--- NEW FILE: ButtonBox.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget ButtonBox
--
--  Author : Matthew Walton
--          
--  Created: 28 April 2004
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:13 $
--
--  Copyright (c) 2004 Matthew Walton
--
--  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.
--
-- |
--
module ButtonBox(
  ButtonBox,
  ButtonBoxClass,
  castToButtonBox,
  buttonBoxGetLayout,
  buttonBoxSetLayout,
  buttonBoxSetChildSecondary,
#if GTK_CHECK_VERSION(2,4,0)
  buttonBoxGetChildSecondary
#endif
  ) where

import Monad (liftM)
import FFI

import Object (makeNewObject)
{#import Hierarchy#}
{#import Signal#}

import Enums (ButtonBoxStyle)

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

-- methods

-- | Retrieve the method being used to
-- arrange the buttons in the button box
--
buttonBoxGetLayout :: ButtonBoxClass b => b -> IO ButtonBoxStyle
buttonBoxGetLayout b = liftM (toEnum . fromIntegral) $
  {#call gtk_button_box_get_layout#} (toButtonBox b)

#if GTK_CHECK_VERSION(2,4,0)
-- | Returns whether child should appear
-- in a secondary group of children
--
-- * Since Gtk 2.4.
buttonBoxGetChildSecondary :: (ButtonBoxClass b, WidgetClass w) => b -> w -> IO Bool
buttonBoxGetChildSecondary b w = liftM toBool $
  {#call gtk_button_box_get_child_secondary#} (toButtonBox b) (toWidget w)
#endif

-- | Changes the way buttons are arranged in their container
--
buttonBoxSetLayout :: ButtonBoxClass b => b -> ButtonBoxStyle -> IO ()
buttonBoxSetLayout b l =
  {#call gtk_button_box_set_layout#} (toButtonBox b)
    ((fromIntegral . fromEnum) l)

-- | Sets whether child should appear in a secondary
-- group of children. A typical use of a secondary child is the help button in a dialog.
--
-- * This group appears after the other children if the style is 'ButtonboxStart',
-- 'ButtonboxSpread' or 'ButtonboxEdge', and before the the other children if the
-- style is 'ButtonboxEnd'. For horizontal button boxes, the definition of before\/after
-- depends on direction of the widget (see 'widgetSetDirection'). If the style is
-- 'buttonBoxStart' or 'buttonBoxEnd', then the secondary children are aligned at
-- the other end of the button box from the main children. For the other styles,
-- they appear immediately next to the main children.
--
buttonBoxSetChildSecondary :: (ButtonBoxClass b, WidgetClass w) => b -> w -> Bool -> IO ()
buttonBoxSetChildSecondary b w s =
  {#call gtk_button_box_set_child_secondary #} (toButtonBox b) (toWidget w)
    (fromBool s)

[Gtk2hs-commit] gtk2hs/gtk/entry Editable.chs.pp,NONE,1.1 Entry.chs.pp,NONE,1.1 EntryCompletion.chs.pp,NONE,1.1 Editable.chs.cpp,1.1,NONE Entry.chs.cpp,1.1,NONE EntryCompletion.chs.cpp,1.1,NONE

[Axel S. <as...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/gtk/entry
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2280/gtk/entry

Added Files:
	Editable.chs.pp Entry.chs.pp EntryCompletion.chs.pp 
Removed Files:
	Editable.chs.cpp Entry.chs.cpp EntryCompletion.chs.cpp 
Log Message:
Renamed files that need CPP pre-processing to .chs.pp instead of .chs.cpp
since the latter makes automake think we are compiling C++.



--- EntryCompletion.chs.cpp DELETED ---

--- NEW FILE: Editable.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Interface Editable
--
--  Author : Axel Simon, Duncan Coutts
--          
--  Created: 30 July 2004
--  split off from Entry.chs
--
--  Copyright (c) 1999..2002 Axel Simon
--  modified 2004 Duncan Coutts
--
--  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.
--
-- |
--
-- * This is an interface for simple single-line text editing widgets. It is
--   implemented by "Entry" and "SpinButton".
--
-- * TODO
--
-- * Find out if \"insert-text\" signal is useful and how to bind it. It is
--   tricky because it has an in-out parameter.
--
module Editable(
  -- * Data types
  Editable,
  EditableClass,
  castToEditable,

  -- * Methods
  editableSelectRegion,
  editableGetSelectionBounds,
  editableInsertText,
  editableDeleteText,
  editableGetChars,
  editableCutClipboard,
  editableCopyClipboard,
  editablePasteClipboard,
  editableDeleteSelection,
  editableSetEditable,
  editableGetEditable,
  editableSetPosition,
  editableGetPosition,
  
  -- * Signals
  onEditableChanged,
  afterEditableChanged,
  onDeleteText,
  afterDeleteText,
  ) where

import Monad	(liftM)
import FFI

import Object	(makeNewObject)
import GObject (makeNewGObject)
{#import Hierarchy#}
{#import Signal#}

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

-- | Select a span of text.
--
-- * A negative @end@ position will make the selection extend to the
--   end of the buffer.
--
-- * Calling this function with @start@=1 and @end@=4 it will
--   mark \"ask\" in the string \"Haskell\". (FIXME: verify)
--
editableSelectRegion :: EditableClass ed => ed -> Int -> Int -> IO ()
editableSelectRegion ed start end =
  {#call editable_select_region#} (toEditable ed)
    (fromIntegral start) (fromIntegral end)

-- | Get the span of the current selection.
--
-- * The returned tuple is not ordered. The second index represents the
--   position of the cursor. The first index is the other end of the
--   selection. If both numbers are equal there is in fact no selection.
--
editableGetSelectionBounds :: EditableClass ed => ed -> IO (Int,Int)
editableGetSelectionBounds ed = alloca $ \startPtr -> alloca $ \endPtr -> do
  {#call unsafe editable_get_selection_bounds#} (toEditable ed) startPtr endPtr
  start <- liftM fromIntegral $ peek startPtr
  end	<- liftM fromIntegral $ peek endPtr
  return (start,end)

-- | Insert new text at the specified position.
--
-- * If the position is invalid the text will be inserted at the end of the
--   buffer. The returned value reflects the actual insertion point.
--
editableInsertText :: EditableClass ed => ed -> String -> Int -> IO Int
editableInsertText ed str pos = withObject (fromIntegral pos) $ \posPtr ->
  withUTFStringLen str $ \(strPtr,len) -> do
    {#call editable_insert_text#} (toEditable ed) strPtr (fromIntegral len) 
      posPtr
    liftM fromIntegral $ peek posPtr

-- | Delete a given range of text.
--
-- * If the @end@ position is invalid, it is set to the lenght of the
--   buffer.
--
-- * @start@ is restricted to 0..@end@.
--
editableDeleteText :: EditableClass ed => ed -> Int -> Int -> IO ()
editableDeleteText ed start end = {#call editable_delete_text#} (toEditable ed)
  (fromIntegral start) (fromIntegral end)

-- | Retrieve a range of characters.
--
-- * Set @end@ to a negative value to reach the end of the buffer.
--
editableGetChars :: EditableClass ed => ed -> Int -> Int -> IO String
editableGetChars ed start end = do
  strPtr <- {#call unsafe editable_get_chars#} (toEditable ed) 
    (fromIntegral start) (fromIntegral end)
  str <- peekUTFString strPtr
  {#call unsafe g_free#} (castPtr strPtr)
  return str

-- | Cut the selected characters to the Clipboard.
--
editableCutClipboard :: EditableClass ed => ed -> IO ()
editableCutClipboard  = {#call editable_cut_clipboard#}.toEditable

-- | Copy the selected characters to the Clipboard.
--
editableCopyClipboard :: EditableClass ed => ed -> IO ()
editableCopyClipboard  = {#call editable_copy_clipboard#}.toEditable

-- | Paste the selected characters to the
-- Clipboard.
--
editablePasteClipboard :: EditableClass ed => ed -> IO ()
editablePasteClipboard  = {#call editable_paste_clipboard#}.toEditable

-- | Delete the current selection.
--
editableDeleteSelection :: EditableClass ed => ed -> IO ()
editableDeleteSelection  = {#call editable_delete_selection#}.toEditable

-- | Set the cursor to a specific position.
--
editableSetPosition :: EditableClass ed => ed -> Int -> IO ()
editableSetPosition ed pos = 
  {#call editable_set_position#} (toEditable ed) (fromIntegral pos)

-- | Get the current cursor position.
--
editableGetPosition :: EditableClass ed => ed -> IO Int
editableGetPosition ed = liftM fromIntegral $
  {#call unsafe editable_get_position#} (toEditable ed)

-- | Make the widget insensitive.
--
-- * Called with False will make the text uneditable.
--
editableSetEditable :: EditableClass ed => ed -> Bool -> IO ()
editableSetEditable ed isEditable = {#call editable_set_editable#}
  (toEditable ed) (fromBool isEditable)

-- | Retrieves whether the text is editable.
--
editableGetEditable :: EditableClass ed => ed -> IO Bool
editableGetEditable ed =
  liftM toBool $ {#call editable_get_editable#} (toEditable ed)
  

-- signals

-- | Emitted when the settings of the 'Editable' widget changes.
--
onEditableChanged, afterEditableChanged :: EditableClass ec => ec -> IO () ->
                                     IO (ConnectId ec)
onEditableChanged = connect_NONE__NONE "changed" False
afterEditableChanged = connect_NONE__NONE "changed" True

-- | Emitted when a piece of text is deleted from the 'Editable' widget.
--
onDeleteText, afterDeleteText :: EditableClass ec => ec ->
                                 (Int -> Int -> IO ()) -> IO (ConnectId ec)
onDeleteText = connect_INT_INT__NONE "delete_text" False
afterDeleteText = connect_INT_INT__NONE "delete_text" True


--- NEW FILE: Entry.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget Entry
--
--  Author : Axel Simon
--          
--  Created: 23 May 2001
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:13 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
-- |
--
-- * This widget lets the user enter a single line of text.
--
-- * TODO
--
-- * A couple of signals are not bound because I could not figure out what
--   they mean. Some of them do not seem to be emitted at all.
--
module Entry(
  Entry,
  EntryClass,
  castToEntry,
  entryNew,
  entrySetText,
  entryGetText,
#ifndef DISABLE_DEPRECATED
  entryAppendText,
  entryPrependText,
#endif
  entrySetVisibility,
  entryGetVisibility,
  entrySetInvisibleChar,
  entryGetInvisibleChar,
  entrySetMaxLength,
  entryGetActivatesDefault,
  entrySetActivatesDefault,
  entryGetHasFrame,
  entrySetHasFrame,
  entryGetWidthChars,
  entrySetWidthChars,
#if GTK_CHECK_VERSION(2,4,0)
  entrySetAlignment,
  entryGetAlignment,
  entrySetCompletion,
  entryGetCompletion,
#endif
  onEntryActivate,
  afterEntryActivate,
  onCopyClipboard,
  afterCopyClipboard,
  onCutClipboard,
  afterCutClipboard,
  onPasteClipboard,
  afterPasteClipboard,
  onInsertAtCursor,
  afterInsertAtCursor,
  onToggleOverwrite,
  afterToggleOverwrite
  ) where

import Monad	(liftM)
import FFI

import Object	(makeNewObject)
import GObject (makeNewGObject)
{#import Hierarchy#}
{#import Signal#}
import Char	(ord, chr)

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

-- GtkEntry implements the GtkEditable interface
instance EditableClass Entry

-- methods

-- | Create a new 'Entry' widget.
--
entryNew :: IO Entry
entryNew  = makeNewObject mkEntry $ liftM castPtr $ {#call unsafe entry_new#}

-- | Set the text of the 'Entry' widget.
--
entrySetText :: EntryClass ec => ec -> String -> IO ()
entrySetText ec str = withUTFString str $ {#call entry_set_text#} (toEntry ec)

-- | Get the text of the 'Entry' widget.
--
entryGetText :: EntryClass ec => ec -> IO String
entryGetText ec = {#call entry_get_text#} (toEntry ec) >>= peekUTFString

#ifndef DISABLE_DEPRECATED
-- | Append to the text of the 'Entry' widget.
--
entryAppendText :: EntryClass ec => ec -> String -> IO ()
entryAppendText ec str = 
  withUTFString str $ {#call entry_append_text#} (toEntry ec)

-- | Prepend the text of the 'Entry' widget.
--
entryPrependText :: EntryClass ec => ec -> String -> IO ()
entryPrependText ec str = 
  withUTFString str $ {#call entry_prepend_text#} (toEntry ec)
#endif

-- | Set whether to use password mode (display stars instead of the text).
--
-- * The replacement character can be changed with 'entrySetInvisibleChar'.
--
entrySetVisibility :: EntryClass ec => ec -> Bool -> IO ()
entrySetVisibility ec visible =
  {#call entry_set_visibility#} (toEntry ec) (fromBool visible)

-- | Get whether widget is in password mode.
--
entryGetVisibility :: EntryClass ec => ec -> IO Bool
entryGetVisibility ec =
  liftM toBool $ {#call entry_get_visibility#} (toEntry ec)

-- | Set the replacement character for invisible text.
--
entrySetInvisibleChar :: EntryClass ec => ec -> Char -> IO ()
entrySetInvisibleChar ec ch =
  {#call unsafe entry_set_invisible_char#} (toEntry ec) ((fromIntegral.ord) ch)

-- | Get the current replacement character for invisible text,
-- or 0 if not in password mode.
--
entryGetInvisibleChar :: EntryClass ec => ec -> IO Char
entryGetInvisibleChar ec = liftM (chr.fromIntegral) $
  {#call unsafe entry_get_invisible_char#} (toEntry ec)

-- | Sets a maximum length the text may grow to.
--
-- * A negative number resets the restriction.
--
entrySetMaxLength :: EntryClass ec => ec -> Int -> IO ()
entrySetMaxLength ec max = 
  {#call entry_set_max_length#} (toEntry ec) (fromIntegral max)

-- | Gets a maximum length the text is allowed to grow to.
--
entryGetMaxLength :: EntryClass ec => ec -> IO Int
entryGetMaxLength ec =
  liftM fromIntegral $ {#call unsafe entry_get_max_length#} (toEntry ec)

-- | Query whether pressing return will activate the default widget.
--
entryGetActivatesDefault :: EntryClass ec => ec -> IO Bool
entryGetActivatesDefault ec = liftM toBool $
  {#call unsafe entry_get_activates_default#} (toEntry ec)

-- | Specify if pressing return will activate
-- the default widget.
--
-- * This setting is useful in 'Dialog' boxes where enter should press
--   the default button.
--
entrySetActivatesDefault :: EntryClass ec => ec -> Bool -> IO ()
entrySetActivatesDefault ec setting = {#call entry_set_activates_default#}
  (toEntry ec) (fromBool setting)

-- | Query if the text 'Entry' is displayed with a frame around it.
--
entryGetHasFrame :: EntryClass ec => ec -> IO Bool
entryGetHasFrame ec = liftM toBool $
  {#call unsafe entry_get_has_frame#} (toEntry ec)

-- | Specifies whehter the 'Entry' should be in an etched-in frame.
--
entrySetHasFrame :: EntryClass ec => ec -> Bool -> IO ()
entrySetHasFrame ec setting = {#call entry_set_has_frame#}
  (toEntry ec) (fromBool setting)

-- | Retrieve the number of characters the widget should ask for.
--
entryGetWidthChars :: EntryClass ec => ec -> IO Int
entryGetWidthChars ec = liftM fromIntegral $ 
  {#call unsafe entry_get_width_chars#} (toEntry ec)

-- | Specifies how large the 'Entry' should be in characters.
--
-- * This setting is only considered when the widget formulates its size
--   request. Make sure that it is not mapped (shown) before you change this
--   value.
--
entrySetWidthChars :: EntryClass ec => ec -> Int -> IO ()
entrySetWidthChars ec setting = {#call entry_set_width_chars#}
  (toEntry ec) (fromIntegral setting)

#if GTK_CHECK_VERSION(2,4,0)
-- | Sets the alignment for the contents of the entry. This controls the
-- horizontal positioning of the contents when the displayed text is shorter
-- than the width of the entry.
--
-- * Since gtk 2.4
--
entrySetAlignment :: EntryClass ec => ec -> Float -> IO ()
entrySetAlignment ec xalign =
  {#call entry_set_alignment#} (toEntry ec) (realToFrac xalign)

-- | Gets the value set by 'entrySetAlignment'.
--
-- * Since gtk 2.4
--
entryGetAlignment :: EntryClass ec => ec -> IO Float
entryGetAlignment ec =
  liftM realToFrac $ {#call unsafe entry_get_alignment#} (toEntry ec)

-- | Sets the auxiliary completion object to use with the entry. All further
-- configuration of the completion mechanism is done on completion using the
-- "EntryCompletion" API.
--
-- * Since gtk 2.4
--
entrySetCompletion :: EntryClass ec => ec -> EntryCompletion -> IO ()
entrySetCompletion ec completion = {#call gtk_entry_set_completion#}
  (toEntry ec) completion

-- | Returns the auxiliary completion object currently in use by the entry.
--
-- * Since gtk 2.4
--
entryGetCompletion :: EntryClass ec => ec -> IO EntryCompletion
entryGetCompletion ec =
  makeNewGObject mkEntryCompletion $
  {#call gtk_entry_get_completion#} (toEntry ec)
#endif


-- signals

-- | Emitted when the user presses return within
-- the 'Entry' field.
--
onEntryActivate, afterEntryActivate :: EntryClass ec => ec -> IO () ->
                                       IO (ConnectId ec)
onEntryActivate = connect_NONE__NONE "activate" False
afterEntryActivate = connect_NONE__NONE "activate" True

-- | Emitted when the settings of the
-- 'Entry' widget changes.
--
onEntryChanged, afterEntryChanged :: EntryClass ec => ec -> IO () ->
                                     IO (ConnectId ec)
onEntryChanged = connect_NONE__NONE "changed" False
afterEntryChanged = connect_NONE__NONE "changed" True

-- | Emitted when the current selection has been
-- copied to the clipboard.
--
onCopyClipboard, afterCopyClipboard :: EntryClass ec => ec -> IO () ->
                                       IO (ConnectId ec)
onCopyClipboard = connect_NONE__NONE "copy_clipboard" False
afterCopyClipboard = connect_NONE__NONE "copy_clipboard" True

-- | Emitted when the current selection has been
-- cut to the clipboard.
--
onCutClipboard, afterCutClipboard :: EntryClass ec => ec -> IO () ->
                                     IO (ConnectId ec)
onCutClipboard = connect_NONE__NONE "cut_clipboard" False
afterCutClipboard = connect_NONE__NONE "cut_clipboard" True

-- | Emitted when the current selection has
-- been pasted from the clipboard.
--
onPasteClipboard, afterPasteClipboard :: EntryClass ec => ec -> IO () ->
                                         IO (ConnectId ec)
onPasteClipboard = connect_NONE__NONE "paste_clipboard" False
afterPasteClipboard = connect_NONE__NONE "paste_clipboard" True

-- | Emitted when a piece of text is deleted from
-- the 'Entry'.
--
onDeleteText, afterDeleteText :: EntryClass ec => ec ->
                                 (Int -> Int -> IO ()) -> IO (ConnectId ec)
onDeleteText = connect_INT_INT__NONE "delete_text" False
afterDeleteText = connect_INT_INT__NONE "delete_text" True

-- | Emitted when a piece of text is inserted
-- at the cursor position.
--
onInsertAtCursor, afterInsertAtCursor :: EntryClass ec => ec ->
                                         (String -> IO ()) ->
                                         IO (ConnectId ec)
onInsertAtCursor = connect_STRING__NONE "insert_at_cursor" False
afterInsertAtCursor = connect_STRING__NONE "insert_at_cursor" True

-- | Emitted when the user changes from
-- overwriting to inserting.
--
onToggleOverwrite, afterToggleOverwrite :: EntryClass ec => ec -> IO () ->
                                           IO (ConnectId ec)
onToggleOverwrite = connect_NONE__NONE "toggle_overwrite" False
afterToggleOverwrite = connect_NONE__NONE "toggle_overwrite" True

--- Entry.chs.cpp DELETED ---

--- NEW FILE: EntryCompletion.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) entry Widget EntryCompletion
--
--  Author : Duncan Coutts
--  Created: 24 April 2004
--
--  Copyright (c) 2004 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 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
--  Library General Public License for more details.
--
-- |
--
-- Completion functionality for the Entry widget.
--
-- * Added in GTK+ 2.4
--
module EntryCompletion (
#if GTK_CHECK_VERSION(2,4,0)
  EntryCompletion,
  EntryCompletionClass,
  entryCompletionNew,
  entryCompletionGetEntry,
  entryCompletionSetModel,
  entryCompletionGetModel,
  entryCompletionSetMatchFunc,
  entryCompletionSetMinimumKeyLength,
  entryCompletionGetMinimumKeyLength,
  entryCompletionComplete,
  entryCompletionInsertActionText,
  entryCompletionInsertActionMarkup,
  entryCompletionDeleteAction,
  entryCompletionSetTextColumn
#endif
) where

#if GTK_CHECK_VERSION(2,4,0)

import Monad	(liftM)
import FFI
import LocalData (newIORef, readIORef, writeIORef)

import GObject (makeNewGObject)
import Object  (makeNewObject)
{#import Hierarchy#}
{#import Signal#}
{#import TreeModel#} (TreeIter, createTreeIter)

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

entryCompletionNew :: IO EntryCompletion
entryCompletionNew =
  makeNewGObject mkEntryCompletion $ liftM castPtr $
  {# call gtk_entry_completion_new #}

entryCompletionGetEntry :: EntryCompletion -> IO (Maybe Entry)
entryCompletionGetEntry ec = do
  entryPtr <- {# call gtk_entry_completion_get_entry #} ec
  if entryPtr == nullPtr
    then return Nothing
    else liftM Just $ makeNewObject mkEntry $ return (castPtr entryPtr)

entryCompletionSetModel :: EntryCompletion ->  TreeModel -> IO ()
entryCompletionSetModel ec tm =
  {# call gtk_entry_completion_set_model #} ec tm

entryCompletionGetModel :: EntryCompletion -> IO TreeModel
entryCompletionGetModel ec =
  makeNewGObject mkTreeModel $
  {# call gtk_entry_completion_get_model #} ec

entryCompletionSetMatchFunc :: EntryCompletion -> (String -> TreeIter -> IO ()) -> IO ()
entryCompletionSetMatchFunc ec handler =
  connect_GtkEntryCompletionMatchFunc ec handler

entryCompletionSetMinimumKeyLength :: EntryCompletion -> Int -> IO ()
entryCompletionSetMinimumKeyLength ec minLength =
  {# call gtk_entry_completion_set_minimum_key_length #} ec
    (fromIntegral minLength)

entryCompletionGetMinimumKeyLength :: EntryCompletion -> IO Int
entryCompletionGetMinimumKeyLength ec =
  liftM fromIntegral $
  {# call gtk_entry_completion_get_minimum_key_length #} ec

entryCompletionComplete :: EntryCompletion -> IO ()
entryCompletionComplete ec =
  {# call gtk_entry_completion_complete #} ec

entryCompletionInsertActionText :: EntryCompletion -> Int -> String -> IO ()
entryCompletionInsertActionText ec index text =
  withUTFString text $ \strPtr ->
  {# call gtk_entry_completion_insert_action_text #} ec
    (fromIntegral index) strPtr

entryCompletionInsertActionMarkup :: EntryCompletion -> Int -> String -> IO ()
entryCompletionInsertActionMarkup ec index markup =
  withUTFString markup $ \strPtr ->
  {# call gtk_entry_completion_insert_action_markup #} ec
    (fromIntegral index) strPtr 

entryCompletionDeleteAction :: EntryCompletion -> Int -> IO ()
entryCompletionDeleteAction ec index =
  {# call gtk_entry_completion_delete_action #} ec (fromIntegral index)

entryCompletionSetTextColumn :: EntryCompletion -> Int -> IO ()
entryCompletionSetTextColumn ec column =
  {# call gtk_entry_completion_set_text_column #} ec (fromIntegral column)


-------------------------------------------------
-- Callback stuff for entryCompletionSetMatchFunc
--
{#pointer GDestroyNotify#}

foreign import ccall "wrapper" mkDestructor :: IO () -> IO GDestroyNotify

type GtkEntryCompletionMatchFunc =
  Ptr EntryCompletion -> --GtkEntryCompletion *completion
  Ptr CChar ->           --const gchar *key
  Ptr TreeIter ->        --GtkTreeIter *iter
  Ptr () ->              --gpointer user_data
  IO ()

foreign import ccall "wrapper" mkHandler_GtkEntryCompletionMatchFunc ::
  GtkEntryCompletionMatchFunc -> 
  IO (FunPtr GtkEntryCompletionMatchFunc)

connect_GtkEntryCompletionMatchFunc :: EntryCompletion ->
                                       (String -> TreeIter -> IO ()) ->
                                       IO ()
connect_GtkEntryCompletionMatchFunc ec user = do
  hPtr <- mkHandler_GtkEntryCompletionMatchFunc
    (\_ keyPtr iterPtr _ -> do key <- peekUTFString keyPtr
                               iter <- createTreeIter iterPtr
                               user key iter)
  dRef <- newIORef nullFunPtr
  dPtr <- mkDestructor $ do
    freeHaskellFunPtr hPtr
    dPtr <- readIORef dRef
    freeHaskellFunPtr dPtr
  writeIORef dRef dPtr
  {# call gtk_entry_completion_set_match_func #} ec
    (castFunPtr hPtr) nullPtr dPtr
#endif

--- Editable.chs.cpp DELETED ---

[Gtk2hs-commit] gtk2hs/gtk/buttons Button.chs.pp,NONE,1.1 Button.chs.cpp,1.1,NONE

[Axel S. <as...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/gtk/buttons
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2280/gtk/buttons

Added Files:
	Button.chs.pp 
Removed Files:
	Button.chs.cpp 
Log Message:
Renamed files that need CPP pre-processing to .chs.pp instead of .chs.cpp
since the latter makes automake think we are compiling C++.



--- NEW FILE: Button.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget Button
--
--  Author : Axel Simon
--          
--  Created: 15 May 2001
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:13 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
-- |
--
module Button(
  Button,
  ButtonClass,
  castToButton,
  buttonNew,
  buttonNewWithLabel,
  buttonNewWithMnemonic,
  buttonNewFromStock,
  buttonPressed,
  buttonReleased,
  buttonClicked,
  buttonEnter,
  buttonLeave,
  ReliefStyle(..),
  buttonSetRelief,
  buttonGetRelief,
  buttonSetLabel,
  buttonGetLabel,
  buttonSetUseStock,
  buttonGetUseStock,
  buttonSetUseUnderline,
  buttonGetUseUnderline,
#if GTK_CHECK_VERSION(2,4,0)
  buttonSetFocusOnClick,
  buttonGetFocusOnClick,
  buttonSetAlignment,
  buttonGetAlignment,
#endif
  onButtonActivate,
  afterButtonActivate,
  onClicked,
  afterClicked,
  onEnter,
  afterEnter,
  onLeave,
  afterLeave,
  onPressed,
  afterPressed,
  onReleased,
  afterReleased
  ) where

import Monad	(liftM)
import FFI

import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Enums	(ReliefStyle(..))

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

-- methods

-- | Create a new Button widget.
--
buttonNew :: IO Button
buttonNew  = makeNewObject mkButton $ liftM castPtr {#call unsafe button_new#}


-- | Create a button with a label in it.
--
buttonNewWithLabel :: String -> IO Button
buttonNewWithLabel lbl = withUTFString lbl (\strPtr ->
  makeNewObject mkButton $ liftM castPtr $
  {#call unsafe button_new_with_label#} strPtr)

-- | Create a button with an accelerator key.
--
-- * Like 'buttonNewWithLabel' but turns every underscore in the
--   label to a underlined character which then acts as a mnemonic (keyboard
--   shortcut).
--
buttonNewWithMnemonic :: String -> IO Button
buttonNewWithMnemonic lbl = withUTFString lbl (\strPtr ->
  makeNewObject mkButton $ liftM castPtr $ 
  {#call unsafe button_new_with_mnemonic#} strPtr)

-- | Create a stock (predefined appearance) button.
--
buttonNewFromStock :: String -> IO Button
buttonNewFromStock stockId = withUTFString stockId (\strPtr -> 
  makeNewObject mkButton $ liftM castPtr $
  throwIfNull "buttonNewFromStock: Invalid stock identifier." $ 
  {#call unsafe button_new_from_stock#} strPtr)

-- | Depress the button, i.e. emit the pressed signal.
--
buttonPressed :: ButtonClass b => b -> IO ()
buttonPressed b = {#call button_pressed#} (toButton b)

-- | Release the button, i.e. emit the released signal.
--
buttonReleased :: ButtonClass b => b -> IO ()
buttonReleased b = {#call button_released#} (toButton b)

-- | Emit the clicked signal on the button.
--
-- * This is similar to calling 'buttonPressed' and
--   'buttonReleased' in sequence.
--
buttonClicked :: ButtonClass b => b -> IO ()
buttonClicked b = {#call button_clicked#} (toButton b)

-- | Emit the cursor enters signal to the button.
--
buttonEnter :: ButtonClass b => b -> IO ()
buttonEnter b = {#call button_enter#} (toButton b)

-- | Emit the cursor leaves signal to the button.
--
buttonLeave :: ButtonClass b => b -> IO ()
buttonLeave b = {#call button_leave#} (toButton b)

-- | Set the style of the button edges.
--
buttonSetRelief :: ButtonClass b => b -> ReliefStyle -> IO ()
buttonSetRelief b rs = 
  {#call button_set_relief#} (toButton b) ((fromIntegral.fromEnum) rs)

-- | Get the current relief style.
--
buttonGetRelief :: ButtonClass b => b -> IO ReliefStyle
buttonGetRelief b = liftM (toEnum.fromIntegral) $
  {#call unsafe button_get_relief#} (toButton b)

-- | Set the text of the button.
--
buttonSetLabel :: ButtonClass b => b -> String -> IO ()
buttonSetLabel b lbl = withUTFString lbl $ \strPtr ->
  {#call button_set_label#} (toButton b) strPtr

-- | Get the current text on the button.
--
-- * The method returns the empty string in case the button does not have
--   a label (e.g. it was created with 'buttonNew'.
--
buttonGetLabel :: ButtonClass b => b -> IO String
buttonGetLabel b = do
  strPtr <- {#call unsafe button_get_label#} (toButton b)
  if strPtr==nullPtr then return "" else peekUTFString strPtr

-- | Set if the label is a stock identifier.
--
-- * Setting this property to @True@ will make the button lookup
--   its label in the table of stock items. If there is a match, the button
--   will use the stock item instead of the label.  You need to set this
--   flag before you change the label.
--
buttonSetUseStock :: ButtonClass b => b -> Bool -> IO ()
buttonSetUseStock b flag = 
  {#call button_set_use_stock#} (toButton b) (fromBool flag)

-- | Get the current flag for stock lookups.
--
buttonGetUseStock :: ButtonClass b => b -> IO Bool
buttonGetUseStock b = liftM toBool $
  {#call unsafe button_get_use_stock#} (toButton b)

-- | Set if the label has accelerators.
--
-- * Setting this property will make the button join any underline character
--   into the following letter and inserting this letter as a keyboard
--   shortcut. You need to set this flag before you change the label.
--
buttonSetUseUnderline :: ButtonClass b => b -> Bool -> IO ()
buttonSetUseUnderline b flag = 
  {#call button_set_use_underline#} (toButton b) (fromBool flag)

-- | Query if the underlines are mnemonics.
--
buttonGetUseUnderline :: ButtonClass b => b -> IO Bool
buttonGetUseUnderline b = liftM toBool $
  {#call unsafe button_get_use_underline#} (toButton b)

#if GTK_CHECK_VERSION(2,4,0)
-- | Sets whether the button will grab focus when it is clicked with the mouse.
--
buttonSetFocusOnClick :: ButtonClass b => b -> Bool -> IO ()
buttonSetFocusOnClick b focus =
  {#call unsafe button_set_focus_on_click#} (toButton b) (fromBool focus)

-- | Gets whether the button grabs focus when it is clicked with the mouse.
--
buttonGetFocusOnClick :: ButtonClass b => b -> IO Bool
buttonGetFocusOnClick b = liftM toBool $
  {#call unsafe button_get_focus_on_click#} (toButton b)

-- | Sets the alignment of the child. This has no effect unless the child
--   derives from "Misc" "Aligment".
--
buttonSetAlignment :: ButtonClass b => b -> (Float, Float) -> IO ()
buttonSetAlignment b (xalign, yalign) =
  {#call unsafe button_set_alignment#} (toButton b)
    (realToFrac xalign) (realToFrac yalign)

-- | Gets the alignment of the child in the button.
--
buttonGetAlignment :: ButtonClass b => b -> IO (Float, Float)
buttonGetAlignment b =
  alloca $ \xalignPtr -> alloca $ \yalignPtr -> do
  {#call unsafe button_get_alignment#} (toButton b) xalignPtr yalignPtr
  xalign <- peek xalignPtr
  yalign <- peek yalignPtr
  return (realToFrac xalign, realToFrac yalign)
#endif


-- signals

-- | The button has been depressed (but not
-- necessarily released yet). See @clicked@ signal.
--
onButtonActivate, afterButtonActivate :: ButtonClass b => b -> IO () ->
                                         IO (ConnectId b)
onButtonActivate = connect_NONE__NONE "activate"  False
afterButtonActivate = connect_NONE__NONE "activate"  True

-- | The button was clicked. This is only emitted if
-- the mouse cursor was over the button when it was released.
--
onClicked, afterClicked :: ButtonClass b => b -> IO () -> IO (ConnectId b)
onClicked = connect_NONE__NONE "clicked" False
afterClicked = connect_NONE__NONE "clicked" True

-- | The cursor enters the button box.
--
onEnter, afterEnter :: ButtonClass b => b -> IO () -> IO (ConnectId b)
onEnter = connect_NONE__NONE "enter" False
afterEnter = connect_NONE__NONE "enter" True

-- | The cursor leaves the button box.
--
onLeave, afterLeave :: ButtonClass b => b -> IO () -> IO (ConnectId b)
onLeave = connect_NONE__NONE "leave" False
afterLeave = connect_NONE__NONE "leave" True

-- | The button is pressed.
--
onPressed, afterPressed :: ButtonClass b => b -> IO () -> IO (ConnectId b)
onPressed = connect_NONE__NONE "pressed" False
afterPressed = connect_NONE__NONE "pressed" True


-- | The button is released.
--
onReleased, afterReleased :: ButtonClass b => b -> IO () -> IO (ConnectId b)
onReleased = connect_NONE__NONE "released" False
afterReleased = connect_NONE__NONE "released" True










--- Button.chs.cpp DELETED ---

[Gtk2hs-commit] gtk2hs/tools/c2hs/.deps - New directory

[Axel S. <as...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/tools/c2hs/.deps
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv8279/.deps

Log Message:
Directory /cvsroot/gtk2hs/gtk2hs/tools/c2hs/.deps added to the repository

[Gtk2hs-commit] gtk2hs/tools/c2hs configure,1.1.1.1,NONE

[Duncan C. <dun...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/tools/c2hs
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18149

Removed Files:
	configure 
Log Message:
./configure should never have been added to cvs in the first place.


--- configure DELETED ---

[Gtk2hs-commit] gtk2hs/tools/c2hs/base/general FiniteMaps.hs,1.1.1.1,NONE Sets.hs,1.1.1.1,NONE

[Duncan C. <dun...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/general
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17881/base/general

Removed Files:
	FiniteMaps.hs Sets.hs 
Log Message:
These modules are no longer needed, replaced by standard libs versions.


--- Sets.hs DELETED ---

--- FiniteMaps.hs DELETED ---

[Gtk2hs-commit] gtk2hs/tools/c2hs/base/general Binary.hs,NONE,1.1 FastMutInt.hs,NONE,1.1 Makefile,1.1.1.1,1.2 UNames.hs,1.1.1.1,1.2

[Duncan C. <dun...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/general
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15642/base/general

Modified Files:
	Makefile UNames.hs 
Added Files:
	Binary.hs FastMutInt.hs 
Log Message:
add Axel's --precomp patches with a binary serialisation framework derived from
the one used in ghc. This required makeing Position a proper data type.
Also converted to using Data.FiniteMap rather than the CTK FiniteMaps module.


Index: UNames.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/general/UNames.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- UNames.hs	13 Nov 2004 16:42:47 -0000	1.1.1.1
+++ UNames.hs	13 Nov 2004 17:26:50 -0000	1.2
@@ -51,11 +51,15 @@
 --
 
 module UNames (NameSupply, Name,
-	       rootSupply, splitSupply, names)
+	       rootSupply, splitSupply, names,
+	       saveRootNameSupply, restoreRootNameSupply)
 where
 
+import Monad  (when)
 import Ix
-import SysDep (IORef, unsafeNewIntRef, unsafeReadAndIncIntRef)
+import SysDep (IORef, readIORef, writeIORef,
+               unsafeNewIntRef, unsafeReadAndIncIntRef)
+import Binary (Binary(..))
 
 
 -- Name supply definition (EXPORTED ABSTRACTLY)
@@ -110,3 +114,34 @@
   theNames s
   where
     theNames s = Name (unsafeReadAndIncIntRef s) : theNames s
+
+-- Actions for saving and restoring the state of the whole program. (EXPORTED)
+-- The rules for these functions are as follows:
+--   you must not use the root name supply after saving it
+--   you must not use the root namue supply before restoring it
+-- Otherwise bad things will happen, your unique Ids will no longer be unique
+saveRootNameSupply :: IO Name
+saveRootNameSupply =
+  case rootSupply of
+    NameSupply ref -> do
+      val <- readIORef ref
+      writeIORef ref (error "UName: root name supply used after saving")
+      return (Name val)
+
+restoreRootNameSupply :: Name -> IO ()
+restoreRootNameSupply (Name val) = 
+  case rootSupply of
+    NameSupply ref -> do
+      prev <- readIORef ref
+      when (prev /= 1) (error "UName: root name supply used before restoring")
+      writeIORef ref val
+
+
+{-! for Name derive : GhcBinary !-}
+{-* Generated by DrIFT : Look, but Don't Touch. *-}
+instance Binary Name where
+    put_ bh (Name aa) = do
+            put_ bh aa
+    get bh = do
+    aa <- get bh
+    return (Name aa)

--- NEW FILE: Binary.hs ---
{-# OPTIONS -cpp -fglasgow-exts -O -funbox-strict-fields #-}
--
-- (c) The University of Glasgow 2002
--
-- Binary I/O library, with special tweaks for GHC
--
-- Based on the nhc98 Binary library, which is copyright
-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.
-- Under the terms of the license for that software, we must tell you
-- where you can obtain the original version of the Binary library, namely
--     http://www.cs.york.ac.uk/fp/nhc98/

module Binary
  ( {-type-}  Bin,
    {-class-} Binary(..),
    {-type-}  BinHandle,

   openBinIO, openBinIO_,
   openBinMem,
--   closeBin,

   seekBin,
   tellBin,
   castBin,

   writeBinMem,
   readBinMem,

   isEOFBin,

   -- for writing instances:
   putByte,
   getByte,
   putSharedString,
   getSharedString,

   -- lazy Bin I/O
   lazyGet,
   lazyPut,

   -- GHC only:
   ByteArray(..),
   getByteArray,
   putByteArray,

   getBinFileWithDict,	-- :: Binary a => FilePath -> IO a
   putBinFileWithDict,	-- :: Binary a => FilePath -> ModuleName -> a -> IO ()

  ) where

import FastMutInt

import Data.FiniteMap
import Data.HashTable as HashTable
import Data.Array.IO
import Data.Array
import Data.Bits
import Data.Int
import Data.Word
import Data.IORef
import Data.Char		( ord, chr )
import Data.Array.Base  	( unsafeRead, unsafeWrite )
import Control.Monad		( when )
import Control.Exception	( throwDyn )
import System.IO as IO
import System.IO.Unsafe		( unsafeInterleaveIO )
import System.IO.Error		( mkIOError, eofErrorType )
import GHC.Real			( Ratio(..) )
import GHC.Exts
import GHC.IOBase	 	( IO(..) )
import GHC.Word			( Word8(..) )
import System.IO		( openBinaryFile )

-- for debug
import System.CPUTime           (getCPUTime)
import Numeric                  (showFFloat)

#define SIZEOF_HSINT 4

type BinArray = IOUArray Int Word8

---------------------------------------------------------------
--		BinHandle
---------------------------------------------------------------

data BinHandle
  = BinMem {		-- binary data stored in an unboxed array
     bh_usr :: UserData,	-- sigh, need parameterized modules :-)
     off_r :: !FastMutInt,		-- the current offset
     sz_r  :: !FastMutInt,		-- size of the array (cached)
     arr_r :: !(IORef BinArray) 	-- the array (bounds: (0,size-1))
    }
	-- XXX: should really store a "high water mark" for dumping out
	-- the binary data to a file.

  | BinIO {		-- binary data stored in a file
     bh_usr :: UserData,
     off_r :: !FastMutInt,		-- the current offset (cached)
     hdl   :: !IO.Handle		-- the file handle (must be seekable)
   }
	-- cache the file ptr in BinIO; using hTell is too expensive
	-- to call repeatedly.  If anyone else is modifying this Handle
	-- at the same time, we'll be screwed.

getUserData :: BinHandle -> UserData
getUserData bh = bh_usr bh

setUserData :: BinHandle -> UserData -> BinHandle
setUserData bh us = bh { bh_usr = us }


---------------------------------------------------------------
--		Bin
---------------------------------------------------------------

newtype Bin a = BinPtr Int 
  deriving (Eq, Ord, Show, Bounded)

castBin :: Bin a -> Bin b
castBin (BinPtr i) = BinPtr i

---------------------------------------------------------------
--		class Binary
---------------------------------------------------------------

class Binary a where
    put_   :: BinHandle -> a -> IO ()
    put    :: BinHandle -> a -> IO (Bin a)
    get    :: BinHandle -> IO a

    -- define one of put_, put.  Use of put_ is recommended because it
    -- is more likely that tail-calls can kick in, and we rarely need the
    -- position return value.
    put_ bh a = do put bh a; return ()
    put bh a  = do p <- tellBin bh; put_ bh a; return p

putAt  :: Binary a => BinHandle -> Bin a -> a -> IO ()
putAt bh p x = do seekBin bh p; put bh x; return ()

getAt  :: Binary a => BinHandle -> Bin a -> IO a
getAt bh p = do seekBin bh p; get bh

openBinIO_ :: IO.Handle -> IO BinHandle
openBinIO_ h = openBinIO h 

openBinIO :: IO.Handle -> IO BinHandle
openBinIO h = do
  r <- newFastMutInt
  writeFastMutInt r 0
  return (BinIO noUserData r h)

openBinMem :: Int -> IO BinHandle
openBinMem size
 | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
 | otherwise = do
   arr <- newArray_ (0,size-1)
   arr_r <- newIORef arr
   ix_r <- newFastMutInt
   writeFastMutInt ix_r 0
   sz_r <- newFastMutInt
   writeFastMutInt sz_r size
   return (BinMem noUserData ix_r sz_r arr_r)

tellBin :: BinHandle -> IO (Bin a)
tellBin (BinIO  _ r _)   = do ix <- readFastMutInt r; return (BinPtr ix)
tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)

seekBin :: BinHandle -> Bin a -> IO ()
seekBin (BinIO _ ix_r h) (BinPtr p) = do 
  writeFastMutInt ix_r p
  hSeek h AbsoluteSeek (fromIntegral p)
seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do
  sz <- readFastMutInt sz_r
  if (p >= sz)
	then do expandBin h p; writeFastMutInt ix_r p
	else writeFastMutInt ix_r p

isEOFBin :: BinHandle -> IO Bool
isEOFBin (BinMem _ ix_r sz_r a) = do
  ix <- readFastMutInt ix_r
  sz <- readFastMutInt sz_r
  return (ix >= sz)
isEOFBin (BinIO _ ix_r h) = hIsEOF h

writeBinMem :: BinHandle -> FilePath -> IO ()
writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do
  h <- openBinaryFile fn WriteMode
  arr <- readIORef arr_r
  ix  <- readFastMutInt ix_r
  hPutArray h arr ix
  hClose h

readBinMem :: FilePath -> IO BinHandle
-- Return a BinHandle with a totally undefined State
readBinMem filename = do
  h <- openBinaryFile filename ReadMode
  filesize' <- hFileSize h
  let filesize = fromIntegral filesize'
  arr <- newArray_ (0,filesize-1)
  count <- hGetArray h arr filesize
  when (count /= filesize)
	(error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
  hClose h
  arr_r <- newIORef arr
  ix_r <- newFastMutInt
  writeFastMutInt ix_r 0
  sz_r <- newFastMutInt
  writeFastMutInt sz_r filesize
  return (BinMem noUserData ix_r sz_r arr_r)

-- expand the size of the array to include a specified offset
expandBin :: BinHandle -> Int -> IO ()
expandBin (BinMem _ ix_r sz_r arr_r) off = do
   sz <- readFastMutInt sz_r
   let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
   arr <- readIORef arr_r
   arr' <- newArray_ (0,sz'-1)
   sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
 	     | i <- [ 0 .. sz-1 ] ]
   writeFastMutInt sz_r sz'
   writeIORef arr_r arr'
#ifdef DEBUG
   hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
#endif
   return ()
expandBin (BinIO _ _ _) _ = return ()
	-- no need to expand a file, we'll assume they expand by themselves.

-- -----------------------------------------------------------------------------
-- Low-level reading/writing of bytes

putWord8 :: BinHandle -> Word8 -> IO ()
putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
    ix <- readFastMutInt ix_r
    sz <- readFastMutInt sz_r
	-- double the size of the array if it overflows
    if (ix >= sz) 
	then do expandBin h ix
		putWord8 h w
	else do arr <- readIORef arr_r
		unsafeWrite arr ix w
    		writeFastMutInt ix_r (ix+1)
    		return ()
putWord8 (BinIO _ ix_r h) w = do
    ix <- readFastMutInt ix_r
    hPutChar h (chr (fromIntegral w))	-- XXX not really correct
    writeFastMutInt ix_r (ix+1)
    return ()

getWord8 :: BinHandle -> IO Word8
getWord8 (BinMem _ ix_r sz_r arr_r) = do
    ix <- readFastMutInt ix_r
    sz <- readFastMutInt sz_r
    when (ix >= sz)  $
	ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
    arr <- readIORef arr_r
    w <- unsafeRead arr ix
    writeFastMutInt ix_r (ix+1)
    return w
getWord8 (BinIO _ ix_r h) = do
    ix <- readFastMutInt ix_r
    c <- hGetChar h
    writeFastMutInt ix_r (ix+1)
    return $! (fromIntegral (ord c))	-- XXX not really correct

putByte :: BinHandle -> Word8 -> IO ()
putByte bh w = put_ bh w

getByte :: BinHandle -> IO Word8
getByte = getWord8

-- -----------------------------------------------------------------------------
-- Primitve Word writes

instance Binary Word8 where
  put_ = putWord8
  get  = getWord8

instance Binary Word16 where
  put_ h w = do -- XXX too slow.. inline putWord8?
    putByte h (fromIntegral (w `shiftR` 8))
    putByte h (fromIntegral (w .&. 0xff))
  get h = do
    w1 <- getWord8 h
    w2 <- getWord8 h
    return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)


instance Binary Word32 where
  put_ h w = do
    putByte h (fromIntegral (w `shiftR` 24))
    putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
    putByte h (fromIntegral ((w `shiftR` 8)  .&. 0xff))
    putByte h (fromIntegral (w .&. 0xff))
  get h = do
    w1 <- getWord8 h
    w2 <- getWord8 h
    w3 <- getWord8 h
    w4 <- getWord8 h
    return $! ((fromIntegral w1 `shiftL` 24) .|. 
	       (fromIntegral w2 `shiftL` 16) .|. 
	       (fromIntegral w3 `shiftL`  8) .|. 
	       (fromIntegral w4))


instance Binary Word64 where
  put_ h w = do
    putByte h (fromIntegral (w `shiftR` 56))
    putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
    putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
    putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
    putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
    putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
    putByte h (fromIntegral ((w `shiftR`  8) .&. 0xff))
    putByte h (fromIntegral (w .&. 0xff))
  get h = do
    w1 <- getWord8 h
    w2 <- getWord8 h
    w3 <- getWord8 h
    w4 <- getWord8 h
    w5 <- getWord8 h
    w6 <- getWord8 h
    w7 <- getWord8 h
    w8 <- getWord8 h
    return $! ((fromIntegral w1 `shiftL` 56) .|. 
	       (fromIntegral w2 `shiftL` 48) .|. 
	       (fromIntegral w3 `shiftL` 40) .|. 
	       (fromIntegral w4 `shiftL` 32) .|. 
	       (fromIntegral w5 `shiftL` 24) .|. 
	       (fromIntegral w6 `shiftL` 16) .|. 
	       (fromIntegral w7 `shiftL`  8) .|. 
	       (fromIntegral w8))

-- -----------------------------------------------------------------------------
-- Primitve Int writes

instance Binary Int8 where
  put_ h w = put_ h (fromIntegral w :: Word8)
  get h    = do w <- get h; return $! (fromIntegral (w::Word8))

instance Binary Int16 where
  put_ h w = put_ h (fromIntegral w :: Word16)
  get h    = do w <- get h; return $! (fromIntegral (w::Word16))

instance Binary Int32 where
  put_ h w = put_ h (fromIntegral w :: Word32)
  get h    = do w <- get h; return $! (fromIntegral (w::Word32))

instance Binary Int64 where
  put_ h w = put_ h (fromIntegral w :: Word64)
  get h    = do w <- get h; return $! (fromIntegral (w::Word64))

-- -----------------------------------------------------------------------------
-- Instances for standard types

instance Binary () where
    put_ bh () = return ()
    get  _     = return ()
--    getF bh p  = case getBitsF bh 0 p of (_,b) -> ((),b)

instance Binary Bool where
    put_ bh b = putByte bh (fromIntegral (fromEnum b))
    get  bh   = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
--    getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)

instance Binary Char where
    put_  bh c = put_ bh (fromIntegral (ord c) :: Word8)
    get  bh   = do x <- get bh; return $! (chr (fromIntegral (x :: Word8)))
--    getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)

instance Binary Int where
#if SIZEOF_HSINT == 4
    put_ bh i = put_ bh (fromIntegral i :: Int32)
    get  bh = do
	x <- get bh
	return $! (fromIntegral (x :: Int32))
#elif SIZEOF_HSINT == 8
    put_ bh i = put_ bh (fromIntegral i :: Int64)
    get  bh = do
	x <- get bh
	return $! (fromIntegral (x :: Int64))
#else
#error "unsupported sizeof(HsInt)"
#endif
--    getF bh   = getBitsF bh 32

instance Binary a => Binary [a] where
    put_ bh list = do put_ bh (length list)
                      mapM_ (put_ bh) list
    get bh = do len <- get bh
                let getMany :: Int -> IO [a]
                    getMany 0 = return []
                    getMany n = do x <- get bh
                                   xs <- getMany (n-1)
                                   return (x:xs)
                getMany len

instance (Binary a, Binary b) => Binary (a,b) where
    put_ bh (a,b) = do put_ bh a; put_ bh b
    get bh        = do a <- get bh
                       b <- get bh
                       return (a,b)

instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
    put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
    get bh          = do a <- get bh
                         b <- get bh
                         c <- get bh
                         return (a,b,c)

instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
    put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
    get bh          = do a <- get bh
                         b <- get bh
                         c <- get bh
                         d <- get bh
                         return (a,b,c,d)

instance Binary a => Binary (Maybe a) where
    put_ bh Nothing  = putByte bh 0
    put_ bh (Just a) = do putByte bh 1; put_ bh a
    get bh           = do h <- getWord8 bh
                          case h of
                            0 -> return Nothing
                            _ -> do x <- get bh; return (Just x)

instance (Binary a, Binary b) => Binary (Either a b) where
    put_ bh (Left  a) = do putByte bh 0; put_ bh a
    put_ bh (Right b) = do putByte bh 1; put_ bh b
    get bh            = do h <- getWord8 bh
                           case h of
                             0 -> do a <- get bh ; return (Left a)
                             _ -> do b <- get bh ; return (Right b)

instance (Binary a, Binary i, Ix i) => Binary (Array i a) where
  put_ bh arr = do put_ bh (Data.Array.bounds arr)
                   put_ bh (Data.Array.elems arr)
  get bh = do bounds <- get bh
              elems <- get bh
              return $ listArray bounds elems

instance (Binary key, Ord key, Binary elem) => Binary (FiniteMap key elem) where
--    put_ bh fm = put_ bh (fmToList fm)
--    get bh = do list <- get bh
--                return (listToFM list)

    put_ bh fm = do let list = fmToList fm
                    put_ bh (length list)
                    mapM_ (\(key, val) -> do put_ bh key
                                             lazyPut bh val) list
    get bh = do len <- get bh
                let getMany :: Int -> IO [(key,elem)]
                    getMany 0 = return []
                    getMany n = do key <- get bh
                                   val <- lazyGet bh
                                   xs <- getMany (n-1)
                                   return ((key,val):xs)
--                printElapsedTime "before get FiniteMap"
                list <- getMany len
--                printElapsedTime "after get FiniteMap"
                return (listToFM list)

#ifdef __GLASGOW_HASKELL__
instance Binary Integer where
    put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
    put_ bh (J# s# a#) = do
 	p <- putByte bh 1;
	put_ bh (I# s#)
	let sz# = sizeofByteArray# a#  -- in *bytes*
	put_ bh (I# sz#)  -- in *bytes*
	putByteArray bh a# sz#
   
    get bh = do 
	b <- getByte bh
	case b of
	  0 -> do (I# i#) <- get bh
		  return (S# i#)
	  _ -> do (I# s#) <- get bh
		  sz <- get bh
		  (BA a#) <- getByteArray bh sz
		  return (J# s# a#)

putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
putByteArray bh a s# = loop 0#
  where loop n# 
	   | n# ==# s# = return ()
	   | otherwise = do
	   	putByte bh (indexByteArray a n#)
		loop (n# +# 1#)

getByteArray :: BinHandle -> Int -> IO ByteArray
getByteArray bh (I# sz) = do
  (MBA arr) <- newByteArray sz 
  let loop n
	   | n ==# sz = return ()
	   | otherwise = do
		w <- getByte bh 
		writeByteArray arr n w
		loop (n +# 1#)
  loop 0#
  freezeByteArray arr


data ByteArray = BA ByteArray#
data MBA = MBA (MutableByteArray# RealWorld)

newByteArray :: Int# -> IO MBA
newByteArray sz = IO $ \s ->
  case newByteArray# sz s of { (# s, arr #) ->
  (# s, MBA arr #) }

freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
freezeByteArray arr = IO $ \s ->
  case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
  (# s, BA arr #) }

writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()

#if __GLASGOW_HASKELL__ < 503
writeByteArray arr i w8 = IO $ \s ->
  case word8ToWord w8 of { W# w# -> 
  case writeCharArray# arr i (chr# (word2Int# w#)) s  of { s ->
  (# s , () #) }}
#else
writeByteArray arr i (W8# w) = IO $ \s ->
  case writeWord8Array# arr i w s of { s ->
  (# s, () #) }
#endif

#if __GLASGOW_HASKELL__ < 503
indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#)))
#else
indexByteArray a# n# = W8# (indexWord8Array# a# n#)
#endif

instance (Integral a, Binary a) => Binary (Ratio a) where
    put_ bh (a :% b) = do put_ bh a; put_ bh b
    get bh = do a <- get bh; b <- get bh; return (a :% b)
#endif

instance Binary (Bin a) where
  put_ bh (BinPtr i) = put_ bh i
  get bh = do i <- get bh; return (BinPtr i)

-- -----------------------------------------------------------------------------
-- Lazy reading/writing

lazyPut :: Binary a => BinHandle -> a -> IO ()
lazyPut bh a = do
	-- output the obj with a ptr to skip over it:
    pre_a <- tellBin bh
    put_ bh pre_a	-- save a slot for the ptr
    put_ bh a		-- dump the object
    q <- tellBin bh 	-- q = ptr to after object
    putAt bh pre_a q 	-- fill in slot before a with ptr to q
    seekBin bh q	-- finally carry on writing at q

lazyGet :: Binary a => BinHandle -> IO a
lazyGet bh = do
    p <- get bh		-- a BinPtr
    p_a <- tellBin bh
    a <- unsafeInterleaveIO (getAt bh p_a)
    seekBin bh p -- skip over the object for now
    return a

-- --------------------------------------------------------------
-- 	Main wrappers: getBinFileWithDict, putBinFileWithDict
--
--	This layer is built on top of the stuff above, 
--	and should not know anything about BinHandles
-- --------------------------------------------------------------

initBinMemSize       = (1024*1024) :: Int
binaryInterfaceMagic = 0x1face :: Word32

getBinFileWithDict :: Binary a => FilePath -> IO a
getBinFileWithDict file_path = do
  bh <- Binary.readBinMem file_path

	-- Read the magic number to check that this really is a GHC .hi file
	-- (This magic number does not change when we change 
	--  GHC interface file format)
  magic <- get bh
  when (magic /= binaryInterfaceMagic) $
	error "magic number mismatch: old/corrupt interface file?"

	-- Read the dictionary
	-- The next word in the file is a pointer to where the dictionary is
	-- (probably at the end of the file)
  dict_p <- Binary.get bh	-- Get the dictionary ptr
  data_p <- tellBin bh		-- Remember where we are now
  seekBin bh dict_p
  dict <- getDictionary bh
  seekBin bh data_p		-- Back to where we were before

	-- Initialise the user-data field of bh
  let bh' = setUserData bh (initReadState dict)
	
	-- At last, get the thing 
  get bh'

putBinFileWithDict :: Binary a => FilePath -> a -> IO ()
putBinFileWithDict file_path the_thing = do
--  hnd <- openBinaryFile file_path WriteMode
--  bh <- openBinIO hnd
  bh <- openBinMem initBinMemSize
  put_ bh binaryInterfaceMagic

	-- Remember where the dictionary pointer will go
  dict_p_p <- tellBin bh
  put_ bh dict_p_p	-- Placeholder for ptr to dictionary

	-- Make some intial state
  usr_state <- newWriteState

	-- Put the main thing, 
  put_ (setUserData bh usr_state) the_thing

	-- Get the final-state
  j <- readIORef  (ud_next usr_state)
  fm <- HashTable.toList (ud_map  usr_state)
  dict_p <- tellBin bh	-- This is where the dictionary will start

	-- Write the dictionary pointer at the fornt of the file
  putAt bh dict_p_p dict_p	-- Fill in the placeholder
  seekBin bh dict_p		-- Seek back to the end of the file

	-- Write the dictionary itself
  putDictionary bh j (constructDictionary j fm)

	-- And send the result to the file
  writeBinMem bh file_path
--  hClose hnd
  
-- -----------------------------------------------------------------------------
-- UserData
-- -----------------------------------------------------------------------------

data UserData = 
   UserData { 	-- This field is used only when reading
	      ud_dict :: Dictionary,

		-- The next two fields are only used when writing
	      ud_next :: IORef Int,	-- The next index to use
	      ud_map  :: HashTable String Int -- The index of each string
	}

noUserData = error "Binary.UserData: no user data"

initReadState :: Dictionary -> UserData
initReadState dict = UserData{ ud_dict = dict,
			       ud_next = undef "next",
			       ud_map  = undef "map" }

newWriteState :: IO UserData
newWriteState = do
  j_r <- newIORef 0
  out_r <- HashTable.new (==) HashTable.hashString
  return (UserData { ud_dict = error "dict",
		     ud_next = j_r,
		     ud_map  = out_r })


undef s = error ("Binary.UserData: no " ++ s)

---------------------------------------------------------
--		The Dictionary 
---------------------------------------------------------

type Dictionary = Array Int String	-- The dictionary
					-- Should be 0-indexed

putDictionary :: BinHandle -> Int -> Dictionary -> IO ()
putDictionary bh sz dict = do
  put_ bh sz
  mapM_ (put_ bh) (elems dict)

getDictionary :: BinHandle -> IO Dictionary
getDictionary bh = do 
  sz <- get bh
  elems <- sequence (take sz (repeat (get bh)))
  return (listArray (0,sz-1) elems)

constructDictionary :: Int -> [(String,Int)] -> Dictionary
constructDictionary j fm = array (0,j-1) (map (\(x,y) -> (y,x)) fm)

---------------------------------------------------------
--              Reading and writing memoised Strings
---------------------------------------------------------

putSharedString :: BinHandle -> String -> IO ()
putSharedString bh str =
  case getUserData bh of
    UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do
      entry <- HashTable.lookup out_r str
      case entry of
	Just j  -> put_ bh j
	Nothing -> do
		     j <- readIORef j_r
		     put_ bh j
		     writeIORef j_r (j+1)
		     HashTable.insert out_r str j

getSharedString :: BinHandle -> IO String
getSharedString bh = do
	j <- get bh
	return $! (ud_dict (getUserData bh) ! j)

{-
---------------------------------------------------------
--		Reading and writing FastStrings
---------------------------------------------------------

putFS bh (FastString id l ba) = do
  put_ bh (I# l)
  putByteArray bh ba l
putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s)
	-- Note: the length of the FastString is *not* the same as
	-- the size of the ByteArray: the latter is rounded up to a
	-- multiple of the word size.
  
{- -- possible faster version, not quite there yet:
getFS bh@BinMem{} = do
  (I# l) <- get bh
  arr <- readIORef (arr_r bh)
  off <- readFastMutInt (off_r bh)
  return $! (mkFastSubStringBA# arr off l)
-}
getFS bh = do
  (I# l) <- get bh
  (BA ba) <- getByteArray bh (I# l)
  return $! (mkFastSubStringBA# ba 0# l)

instance Binary FastString where
  put_ bh f@(FastString id l ba) =
    case getUserData bh of { 
	UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do
    out <- readIORef out_r
    let uniq = getUnique f
    case lookupUFM out uniq of
	Just (j,f)  -> put_ bh j
	Nothing -> do
	   j <- readIORef j_r
	   put_ bh j
	   writeIORef j_r (j+1)
	   writeIORef out_r (addToUFM out uniq (j,f))
    }
  put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s))

  get bh = do 
	j <- get bh
	return $! (ud_dict (getUserData bh) ! j)
-}

printElapsedTime :: String -> IO ()
printElapsedTime msg = do
  time <- getCPUTime
  hPutStr stderr $ "elapsed time: " ++ Numeric.showFFloat (Just 2) ((fromIntegral time) / 10^12) " (" ++ msg ++ ")\n"


Index: Makefile
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/general/Makefile,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- Makefile	13 Nov 2004 16:42:47 -0000	1.1.1.1
+++ Makefile	13 Nov 2004 17:26:50 -0000	1.2
@@ -30,8 +30,8 @@
 PACKAGE = base
 PCKNAME = ctk
 PART    = general
-SRCS	= DLists.hs FiniteMaps.hs FNameOps.hs FileOps.hs GetOpt.hs Sets.hs\
-	  UNames.hs Utils.hs
+SRCS	= DLists.hs FNameOps.hs FileOps.hs GetOpt.hs UNames.hs Utils.hs \
+	  FastMutInt.hs Binary.hs
 OBJS	= $(patsubst %.hs,%.o,$(SRCS))
 
 include ../../mk/common.mk

--- NEW FILE: FastMutInt.hs ---
{-# OPTIONS -cpp -fglasgow-exts -O #-}
--
-- (c) The University of Glasgow 2002
--
-- Unboxed mutable Ints

module FastMutInt(
	FastMutInt, newFastMutInt,
	readFastMutInt, writeFastMutInt
  ) where

#define SIZEOF_HSINT  4

import GHC.Base
import GHC.IOBase

data FastMutInt = FastMutInt (MutableByteArray# RealWorld)

newFastMutInt :: IO FastMutInt
newFastMutInt = IO $ \s ->
  case newByteArray# size s of { (# s, arr #) ->
  (# s, FastMutInt arr #) }
  where I# size = SIZEOF_HSINT

readFastMutInt :: FastMutInt -> IO Int
readFastMutInt (FastMutInt arr) = IO $ \s ->
  case readIntArray# arr 0# s of { (# s, i #) ->
  (# s, I# i #) }

writeFastMutInt :: FastMutInt -> Int -> IO ()
writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s ->
  case writeIntArray# arr 0# i s of { s ->
  (# s, () #) }

[Gtk2hs-commit] gtk2hs/tools/c2hs/base/syms Attributes.hs,1.1.1.1,1.2 Idents.hs,1.1.1.1,1.2 NameSpaces.hs,1.1.1.1,1.2

[Duncan C. <dun...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/syms
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15642/base/syms

Modified Files:
	Attributes.hs Idents.hs NameSpaces.hs 
Log Message:
add Axel's --precomp patches with a binary serialisation framework derived from
the one used in ghc. This required makeing Position a proper data type.
Also converted to using Data.FiniteMap rather than the CTK FiniteMaps module.


Index: Attributes.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/syms/Attributes.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- Attributes.hs	13 Nov 2004 16:42:44 -0000	1.1.1.1
+++ Attributes.hs	13 Nov 2004 17:26:50 -0000	1.2
@@ -94,7 +94,9 @@
 import Errors     (interr)
 import UNames	  (NameSupply, Name,
 		   rootSupply, splitSupply, names)
-import FiniteMaps (FiniteMap, listToFM, toListFM, addToFM, lookupDftFM, zeroFM)
+import Data.FiniteMap (FiniteMap, listToFM, fmToList, addToFM,
+		       lookupWithDefaultFM, emptyFM)
+import Binary     (Binary(..), putByte, getByte)
 
 
 -- attribute management data structures and operations
@@ -221,7 +223,7 @@
 -- (internal errors); a	table is initially soft
 --
 newAttrTable      :: Attr a => String -> AttrTable a
-newAttrTable desc  = SoftTable zeroFM desc
+newAttrTable desc  = SoftTable emptyFM desc
 
 -- get the value of an attribute from the given attribute table (EXPORTED)
 --
@@ -229,7 +231,7 @@
 getAttr at (OnlyPos pos    )  = onlyPosErr "getAttr" at pos
 getAttr at (Attrs   _   aid)  = 
   case at of
-    (SoftTable   fm  _) -> lookupDftFM fm undef aid
+    (SoftTable   fm  _) -> lookupWithDefaultFM fm undef aid
     (FrozenTable arr _) -> let (lbd, ubd) = bounds arr
 			   in
 			   if (aid < lbd || aid > ubd) then undef else arr!aid
@@ -241,9 +243,9 @@
 setAttr at (OnlyPos pos    ) av = onlyPosErr "setAttr" at pos
 setAttr at (Attrs   pos aid) av = 
   case at of
-    (SoftTable fm desc) -> assert (isUndef (lookupDftFM fm undef aid)) 
+    (SoftTable fm desc) -> assert (isUndef (lookupWithDefaultFM fm undef aid)) 
 				  alreadySetErr $  
-			     SoftTable (addToFM aid av fm) desc
+			     SoftTable (addToFM fm aid av) desc
     (FrozenTable arr _) -> interr frozenErr 
   where
     alreadySetErr = "Attributes.setAttr: Attempt to set *already* set \
@@ -257,7 +259,7 @@
 updAttr at (OnlyPos pos    ) av = onlyPosErr "updAttr" at pos
 updAttr at (Attrs   pos aid) av = 
   case at of
-    (SoftTable   fm  desc) -> SoftTable (addToFM aid av fm) desc
+    (SoftTable   fm  desc) -> SoftTable (addToFM fm aid av) desc
     (FrozenTable arr _)    -> interr $ "Attributes.updAttr: Tried to\
 				       \ update frozen attribute in\n"
 				       ++ errLoc at pos
@@ -296,7 +298,7 @@
 --
 freezeAttrTable			       :: Attr a => AttrTable a -> AttrTable a
 freezeAttrTable (SoftTable   fm  desc)  = 
-  let contents = toListFM fm
+  let contents = fmToList fm
       keys     = map fst contents
       lbd      = minimum keys
       ubd      = maximum keys
@@ -398,3 +400,47 @@
 updGenAttr            :: (Attr a, Attributed obj) 
 		      => AttrTable a -> obj -> a -> AttrTable a
 updGenAttr atab at av  = updAttr atab (attrsOf at) av
+
+
+{-! for Attrs derive : GhcBinary !-}
+{-! for AttrTable derive : GhcBinary !-}
+{-* Generated by DrIFT : Look, but Don't Touch. *-}
+instance Binary Attrs where
+    put_ bh (OnlyPos aa) = do
+            putByte bh 0
+            put_ bh aa
+    put_ bh (Attrs ab ac) = do
+            putByte bh 1
+            put_ bh ab
+            put_ bh ac
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do
+                    aa <- get bh
+                    return (OnlyPos aa)
+              1 -> do
+                    ab <- get bh
+                    ac <- get bh
+                    return (Attrs ab ac)
+
+instance (Binary a, Attr a) => Binary (AttrTable a) where
+    put_ bh (SoftTable aa ab) = do
+            putByte bh 0
+            put_ bh aa
+            put_ bh ab
+    put_ bh (FrozenTable ac ad) = do
+            putByte bh 1
+            put_ bh ac
+            put_ bh ad
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do
+                    aa <- get bh
+                    ab <- get bh
+                    return (SoftTable aa ab)
+              1 -> do
+                    ac <- get bh
+                    ad <- get bh
+                    return (FrozenTable ac ad)

Index: NameSpaces.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/syms/NameSpaces.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- NameSpaces.hs	13 Nov 2004 16:42:44 -0000	1.1.1.1
+++ NameSpaces.hs	13 Nov 2004 17:26:50 -0000	1.2
@@ -42,9 +42,10 @@
 where
 
 import Common	  (Position, Pos(posOf))	      -- for importing `Idents'
-import FiniteMaps (FiniteMap, zeroFM, addToFM, lookupFM, toListFM)
+import Data.FiniteMap (FiniteMap, emptyFM, addToFM, lookupFM, fmToList, listToFM)
 import Idents     (Ident)
 import Errors     (interr)
+import Binary     (Binary(..))
 
 
 -- name space (EXPORTED ABSTRACT)
@@ -71,7 +72,7 @@
 -- create a name space (EXPORTED)
 --
 nameSpace :: NameSpace a
-nameSpace  = NameSpace zeroFM []
+nameSpace  = NameSpace emptyFM []
 
 -- add global definition (EXPORTED)
 --
@@ -83,7 +84,7 @@
 --   name space anymore)
 --
 defGlobal :: NameSpace a -> Ident -> a -> (NameSpace a, Maybe a)
-defGlobal (NameSpace gs lss) id def  = (NameSpace (addToFM id def gs) lss, 
+defGlobal (NameSpace gs lss) id def  = (NameSpace (addToFM gs id def) lss, 
 				        lookupFM gs id)
 
 -- add new range (EXPORTED)
@@ -143,4 +144,16 @@
 -- * local ranges are concatenated
 --
 nameSpaceToList                    :: NameSpace a -> [(Ident, a)]
-nameSpaceToList (NameSpace gs lss)  = toListFM gs ++ concat lss
+nameSpaceToList (NameSpace gs lss)  = fmToList gs ++ concat lss
+
+
+{-! for NameSpace derive : GhcBinary !-}
+{-* Generated by DrIFT : Look, but Don't Touch. *-}
+instance (Binary a) => Binary (NameSpace a) where
+    put_ bh (NameSpace aa ab) = do
+            put_ bh aa
+            put_ bh ab
+    get bh = do
+    aa <- get bh
+    ab <- get bh
+    return (NameSpace aa ab)

Index: Idents.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/syms/Idents.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- Idents.hs	13 Nov 2004 16:42:44 -0000	1.1.1.1
+++ Idents.hs	13 Nov 2004 17:26:50 -0000	1.2
@@ -69,6 +69,7 @@
 import Errors     (interr)
 import Attributes (Attrs, newAttrsOnlyPos, newAttrs,
 		   Attributed(attrsOf), posOfAttrsOf)
+import Binary     (Binary(..), putSharedString, getSharedString)
 
 
 -- simple identifier representation (EXPORTED)
@@ -77,9 +78,9 @@
 -- number
 --
 data Ident = Ident String	-- lexeme
-		   Int		-- ambiguousness resolving number
-		   Int		-- id. number to speed up equality check
-		   Attrs    	-- attributes of this ident. incl. position
+		   !Int		-- ambiguousness resolving number
+		   !Int		-- id. number to speed up equality check
+		   !Attrs    	-- attributes of this ident. incl. position
 
 -- the definition of the equality allows identifiers to be equal that are
 -- defined at different source text positions, and aims at speeding up the
@@ -373,3 +374,21 @@
 --
 dumpIdent     :: Ident -> String
 dumpIdent ide  = identToLexeme ide ++ " at " ++ show (posOf ide) 
+
+
+{-! for Ident derive : GhcBinary !-}
+{-* Generated by DrIFT : Look, but Don't Touch. *-}
+instance Binary Ident where
+    put_ bh (Ident aa ab ac ad) = do
+            putSharedString bh aa
+--            put_ bh aa
+            put_ bh ab
+            put_ bh ac
+            put_ bh ad
+    get bh = do
+    aa <- getSharedString bh
+--    aa <- get bh
+    ab <- get bh
+    ac <- get bh
+    ad <- get bh
+    return (Ident aa ab ac ad)

[Gtk2hs-commit] gtk2hs/tools/c2hs/base/syntax Lexers.hs,1.1.1.1,1.2 Parsers.hs,1.1.1.1,1.2

[Duncan C. <dun...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/syntax
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15642/base/syntax

Modified Files:
	Lexers.hs Parsers.hs 
Log Message:
add Axel's --precomp patches with a binary serialisation framework derived from
the one used in ghc. This required makeing Position a proper data type.
Also converted to using Data.FiniteMap rather than the CTK FiniteMaps module.


Index: Parsers.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/syntax/Parsers.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- Parsers.hs	13 Nov 2004 16:42:50 -0000	1.1.1.1
+++ Parsers.hs	13 Nov 2004 17:26:51 -0000	1.2
@@ -83,7 +83,7 @@
 import List       (sort)
 
 import Common     (Position, Pos (posOf), nopos)
-import FiniteMaps (FiniteMap, unitFM, joinCombFM, mapFM, lookupFM, toListFM)
+import Data.FiniteMap (FiniteMap, unitFM, plusFM_C, mapFM, lookupFM, fmToList)
 import Errors     (interr, ErrorLvl(..), Error, makeError)
 
 infix  5 `opt`
@@ -207,7 +207,7 @@
 (Parser a (Empty x p))  <|> q                        = mergeEpsilon a  x p q
 p                       <|> (Parser a' (Empty x q))  = mergeEpsilon a' x q p
 (Parser a (Alts alts1)) <|> (Parser a' (Alts alts2)) = 
-  Parser (a `joinActions` a') $ Alts (joinCombFM (<|>) alts1' alts2')
+  Parser (a `joinActions` a') $ Alts (plusFM_C (<|>) alts1' alts2')
   where
     alts1' = mapFM (\_ p -> Left  $> p) alts1
     alts2' = mapFM (\_ p -> Right $> p) alts2
@@ -470,12 +470,12 @@
 				. sort 
 				. map show 
 				. map fst 
-				. toListFM 
+				. fmToList
 				$ alts
 
-instance Token t => Show (Parser a t r) where
-  showsPrec _ (Parser a c) = shows c
+--instance Token t => Show (Parser a t r) where
+--  showsPrec _ (Parser a c) = shows c
 
-instance Token t => Show (Cont a t r) where
-  showsPrec _ (Empty r p ) = showString "*" . shows p
-  showsPrec _ (Alts  alts) = shows alts
+--instance Token t => Show (Cont a t r) where
+--  showsPrec _ (Empty r p ) = showString "*" . shows p
+--  showsPrec _ (Alts  alts) = shows alts

Index: Lexers.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/syntax/Lexers.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- Lexers.hs	13 Nov 2004 16:42:50 -0000	1.1.1.1
+++ Lexers.hs	13 Nov 2004 17:26:51 -0000	1.2
@@ -137,7 +137,7 @@
 import Maybe  (fromMaybe, isNothing)
 import Array  (Ix(..), Array, array, (!), assocs, accumArray)
 
-import Common (Position, Pos (posOf), nopos, incPos, tabPos, retPos)
+import Common (Position(Position), Pos (posOf), nopos, incPos, tabPos, retPos)
 import DLists (DList, openDL, zeroDL, unitDL, snocDL, joinDL, closeDL)
 import Errors (interr, ErrorLvl(..), Error, makeError)
 
@@ -263,22 +263,22 @@
 lexaction      :: Regexp s t -> Action t -> Lexer s t
 lexaction re a  = re `lexmeta` a'
   where
-    a' lexeme pos@(fname, row, col) s = 
+    a' lexeme pos@(Position fname row col) s = 
        let col' = col + length lexeme
        in
        col' `seq` case a lexeme pos of
-		    Nothing -> (Nothing, (fname, row, col'), s, Nothing)
-		    Just t  -> (Just (Right t), (fname, row, col'), s, Nothing)
+		    Nothing -> (Nothing, (Position fname row col'), s, Nothing)
+		    Just t  -> (Just (Right t), (Position fname row col'), s, Nothing)
 
 -- Variant for actions that may returns an error (EXPORTED)
 --
 lexactionErr      :: Regexp s t -> ActionErr t -> Lexer s t
 lexactionErr re a  = re `lexmeta` a'
   where
-     a' lexeme pos@(fname, row, col) s = 
+     a' lexeme pos@(Position fname row col) s = 
        let col' = col + length lexeme
        in
-       col' `seq` (Just (a lexeme pos), (fname, row, col'), s, Nothing)
+       col' `seq` (Just (a lexeme pos), (Position fname row col'), s, Nothing)
 
 -- Close a regular expression with a meta action (EXPORTED)
 --
@@ -464,13 +464,13 @@
         -- the result triple of `lexOne' that signals a lexical error;
         -- the result state is advanced by one character for error correction
         --
-	lexErr = let (cs, pos@(fname, row, col), s) = state
+	lexErr = let (cs, pos@(Position fname row col), s) = state
 	             err = makeError ErrorErr pos
 			     ["Lexical error!", 
 			      "The character " ++ show (head cs) 
 			      ++ " does not fit here; skipping it."]
 		 in
-		 (Just (Left err), l, (tail cs, (fname, row, (col + 1)), s))
+		 (Just (Left err), l, (tail cs, (Position fname row (col + 1)), s))
 
 	-- we take an open list of characters down, where we accumulate the
 	-- lexeme; this function returns maybe a token, the next lexer to use

[Gtk2hs-commit] gtk2hs/tools/c2hs/base/graphs Marks.hs,1.1.1.1,1.2

[Duncan C. <dun...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/graphs
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15642/base/graphs

Modified Files:
	Marks.hs 
Log Message:
add Axel's --precomp patches with a binary serialisation framework derived from
the one used in ghc. This required makeing Position a proper data type.
Also converted to using Data.FiniteMap rather than the CTK FiniteMaps module.


Index: Marks.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/graphs/Marks.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- Marks.hs	13 Nov 2004 16:42:49 -0000	1.1.1.1
+++ Marks.hs	13 Nov 2004 17:26:50 -0000	1.2
@@ -42,7 +42,7 @@
 module Marks (Marks, newMarks, mark, isMarked) 
 where
 
-import Sets	  (Set, zeroSet, addToSet, elemSet)
+import Data.Set	  (Set, emptySet, addToSet, elementOf)
 import Attributes (Attrs, Attributed(..))
 
 
@@ -55,15 +55,15 @@
 -- get a new collection of marks (EXPORTED)
 --
 newMarks :: Attributed a => Marks a
-newMarks  = Marks zeroSet
+newMarks  = Marks emptySet
 
 -- mark an entity in a specific collection of marks (EXPORTED)
 --
 mark              :: Attributed a => Marks a -> a -> Marks a
-mark (Marks ms) e  = Marks $ addToSet (attrsOf e) ms
+mark (Marks ms) e  = Marks $ addToSet ms (attrsOf e)
 
 -- test whether a given entity is marked in a given collection of marks
 -- (EXPORTED) 
 --
 isMarked              :: Attributed a => Marks a -> a -> Bool
-isMarked (Marks ms) e  = (attrsOf e) `elemSet` ms
+isMarked (Marks ms) e  = (attrsOf e) `elementOf` ms

[Gtk2hs-commit] gtk2hs/tools/c2hs/base/errors Errors.hs,1.1.1.1,1.2

[Duncan C. <dun...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/errors
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15642/base/errors

Modified Files:
	Errors.hs 
Log Message:
add Axel's --precomp patches with a binary serialisation framework derived from
the one used in ghc. This required makeing Position a proper data type.
Also converted to using Data.FiniteMap rather than the CTK FiniteMaps module.


Index: Errors.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/errors/Errors.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- Errors.hs	13 Nov 2004 16:42:47 -0000	1.1.1.1
+++ Errors.hs	13 Nov 2004 17:26:50 -0000	1.2
@@ -42,7 +42,7 @@
 ) where
 
 import Config (assertEnabled)
-import Common (Position, isInternalPos)
+import Common (Position(Position), isInternalPos)
 import Utils  (indentMultilineString)
 
 
@@ -128,7 +128,7 @@
   "INTERNAL ERROR!\n" 
   ++ "  >>> " ++ l ++ "\n"
   ++ (indentMultilineString 2 . unlines) ls  
-showError (Error lvl (fname, row, col) (l:ls))  =
+showError (Error lvl (Position fname row col) (l:ls))  =
   let
     prefix = fname ++ ":" ++ show (row::Int) ++ ": "
 	     ++ "(column " 

[Gtk2hs-commit] gtk2hs/tools/c2hs/base/admin Common.hs,1.1.1.1,1.2

[Duncan C. <dun...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/admin
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15642/base/admin

Modified Files:
	Common.hs 
Log Message:
add Axel's --precomp patches with a binary serialisation framework derived from
the one used in ghc. This required makeing Position a proper data type.
Also converted to using Data.FiniteMap rather than the CTK FiniteMaps module.


Index: Common.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/base/admin/Common.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- Common.hs	13 Nov 2004 16:42:44 -0000	1.1.1.1
+++ Common.hs	13 Nov 2004 17:26:50 -0000	1.2
@@ -38,7 +38,7 @@
   --
   -- source text positions
   --
-  Position, Pos (posOf), nopos, isNopos, dontCarePos,  isDontCarePos,
+  Position(Position), Pos (posOf), nopos, isNopos, dontCarePos,  isDontCarePos,
   builtinPos, isBuiltinPos, internalPos, isInternalPos,
   incPos, tabPos, retPos,
   --
@@ -52,6 +52,7 @@
 ) where
 
 import Config      (assertEnabled)
+import Binary      (Binary(..), putSharedString, getSharedString)
 
 
 -- error codes
@@ -75,44 +76,61 @@
 -- is important as it leads to the desired ordering of source positions
 -- (EXPORTED) 
 --
-type Position = (String,	-- file name
-		 Int,		-- row
-		 Int)		-- column
+data Position = Position !String	-- file name
+			 !Int		-- row
+			 !Int		-- column
+  deriving (Eq, Ord)
+
+instance Show Position where
+  show (Position fname row col) = show (fname, row, col)
+
+instance Binary Position where
+  put_ bh (Position fname row col) = do
+    putSharedString bh fname
+--    put_ bh fname
+    put_ bh row
+    put_ bh col
+  get bh = do
+    fname <- getSharedString bh
+--    aa <- get bh
+    row <- get bh
+    col <- get bh
+    return (Position fname row col)				    
 
 -- no position (for unknown position information) (EXPORTED)
 --
 nopos :: Position
-nopos  = ("<no file>", -1, -1)
+nopos  = Position "<no file>"  (-1) (-1)
 
 isNopos	            :: Position -> Bool
-isNopos (_, -1, -1)  = True
+isNopos (Position _ (-1) (-1))  = True
 isNopos _	     = False
 
 -- don't care position (to be used for invalid position information) (EXPORTED)
 --
 dontCarePos :: Position
-dontCarePos  = ("<invalid>", -2, -2)
+dontCarePos  = Position "<invalid>" (-2) (-2)
 
 isDontCarePos	          :: Position -> Bool
-isDontCarePos (_, -2, -2)  = True
+isDontCarePos (Position _ (-2) (-2))  = True
 isDontCarePos _		   = False
 
 -- position attached to objects that are hard-coded into the toolkit (EXPORTED)
 --
 builtinPos :: Position
-builtinPos  = ("<built into the compiler>", -3, -3)
+builtinPos  = Position "<built into the compiler>" (-3) (-3)
 
 isBuiltinPos	         :: Position -> Bool
-isBuiltinPos (_, -3, -3)  = True
+isBuiltinPos (Position _  (-3) (-3))  = True
 isBuiltinPos _		  = False
 
 -- position used for internal errors (EXPORTED)
 --
 internalPos :: Position
-internalPos  = ("<internal error>", -4, -4)
+internalPos  = Position "<internal error>" (-4) (-4)
 
 isInternalPos	          :: Position -> Bool
-isInternalPos (_, -4, -4)  = True
+isInternalPos (Position _ (-4) (-4))  = True
 isInternalPos _		   = False
 
 -- instances of the class `Pos' are associated with some source text position
@@ -124,17 +142,17 @@
 -- advance column
 --
 incPos                     :: Position -> Int -> Position
-incPos (fname, row, col) n  = (fname, row, col + n)
+incPos (Position fname row col) n  = Position fname row (col + n)
 
 -- advance column to next tab positions (tabs are at every 8th column)
 --
 tabPos                   :: Position -> Position
-tabPos (fname, row, col)  = (fname, row, (col + 8 - (col - 1) `mod` 8))
+tabPos (Position fname row col)  = Position fname row (col + 8 - (col - 1) `mod` 8)
 
 -- advance to next line
 --
 retPos                   :: Position -> Position
-retPos (fname, row, col)  = (fname, row + 1, 1)
+retPos (Position fname row col)  = Position fname (row + 1) 1
 
 
 -- Miscellaneous stuff for pretty printing 

[Gtk2hs-commit] gtk2hs/tools/c2hs/c2hs/toplevel Main.hs,1.1.1.1,1.2 Version.hs,1.1.1.1,1.2

[Duncan C. <dun...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/toplevel
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15642/c2hs/toplevel

Modified Files:
	Main.hs Version.hs 
Log Message:
add Axel's --precomp patches with a binary serialisation framework derived from
the one used in ghc. This required makeing Position a proper data type.
Also converted to using Data.FiniteMap rather than the CTK FiniteMaps module.


Index: Version.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/toplevel/Version.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- Version.hs	13 Nov 2004 16:42:41 -0000	1.1.1.1
+++ Version.hs	13 Nov 2004 17:26:54 -0000	1.2
@@ -6,9 +6,9 @@
 --
 idstr      = "$Id$"
 name       = "C->Haskell Compiler"
-versnum    = "0.13.4"
-versnick   = "\"Pressing Forward\""
-date	   = "17 Oct 2004"
+versnum    = "0.13.4 (gtk2hs branch)"
+versnick   = "\"Bin IO\""
+date	   = "13 Nov 2004"
 version    = name ++ ", version " ++ versnum ++ " " ++ versnick ++ ", " ++ date
 copyright  = "Copyright (c) [1999..2004] Manuel M T Chakravarty"
 disclaimer = "This software is distributed under the \

Index: Main.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/toplevel/Main.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- Main.hs	13 Nov 2004 16:42:41 -0000	1.1.1.1
+++ Main.hs	13 Nov 2004 17:26:54 -0000	1.2
@@ -110,6 +110,14 @@
 --        Print (on standard error output) the version and copyright
 --	  information of the compiler (before doing anything else).
 --
+--  -p FILE
+--  --precomp=FILE
+--        Use or generate a precompiled header. If a header file is
+--        given write a condensed version of the header file into
+--        FILE. If a binding file is given that does not contain any C
+--        declarations itself, use the condensed information in FILE
+--        to generate the binding. Using a precompiled header file will
+--        significantly speed up the translation of a binding module.
 --
 --  --old-ffi [=yes|=no]
 --	  Generate hooks using pre-standard FFI libraries.  This currently
@@ -126,6 +134,7 @@
 import List	  (isPrefixOf)
 import IO	  ()
 import Monad      (when, unless, mapM)
+import Maybe      (fromJust)
 
 -- base libraries
 import Common     (errorCodeFatal)
@@ -133,6 +142,8 @@
 		   getOpt)
 import FNameOps   (suffix, basename, dirname, stripSuffix, addPath)
 import Errors	  (interr)
+import UNames     (saveRootNameSupply, restoreRootNameSupply)
+import Binary	  (Binary(..), putBinFileWithDict, getBinFileWithDict)
 
 -- c2hs modules
 import C2HSState  (CST, nop, runC2HS, fatal, fatalsHandledBy, getId,
@@ -149,6 +160,11 @@
 import Version    (version, copyright, disclaimer)
 import C2HSConfig (cpp, cppopts, hpaths, tmpdir)
 
+-- for debug:
+import System.CPUTime (getCPUTime)
+import Numeric    (showFFloat)
+import StateBase  (liftIO)
+
 
 -- wrapper running the compiler
 -- ============================
@@ -189,6 +205,7 @@
 	  | Include String	-- list of directories to search .chi files
 	  | Output  String      -- file where the generated file should go
 	  | OutDir  String      -- directory where generates files should go
+	  | PreComp String      -- write or read a precompiled header
 	  | Version	        -- print version information on stderr
 	  | Error   String      -- error occured during processing of options
 	  deriving Eq
@@ -235,6 +252,10 @@
 	 ["output-dir"] 
 	 (ReqArg OutDir "PATH") 
 	 "place generated files in PATH",
+  Option ['p']
+         ["precomp"]
+         (ReqArg PreComp "FILE")
+         "generate or read precompiled header file FILE",
   Option ['v'] 
 	 ["version"] 
 	 (NoArg Version) 
@@ -263,14 +284,19 @@
       ([Help]   , []  , []) -> doExecute [Help]    []
       ([Version], []  , []) -> doExecute [Version] []
       (opts     , args, []) 
-        | properArgs args -> doExecute opts args
-        | otherwise       -> raiseErrs [wrongNoOfArgsErr]
-      (_   , _   , errs)  -> raiseErrs errs
+        | properArgs (hasPreCompFlag opts) args -> doExecute opts args
+        | otherwise                             -> raiseErrs [wrongNoOfArgsErr]
+      (_   , _   , errs)    -> raiseErrs errs
   where
-    properArgs [bnd]         = suffix bnd == chssuffix 
-    properArgs [header, bnd] = suffix header == hsuffix 
-			       && suffix bnd == chssuffix 
-    properArgs _             = False
+    properArgs preComp [file]         = suffix file == chssuffix ||
+					suffix file == hsuffix && preComp
+    properArgs preComp [file1, file2] = suffix file1 == hsuffix 
+					&& suffix file2 == chssuffix 
+    properArgs _       _              = False
+    --
+    hasPreCompFlag (PreComp _:fs) = True
+    hasPreCompFlag (f:fs) = hasPreCompFlag fs
+    hasPreCompFlag [] = False
     --
     doExecute opts args = do
 			    execute opts args
@@ -278,8 +304,9 @@
 			    exitWithCIO ExitSuccess
     --
     wrongNoOfArgsErr = 
-      "There must be exactly one binding file (suffix .chs), possibly\n\
-      \preceded by one header file (suffix .h).\n"
+      "Supply the header file followed by the binding file.\n\
+      \The header file can be omitted if it is supplied in the binding file.\n\
+      \The binding file can be omitted if the --precomp flag is given.\n"
     --
     -- exception handler
     --
@@ -325,23 +352,40 @@
     let vs      = filter (== Version) opts
 	opts'   = filter (/= Version) opts
     mapM_ processOpt (atMostOne vs ++ opts')
-    when (length args `elem` [1, 2]) $
-      let (headerFile, bndFile) = case args of
-				    [       bfile] -> (""   , bfile)
-				    [hfile, bfile] -> (hfile, bfile)
-          bndFileWithoutSuffix  = stripSuffix bndFile
-      in do
+
+    let (headerFile, bndFile) = determineFileTypes args
+
+    preCompFile <- getSwitch preCompSB
+
+    unless (preCompFile==Nothing || null headerFile) $
+      preCompileHeader headerFile (fromJust preCompFile)
+        `fatalsHandledBy` ioErrorHandler
+
+    let bndFileWithoutSuffix  = stripSuffix bndFile
+    unless (null bndFile) $ do
       computeOutputName bndFileWithoutSuffix
-      process headerFile bndFileWithoutSuffix
-	`fatalsHandledBy` 
-	  \ioerr -> do
-		      name <- getProgNameCIO
-		      putStrCIO $
-		        name ++ ": " ++ ioeGetErrorString ioerr ++ "\n"
-		      exitWithCIO $ ExitFailure 1
+      if preCompFile==Nothing
+	then process headerFile bndFileWithoutSuffix
+	       `fatalsHandledBy` ioErrorHandler
+        else do
+	     containsHeaderInfo <-
+	       processPreComp (fromJust preCompFile) bndFileWithoutSuffix
+	     when containsHeaderInfo $ process headerFile bndFileWithoutSuffix
+	  `fatalsHandledBy` ioErrorHandler
   where
     atMostOne = (foldl (\_ x -> [x]) [])
 
+    determineFileTypes [hfile, bfile]                = (hfile, bfile)
+    determineFileTypes [file] | suffix file==hsuffix = (file, "")
+			      | otherwise            = ("", file)
+    determineFileTypes []                            = ("", "")
+
+    ioErrorHandler ioerr = do
+			     name <- getProgNameCIO
+			     putStrCIO $
+			       name ++ ": " ++ ioeGetErrorString ioerr ++ "\n"
+			     exitWithCIO $ ExitFailure 1
+
 -- emit help message
 --
 help :: CST s ()
@@ -362,6 +406,7 @@
 processOpt (Include dirs   )  = setInclude dirs
 processOpt (Output  fname  )  = setOutput  fname
 processOpt (OutDir  fname  )  = setOutDir  fname
+processOpt (PreComp fname  )  = setPreComp fname
 processOpt Version            = do
 			          (version, _, _) <- getId 
 			          putStrCIO (version ++ "\n")
@@ -476,6 +521,11 @@
 setHeader       :: FilePath -> CST s ()
 setHeader fname  = setSwitch $ \sb -> sb {headerSB = fname}
 
+-- set the file name in which the precompiled header ends up
+--
+setPreComp      :: FilePath -> CST s ()
+setPreComp fname = setSwitch $ \sb -> sb { preCompSB = Just fname }
+
 
 -- compilation process
 -- -------------------
@@ -560,3 +610,124 @@
 			      dumpCHS chsName mod False)
 
     chsName = basename bndFile ++ ".dump"
+
+preCompileHeader :: FilePath -> FilePath -> CST s ()
+preCompileHeader headerFile preCompFile =
+  do
+    printElapsedTime "start"
+    let preprocFile  = basename headerFile ++ isuffix
+    hpaths          <- getSwitch hpathsSB
+    realHeaderFile  <- headerFile `fileFindInCIO` hpaths
+
+    --
+    -- run C preprocessor over the header
+    --
+    cpp     <- getSwitch cppSB
+    cppOpts <- getSwitch cppOptsSB
+    let cmd  = unwords [cpp, cppOpts, realHeaderFile, ">" ++ preprocFile]
+    tracePreproc cmd
+    printElapsedTime "about to run cpp"
+    exitCode <- systemCIO cmd
+    case exitCode of
+      ExitFailure _ -> fatal "Error during preprocessing"
+      _             -> nop
+    printElapsedTime "about to parse headder"
+    --
+    -- load and analyse the C header file
+    --
+    (cheader, warnmsgs) <- loadAttrC preprocFile
+    printElapsedTime "about to emit warnings"
+    putStrCIO warnmsgs
+    
+    printElapsedTime "about to serialise header"
+
+    --
+    -- save the attributed C to disk
+    --
+    liftIO $ putBinFileWithDict preCompFile (WithNameSupply cheader)
+    printElapsedTime "finnished serialising header"
+    --
+    -- remove the pre-processed header
+    --
+    keep <- getSwitch keepSB
+    unless keep $
+      removeFileCIO preprocFile
+ 
+    printElapsedTime "finnish"
+    return ()
+  where
+    tracePreproc cmd = putTraceStr tracePhasesSW $
+                         "Invoking cpp as `" ++ cmd ++ "'...\n"
+
+processPreComp :: FilePath -> FilePath -> CST s Bool
+processPreComp preCompFile bndFile = do
+    printElapsedTime "start"
+    
+    -- load the Haskell binding module
+    --
+    printElapsedTime "about to read .chs file"
+    (chsMod , warnmsgs) <- loadCHS bndFile
+    putStrCIO warnmsgs
+    traceCHSDump chsMod
+    --
+    -- extract CPP and inline-C embedded in the .chs file (all CPP and
+    -- inline-C fragments are removed from the .chs tree and conditionals are
+    -- replaced by structured conditionals)
+    --
+    printElapsedTime "extracting cpp stuff from .chs file"
+    (header, strippedCHSMod, warnmsgs) <- genHeader chsMod
+    if not (null header) then return True else do
+      putStrCIO warnmsgs
+      --
+      -- load and analyse the C header file
+      --
+      printElapsedTime "about to deserialise header"
+      WithNameSupply cheader <- liftIO $ getBinFileWithDict preCompFile
+
+      --
+      -- expand binding hooks into plain Haskell
+      --
+      printElapsedTime "about to expand hooks in .chs file"
+      (hsMod, chi, warnmsgs) <- expandHooks cheader strippedCHSMod
+      putStrCIO warnmsgs
+      --
+      -- output the result
+      --
+      printElapsedTime "about to dump .hs and .chi files"
+      outFName <- getSwitch outputSB
+      let hsFile  = if null outFName then basename bndFile else outFName
+      dumpCHS hsFile hsMod True
+      dumpCHI hsFile chi		-- different suffix will be appended
+
+      -- CHS file did not contain C declarations, so return False
+      printElapsedTime "finnish"
+      return False
+  where
+    traceCHSDump mod = do
+			 flag <- traceSet dumpCHSSW
+			 when flag $
+			   (do
+			      putStrCIO ("Reading CHS for `" ++ chsName 
+					 ++ "'...\n")
+			      dumpCHS chsName mod False)
+
+    chsName = basename bndFile ++ ".dump"
+
+printElapsedTime :: String -> CST s ()
+printElapsedTime msg = do
+  time <- liftIO getCPUTime
+  hPutStrCIO stderr $ "elapsed time: " ++ Numeric.showFFloat (Just 2) ((fromIntegral time) / 10^12) " (" ++ msg ++ ")\n"
+
+-- dummy type so we can save and restore the name supply
+data WithNameSupply a = WithNameSupply a
+
+instance Binary a => Binary (WithNameSupply a) where
+  put_ bh (WithNameSupply x) = do
+    put_ bh x
+    nameSupply <- saveRootNameSupply
+    put_ bh nameSupply
+  get bh = do
+    x <- get bh
+    nameSupply <- get bh
+    restoreRootNameSupply nameSupply
+    return (WithNameSupply x)

[Gtk2hs-commit] gtk2hs/tools/c2hs/c2hs/c C.hs,1.1.1.1,1.2 CAST.hs,1.1.1.1,1.2 CAttrs.hs,1.1.1.1,1.2 CLexer.hs,1.1.1.1,1.2 CParser.hs,1.1.1.1,1.2

[Duncan C. <dun...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/c
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15642/c2hs/c

Modified Files:
	C.hs CAST.hs CAttrs.hs CLexer.hs CParser.hs 
Log Message:
add Axel's --precomp patches with a binary serialisation framework derived from
the one used in ghc. This required makeing Position a proper data type.
Also converted to using Data.FiniteMap rather than the CTK FiniteMaps module.


Index: C.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/c/C.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- C.hs	13 Nov 2004 16:42:21 -0000	1.1.1.1
+++ C.hs	13 Nov 2004 17:26:51 -0000	1.2
@@ -35,10 +35,6 @@
 	  -- stuff from `Common' (reexported)
 	  --
 	  Pos(posOf), 
-	  --
-	  -- reexported from `FiniteMaps'
-	  --
-	  FiniteMap,
 	  --	      
 	  -- structure tree
 	  --
@@ -70,8 +66,7 @@
 	  csuffix, hsuffix, isuffix)
 where
 
-import Common     (Position, Pos(posOf))
-import FiniteMaps (FiniteMap)
+import Common     (Position(Position), Pos(posOf))
 import Idents	  (Ident, lexemeToIdent)
 import Attributes (Attrs, Attr(..))
 
@@ -114,7 +109,7 @@
 		     -- parse
 		     --
 		     traceInfoParse
-		     rawHeader <- parseC contents (fname, 1, 1)
+		     rawHeader <- parseC contents (Position fname 1 1)
 		     let header = attrC rawHeader
 
 		     -- name analysis

Index: CParser.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/c/CParser.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- CParser.hs	13 Nov 2004 16:42:28 -0000	1.1.1.1
+++ CParser.hs	13 Nov 2004 17:26:52 -0000	1.2
@@ -85,7 +85,7 @@
 import Maybe      (catMaybes)
 
 import Common	  (Position, Pos(..), nopos)
-import Sets	  (Set, listToSet, joinSet, elemSet)
+import Data.Set	  (Set, mkSet, union, elementOf)
 import Utils      (Tag(tag))
 import UNames     (Name, NameSupply, names)
 import Idents     (Ident)
@@ -281,7 +281,7 @@
     nameSupply <- getNameSupply
     let name          = (head . names) nameSupply
 	at            = newAttrs pos name
-	predefTypeIds = listToSet . map fst $ builtinTypeNames
+	predefTypeIds = mkSet . map fst $ builtinTypeNames
     decls <- parseCExtDeclList [] predefTypeIds tokens
     return (CHeader decls at)
   where
@@ -304,7 +304,7 @@
 	-- raise the errors first, in case any of them is fatal
 	--
 	mapM raise errs
-	let tdefNames' = tdefNames `joinSet` (listToSet $ getTDefNames decl)
+	let tdefNames' = tdefNames `union` (mkSet $ getTDefNames decl)
 	parseCExtDeclList (decl:decls) tdefNames' toks'
 
     -- extract all identifiers turned into `typedef-name's
@@ -330,7 +330,7 @@
     --
     morphTypeNames :: Set Ident -> CToken -> CToken
     morphTypeNames tides (CTokIdent pos ide)
-      | ide `elemSet` tides  = CTokTypeName pos ide
+      | ide `elementOf` tides  = CTokTypeName pos ide
     morphTypeNames tides tok = tok
 
 -- parse external C declaration (K&R A10)

Index: CAttrs.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/c/CAttrs.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- CAttrs.hs	13 Nov 2004 16:42:22 -0000	1.1.1.1
+++ CAttrs.hs	13 Nov 2004 17:26:51 -0000	1.2
@@ -79,6 +79,7 @@
 		   newAttrTable, freezeAttrTable, softenAttrTable)
 import NameSpaces (NameSpace, nameSpace, enterNewRange, leaveRange, defLocal,
 		   defGlobal, find, nameSpaceToList)
+import Binary     (Binary(..), putByte, getByte)
 
 import CAST
 
@@ -364,7 +365,7 @@
 -- object tables (internal use only)
 -- ---------------------------------
 
--- the object name spavce
+-- the object name space
 --
 type CObjNS = NameSpace CObj
 
@@ -399,3 +400,95 @@
 --
 cDefTable :: CDefTable
 cDefTable  = newAttrTable "C General Definition Table for Idents"
+
+
+{-! for AttrC derive : GhcBinary !-}
+{-! for CObj derive : GhcBinary !-}
+{-! for CTag derive : GhcBinary !-}
+{-! for CDef derive : GhcBinary !-}
+{-* Generated by DrIFT : Look, but Don't Touch. *-}
+instance Binary AttrC where
+    put_ bh (AttrC aa ab ac ad ae) = do
+--          put_ bh aa
+            put_ bh ab
+            put_ bh ac
+            put_ bh ad
+            put_ bh ae
+    get bh = do
+--    aa <- get bh
+    ab <- get bh
+    ac <- get bh
+    ad <- get bh
+    ae <- get bh
+    return (AttrC (error "AttrC.headerAC should not be needed") ab ac ad ae)
+
+instance Binary CObj where
+    put_ bh (TypeCO aa) = do
+            putByte bh 0
+            put_ bh aa
+    put_ bh (ObjCO ab) = do
+            putByte bh 1
+            put_ bh ab
+    put_ bh (EnumCO ac ad) = do
+            putByte bh 2
+            put_ bh ac
+            put_ bh ad
+    put_ bh BuiltinCO = do
+            putByte bh 3
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do
+                    aa <- get bh
+                    return (TypeCO aa)
+              1 -> do
+                    ab <- get bh
+                    return (ObjCO ab)
+              2 -> do
+                    ac <- get bh
+                    ad <- get bh
+                    return (EnumCO ac ad)
+              3 -> do
+                    return BuiltinCO
+
+instance Binary CTag where
+    put_ bh (StructUnionCT aa) = do
+            putByte bh 0
+            put_ bh aa
+    put_ bh (EnumCT ab) = do
+            putByte bh 1
+            put_ bh ab
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do
+                    aa <- get bh
+                    return (StructUnionCT aa)
+              1 -> do
+                    ab <- get bh
+                    return (EnumCT ab)
+
+instance Binary CDef where
+    put_ bh UndefCD = do
+            putByte bh 0
+    put_ bh DontCareCD = do
+            putByte bh 1
+    put_ bh (ObjCD aa) = do
+            putByte bh 2
+            put_ bh aa
+    put_ bh (TagCD ab) = do
+            putByte bh 3
+            put_ bh ab
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do
+                    return UndefCD
+              1 -> do
+                    return DontCareCD
+              2 -> do
+                    aa <- get bh
+                    return (ObjCD aa)
+              3 -> do
+                    ab <- get bh
+                    return (TagCD ab)

Index: CAST.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/c/CAST.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- CAST.hs	13 Nov 2004 16:42:30 -0000	1.1.1.1
+++ CAST.hs	13 Nov 2004 17:26:51 -0000	1.2
@@ -50,6 +50,7 @@
 import Common     (Position, Pos(posOf), nopos)
 import Idents     (Ident)
 import Attributes (Attrs)
+import Binary     (Binary(..), putByte, getByte)
 
 
 -- a complete C header file (K&R A10) (EXPORTED)
@@ -582,3 +583,583 @@
   (CCharConst  _ at1) == (CCharConst  _ at2) = at1 == at2
   (CFloatConst _ at1) == (CFloatConst _ at2) = at1 == at2
   (CStrConst   _ at1) == (CStrConst   _ at2) = at1 == at2
+
+
+{-! for CDecl derive : GhcBinary !-}
+{-! for CEnum derive : GhcBinary !-}
+{-! for CStructUnion derive : GhcBinary !-}
+{-! for CStructTag derive : GhcBinary !-}
+{-! for CExpr derive : GhcBinary !-}
+{-! for CInit derive : GhcBinary !-}
+{-! for CDeclr derive : GhcBinary !-}
+{-! for CDeclSpec derive : GhcBinary !-}
+{-! for CTypeSpec derive : GhcBinary !-}
+{-! for CStorageSpec derive : GhcBinary !-}
+{-! for CTypeQual derive : GhcBinary !-}
+{-! for CConst derive : GhcBinary !-}
+{-! for CUnaryOp derive : GhcBinary !-}
+{-! for CBinaryOp derive : GhcBinary !-}
+{-! for CAssignOp derive : GhcBinary !-}
+{-* Generated by DrIFT : Look, but Don't Touch. *-}
+instance Binary CDecl where
+    put_ bh (CDecl aa ab ac) = do
+            put_ bh aa
+            put_ bh ab
+            put_ bh ac
+    get bh = do
+    aa <- get bh
+    ab <- get bh
+    ac <- get bh
+    return (CDecl aa ab ac)
+
+instance Binary CEnum where
+    put_ bh (CEnum aa ab ac) = do
+            put_ bh aa
+            put_ bh ab
+            put_ bh ac
+    get bh = do
+    aa <- get bh
+    ab <- get bh
+    ac <- get bh
+    return (CEnum aa ab ac)
+
+instance Binary CStructUnion where
+    put_ bh (CStruct aa ab ac ad) = do
+            put_ bh aa
+            put_ bh ab
+            put_ bh ac
+            put_ bh ad
+    get bh = do
+    aa <- get bh
+    ab <- get bh
+    ac <- get bh
+    ad <- get bh
+    return (CStruct aa ab ac ad)
+
+instance Binary CStructTag where
+    put_ bh CStructTag = do
+            putByte bh 0
+    put_ bh CUnionTag = do
+            putByte bh 1
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do
+                    return CStructTag
+              1 -> do
+                    return CUnionTag
+
+instance Binary CExpr where
+    put_ bh (CComma aa ab) = do
+            putByte bh 0
+            put_ bh aa
+            put_ bh ab
+    put_ bh (CAssign ac ad ae af) = do
+            putByte bh 1
+            put_ bh ac
+            put_ bh ad
+            put_ bh ae
+            put_ bh af
+    put_ bh (CCond ag ah ai aj) = do
+            putByte bh 2
+            put_ bh ag
+            put_ bh ah
+            put_ bh ai
+            put_ bh aj
+    put_ bh (CBinary ak al am an) = do
+            putByte bh 3
+            put_ bh ak
+            put_ bh al
+            put_ bh am
+            put_ bh an
+    put_ bh (CCast ao ap aq) = do
+            putByte bh 4
+            put_ bh ao
+            put_ bh ap
+            put_ bh aq
+    put_ bh (CUnary ar as at) = do
+            putByte bh 5
+            put_ bh ar
+            put_ bh as
+            put_ bh at
+    put_ bh (CSizeofExpr au av) = do
+            putByte bh 6
+            put_ bh au
+            put_ bh av
+    put_ bh (CSizeofType aw ax) = do
+            putByte bh 7
+            put_ bh aw
+            put_ bh ax
+    put_ bh (CAlignofExpr ay az) = do
+            putByte bh 8
+            put_ bh ay
+            put_ bh az
+    put_ bh (CAlignofType aA aB) = do
+            putByte bh 9
+            put_ bh aA
+            put_ bh aB
+    put_ bh (CIndex aC aD aE) = do
+            putByte bh 10
+            put_ bh aC
+            put_ bh aD
+            put_ bh aE
+    put_ bh (CCall aF aG aH) = do
+            putByte bh 11
+            put_ bh aF
+            put_ bh aG
+            put_ bh aH
+    put_ bh (CMember aI aJ aK aL) = do
+            putByte bh 12
+            put_ bh aI
+            put_ bh aJ
+            put_ bh aK
+            put_ bh aL
+    put_ bh (CVar aM aN) = do
+            putByte bh 13
+            put_ bh aM
+            put_ bh aN
+    put_ bh (CConst aO aP) = do
+            putByte bh 14
+            put_ bh aO
+            put_ bh aP
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do
+                    aa <- get bh
+                    ab <- get bh
+                    return (CComma aa ab)
+              1 -> do
+                    ac <- get bh
+                    ad <- get bh
+                    ae <- get bh
+                    af <- get bh
+                    return (CAssign ac ad ae af)
+              2 -> do
+                    ag <- get bh
+                    ah <- get bh
+                    ai <- get bh
+                    aj <- get bh
+                    return (CCond ag ah ai aj)
+              3 -> do
+                    ak <- get bh
+                    al <- get bh
+                    am <- get bh
+                    an <- get bh
+                    return (CBinary ak al am an)
+              4 -> do
+                    ao <- get bh
+                    ap <- get bh
+                    aq <- get bh
+                    return (CCast ao ap aq)
+              5 -> do
+                    ar <- get bh
+                    as <- get bh
+                    at <- get bh
+                    return (CUnary ar as at)
+              6 -> do
+                    au <- get bh
+                    av <- get bh
+                    return (CSizeofExpr au av)
+              7 -> do
+                    aw <- get bh
+                    ax <- get bh
+                    return (CSizeofType aw ax)
+              8 -> do
+                    ay <- get bh
+                    az <- get bh
+                    return (CAlignofExpr ay az)
+              9 -> do
+                    aA <- get bh
+                    aB <- get bh
+                    return (CAlignofType aA aB)
+              10 -> do
+                    aC <- get bh
+                    aD <- get bh
+                    aE <- get bh
+                    return (CIndex aC aD aE)
+              11 -> do
+                    aF <- get bh
+                    aG <- get bh
+                    aH <- get bh
+                    return (CCall aF aG aH)
+              12 -> do
+                    aI <- get bh
+                    aJ <- get bh
+                    aK <- get bh
+                    aL <- get bh
+                    return (CMember aI aJ aK aL)
+              13 -> do
+                    aM <- get bh
+                    aN <- get bh
+                    return (CVar aM aN)
+              14 -> do
+                    aO <- get bh
+                    aP <- get bh
+                    return (CConst aO aP)
+
+instance Binary CInit where
+    put_ bh (CInitExpr aa ab) = do
+            putByte bh 0
+            put_ bh aa
+            put_ bh ab
+    put_ bh (CInitList ac ad) = do
+            putByte bh 1
+            put_ bh ac
+            put_ bh ad
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do
+                    aa <- get bh
+                    ab <- get bh
+                    return (CInitExpr aa ab)
+              1 -> do
+                    ac <- get bh
+                    ad <- get bh
+                    return (CInitList ac ad)
+
+instance Binary CDeclr where
+    put_ bh (CVarDeclr aa ab) = do
+            putByte bh 0
+            put_ bh aa
+            put_ bh ab
+    put_ bh (CPtrDeclr ac ad ae) = do
+            putByte bh 1
+            put_ bh ac
+            put_ bh ad
+            put_ bh ae
+    put_ bh (CArrDeclr af ag ah) = do
+            putByte bh 2
+            put_ bh af
+            put_ bh ag
+            put_ bh ah
+    put_ bh (CFunDeclr ai aj ak al) = do
+            putByte bh 3
+            put_ bh ai
+            put_ bh aj
+            put_ bh ak
+            put_ bh al
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do
+                    aa <- get bh
+                    ab <- get bh
+                    return (CVarDeclr aa ab)
+              1 -> do
+                    ac <- get bh
+                    ad <- get bh
+                    ae <- get bh
+                    return (CPtrDeclr ac ad ae)
+              2 -> do
+                    af <- get bh
+                    ag <- get bh
+                    ah <- get bh
+                    return (CArrDeclr af ag ah)
+              3 -> do
+                    ai <- get bh
+                    aj <- get bh
+                    ak <- get bh
+                    al <- get bh
+                    return (CFunDeclr ai aj ak al)
+
+instance Binary CDeclSpec where
+    put_ bh (CStorageSpec aa) = do
+            putByte bh 0
+            put_ bh aa
+    put_ bh (CTypeSpec ab) = do
+            putByte bh 1
+            put_ bh ab
+    put_ bh (CTypeQual ac) = do
+            putByte bh 2
+            put_ bh ac
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do
+                    aa <- get bh
+                    return (CStorageSpec aa)
+              1 -> do
+                    ab <- get bh
+                    return (CTypeSpec ab)
+              2 -> do
+                    ac <- get bh
+                    return (CTypeQual ac)
+
+instance Binary CTypeSpec where
+    put_ bh (CVoidType aa) = do
+            putByte bh 0
+            put_ bh aa
+    put_ bh (CCharType ab) = do
+            putByte bh 1
+            put_ bh ab
+    put_ bh (CShortType ac) = do
+            putByte bh 2
+            put_ bh ac
+    put_ bh (CIntType ad) = do
+            putByte bh 3
+            put_ bh ad
+    put_ bh (CLongType ae) = do
+            putByte bh 4
+            put_ bh ae
+    put_ bh (CFloatType af) = do
+            putByte bh 5
+            put_ bh af
+    put_ bh (CDoubleType ag) = do
+            putByte bh 6
+            put_ bh ag
+    put_ bh (CSignedType ah) = do
+            putByte bh 7
+            put_ bh ah
+    put_ bh (CUnsigType ai) = do
+            putByte bh 8
+            put_ bh ai
+    put_ bh (CSUType aj ak) = do
+            putByte bh 9
+            put_ bh aj
+            put_ bh ak
+    put_ bh (CEnumType al am) = do
+            putByte bh 10
+            put_ bh al
+            put_ bh am
+    put_ bh (CTypeDef an ao) = do
+            putByte bh 11
+            put_ bh an
+            put_ bh ao
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do
+                    aa <- get bh
+                    return (CVoidType aa)
+              1 -> do
+                    ab <- get bh
+                    return (CCharType ab)
+              2 -> do
+                    ac <- get bh
+                    return (CShortType ac)
+              3 -> do
+                    ad <- get bh
+                    return (CIntType ad)
+              4 -> do
+                    ae <- get bh
+                    return (CLongType ae)
+              5 -> do
+                    af <- get bh
+                    return (CFloatType af)
+              6 -> do
+                    ag <- get bh
+                    return (CDoubleType ag)
+              7 -> do
+                    ah <- get bh
+                    return (CSignedType ah)
+              8 -> do
+                    ai <- get bh
+                    return (CUnsigType ai)
+              9 -> do
+                    aj <- get bh
+                    ak <- get bh
+                    return (CSUType aj ak)
+              10 -> do
+                    al <- get bh
+                    am <- get bh
+                    return (CEnumType al am)
+              11 -> do
+                    an <- get bh
+                    ao <- get bh
+                    return (CTypeDef an ao)
+
+instance Binary CStorageSpec where
+    put_ bh (CAuto aa) = do
+            putByte bh 0
+            put_ bh aa
+    put_ bh (CRegister ab) = do
+            putByte bh 1
+            put_ bh ab
+    put_ bh (CStatic ac) = do
+            putByte bh 2
+            put_ bh ac
+    put_ bh (CExtern ad) = do
+            putByte bh 3
+            put_ bh ad
+    put_ bh (CTypedef ae) = do
+            putByte bh 4
+            put_ bh ae
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do
+                    aa <- get bh
+                    return (CAuto aa)
+              1 -> do
+                    ab <- get bh
+                    return (CRegister ab)
+              2 -> do
+                    ac <- get bh
+                    return (CStatic ac)
+              3 -> do
+                    ad <- get bh
+                    return (CExtern ad)
+              4 -> do
+                    ae <- get bh
+                    return (CTypedef ae)
+
+instance Binary CTypeQual where
+    put_ bh (CConstQual aa) = do
+            putByte bh 0
+            put_ bh aa
+    put_ bh (CVolatQual ab) = do
+            putByte bh 1
+            put_ bh ab
+    put_ bh (CRestrQual ac) = do
+            putByte bh 2
+            put_ bh ac
+    put_ bh (CInlinQual ad) = do
+            putByte bh 3
+            put_ bh ad
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do
+                    aa <- get bh
+                    return (CConstQual aa)
+              1 -> do
+                    ab <- get bh
+                    return (CVolatQual ab)
+              2 -> do
+                    ac <- get bh
+                    return (CRestrQual ac)
+              3 -> do
+                    ad <- get bh
+                    return (CInlinQual ad)
+
+instance Binary CConst where
+    put_ bh (CIntConst aa ab) = do
+            putByte bh 0
+            put_ bh aa
+            put_ bh ab
+    put_ bh (CCharConst ac ad) = do
+            putByte bh 1
+            put_ bh ac
+            put_ bh ad
+    put_ bh (CFloatConst ae af) = do
+            putByte bh 2
+            put_ bh ae
+            put_ bh af
+    put_ bh (CStrConst ag ah) = do
+            putByte bh 3
+            put_ bh ag
+            put_ bh ah
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do
+                    aa <- get bh
+                    ab <- get bh
+                    return (CIntConst aa ab)
+              1 -> do
+                    ac <- get bh
+                    ad <- get bh
+                    return (CCharConst ac ad)
+              2 -> do
+                    ae <- get bh
+                    af <- get bh
+                    return (CFloatConst ae af)
+              3 -> do
+                    ag <- get bh
+                    ah <- get bh
+                    return (CStrConst ag ah)
+
+instance Binary CUnaryOp where
+    put_ bh CPreIncOp = putByte bh 0
+    put_ bh CPreDecOp = putByte bh 1
+    put_ bh CPostIncOp = putByte bh 2
+    put_ bh CPostDecOp = putByte bh 3
+    put_ bh CAdrOp = putByte bh 4
+    put_ bh CIndOp = putByte bh 5
+    put_ bh CPlusOp = putByte bh 6
+    put_ bh CMinOp = putByte bh 7
+    put_ bh CCompOp = putByte bh 8
+    put_ bh CNegOp = putByte bh 9
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> return CPreIncOp
+              1 -> return CPreDecOp
+              2 -> return CPostIncOp
+              3 -> return CPostDecOp
+              4 -> return CAdrOp
+              5 -> return CIndOp
+              6 -> return CPlusOp
+              7 -> return CMinOp
+              8 -> return CCompOp
+              9 -> return CNegOp
+
+instance Binary CBinaryOp where
+    put_ bh CMulOp = putByte bh 0
+    put_ bh CDivOp = putByte bh 1
+    put_ bh CRmdOp = putByte bh 2
+    put_ bh CAddOp = putByte bh 3
+    put_ bh CSubOp = putByte bh 4
+    put_ bh CShlOp = putByte bh 5
+    put_ bh CShrOp = putByte bh 6
+    put_ bh CLeOp = putByte bh 7
+    put_ bh CGrOp = putByte bh 8
+    put_ bh CLeqOp = putByte bh 9
+    put_ bh CGeqOp = putByte bh 10
+    put_ bh CEqOp = putByte bh 11
+    put_ bh CNeqOp = putByte bh 12
+    put_ bh CAndOp = putByte bh 13
+    put_ bh CXorOp = putByte bh 14
+    put_ bh COrOp = putByte bh 15
+    put_ bh CLndOp = putByte bh 16
+    put_ bh CLorOp = putByte bh 17
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> return CMulOp
+              1 -> return CDivOp
+              2 -> return CRmdOp
+              3 -> return CAddOp
+              4 -> return CSubOp
+              5 -> return CShlOp
+              6 -> return CShrOp
+              7 -> return CLeOp
+              8 -> return CGrOp
+              9 -> return CLeqOp
+              10 -> return CGeqOp
+              11 -> return CEqOp
+              12 -> return CNeqOp
+              13 -> return CAndOp
+              14 -> return CXorOp
+              15 -> return COrOp
+              16 -> return CLndOp
+              17 -> return CLorOp
+
+instance Binary CAssignOp where
+    put_ bh CAssignOp = putByte bh 0
+    put_ bh CMulAssOp = putByte bh 1
+    put_ bh CDivAssOp = putByte bh 2
+    put_ bh CRmdAssOp = putByte bh 3
+    put_ bh CAddAssOp = putByte bh 4
+    put_ bh CSubAssOp = putByte bh 5
+    put_ bh CShlAssOp = putByte bh 6
+    put_ bh CShrAssOp = putByte bh 7
+    put_ bh CAndAssOp = putByte bh 8
+    put_ bh CXorAssOp = putByte bh 9
+    put_ bh COrAssOp = putByte bh 10
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> return CAssignOp
+              1 -> return CMulAssOp
+              2 -> return CDivAssOp
+              3 -> return CRmdAssOp
+              4 -> return CAddAssOp
+              5 -> return CSubAssOp
+              6 -> return CShlAssOp
+              7 -> return CShrAssOp
+              8 -> return CAndAssOp
+              9 -> return CXorAssOp
+              10 -> return COrAssOp

Index: CLexer.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/c/CLexer.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- CLexer.hs	13 Nov 2004 16:42:27 -0000	1.1.1.1
+++ CLexer.hs	13 Nov 2004 17:26:52 -0000	1.2
@@ -69,7 +69,7 @@
 import Monad	 (liftM)
 import Numeric   (readDec, readOct, readHex)
 
-import Common    (Position, Pos(posOf), incPos, retPos)
+import Common    (Position(Position), Pos(posOf), incPos, retPos)
 import Utils     (Tag(tag))
 import Errors    (Error)
 import UNames	 (NameSupply, Name, names)
@@ -526,7 +526,7 @@
 	     int     = digitNZ +> digit`star` epsilon
 	     fname   = char '"' +> infname`star` char '"'
 	     --
-	     adjustPos str (fname, row, _) = (fname', row', 0)
+	     adjustPos str (Position fname row _) = (Position fname' row' 0)
 	       where
 	         str'            = dropWhite . drop 1 $ str
 		 (rowStr, str'') = span isDigit str'

[Gtk2hs-commit] gtk2hs/tools/c2hs/c2hs/state Switches.hs,1.1.1.1,1.2

[Duncan C. <dun...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/state
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15642/c2hs/state

Modified Files:
	Switches.hs 
Log Message:
add Axel's --precomp patches with a binary serialisation framework derived from
the one used in ghc. This required makeing Position a proper data type.
Also converted to using Data.FiniteMap rather than the CTK FiniteMaps module.


Index: Switches.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/state/Switches.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- Switches.hs	13 Nov 2004 16:42:40 -0000	1.1.1.1
+++ Switches.hs	13 Nov 2004 17:26:53 -0000	1.2
@@ -49,6 +49,12 @@
 --    `--output' option and `outDirSB' contains arguments to the
 --    `--output-dir' option.
 --
+--  * The pre-compiled header switch is unset if no pre-compiled header should
+--    be read or generated. If the option is set and a header file is given
+--    a concise version of the header will be written to the FilePath. If
+--    a binding file is given, the pre-compiled header is used to expand the
+--    module unless the binding file contains itself C declarations.
+--
 --- TODO ----------------------------------------------------------------------
 --
 
@@ -73,6 +79,7 @@
 		     outputSB  :: FilePath,	-- basename of generated files
 		     outDirSB  :: FilePath,	-- dir where generated files go
 		     headerSB  :: FilePath,	-- generated header file
+		     preCompSB :: Maybe FilePath,-- optional binary header r/w
 		     oldFFI    :: Bool,		-- GHC 4.XX compatible code
 		     chiPathSB :: [FilePath]	-- .chi file directories
 		   }
@@ -89,6 +96,7 @@
 			outputSB  = "",
 			outDirSB  = "",
 			headerSB  = "",
+			preCompSB = Nothing,
 			oldFFI	  = False,
 			chiPathSB = ["."]
 		      }

[Gtk2hs-commit] gtk2hs/tools/c2hs/c2hs/gen GBMonad.hs,1.1.1.1,1.2

[Duncan C. <dun...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/gen
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15642/c2hs/gen

Modified Files:
	GBMonad.hs 
Log Message:
add Axel's --precomp patches with a binary serialisation framework derived from
the one used in ghc. This required makeing Position a proper data type.
Also converted to using Data.FiniteMap rather than the CTK FiniteMaps module.


Index: GBMonad.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/gen/GBMonad.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- GBMonad.hs	13 Nov 2004 16:42:39 -0000	1.1.1.1
+++ GBMonad.hs	13 Nov 2004 17:26:53 -0000	1.2
@@ -80,8 +80,8 @@
 import Common     (Position, Pos(posOf), nopos, builtinPos)
 import Errors	  (interr)
 import Idents     (Ident, identToLexeme, onlyPosIdent)
-import FiniteMaps (FiniteMap, zeroFM, addToFM, lookupFM, joinFM, toListFM,
-		   listToFM)
+import Data.FiniteMap (FiniteMap, emptyFM, addToFM, lookupFM, plusFM,
+		       fmToList, listToFM)
 
 -- C -> Haskell
 import C	  (CT, readCT, transCT, raiseErrorCTExc)
@@ -237,8 +237,8 @@
 		    lib    = "",
 		    prefix = "",
 		    frags  = [],
-		    ptrmap = zeroFM,
-		    objmap = zeroFM
+		    ptrmap = emptyFM,
+		    objmap = emptyFM
 		  }
 
 -- set the dynamic library and library prefix
@@ -299,7 +299,7 @@
 ptrMapsTo :: (Bool, Ident) -> (String, String) -> GB ()
 (isStar, cName) `ptrMapsTo` hsRepr =
   transCT (\state -> (state { 
-		        ptrmap = addToFM (isStar, cName) hsRepr (ptrmap state)
+		        ptrmap = addToFM (ptrmap state) (isStar, cName) hsRepr
 		      }, ()))
 
 -- query the pointer map
@@ -314,7 +314,7 @@
 objIs :: Ident -> HsObject -> GB ()
 hsName `objIs` obj =
   transCT (\state -> (state { 
-		        objmap = addToFM hsName obj (objmap state)
+		        objmap = addToFM (objmap state) hsName obj
 		      }, ()))
 
 -- query the Haskell object map
@@ -367,8 +367,8 @@
 mergeMaps     :: String -> GB ()
 mergeMaps str  =
   transCT (\state -> (state { 
-		        ptrmap = joinFM readPtrMap (ptrmap state),
-		        objmap = joinFM readObjMap (objmap state)
+		        ptrmap = plusFM readPtrMap (ptrmap state),
+		        objmap = plusFM readObjMap (objmap state)
 		      }, ()))
   where
     (ptrAssoc, objAssoc) = read str
@@ -384,9 +384,9 @@
 	      ptrFM <- readCT ptrmap
 	      objFM <- readCT objmap
 	      let dumpable = ([((isStar, identToLexeme ide), repr)
-			      | ((isStar, ide), repr) <- toListFM ptrFM],
+			      | ((isStar, ide), repr) <- fmToList ptrFM],
 			      [(identToLexeme ide, obj)
-			      | (ide, obj)            <- toListFM objFM])
+			      | (ide, obj)            <- fmToList objFM])
 	      return $ show dumpable
 
 

[Gtk2hs-commit] gtk2hs/tools/c2hs/c2hs/chs CHS.hs,1.1.1.1,1.2

[Duncan C. <dun...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/chs
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15642/c2hs/chs

Modified Files:
	CHS.hs 
Log Message:
add Axel's --precomp patches with a binary serialisation framework derived from
the one used in ghc. This required makeing Position a proper data type.
Also converted to using Data.FiniteMap rather than the CTK FiniteMaps module.


Index: CHS.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/c2hs/c2hs/chs/CHS.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- CHS.hs	13 Nov 2004 16:42:35 -0000	1.1.1.1
+++ CHS.hs	13 Nov 2004 17:26:52 -0000	1.2
@@ -98,7 +98,7 @@
 import Monad	 (when)
 
 -- Compiler Toolkit
-import Common    (Position, Pos(posOf), nopos, isBuiltinPos)
+import Common    (Position(Position), Pos(posOf), nopos, isBuiltinPos)
 import Errors	 (interr)
 import Idents    (Ident, identToLexeme, onlyPosIdent)
 
@@ -327,7 +327,7 @@
 		   -- parse
 		   --
 		   traceInfoParse
-		   mod <- parseCHSModule (fullname, 1, 1) contents
+		   mod <- parseCHSModule (Position fullname 1 1) contents
 
 		   -- check for errors and finalize
 		   --
@@ -401,7 +401,7 @@
     showFrags _      _     []                           = id
     showFrags pureHs state (CHSVerb s      pos : frags) = 
       let
-	(fname, line, _) = pos
+	(Position fname line _) = pos
 	generated	 = isBuiltinPos pos
 	emitNow		 = state == Emit || 
 			   (state == Wait && not (null s) && head s == '\n')

[Gtk2hs-commit] gtk2hs ChangeLog,1.231,1.232 Makefile.am,1.3,1.4 configure.ac,1.2,1.3

[Axel S. <as...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv11265

Modified Files:
	ChangeLog Makefile.am configure.ac 
Log Message:
New, hopefully clever enough, way of calculating dependencies.


Index: configure.ac
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/configure.ac,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- configure.ac	25 Oct 2004 08:49:40 -0000	1.2
+++ configure.ac	28 Oct 2004 21:47:57 -0000	1.3
@@ -83,6 +83,7 @@
   C2HSFLAGS=" -C-D__signed=signed";
   dnl Where are we? (only used during configuration)
   TOP=`$PWD`;
+  CREATE_TYPES="plugNsocket default";
 else
   dnl must be Win32
   SLSUFFIX=".lib";
@@ -100,6 +101,7 @@
   dnl Where are we? (only used during configuration)
   TOP=`$PWD | $SED $PATHSED`;
   WIN32=yes;
+  CREATE_TYPES=default;
 fi;
 
 dnl determine a temporary directory for c2hs
@@ -271,10 +273,10 @@
   PKG_CHECK_MODULES(SOURCEVIEW,[gtksourceview-1.0 >= 0.6.0])
 fi
 
-dnl Some APIs only appeared in later versions of libraries, so check if we're
-dnl using later than particular versions.
-GTK_VERSION_2_2=`$PKG_CONFIG gtk+-2.0 --atleast-version=2.2 && echo yes || echo no`
-GTK_VERSION_2_4=`$PKG_CONFIG gtk+-2.0 --atleast-version=2.4 && echo yes || echo no`
+dnl Some APIs only appeared in later versions of libraries. Generate only
+dnl Haskell types for the available C types.
+CREATE_TYPES="$CREATE_TYPES `$PKG_CONFIG gtk+-2.0 --atleast-version=2.2 && echo gtk-2.2`"
+CREATE_TYPES="$CREATE_TYPES `$PKG_CONFIG gtk+-2.0 --atleast-version=2.4 && echo gtk-2.4`"
 
 dnl The configuration program for GTK is kind of stupid in that it
 dnl lists directories which don't exist. ghc-pkg in ghc 5.04 or greater
@@ -361,14 +363,20 @@
 AC_ARG_ENABLE(deprecated,
 	     [  --disable-deprecated    do not generate bindings for any deprecated APIs],
 	     [ENABLE_DEPRECATED=$enableval],[ENABLE_DEPRECATED=yes])
+AC_MSG_RESULT($ENABLE_DEPRECATED)
 
 DISABLE_DEPRECATED=`test $ENABLE_DEPRECATED = yes && echo no || echo yes`
-AC_MSG_RESULT($ENABLE_DEPRECATED)
 
 if test $DISABLE_DEPRECATED = yes; then
-C2HSFLAGS="$C2HSFLAGS -C-DDISABLE_DEPRECATED"
-HSCFLAGS="$HSCFLAGS -DDISABLE_DEPRECATED"
-fi
+  AC_DEFINE(DISABLE_DEPRECATED, [], [Leave out all deprecated functions.])
+  AC_DEFINE(G_DISABLE_DEPRECATED, [], [Omit deprecated glib functions.])
+  AC_DEFINE(GDK_DISABLE_DEPRECATED, [], [Omit deprecated gdk functions.])
+  AC_DEFINE(GDK_PIXBUF_DISABLE_DEPRECATED, [],
+	[Omit deprecated pixbuf functions.])
+  AC_DEFINE(GTK_DISABLE_DEPRECATED, [], [Omit deprecated gtk functions.])
+else
+  CREATE_TYPES="deprecated $CREATE_TYPES";
+fi;
 
 dnl Have a special marshall list (available in the source tree of Gtk+ under
 dnl gtk/gtkmarshal.list)
@@ -501,6 +509,7 @@
 AC_SUBST(GTK_VERSION_2_2)
 AC_SUBST(GTK_VERSION_2_4)
 AC_SUBST(DISABLE_DEPRECATED)
+AC_SUBST(CREATE_TYPES)
 dnl Optional packages
 dnl AC_SUBST(ENABLE_OPENGL)
 AC_SUBST(ENABLE_LIBGLADE)

Index: Makefile.am
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/Makefile.am,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- Makefile.am	27 Oct 2004 13:21:38 -0000	1.3
+++ Makefile.am	28 Oct 2004 21:47:57 -0000	1.4
@@ -1,43 +1,120 @@
 AUTOMAKE_OPTIONS = foreign subdir-objects
-SUFFIXES = .chs.cpp .chs .hsc
+SUFFIXES = .chs.cpp .chs .hsc .deps .dep
+DEPDIR = $(addsuffix /,@DEPDIR@)
 CLEANFILES = $(DEPDIR)*.dep
 DISTCLEANFILES = *.precomp
 
+# Before chaning anything on dependency calculation:
+# - Note that the initial dependencies are computed when make checks if
+#   the include files are up to date.
+# - CFLAGS and CPPFLAGS are not package/application specific. This is due
+#   to the initial dependency calculation where it is not clear which
+#   package a particular file belongs to. But the CPPFLAGS are needed to
+#   run .chs.cpp files through the pre-processor.
+# - Dependencies between Haskell .hs modules are stored in
+#   .deps/<pkg-name>.deps . To calculate these dependencies, c2hs must be
+#   run on the .chs and the header file belonging to the package to which
+#   the .chs file belongs to. But since the dependencies for a package are
+#   stored in a file with the package's name, set the NAME variable to the
+#   file name of the target .deps/<pkg-name>.deps and then run c2hs.
+
+CFLAGS = $(filter-out -I%,$(GTK_CFLAGS))
+CPPFLAGS = $(filter -I%,$(GTK_CFLAGS))
+
 SOURCEDIRS = gtk/general gtk/glib gtk/pango gtk/treeList gtk/multiline \
 	gtk/gdk gtk/abstract gtk/display gtk/entry gtk/misc gtk/multiline \
 	gtk/ornaments gtk/scrolling gtk/treeList gtk/selectors gtk/embedding \
-	compat gtk/layout gtk/menuComboToolbar gtk/buttons gtk/windows
+	compat gtk/layout gtk/menuComboToolbar gtk/buttons gtk/windows \
+	tools/hierarchyGen tools/callbackGen tools/apicoverage
 
 # fixme: this should be in configure.ac:
 HSCPP = $(CPP) -x c -traditional-cpp -P
 
 CHSDEPEND = $(srcdir)/mk/chsDepend
 
-DEPDIR = $(addsuffix /,@DEPDIR@)
-
 HSC = hsc2hs
 
+# all packages and applications
+lib_LIBRARIES = gtk/libgtk2hs.a
+bin_PROGRAMS = \
+	tools/hierarchyGen/TypeGenerator \
+	tools/callbackGen/HookGenerator \
+	tools/apicoverage/Exclude
+
+# TypeGenerator
+
+# While building the program <name>, set the variable NAME to <name> so
+# we can access program-specific variables like <name>_PACKAGEDEPS. The
+# following is a hack to prevent automake from assuming that we are overriding
+# the tools/hierarchyGen/TypeGenerator goal.
+TypeGenerator_NAME = tools/hierarchyGen/TypeGenerator
+$(TypeGenerator_NAME) : NAME = tools_hierarchyGen_TypeGenerator
+
+tools_hierarchyGen_TypeGenerator_MAIN = \
+  $(tools_hierarchyGen_TypeGenerator_SOURCES)
+tools_hierarchyGen_TypeGenerator_PACKAGEDEPS = data
+tools_hierarchyGen_TypeGenerator_SOURCES = \
+  tools/hierarchyGen/TypeGen.hs
+# Fix automake - the subdir-objects option doesn't work here.
+am_tools_hierarchyGen_TypeGenerator_OBJECTS = $(addsuffix .$(OBJEXT),\
+  $(basename $(tools_hierarchyGen_TypeGenerator_SOURCES)))
+
+gtk/general/Hierarchy.chs : $(srcdir)/tools/hierarchyGen/hierarchy.list \
+			    $(srcdir)/tools/hierarchyGen/TypeGenerator
+	$(strip $(srcdir)/tools/hierarchyGen/TypeGenerator \
+        $(srcdir)/tools/hierarchyGen/hierarchy.list \
+        $@ $(addprefix --tag=,$(CREATE_TYPES)))
+
+# HookGenerator
+HookGenerator_NAME = tools/callbackGen/HookGenerator
+$(HookGenerator_NAME) : NAME = tools_callbackGen_HookGenerator
+
+tools_callbackGen_HookGenerator_MAIN = \
+  $(tools_callbackGen_HookGenerator_SOURCES)
+tools_callbackGen_HookGenerator_PACKAGEDEPS = data
+tools_callbackGen_HookGenerator_SOURCES = \
+  tools/callbackGen/HookGenerator.hs
+am_tools_callbackGen_HookGenerator_OBJECTS = $(addsuffix .$(OBJEXT),\
+  $(basename $(tools_callbackGen_HookGenerator_SOURCES)))
+
+
+gtk/general/Signal.chs : $(srcdir)/tools/callbackGen/Signal.chs-boot1 \
+			 $(srcdir)/tools/callbackGen/Signal.chs-boot2 \
+			 $(srcdir)/tools/callbackGen/gtkmarshal.list \
+			 $(srcdir)/tools/callbackGen/HookGenerator
+	$(strip $(srcdir)/tools/callbackGen/HookGenerator $(MARSHALLDEFS) \
+	$(srcdir)/tools/callbackGen/ gtk/general/Signal.chs \
+	$(if $(subst yes,,$(BROKENCB)),--broken))
+
+# API Coverage Tool
+Exclude_NAME = tools/apicoverage/Exclude
+$(Exclude_NAME) : NAME = tools_apicoverage_Exclude
+
+tools_apicoverage_Exclude_MAIN = \
+  $(tools_apicoverage_Exclude_SOURCES)
+tools_apicoverage_Exclude_PACKAGEDEPS = data
+tools_apicoverage_Exclude_SOURCES = \
+  tools/apicoverage/Exclude.hs
+am_tools_apicoverage_Exclude_OBJECTS = $(addsuffix .$(OBJEXT),\
+  $(basename $(tools_apicoverage_Exclude_SOURCES)))
+
+
 # While building lib<name>, set the variable NAME to <name> so we can access
 # the package-specific variable <name>_HEADER, <name>_PACKAGE, etc. The
 # following is a hack to prevent automake from assuming that we are overriding
 # the libgtk2hs.a goal.
-libgtk2hs_a_NAME = libgtk2hs.a
-$(libgtk2hs_a_NAME) : NAME = libgtk2hs_a
-
-libgtk2hs_a_TOPLEVEL 	= gtk/general/Gtk.hs
-libgtk2hs_a_PACKAGECONF	= libgtk2hs_a.conf
-libgtk2hs_a_PACKAGE	= gtk2hs
-libgtk2hs_a_PACKAGEDEPS	= data
-libgtk2hs_a_HEADER 	= gtk/gtk.h
-libgtk2hs_a_PRECOMP	= gtk.precomp
-libgtk2hs_a_CFLAGS 	= $(filter-out -I%,@GTK_CFLAGS@)
-libgtk2hs_a_CPPFLAGS	= $(filter -I%,@GTK_CFLAGS@)
-libgtk2hs_a_LIBS	= @GTK_LIBS@
-libgtk2hs_a_HCFLAGS	= -fglasgow-exts
+gtk_libgtk2hs_a_NAME = gtk/libgtk2hs.a
+$(gtk_libgtk2hs_a_NAME) : NAME = gtk_libgtk2hs_a
 
-lib_LIBRARIES = libgtk2hs.a
+gtk_libgtk2hs_a_PACKAGECONF	= libgtk2hs.conf
+gtk_libgtk2hs_a_PACKAGE		= gtk2hs
+gtk_libgtk2hs_a_PACKAGEDEPS	= data
+gtk_libgtk2hs_a_HEADER 		= gtk/gtk.h
+gtk_libgtk2hs_a_PRECOMP		= gtk/gtk.precomp
+gtk_libgtk2hs_a_LIBS		= @GTK_LIBS@
+gtk_libgtk2hs_a_HCFLAGS		= -fglasgow-exts
 
-libgtk2hs_a_SOURCES = \
+gtk_libgtk2hs_a_SOURCES = \
 	gtk/general/Hierarchy.chs \
 	gtk/general/Signal.chs \
 	gtk/glib/GValue.chs \
@@ -171,22 +248,26 @@
 	compat/LocalControl.hs \
 	compat/LocalData.hs
 
-am_libgtk2hs_a_OBJECTS = \
-  $(addsuffix .$(OBJEXT),$(basename $(libgtk2hs_a_SOURCES)))
+am_gtk_libgtk2hs_a_OBJECTS = \
+  $(addsuffix .$(OBJEXT),$(basename $(gtk_libgtk2hs_a_SOURCES)))
 
-libgtk2hs_a_CHSFILES = $(filter %.chs %.chspp, $(libgtk2hs_a_SOURCES))
-libgtk2hs_a_CHSFILES_HS = $(patsubst %.chs,%.hs,\
-	$(patsubst %.chspp,%.hs,$(libgtk2hs_a_CHSFILES)))
-libgtk2hs_a_HSCFILES = $(filter %.hsc, $(libgtk2hs_a_SOURCES))
-libgtk2hs_a_HSCFILES_HS = $(libgtk2hs_a_HSCFILES:.hsc=.hs)
-libgtk2hs_a_BUILDSOURCES = \
-	$(libgtk2hs_a_CHSFILES_HS) \
-	$(libgtk2hs_a_HSCFILES_HS)
-libgtk2hs_a_HSFILES  = \
-	$(libgtk2hs_a_BUILDSOURCES) \
-	$(filter %.hs,$(libgtk2hs_a_SOURCES))
-MOSTLYCLEANFILES = $(libgtk2hs_a_HSFILES:.hs=.$(OBJEXT))
-CLEANFILES+= $(libgtk2hs_a_BUILDSOURCES)
+gtk_libgtk2hs_a_CHSFILES = $(filter %.chs %.chspp, $(gtk_libgtk2hs_a_SOURCES))
+gtk_libgtk2hs_a_CHSFILES_HS = $(patsubst %.chs,%.hs,\
+	$(patsubst %.chspp,%.hs,$(gtk_libgtk2hs_a_CHSFILES)))
+gtk_libgtk2hs_a_HSCFILES = $(filter %.hsc, $(gtk_libgtk2hs_a_SOURCES))
+gtk_libgtk2hs_a_HSCFILES_HS = $(gtk_libgtk2hs_a_HSCFILES:.hsc=.hs)
+gtk_libgtk2hs_a_BUILDSOURCES = \
+	$(gtk_libgtk2hs_a_CHSFILES_HS) \
+	$(gtk_libgtk2hs_a_HSCFILES_HS)
+gtk_libgtk2hs_a_HSFILES  = \
+	$(gtk_libgtk2hs_a_BUILDSOURCES) \
+	$(filter %.hs,$(gtk_libgtk2hs_a_SOURCES))
+MOSTLYCLEANFILES = $(gtk_libgtk2hs_a_HSFILES:.hs=.$(OBJEXT))
+CLEANFILES+= $(gtk_libgtk2hs_a_BUILDSOURCES) $(gtk_libgtk2hs_a_HSFILES:.hs=.hi)
+CLEANFILES+= $(DEPDIR)gtk_libgtk2hs_a.deps
+CLEANFILES+= $(gtk_libgtk2hs_a_CHSFILES_HS:.hs=.dep)
+
+-include $(DEPDIR)gtk_libgtk2hs_a.deps $(gtk_libgtk2hs_a_CHSFILES_HS:.hs=.dep)
 
 # A file with CPP defines that reflect the current configuration.
 CONFIG_H = config.h
@@ -201,35 +282,37 @@
 	$(if $(subst .,,$(srcdir)),$(addprefix $(srcdir)/,$(SOURCEDIRS)), \
 	$(SOURCEDIRS))))
 
-BUILDSOURCES = $(libgtk2hs_a_BUILDSOURCES)
+BUILDSOURCES = $(gtk_libgtk2hs_a_BUILDSOURCES)
+
+LINK = $(strip $(HC) -o $@ $($(NAME)_HCFLAGS) \
+  $(addprefix -package ,$($(NAME)_PACKAGEDEPS)) \
+  $(AM_LDFLAGS) $($(NAME)_EXTRA_LDFLAGS) $($(NAME)_LDFLAGS))
 
 .hs.o: $(CONFIG_H)
-	if test -f $(DEPDIR)$(NAME).dep; then \
-	  $(strip $(HC) -c $< -o $@ $($(NAME)_HCFLAGS) -i$(VPATH) \
-	  $(addprefix -package ,$($(NAME)_PACKAGEDEPS)) \
-	  $(addprefix -package-name ,$($(NAME)_PACKAGE)) \
-	  $(addprefix '-\#include<,$(addsuffix >',$(CONFIG_H) \
-	  $($(NAME)_EXTRA_HFILES))) \
-	  $(AM_CPPFLAGS) $($(NAME)_EXTRA_CPPFLAGS) $($(NAME)_CPPFLAGS))\
-	; else \
-	  $(MAKE) $(AM_MAKEFLAGS) NAME="$(NAME)" $($(NAME)_BUILDSOURCES) \
-	  && \
-	  $(strip $(HC) -M $(addprefix -optdep,-f $(DEPDIR)$(NAME).dep) \
-	  $($(NAME)_HCFLAGS) -i$(VPATH) \
-	  $(addprefix -package ,$($(NAME)_PACKAGEDEPS)) \
-	  $(addprefix '-\#include<,$(addsuffix >',$(CONFIG_H) \
-	  $($(NAME)_EXTRA_HFILES))) \
-	  $(AM_CPPFLAGS) $($(NAME)_EXTRA_CPPFLAGS) $($(NAME)_CPPFLAGS) \
-	  $($(NAME)_HSFILES)) \
-	  && \
-	  $(strip $(HC) --make $($(NAME)_TOPLEVEL) \
-	  $($(NAME)_HCFLAGS) -i$(VPATH) \
-	  $(addprefix -package ,$($(NAME)_PACKAGEDEPS)) \
-	  $(addprefix -package-name ,$($(NAME)_PACKAGE)) \
-	  $(addprefix '-\#include<,$(addsuffix >',$(CONFIG_H) \
-	  $($(NAME)_EXTRA_HFILES))) \
-	  $(AM_CPPFLAGS) $($(NAME)_EXTRA_CPPFLAGS) $($(NAME)_CPPFLAGS))\
-	; fi
+	$(strip $(HC) -c $< -o $@ $($(NAME)_HCFLAGS) -i$(VPATH) \
+	$(addprefix -package ,$($(NAME)_PACKAGEDEPS)) \
+	$(addprefix -package-name ,$($(NAME)_PACKAGE)) \
+	$(addprefix '-\#include<,$(addsuffix >',$(CONFIG_H) \
+	$($(NAME)_EXTRA_HFILES))) \
+	$(AM_CPPFLAGS) $(EXTRA_CPPFLAGS) $(CPPFLAGS))
+
+.DELETE_ON_ERROR : $(DEPDIR)%.deps
+
+$(DEPDIR)%.deps :
+	touch $@
+	$(if $($*_BUILDSOURCES),$(strip \
+	$(MAKE) $(AM_MAKEFLAGS) NAME="$*" $($*_BUILDSOURCES) \
+	&&))\
+	$(strip $(HC) -M $(addprefix -optdep,-f $(DEPDIR)$*.deps) \
+	$($*_HCFLAGS) -i$(VPATH) \
+	$(addprefix -package ,$($*_PACKAGEDEPS)) \
+	$(addprefix '-\#include<,$(addsuffix >',$(CONFIG_H) \
+	$($*_EXTRA_HFILES))) \
+	$(AM_CPPFLAGS) $(EXTRA_CPPFLAGS) $(CPPFLAGS) \
+	$($*_HSFILES))
+
+.chs.dep :
+	@if test -f $@; then touch $@; else $(CHSDEPEND) -i$(VPATH) $<; fi;
 
 .o.hi:
 	@:
@@ -239,27 +322,29 @@
 .PHONY: debug
 debug	:
 	@echo VPATH: $(VPATH)
+	@echo dep files: $(gtk_libgtk2hs_a_CHSFILES_HS:.hs=.dep)
 
 %.precomp :
 	$(strip $(C2HS) $(C2HS_FLAGS) +RTS $(HSTOOLFLAGS) -RTS \
-	$(addprefix -C,$($(NAME)_CFLAGS) $($(NAME)_CPPFLAGS)) \
+	$(addprefix -C,$(CFLAGS) $(CPPFLAGS)) \
 	--precomp=$($(NAME)_PRECOMP) $($(NAME)_HEADER))
 
 .chs.cpp.chs: $(CONFIG_H)
 	$(strip $(HSCPP) $(AM_CPPFLAGS) \
-	$($(NAME)_EXTRA_CPPFLAGS) $($(NAME)_CPPFLAGS) \
-	$($(NAME)_EXTRA_CFLAGS) $($(NAME)_CFLAGS) \
+	$(EXTRA_CPPFLAGS) $(CPPFLAGS) \
+	$(EXTRA_CFLAGS) $(CFLAGS) \
 	$(addprefix -include ,$(CONFIG_H) $($(NAME)_EXTRA_HFILES)) \
 	$< -o $@)
 
-.hsc.hs:
+.hsc.hs: $(CONFIG_H)
 	$(strip $(HSC) $(HSCFLAGS) +RTS $(HSTOOLFLAGS) -RTS \
         $(addprefix -L-optl,\
 	$(AM_LDFLAGS) $($(NAME)_EXTRA_LIBS) $($(NAME)_LIBS)) \
         $(addprefix -C,	$(filter-out -I%,$(AM_CPPFLAGS)) \
-	$($(NAME)_EXTRA_CFLAGS) $($(NAME)_CFLAGS))\
+	$(EXTRA_CFLAGS) $(CFLAGS))\
         $(filter -I%,$(AM_CPPFLAGS)) \
-	$($(NAME)_EXTRA_CPPFLAGS) $($(NAME)_CPPFLAGS)\
+	$(EXTRA_CPPFLAGS) $(CPPFLAGS)\
+	--include $(CONFIG_H) \
         --cc=$(HC) --lflag=-no-hs-main $<)
 
 .chs.hs:
@@ -270,11 +355,3 @@
 	$(CHSDEPEND) -i$(VPATH) $<
 
 
--include $(DEPDIR)*.dep
-
-
-#	$(ECHO) no header file associated with $@
-#	exit 1
-#
-#$(libgtk2hs_a_CHSFILES:.chs=.hs) : %.hs : %.chs $(libgtk2hs_a_PRECOMP)
-

Index: ChangeLog
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/ChangeLog,v
retrieving revision 1.231
retrieving revision 1.232
diff -u -d -r1.231 -r1.232
--- ChangeLog	27 Oct 2004 13:21:37 -0000	1.231
+++ ChangeLog	28 Oct 2004 21:47:57 -0000	1.232
@@ -1,3 +1,13 @@
+2004-10-28  Axel Simon <A....@ke...>
+
+	* mk/mkDepend.in: Undo changes. Dependencies are again where the
+	.chs ffiles are.
+
+	* Makefile.am: Fancy dependency generation through makes built-in
+	feature of updating files that are -include'd. I had to sacrifice
+	separate CFLAGS for different packages/applications. See comment
+	at the beginning of Makefile.am.
+	
 2004-10-27  Axel Simon <A....@ke...>
 
 	* mk/mkDepend.in: Redirect dependencies into .dep/ directory.

[Gtk2hs-commit] gtk2hs/mk chsDepend.in,1.6,1.7

[Axel S. <as...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/mk
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv11265/mk

Modified Files:
	chsDepend.in 
Log Message:
New, hopefully clever enough, way of calculating dependencies.


Index: chsDepend.in
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/mk/chsDepend.in,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- chsDepend.in	27 Oct 2004 13:21:43 -0000	1.6
+++ chsDepend.in	28 Oct 2004 21:47:57 -0000	1.7
@@ -22,7 +22,6 @@
 for FULLNAME in $@; do
   FULLNAMEDEP=`echo "$FULLNAME" | $SED 's/\.chs/.dep/'`;
   FULLNAMEHS=`echo "$FULLNAME" | $SED 's/\.chs/.hs/'`;
-  TARGETNAMEDEP=$DEPDIRSLASH`basename $FULLNAMEDEP`;
   if test -f "$FULLNAME"; then
     DEPS=`$GREP "{#import" $FULLNAME 2> /dev/null | $SED 's/^{#import \([a-zA-Z1-9]*\)#}.*/\1.chs/'`;
     #echo Looking for dependent files: $DEPS
@@ -40,9 +39,9 @@
       done;
       IFS=$OLDIFS;
     done;
+    echo "# .chs dependencies for $FULLNAME" > $FULLNAMEDEP;
     if test -n "$DEPNAMES"; then
-      echo "$FULLNAMEDEP :" > $TARGETNAMEDEP;
-      echo "$FULLNAMEHS : $DEPNAMES" >> $TARGETNAMEDEP;
+      echo "$FULLNAMEHS : $DEPNAMES" >> $FULLNAMEDEP;
     fi;
     echo Writing dependency information for $FULLNAME
   else