gtk2hs-commit — Mailing list for Darcs commit messages.

[Gtk2hs-commit] gtk2hs/tools/c2hs/c2hs/toplevel C2HSConfig.hs.in,1.1.1.1,NONE Main.hs,1.2,NONE Makefile,1.1.1.1,NONE Version.hs,1.2,NONE c2hs_config.c,1.1.1.1,NONE c2hs_config.h,1.1.1.1,NONE

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

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

Removed Files:
	C2HSConfig.hs.in Main.hs Makefile Version.hs c2hs_config.c 
	c2hs_config.h 
Log Message:
Moved the c2hs directories one level up like it was in the old setup.


--- Version.hs DELETED ---

--- c2hs_config.c DELETED ---

--- Main.hs DELETED ---

--- C2HSConfig.hs.in DELETED ---

--- Makefile DELETED ---

--- c2hs_config.h DELETED ---

[Gtk2hs-commit] gtk2hs/tools/c2hs/c2hs/c/tests Main.hs,1.1.1.1,NONE declr.i,1.1.1.1,NONE simple.i,1.1.1.1,NONE struct.i,1.1.1.1,NONE typedef.i,1.1.1.1,NONE

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

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

Removed Files:
	Main.hs declr.i simple.i struct.i typedef.i 
Log Message:
Moved the c2hs directories one level up like it was in the old setup.


--- declr.i DELETED ---

--- typedef.i DELETED ---

--- struct.i DELETED ---

--- simple.i DELETED ---

--- Main.hs DELETED ---

[Gtk2hs-commit] gtk2hs/tools/c2hs/c2hs/lib C2HS.hs,1.1.1.1,NONE C2HSBase.hs,1.1.1.1,NONE C2HSMarsh.hs,1.1.1.1,NONE Makefile,1.1.1.1,NONE

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

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

Removed Files:
	C2HS.hs C2HSBase.hs C2HSMarsh.hs Makefile 
Log Message:
Moved the c2hs directories one level up like it was in the old setup.


--- C2HSMarsh.hs DELETED ---

--- C2HSBase.hs DELETED ---

--- Makefile DELETED ---

--- C2HS.hs DELETED ---

[Gtk2hs-commit] gtk2hs/tools/c2hs/chs CHS.hs,NONE,1.1 CHSLexer.hs,NONE,1.1

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

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

Added Files:
	CHS.hs CHSLexer.hs 
Log Message:
Moved the c2hs directories one level up like it was in the old setup.


--- NEW FILE: CHS.hs ---
--  C->Haskell Compiler: CHS file abstraction
--
--  Author : Manuel M T Chakravarty
--  Created: 16 August 99
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:35 $
--
--  Copyright (c) [1999..2004] Manuel M T Chakravarty
--
--  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.
--
[...1100 lines suppressed...]
errorCHINotFound ide  = do
  raiseError nopos 
    ["Unknown .chi file!",
     "Cannot find the .chi file for `" ++ ide ++ "'."]
  raiseSyntaxError

errorCHICorrupt      :: String -> CST s a
errorCHICorrupt ide  = do
  raiseError nopos 
    ["Corrupt .chi file!",
     "The file `" ++  ide ++ ".chi' is corrupt."]
  raiseSyntaxError

errorCHIVersion :: String -> String -> String -> CST s a
errorCHIVersion ide chiVersion myVersion  = do
  raiseError nopos 
    ["Wrong version of .chi file!",
     "The file `" ++ ide ++ ".chi' is version " 
     ++ chiVersion ++ ", but mine is " ++ myVersion ++ "."]
  raiseSyntaxError

--- NEW FILE: CHSLexer.hs ---
--  C->Haskell Compiler: Lexer for CHS Files
--
--  Author : Manuel M T Chakravarty
--  Created: 13 August 99
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:35 $
--
--  Copyright (c) [1999..2004] Manuel M T Chakravarty
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
--  Lexer for CHS files; the tokens are only partially recognised.
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  * CHS files are assumed to be Haskell 98 files that include C2HS binding
--    hooks.
--
--  * Haskell code is not tokenised, but binding hooks (delimited by `{#'and 
--    `#}') are analysed.  Therefore the lexer operates in two states
--    (realised as two lexer coupled by meta actions) depending on whether
--    Haskell code or a binding hook is currently read.  The lexer reading
--    Haskell code is called `base lexer'; the other one, `binding-hook
--    lexer'.  In addition, there is a inline-c lexer, which, as the
--    binding-hook lexer, can be triggered from the base lexer.
--
--  * Base lexer:
--
--      haskell -> (inline \\ special)*
--		 | special \\ `"'
--		 | comment
--		 | nested
--		 | hstring
--		 | '{#'
--		 | cpp
--      special -> `(' | `{' | `-' | `"'
--      ctrl    -> `\n' | `\f' | `\r' | `\t' | `\v'
--
--      inline  -> any \\ ctrl
--      any     -> '\0'..'\255'
--
--    Within the base lexer control codes appear as separate tokens in the
--    token list.
--
--    NOTE: It is important that `{' is an extra lexeme and not added as an
--	    optional component at the end of the first alternative for
--	    `haskell'.  Otherwise, the principle of the longest match will
--	    divide `foo {#' into the tokens `foo {' and `#' instead of `foo '
--	    and `{#'.
--
--    One line comments are handled by
--
--      comment -> `--' (any \\ `\n')* `\n'
--
--    and nested comments by
--
--      nested -> `{-' any* `-}'
--
--    where `any*' may contain _balanced_ occurrences of `{-' and `-}'.
--
--      hstring -> `"' inhstr* `"'
--      inhstr  -> ` '..`\127' \\ `"'
--		 | `\"'
--
--    Pre-precessor directives as well as the switch to inline-C code are
--    formed as follows:
--
--      cpp	-> `\n#' (inline | `\t')* `\n'
--		 | `\n#c' (' ' | '\t')* `\n'
--
--    We allow whitespace between the `#' and the actual directive, but in `#c'
--    and `#endc' the directive must immediately follow the `#'.  This might
--    be regarded as a not entirely orthogonal design, but simplifies matters
--    especially for `#endc'.
--
--  * On encountering the lexeme `{#', a meta action in the base lexer
--    transfers control to the following binding-hook lexer:
--
--      ident       -> letter (letter | digit | `\'')*
--		     | `\'' letter (letter | digit)* `\''
--      reservedid  -> `as' | `call' | `class' | `context' | `deriving' 
--		     | `enum' | `foreign' | `fun' | `get' | `lib' 
--		     | `newtype' | `pointer' | `prefix' | `pure' | `set'
--		     | `sizeof' | `stable' | `type' | `underscoreToCase' 
--		     | `unsafe' | `with'
--      reservedsym -> `{#' | `#}' | `{' | `}' | `,' | `.' | `->' | `=' 
--		     | `=>' | '-' | `*' | `&' | `^'
--      string      -> `"' instr* `"'
--      verbhs      -> `\`' instr* `\''
--      instr       -> ` '..`\127' \\ `"'
--      comment	    -> `--' (any \\ `\n')* `\n'
--
--    Control characters, white space, and comments are discarded in the
--    binding-hook lexer.  Nested comments are not allowed in a binding hook.
--    Identifiers can be enclosed in single quotes to avoid collision with
--    C->Haskell keywords.
--
--  * In the binding-hook lexer, the lexeme `#}' transfers control back to the 
--    base lexer.  An occurence of the lexeme `{#' inside the binding-hook
--    lexer triggers an error.  The symbol `{#' is not explcitly represented
--    in the resulting token stream.  However, the occurrence of a token
--    representing one of the reserved identifiers `call', `context', `enum',
--    and `field' marks the start of a binding hook.  Strictly speaking, `#}'
--    need also not occur in the token stream, as the next `haskell' token
--    marks a hook's end.  It is, however, useful for producing accurate error 
--    messages (in case an hook is closed to early) to have a token
--    representing `#}'.
--
--  * The rule `ident' describes Haskell identifiers, but without
--    distinguishing between variable and constructor identifers (ie, those
--    starting with a lowercase and those starting with an uppercase letter).
--    However, we use it also to scan C identifiers; although, strictly
--    speaking, it is too general for them.  In the case of C identifiers,
--    this should not have any impact on the range of descriptions accepted by
--    the tool, as illegal identifier will never occur in a C header file that
--    is accepted by the C lexer.  In the case of Haskell identifiers, a
--    confusion between variable and constructor identifiers will be noted by
--    the Haskell compiler translating the code generated by c2hs.  Moreover,
--    identifiers can be enclosed in single quotes to avoid collision with
--    C->Haskell keywords, but those may not contain apostrophes.
--
--  * Any line starting with the character `#' is regarded to be a C
--    preprocessor directive.  With the exception of `#c' and `#endc', which
--    delimit a set of lines containing inline C code.  Hence, in the base
--    lexer, the lexeme `#c' triggers a meta action transferring control to the
--    following inline-C lexer:
--
--      c  -> inline* \\ `\n#endc'
--
--    We do neither treat C strings nor C comments specially.  Hence, if the
--    string "\n#endc" occurs in a comment, we will mistakenly regard it as
--    the end of the inline C code.  Note that the problem cannot happen with
--    strings, as C does not permit strings that extend over multiple lines.
--    At the moment, it just seems not to be worth the effort required to
--    treat this situation more accurately.
--
--    The inline-C lexer also doesn't handle pre-processor directives
--    specially.  Hence, structural pre-processor directives (namely,
--    conditionals) may occur within inline-C code only properly nested.
--
--  Shortcomings
--  ~~~~~~~~~~~~
--  Some lexemes that include single and double quote characters are not lexed
--  correctly.  See the implementation comment at `haskell' for details.
--
--
--- TODO ----------------------------------------------------------------------
--
--  * In `haskell', the case of a single `"' (without a matching second one)
--    is caught by an eplicit error raising rule.  This shouldn't be
--    necessary, but for some strange reason, the lexer otherwise hangs when a 
--    single `"' appears in the input.
--
--  * Comments in the "gap" of a string are not yet supported.
--

module CHSLexer (CHSToken(..), lexCHS) 
where 

import List	 ((\\))
import Monad	 (liftM)
import Numeric   (readDec, readOct, readHex)

import Common    (Position, Pos(posOf), incPos, retPos, tabPos)
import Errors    (ErrorLvl(..), Error, makeError)
import UNames	 (NameSupply, Name, names)
import Idents    (Ident, lexemeToIdent, identToLexeme)
import Lexers    (Regexp, Lexer, Action, epsilon, char, (+>), lexaction,
		  lexactionErr, lexmeta, (>|<), (>||<), ctrlLexer, star, plus,
		  quest, alt, string, LexerState, execLexer)

import C2HSState (CST, raise, raiseError, nop, getNameSupply) 


-- token definition
-- ----------------

-- possible tokens (EXPORTED)
--
data CHSToken = CHSTokArrow   Position		-- `->'
	      | CHSTokDArrow  Position		-- `=>'
	      | CHSTokDot     Position		-- `.'
	      | CHSTokComma   Position		-- `,'
	      | CHSTokEqual   Position		-- `='
	      | CHSTokMinus   Position		-- `-'
	      | CHSTokStar    Position		-- `*'
	      | CHSTokAmp     Position		-- `&'
	      | CHSTokHat     Position		-- `^'
	      | CHSTokLBrace  Position		-- `{'
	      | CHSTokRBrace  Position		-- `}'
	      | CHSTokLParen  Position		-- `('
	      | CHSTokRParen  Position		-- `)'
	      | CHSTokEndHook Position		-- `#}'
	      | CHSTokAs      Position		-- `as'
	      | CHSTokCall    Position		-- `call'
	      | CHSTokClass   Position		-- `class'
	      | CHSTokContext Position		-- `context'
	      | CHSTokDerive  Position		-- `deriving'
	      | CHSTokEnum    Position		-- `enum'
	      | CHSTokForeign Position          -- `foreign'
	      | CHSTokFun     Position		-- `fun'
	      | CHSTokGet     Position		-- `get'
	      | CHSTokImport  Position		-- `import'
	      | CHSTokLib     Position		-- `lib'
	      | CHSTokNewtype Position		-- `newtype'
	      | CHSTokPointer Position		-- `pointer'
	      | CHSTokPrefix  Position		-- `prefix'
	      | CHSTokPure    Position		-- `pure'
	      | CHSTokQualif  Position		-- `qualified'
	      | CHSTokSet     Position		-- `set'
	      | CHSTokSizeof  Position		-- `sizeof'
	      | CHSTokStable  Position		-- `stable'
	      | CHSTokType    Position		-- `type'
	      | CHSTok_2Case  Position		-- `underscoreToCase'
	      | CHSTokUnsafe  Position		-- `unsafe'
	      | CHSTokWith    Position		-- `with'
	      | CHSTokString  Position String	-- string 
	      | CHSTokHSVerb  Position String	-- verbatim Haskell (`...')
	      | CHSTokIdent   Position Ident	-- identifier
	      | CHSTokHaskell Position String	-- verbatim Haskell code
	      | CHSTokCPP     Position String	-- pre-processor directive
	      | CHSTokC	      Position String	-- verbatim C code
	      | CHSTokCtrl    Position Char	-- control code

instance Pos CHSToken where
  posOf (CHSTokArrow   pos  ) = pos
  posOf (CHSTokDArrow  pos  ) = pos
  posOf (CHSTokDot     pos  ) = pos
  posOf (CHSTokComma   pos  ) = pos
  posOf (CHSTokEqual   pos  ) = pos
  posOf (CHSTokMinus   pos  ) = pos
  posOf (CHSTokStar    pos  ) = pos
  posOf (CHSTokAmp     pos  ) = pos
  posOf (CHSTokHat     pos  ) = pos
  posOf (CHSTokLBrace  pos  ) = pos
  posOf (CHSTokRBrace  pos  ) = pos
  posOf (CHSTokLParen  pos  ) = pos
  posOf (CHSTokRParen  pos  ) = pos
  posOf (CHSTokEndHook pos  ) = pos
  posOf (CHSTokAs      pos  ) = pos
  posOf (CHSTokCall    pos  ) = pos
  posOf (CHSTokClass   pos  ) = pos
  posOf (CHSTokContext pos  ) = pos
  posOf (CHSTokDerive  pos  ) = pos
  posOf (CHSTokEnum    pos  ) = pos
  posOf (CHSTokForeign pos  ) = pos
  posOf (CHSTokFun     pos  ) = pos
  posOf (CHSTokGet     pos  ) = pos
  posOf (CHSTokImport  pos  ) = pos
  posOf (CHSTokLib     pos  ) = pos
  posOf (CHSTokNewtype pos  ) = pos
  posOf (CHSTokPointer pos  ) = pos
  posOf (CHSTokPrefix  pos  ) = pos
  posOf (CHSTokPure    pos  ) = pos
  posOf (CHSTokQualif  pos  ) = pos
  posOf (CHSTokSet     pos  ) = pos
  posOf (CHSTokSizeof  pos  ) = pos
  posOf (CHSTokStable  pos  ) = pos
  posOf (CHSTokType    pos  ) = pos
  posOf (CHSTok_2Case  pos  ) = pos
  posOf (CHSTokUnsafe  pos  ) = pos
  posOf (CHSTokWith    pos  ) = pos
  posOf (CHSTokString  pos _) = pos
  posOf (CHSTokHSVerb  pos _) = pos
  posOf (CHSTokIdent   pos _) = pos
  posOf (CHSTokHaskell pos _) = pos
  posOf (CHSTokCPP     pos _) = pos
  posOf (CHSTokC       pos _) = pos
  posOf (CHSTokCtrl    pos _) = pos

instance Eq CHSToken where
  (CHSTokArrow    _  ) == (CHSTokArrow    _  ) = True
  (CHSTokDArrow   _  ) == (CHSTokDArrow   _  ) = True
  (CHSTokDot      _  ) == (CHSTokDot      _  ) = True
  (CHSTokComma    _  ) == (CHSTokComma    _  ) = True
  (CHSTokEqual    _  ) == (CHSTokEqual    _  ) = True
  (CHSTokMinus    _  ) == (CHSTokMinus    _  ) = True
  (CHSTokStar     _  ) == (CHSTokStar     _  ) = True
  (CHSTokAmp      _  ) == (CHSTokAmp      _  ) = True
  (CHSTokHat      _  ) == (CHSTokHat      _  ) = True
  (CHSTokLBrace   _  ) == (CHSTokLBrace   _  ) = True
  (CHSTokRBrace   _  ) == (CHSTokRBrace   _  ) = True
  (CHSTokLParen   _  ) == (CHSTokLParen   _  ) = True
  (CHSTokRParen   _  ) == (CHSTokRParen   _  ) = True
  (CHSTokEndHook  _  ) == (CHSTokEndHook  _  ) = True
  (CHSTokAs       _  ) == (CHSTokAs       _  ) = True
  (CHSTokCall     _  ) == (CHSTokCall     _  ) = True
  (CHSTokClass    _  ) == (CHSTokClass    _  ) = True
  (CHSTokContext  _  ) == (CHSTokContext  _  ) = True
  (CHSTokDerive   _  ) == (CHSTokDerive   _  ) = True
  (CHSTokEnum     _  ) == (CHSTokEnum     _  ) = True
  (CHSTokForeign  _  ) == (CHSTokForeign  _  ) = True
  (CHSTokFun      _  ) == (CHSTokFun      _  ) = True
  (CHSTokGet      _  ) == (CHSTokGet      _  ) = True
  (CHSTokImport   _  ) == (CHSTokImport   _  ) = True
  (CHSTokLib      _  ) == (CHSTokLib      _  ) = True
  (CHSTokNewtype  _  ) == (CHSTokNewtype  _  ) = True
  (CHSTokPointer  _  ) == (CHSTokPointer  _  ) = True
  (CHSTokPrefix   _  ) == (CHSTokPrefix   _  ) = True
  (CHSTokPure     _  ) == (CHSTokPure     _  ) = True
  (CHSTokQualif   _  ) == (CHSTokQualif   _  ) = True
  (CHSTokSet      _  ) == (CHSTokSet      _  ) = True
  (CHSTokSizeof   _  ) == (CHSTokSizeof   _  ) = True
  (CHSTokStable   _  ) == (CHSTokStable   _  ) = True
  (CHSTokType     _  ) == (CHSTokType     _  ) = True
  (CHSTok_2Case   _  ) == (CHSTok_2Case   _  ) = True
  (CHSTokUnsafe   _  ) == (CHSTokUnsafe   _  ) = True
  (CHSTokWith     _  ) == (CHSTokWith     _  ) = True
  (CHSTokString   _ _) == (CHSTokString   _ _) = True
  (CHSTokHSVerb   _ _) == (CHSTokHSVerb   _ _) = True
  (CHSTokIdent    _ _) == (CHSTokIdent    _ _) = True
  (CHSTokHaskell  _ _) == (CHSTokHaskell  _ _) = True
  (CHSTokCPP	  _ _) == (CHSTokCPP	  _ _) = True
  (CHSTokC	  _ _) == (CHSTokC	  _ _) = True
  (CHSTokCtrl	  _ _) == (CHSTokCtrl	  _ _) = True
  _		       == _		       = False

instance Show CHSToken where
  showsPrec _ (CHSTokArrow   _  ) = showString "->"
  showsPrec _ (CHSTokDArrow  _  ) = showString "=>"
  showsPrec _ (CHSTokDot     _  ) = showString "."
  showsPrec _ (CHSTokComma   _  ) = showString ","
  showsPrec _ (CHSTokEqual   _  ) = showString "="
  showsPrec _ (CHSTokMinus   _  ) = showString "-"
  showsPrec _ (CHSTokStar    _  ) = showString "*"
  showsPrec _ (CHSTokAmp     _  ) = showString "&"
  showsPrec _ (CHSTokHat     _  ) = showString "^"
  showsPrec _ (CHSTokLBrace  _  ) = showString "{"
  showsPrec _ (CHSTokRBrace  _  ) = showString "}"
  showsPrec _ (CHSTokLParen  _  ) = showString "("
  showsPrec _ (CHSTokRParen  _  ) = showString ")"
  showsPrec _ (CHSTokEndHook _  ) = showString "#}"
  showsPrec _ (CHSTokAs      _  ) = showString "as"
  showsPrec _ (CHSTokCall    _  ) = showString "call"
  showsPrec _ (CHSTokClass   _  ) = showString "class"
  showsPrec _ (CHSTokContext _  ) = showString "context"
  showsPrec _ (CHSTokDerive  _  ) = showString "deriving"
  showsPrec _ (CHSTokEnum    _  ) = showString "enum"
  showsPrec _ (CHSTokForeign _  ) = showString "foreign"
  showsPrec _ (CHSTokFun     _  ) = showString "fun"
  showsPrec _ (CHSTokGet     _  ) = showString "get"
  showsPrec _ (CHSTokImport  _  ) = showString "import"
  showsPrec _ (CHSTokLib     _  ) = showString "lib"
  showsPrec _ (CHSTokNewtype _  ) = showString "newtype"
  showsPrec _ (CHSTokPointer _  ) = showString "pointer"
  showsPrec _ (CHSTokPrefix  _  ) = showString "prefix"
  showsPrec _ (CHSTokPure    _  ) = showString "pure"
  showsPrec _ (CHSTokQualif  _  ) = showString "qualified"
  showsPrec _ (CHSTokSet     _  ) = showString "set"
  showsPrec _ (CHSTokSizeof  _  ) = showString "sizeof"
  showsPrec _ (CHSTokStable  _  ) = showString "stable"
  showsPrec _ (CHSTokType    _  ) = showString "type"
  showsPrec _ (CHSTok_2Case  _  ) = showString "underscoreToCase"
  showsPrec _ (CHSTokUnsafe  _  ) = showString "unsafe"
  showsPrec _ (CHSTokWith    _  ) = showString "with"
  showsPrec _ (CHSTokString  _ s) = showString ("\"" ++ s ++ "\"")
  showsPrec _ (CHSTokHSVerb  _ s) = showString ("`" ++ s ++ "'")
  showsPrec _ (CHSTokIdent   _ i) = (showString . identToLexeme) i
  showsPrec _ (CHSTokHaskell _ s) = showString s
  showsPrec _ (CHSTokCPP     _ s) = showString s
  showsPrec _ (CHSTokC	     _ s) = showString s
  showsPrec _ (CHSTokCtrl    _ c) = showChar c


-- lexer state
-- -----------

-- state threaded through the lexer
--
data CHSLexerState = CHSLS {
		       nestLvl :: Int,	 -- nesting depth of nested comments
		       inHook  :: Bool,	 -- within a binding hook?
		       namesup :: [Name] -- supply of unique names
		     }

-- initial state
--
initialState :: CST s CHSLexerState
initialState  = do
		  namesup <- liftM names getNameSupply
		  return $ CHSLS {
			     nestLvl = 0,
			     inHook  = False,
			     namesup = namesup
			   }

-- raise an error if the given state is not a final state
--
assertFinalState :: Position -> CHSLexerState -> CST s ()
assertFinalState pos CHSLS {nestLvl = nestLvl, inHook = inHook} 
  | nestLvl > 0 = raiseError pos ["Unexpected end of file!",
				  "Unclosed nested comment."]
  | inHook      = raiseError pos ["Unexpected end of file!",
				  "Unclosed binding hook."]
  | otherwise   = nop

-- lexer and action type used throughout this specification
--
type CHSLexer  = Lexer  CHSLexerState CHSToken
type CHSAction = Action               CHSToken
type CHSRegexp = Regexp CHSLexerState CHSToken

-- for actions that need a new unique name
--
infixl 3 `lexactionName`
lexactionName :: CHSRegexp 
	      -> (String -> Position -> Name -> CHSToken) 
	      -> CHSLexer
re `lexactionName` action = re `lexmeta` action'
  where
    action' str pos state = let name:ns = namesup state
			    in
			    (Just $ Right (action str pos name),
			     incPos pos (length str),
			     state {namesup = ns},
			     Nothing)


-- lexical specification
-- ---------------------

-- the lexical definition of the tokens (the base lexer)
--
--
chslexer :: CHSLexer
chslexer  =      haskell	-- Haskell code
	    >||< nested		-- nested comments
	    >||< ctrl		-- control code (that has to be preserved)
	    >||< hook		-- start of a binding hook
	    >||< cpp		-- a pre-processor directive (or `#c')

-- stream of Haskell code (terminated by a control character or binding hook)
--
haskell :: CHSLexer
--
-- NB: We need to make sure that '"' is not regarded as the beginning of a
--     string; however, we cannot really lex character literals properly
--     without lexing identifiers (as the latter may containing single quotes
--     as part of their lexeme).  Thus, we special case '"'.  This is still a
--     kludge, as a program fragment, such as
--
--	 foo'"'strange string"
--
--     will not be handled correctly.
--
haskell  = (    anyButSpecial`star` epsilon
	    >|< specialButQuotes
	    >|< char '"'  +> inhstr`star` char '"'
	    >|< string "'\"'"				-- special case of "
	    >|< string "--" +> anyButNL`star` epsilon   -- comment
	   )
	   `lexaction` copyVerbatim
	   >||< char '"'		                -- this is a bad kludge
		`lexactionErr` 
		  \_ pos -> (Left $ makeError ErrorErr pos
					      ["Lexical error!", 
					      "Unclosed string."])
	   where
	     anyButSpecial    = alt (inlineSet \\ specialSet)
	     specialButQuotes = alt (specialSet \\ ['"'])
	     anyButNL	      = alt (anySet \\ ['\n'])
	     inhstr	      = instr >|< char '\\' >|< string "\\\"" >|< gap
	     gap	      = char '\\' +> alt (' ':ctrlSet)`plus` char '\\'

-- action copying the input verbatim to `CHSTokHaskell' tokens
--
copyVerbatim        :: CHSAction 
copyVerbatim cs pos  = Just $ CHSTokHaskell pos cs

-- nested comments
--
nested :: CHSLexer
nested  =
       string "{-"		{- for Haskell emacs mode :-( -}
       `lexmeta` enterComment
  >||<
       string "-}"
       `lexmeta` leaveComment
  where
    enterComment cs pos s =
      (copyVerbatim' cs pos,			-- collect the lexeme
       incPos pos 2,				-- advance current position
       s {nestLvl = nestLvl s + 1},		-- increase nesting level
       Just $ inNestedComment)			-- continue in comment lexer
    --
    leaveComment cs pos s =
      case nestLvl s of
        0 -> (commentCloseErr pos,		-- 0: -} outside comment => err
	      incPos pos 2,			-- advance current position
	      s,
	      Nothing)
        1 -> (copyVerbatim' cs pos,		-- collect the lexeme
	      incPos pos 2,			-- advance current position
	      s {nestLvl = nestLvl s - 1},	-- decrease nesting level
	      Just chslexer)			-- 1: continue with root lexer
        _ -> (copyVerbatim' cs pos,		-- collect the lexeme
	      incPos pos 2,			-- advance current position
	      s {nestLvl = nestLvl s - 1},	-- decrease nesting level
	      Nothing)				-- _: cont with comment lexer
    --
    copyVerbatim' cs pos  = Just $ Right (CHSTokHaskell pos cs)
    --
    commentCloseErr pos =
      Just $ Left (makeError ErrorErr pos
			     ["Lexical error!", 
			     "`-}' not preceded by a matching `{-'."])
			     {- for Haskell emacs mode :-( -}


-- lexer processing the inner of a comment
--
inNestedComment :: CHSLexer
inNestedComment  =      commentInterior		-- inside a comment
		   >||< nested			-- nested comments
		   >||< ctrl			-- control code (preserved)

-- standard characters in a nested comment
--
commentInterior :: CHSLexer
commentInterior  = (    anyButSpecial`star` epsilon
		    >|< special
		   )
		   `lexaction` copyVerbatim
		   where
		     anyButSpecial = alt (inlineSet \\ commentSpecialSet)
		     special	   = alt commentSpecialSet

-- control code in the base lexer (is turned into a token)
--
-- * this covers exactly the same set of characters as contained in `ctrlSet'
--   and `Lexers.ctrlLexer' and advances positions also like the `ctrlLexer'
--
ctrl :: CHSLexer
ctrl  =     
       char '\n' `lexmeta` newline
  >||< char '\r' `lexmeta` newline
  >||< char '\v' `lexmeta` newline
  >||< char '\f' `lexmeta` formfeed
  >||< char '\t' `lexmeta` tab
  where
    newline  [c] pos = ctrlResult pos c (retPos pos)
    formfeed [c] pos = ctrlResult pos c (incPos pos 1)
    tab      [c] pos = ctrlResult pos c (tabPos pos)

    ctrlResult pos c pos' s = 
      (Just $ Right (CHSTokCtrl pos c), pos', s, Nothing)

-- start of a binding hook (ie, enter the binding hook lexer)
--
hook :: CHSLexer
hook  = string "{#"
	`lexmeta` \_ pos s -> (Nothing, incPos pos 2, s, Just bhLexer)

-- pre-processor directives and `#c'
--
-- * we lex `#c' as a directive and special case it in the action
--
cpp :: CHSLexer
cpp = directive
      where
        directive = 
	  string "\n#" +> alt ('\t':inlineSet)`star` epsilon
	  `lexmeta` 
	     \(_:_:dir) pos s ->	-- strip off the "\n#"
	       case dir of
	         ['c']                      ->		-- #c
		   (Nothing, retPos pos, s, Just cLexer)
                 -- a #c may be followed by whitespace
	         'c':sp:_ | sp `elem` " \t" ->		-- #c
		   (Nothing, retPos pos, s, Just cLexer)
                 _                            ->        -- CPP directive
		   (Just $ Right (CHSTokCPP pos dir), 
		    retPos pos, s, Nothing)

-- the binding hook lexer
--
bhLexer :: CHSLexer
bhLexer  =      identOrKW
	   >||< symbol
	   >||< strlit
	   >||< hsverb
	   >||< whitespace
	   >||< endOfHook
	   >||< string "--" +> anyButNL`star` char '\n'	  -- comment
		`lexmeta` \_ pos s -> (Nothing, retPos pos, s, Nothing)
	   where
	     anyButNL  = alt (anySet \\ ['\n'])
	     endOfHook = string "#}"
			 `lexmeta` 
			  \_ pos s -> (Just $ Right (CHSTokEndHook pos), 
				       incPos pos 2, s, Just chslexer)

-- the inline-C lexer
--
cLexer :: CHSLexer
cLexer =      inlineC			  -- inline C code
	 >||< ctrl		          -- control code (preserved)
         >||< string "\n#endc"		  -- end of inline C code...
	      `lexmeta`			  -- ...preserve '\n' as control token
	      \_ pos s -> (Just $ Right (CHSTokCtrl pos '\n'), retPos pos, s, 
			   Just chslexer)
	 where
	   inlineC = alt inlineSet `lexaction` copyVerbatimC
	   --
	   copyVerbatimC :: CHSAction 
	   copyVerbatimC cs pos = Just $ CHSTokC pos cs

-- whitespace
--
-- * horizontal and vertical tabs, newlines, and form feeds are filter out by
--   `Lexers.ctrlLexer' 
--
whitespace :: CHSLexer
whitespace  =      (char ' ' `lexaction` \_ _ -> Nothing)
	      >||< ctrlLexer

-- identifiers and keywords
--
identOrKW :: CHSLexer
--
-- the strictness annotations seem to help a bit
--
identOrKW  = 
       -- identifier or keyword
       (letter +> (letter >|< digit >|< char '\'')`star` epsilon
       `lexactionName` \cs pos name -> (idkwtok $!pos) cs name)
  >||< -- identifier in single quotes
       (char '\'' +> letter +> (letter >|< digit)`star` char '\''
       `lexactionName` \cs pos name -> (mkid $!pos) cs name)
       -- NB: quotes are removed by lexemeToIdent
  where
    idkwtok pos "as"               _    = CHSTokAs      pos
    idkwtok pos "call"             _    = CHSTokCall    pos
    idkwtok pos "class"            _    = CHSTokClass   pos
    idkwtok pos "context"          _    = CHSTokContext pos
    idkwtok pos "deriving"	   _	= CHSTokDerive  pos
    idkwtok pos "enum"             _    = CHSTokEnum    pos
    idkwtok pos "foreign"	   _	= CHSTokForeign pos
    idkwtok pos "fun"              _    = CHSTokFun     pos
    idkwtok pos "get"              _    = CHSTokGet     pos
    idkwtok pos "import"           _    = CHSTokImport  pos
    idkwtok pos "lib"              _    = CHSTokLib     pos
    idkwtok pos "newtype"          _    = CHSTokNewtype pos
    idkwtok pos "pointer"          _    = CHSTokPointer pos
    idkwtok pos "prefix"           _    = CHSTokPrefix  pos
    idkwtok pos "pure"             _    = CHSTokPure    pos
    idkwtok pos "qualified"        _    = CHSTokQualif  pos
    idkwtok pos "set"              _    = CHSTokSet     pos
    idkwtok pos "sizeof"           _    = CHSTokSizeof  pos
    idkwtok pos "stable"	   _	= CHSTokStable	pos
    idkwtok pos "type"             _    = CHSTokType    pos
    idkwtok pos "underscoreToCase" _    = CHSTok_2Case  pos
    idkwtok pos "unsafe"           _    = CHSTokUnsafe  pos
    idkwtok pos "with"             _    = CHSTokWith    pos
    idkwtok pos cs                 name = mkid pos cs name
    --
    mkid pos cs name = CHSTokIdent pos (lexemeToIdent pos cs name)

-- reserved symbols
--
symbol :: CHSLexer
symbol  =      sym "->" CHSTokArrow
	  >||< sym "=>" CHSTokDArrow
	  >||< sym "."  CHSTokDot
	  >||< sym ","  CHSTokComma
	  >||< sym "="  CHSTokEqual
	  >||< sym "-"  CHSTokMinus
	  >||< sym "*"  CHSTokStar
	  >||< sym "&"  CHSTokAmp
	  >||< sym "^"  CHSTokHat
	  >||< sym "{"  CHSTokLBrace
	  >||< sym "}"  CHSTokRBrace
	  >||< sym "("  CHSTokLParen
	  >||< sym ")"  CHSTokRParen
	  where
	    sym cs con = string cs `lexaction` \_ pos -> Just (con pos)

-- string
--
strlit :: CHSLexer
strlit  = char '"' +> (instr >|< char '\\')`star` char '"'
	  `lexaction` \cs pos -> Just (CHSTokString pos (init . tail $ cs))

-- verbatim code
--
hsverb :: CHSLexer
hsverb  = char '`' +> inhsverb`star` char '\''
	  `lexaction` \cs pos -> Just (CHSTokHSVerb pos (init . tail $ cs))


-- regular expressions
--
letter, digit, instr, inchar, inhsverb :: Regexp s t
letter   = alt ['a'..'z'] >|< alt ['A'..'Z'] >|< char '_'
digit    = alt ['0'..'9']
instr    = alt ([' '..'\127'] \\ "\"\\")
inchar   = alt ([' '..'\127'] \\ "\'")
inhsverb = alt ([' '..'\127'] \\ "\'")

-- character sets
--
anySet, inlineSet, specialSet, commentSpecialSet, ctrlSet :: [Char]
anySet            = ['\0'..'\255']
inlineSet         = anySet \\ ctrlSet
specialSet        = ['{', '-', '"', '\'']
commentSpecialSet = ['{', '-']
ctrlSet           = ['\n', '\f', '\r', '\t', '\v']


-- main lexing routine
-- -------------------

-- generate a token sequence out of a string denoting a CHS file
-- (EXPORTED) 
--
-- * the given position is attributed to the first character in the string
--
-- * errors are entered into the compiler state
--
lexCHS        :: String -> Position -> CST s [CHSToken]
lexCHS cs pos  = 
  do
    state <- initialState
    let (ts, lstate, errs) = execLexer chslexer (cs, pos, state)
        (_, pos', state')  = lstate
    mapM raise errs
    assertFinalState pos' state'
    return ts

[Gtk2hs-commit] gtk2hs/tools/c2hs/gen CInfo.hs,NONE,1.1 GBMonad.hs,NONE,1.1 GenBind.hs,NONE,1.1 GenHeader.hs,NONE,1.1

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

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

Added Files:
	CInfo.hs GBMonad.hs GenBind.hs GenHeader.hs 
Log Message:
Moved the c2hs directories one level up like it was in the old setup.


--- NEW FILE: GenHeader.hs ---
--  C->Haskell Compiler: custom header generator
--
--  Author : Manuel M T Chakravarty
--  Created: 5 February 2003
--
--  Version $Revision: 1.1 $
--
--  Copyright (c) 2004 Manuel M T Chakravarty
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
--  This module implements the generation of a custom header from a binding
--  module. 
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  Computing CPP Conditionals
--  ~~~~~~~~~~~~~~~~~~~~~~~~~~
--  We obtain information about which branches of CPP conditions are taken
--  during pre-processing of the custom header file by introducing new
--  struct declarations.  Specifically, after each #if[[n]def] or #elif,
--  we place a declaration of the form
--
--    struct C2HS_COND_SENTRY<unique number>;
--
--  We can, then, determine which branch of a conditional has been taken by
--  checking whether the struct corresponding to that conditional has been
--  declared.
--
--- TODO ----------------------------------------------------------------------
--
-- * Ideally, `ghFrag[s]' should be tail recursive

module GenHeader (
  genHeader
) where 

-- standard libraries
import Monad     (when)

-- Compiler Toolkit
import Common    (Position, Pos(..), nopos)
import DLists	 (DList, openDL, closeDL, zeroDL, unitDL, joinDL, snocDL)
import Errors	 (interr)
import Idents	 (onlyPosIdent)
import UNames    (NameSupply, Name, names)

-- C->Haskell
import C2HSState (CST, getNameSupply, runCST, transCST, raiseError, catchExc,
		  throwExc, errorsPresent, showErrors, fatal)

-- friends
import CHS	 (CHSModule(..), CHSFrag(..))


-- The header generation monad
--
type GH a = CST [Name] a

-- |Generate a custom C header from a CHS binding module.
--
-- * All CPP directives and inline-C fragments are moved into the custom header
--
-- * The CPP and inline-C fragments are removed from the .chs tree and
--   conditionals are replaced by structured conditionals
--
genHeader :: CHSModule -> CST s ([String], CHSModule, String)
genHeader mod = 
  do
    supply <- getNameSupply
    (header, mod) <- runCST (ghModule mod) (names supply)
		     `ifGHExc` return ([], CHSModule [])

    -- check for errors and finalise
    --
    errs <- errorsPresent
    if errs
      then do
	errmsgs <- showErrors
	fatal ("Errors during generation of C header:\n\n"   -- fatal error
	       ++ errmsgs)
      else do
	warnmsgs <- showErrors
        return (header, mod, warnmsgs)

-- Obtain a new base name that may be used, in C, to encode the result of a
-- preprocessor conditionl.
--
newName :: CST [Name] String
newName = transCST $
  \supply -> (tail supply, "C2HS_COND_SENTRY_" ++ show (head supply))

-- Various forms of processed fragments
--
data FragElem = Frag  CHSFrag
	      | Elif  String Position
	      | Else  Position
	      | Endif Position
	      | EOF

instance Pos FragElem where
  posOf (Frag frag    ) = posOf frag
  posOf (Elif _    pos) = pos
  posOf (Else      pos) = pos
  posOf (Endif     pos) = pos
  posOf EOF	        = nopos

-- check for end of file
--
isEOF :: FragElem -> Bool
isEOF EOF = True
isEOF _   = False

-- Generate the C header for an entire .chs module.
--
-- * This works more or less like a recursive decent parser for a statement
--   sequence that may contain conditionals, where `ghFrag' implements most of
--   the state transition system of the associated automaton
--
ghModule :: CHSModule -> GH ([String], CHSModule)
ghModule (CHSModule frags) =
  do
    (header, frags, last, rest) <- ghFrags frags
    when (not . isEOF $ last) $
      notOpenCondErr (posOf last)
    return (closeDL header, CHSModule frags)

-- Collect header and fragments up to eof or a CPP directive that is part of a
-- conditional
--
-- * We collect the header (ie, CPP directives and inline-C) using a
--   difference list to avoid worst case O(n^2) complexity due to
--   concatenation of lines that go into the header.
--
ghFrags :: [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
ghFrags []    = return (zeroDL, [], EOF, [])
ghFrags frags = 
  do
    (header, frag, rest) <- ghFrag frags
    case frag of
      Frag aFrag -> do
		      (header2, frags', frag', rest) <- ghFrags rest
		      -- FIXME: Not tail rec
		      return (header `joinDL` header2, aFrag:frags', 
			      frag', rest)
      _          -> return (header, [], frag, rest)

-- Process a single fragment *structure*; i.e., if the first fragment
-- introduces a conditional, process the whole conditional; otherwise, process
-- the first fragment
--
ghFrag :: [CHSFrag] -> GH (DList String, -- partial header file
			   FragElem,	 -- processed fragment
			   [CHSFrag])	 -- not yet processed fragments
ghFrag []                              =
  return (zeroDL, EOF, [])
ghFrag (frag@(CHSVerb  _ _  ) : frags) = 
  return (zeroDL, Frag frag, frags)
ghFrag (frag@(CHSHook  _    ) : frags) =
  return (zeroDL, Frag frag, frags)
ghFrag (     (CHSC    s  _  ) : frags) =
  do
    (header, frag, frags' ) <- ghFrag frags	-- scan for next CHS fragment
    return (unitDL s `joinDL` header, frag, frags')
    -- FIXME: this is not tail recursive...
ghFrag (     (CHSCond _  _  ) : frags) =
  interr "GenHeader.ghFrags: There can't be a structured conditional yet!"
ghFrag (frag@(CHSCPP  s  pos) : frags) =
  let
    (directive, _) =   break (`elem` " \t")
		     . dropWhile (`elem` " \t") 
		     $ s
  in
  case directive of
    "if"     ->	openIf s pos frags
    "ifdef"  -> openIf s pos frags
    "ifndef" -> openIf s pos frags
    "else"   -> return (zeroDL              , Else   pos               , frags)
    "elif"   -> return (zeroDL              , Elif s pos               , frags)
    "endif"  -> return (zeroDL              , Endif  pos               , frags)
    _        -> return (openDL ['#':s, "\n"], Frag   (CHSVerb "" nopos), frags)
  where
    -- enter a new conditional (may be an #if[[n]def] or #elif)
    --
    -- * Arguments are the lexeme of the directive `s', the position of that
    --   directive `pos', and the fragments following the directive `frags'
    --
    openIf s pos frags = 
      do
        (headerTh, fragsTh, last, rest) <- ghFrags frags
	case last of
	  Else    pos -> do
			   (headerEl, fragsEl, last, rest) <- ghFrags rest
			   case last of
	 	       	     Else    pos -> notOpenCondErr pos
	 	       	     Elif  _ pos -> notOpenCondErr pos
	 	       	     Endif   pos -> closeIf 
					      ((headerTh 
					        `snocDL` "#else\n")
					       `joinDL` 
					       (headerEl
					        `snocDL` "#endif\n"))
		       	      		      (s, fragsTh)
					      []
					      (Just fragsEl)
					      rest
	 	       	     EOF         -> notClosedCondErr pos
	  Elif s' pos -> do
			   (headerEl, condFrag, rest) <- openIf s' pos rest
			   case condFrag of
			     Frag (CHSCond alts dft) -> 
			       closeIf (headerTh `joinDL` headerEl)
				       (s, fragsTh)
				       alts
				       dft
				       rest
			     _		             -> 
			       interr "GenHeader.ghFrag: Expected CHSCond!"
	  Endif   pos -> closeIf (headerTh `snocDL` "#endif\n") 
				 (s, fragsTh)
				 []
				 (Just []) 
				 rest
	  EOF         -> notClosedCondErr pos
    --
    -- turn a completed conditional into a `CHSCond' fragment
    --
    -- * `(s, fragsTh)' is the CPP directive `s' containing the condition under
    --   which `fragTh' should be executed; `alts' are alternative branches
    --   (with conditions); and `oelse' is an optional else-branch
    --
    closeIf headerTail (s, fragsTh) alts oelse rest = 
      do
        sentryName <- newName
	let sentry = onlyPosIdent nopos sentryName
		       -- don't use an internal ident, as we need to test for
		       -- equality with identifiers read from the .i file
		       -- during binding hook expansion
	    header = openDL ['#':s, "\n",
			     "struct ", sentryName, ";\n"] 
			    `joinDL` headerTail
	return (header, Frag (CHSCond ((sentry, fragsTh):alts) oelse), rest)


-- exception handling
-- ------------------

-- exception identifier
--
ghExc :: String
ghExc  = "ghExc"

-- throw an exception
--
throwGHExc :: GH a
throwGHExc  = throwExc ghExc "Error during C header generation"

-- catch a `ghExc'
--
ifGHExc           :: CST s a -> CST s a -> CST s a
ifGHExc m handler  = m `catchExc` (ghExc, const handler)

-- raise an error followed by throwing a GH exception
--
raiseErrorGHExc          :: Position -> [String] -> GH a
raiseErrorGHExc pos errs  = raiseError pos errs >> throwGHExc


-- error messages
-- --------------

notClosedCondErr :: Position -> GH a
notClosedCondErr pos  =
  raiseErrorGHExc pos
    ["Unexpected end of file!",
     "File ended while the conditional block starting here was not closed \
     \properly."]

notOpenCondErr :: Position -> GH a
notOpenCondErr pos  =
  raiseErrorGHExc pos
    ["Missing #if[[n]def]!",
     "There is a #else, #elif, or #endif without an #if, #ifdef, or #ifndef."]

--- NEW FILE: GBMonad.hs ---
--  C->Haskell Compiler: monad for the binding generator
--
--  Author : Manuel M T Chakravarty
--  Derived: 18 February 2 (extracted from GenBind.hs)
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:41 $
--
--  Copyright (c) [2002..2003] Manuel M T Chakravarty
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
--  This modules defines the monad and related utility routines for the code
--  that implements the expansion of the binding hooks.
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  Translation table handling for enumerators:
--  -------------------------------------------
--
--  First a translation table lookup on the original identifier of the
--  enumerator is done.  If that doesn't match and the prefix can be removed
--  from the identifier, a second lookup on the identifier without the prefix
--  is performed.  If this also doesn't match, the identifier without prefix
--  (possible after underscoreToCase translation is returned).  If there is a
--  match, the translation (without any further stripping of prefix) is
--  returned.  
--
--  Pointer map
--  -----------
--
--  Pointer hooks allow the use to customise the Haskell types to which C
--  pointer types are mapped.  The globally maintained map essentially maps C
--  pointer types to Haskell pointer types.  The representation of the Haskell
--  types is defined by the `type' or `newtype' declaration emitted by the
--  corresponding pointer hook.  However, the map stores a flag that tells
--  whether the C type is itself the pointer type in question or whether it is
--  pointers to this C type that should be mapped as specified.  The pointer
--  map is dumped into and read from `.chi' files.
--
--  Haskell object map
--  ------------------
--
--  Some features require information about Haskell objects defined by c2hs.
--  Therefore, the Haskell object map maintains the necessary information
--  about these Haskell objects.  The Haskell object map is dumped into and
--  read from `.chi' files.
--
--- TODO ----------------------------------------------------------------------
--
--  * Look up in translation tables is naive - this probably doesn't affect
--    costs much, but at some point a little profiling might be beneficial.
--

module GBMonad (
  TransFun, transTabToTransFun,

  HsObject(..), GB, HsPtrRep, initialGBState, setContext, getLibrary,
  getPrefix, delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs,
  queryObj, queryClass, queryPointer, mergeMaps, dumpMaps
  ) where

-- standard libraries
import Char	  (toUpper, toLower, isSpace)
import List       (find)
import Maybe	  (fromMaybe)

-- Compiler Toolkit
import Common     (Position, Pos(posOf), nopos, builtinPos)
import Errors	  (interr)
import Idents     (Ident, identToLexeme, onlyPosIdent)
import Data.FiniteMap (FiniteMap, emptyFM, addToFM, lookupFM, plusFM,
		       fmToList, listToFM)

-- C -> Haskell
import C	  (CT, readCT, transCT, raiseErrorCTExc)

-- friends
import CHS	  (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..),
		   CHSAccess(..), CHSAPath(..), CHSPtrType(..))


-- translation tables
-- ------------------

-- takes an identifier to a lexeme including a potential mapping by a
-- translation table
--
type TransFun = Ident -> String

-- translation function for the `underscoreToCase' flag
--
underscoreToCase     :: TransFun
underscoreToCase ide  = let lexeme = identToLexeme ide
			    ps	   = filter (not . null) . parts $ lexeme
			in
			concat . map adjustCase $ ps
			where
			  parts s = let (l, s') = break (== '_') s
				    in  
				    l : case s' of
					  []      -> []
					  (_:s'') -> parts s''
			  
			  adjustCase (c:cs) = toUpper c : map toLower cs

-- takes an identifier association table to a translation function
--
-- * if first argument is `True', identifiers that are not found in the
--   translation table are subjected to `underscoreToCase'
--
-- * the details of handling the prefix are given in the DOCU section at the
--   beginning of this file
--
transTabToTransFun :: String -> CHSTrans -> TransFun
transTabToTransFun prefix (CHSTrans _2Case table) =
  \ide -> let 
	    lexeme = identToLexeme ide
	    dft    = if _2Case			-- default uses maybe the...
		     then underscoreToCase ide  -- ..._2case transformed...
		     else lexeme		-- ...lexeme
	  in
	  case lookup ide table of		    -- lookup original ident
	    Just ide' -> identToLexeme ide'	    -- original ident matches
	    Nothing   -> 
	      case eat prefix lexeme of
	        Nothing          -> dft		    -- no match & no prefix
	        Just eatenLexeme -> 
		  let 
		    eatenIde = onlyPosIdent (posOf ide) eatenLexeme
		    eatenDft = if _2Case 
			       then underscoreToCase eatenIde 
			       else eatenLexeme
		  in
		  case lookup eatenIde table of     -- lookup without prefix
		    Nothing   -> eatenDft	    -- orig ide without prefix
		    Just ide' -> identToLexeme ide' -- without prefix matched
  where
    -- try to eat prefix and return `Just partialLexeme' if successful
    --
    eat []         ('_':cs)                        = eat [] cs
    eat []         cs                              = Just cs
    eat (p:prefix) (c:cs) | toUpper p == toUpper c = eat prefix cs
			  | otherwise		   = Nothing
    eat _          _				   = Nothing


-- the local monad
-- ---------------

-- map that for maps C pointer types to Haskell types for pointer that have
-- been registered using a pointer hook
--
-- * the `Bool' indicates whether for a C type "ctype", we map "ctype" itself
--   or "*ctype"
--
-- * the co-domain details how this pointer is represented in Haskell.
--   See HsPtrRep.
--
type PointerMap = FiniteMap (Bool, Ident) HsPtrRep


-- Define how pointers are represented in Haskell.
--
-- * The first element is true if the pointer points to a function.
--   The second is the Haskell pointer type (plain
--   Ptr, ForeignPtr or StablePtr). The third field is (Just wrap) if the
--   pointer is wrapped in a newtype. Where "wrap" 
--   contains the name of the Haskell data type that was defined for this
--   pointer. The forth element contains the type argument of the
--   Ptr, ForeignPtr or StablePtr and is the same as "wrap"
--   unless the user overrode it with the -> notation.
type HsPtrRep = (Bool, CHSPtrType, Maybe String, String)


-- map that maintains key information about some of the Haskell objects
-- generated by c2hs
--
-- NB: using records here avoids to run into a bug with deriving `Read' in GHC
--     5.04.1
--
data HsObject    = Pointer {
		     ptrTypeHO    :: CHSPtrType,   -- kind of pointer
		     isNewtypeHO  :: Bool	   -- newtype?
		   }
		 | Class {
		     superclassHO :: (Maybe Ident),-- superclass
		     ptrHO	  :: Ident	   -- pointer
		   }
                 deriving (Show, Read)
type HsObjectMap = FiniteMap Ident HsObject

{- FIXME: What a mess...
instance Show HsObject where
  show (Pointer ptrType isNewtype) = 
    "Pointer " ++ show ptrType ++ show isNewtype
  show (Class   osuper  pointer  ) = 
    "Class " ++ show ptrType ++ show isNewtype
-}
-- super kludgy (depends on Show instance of Ident)
instance Read Ident where
  readsPrec _ ('`':lexeme) = let (ideChars, rest) = span (/= '\'') lexeme
			     in
			     if null ideChars 
			     then []
			     else [(onlyPosIdent nopos ideChars, tail rest)]
  readsPrec p (c:cs)
    | isSpace c						     = readsPrec p cs
  readsPrec _ _						     = []

-- the local state consists of
--
-- (1) the dynamic library specified by the context hook,
-- (2) the prefix specified by the context hook,
-- (3) the set of delayed code fragaments, ie, pieces of Haskell code that,
--     finally, have to be appended at the CHS module together with the hook
--     that created them (the latter allows avoid duplication of foreign
--     export declarations), and
-- (4) a map associating C pointer types with their Haskell representation
--     
-- access to the attributes of the C structure tree is via the `CT' monad of
-- which we use an instance here
--
data GBState  = GBState {
		  lib     :: String,		   -- dynamic library
		  prefix  :: String,		   -- prefix
	          frags   :: [(CHSHook, CHSFrag)], -- delayed code (with hooks)
		  ptrmap  :: PointerMap,	   -- pointer representation
		  objmap  :: HsObjectMap	   -- generated Haskell objects
	       }

type GB a = CT GBState a

initialGBState :: GBState
initialGBState  = GBState {
		    lib    = "",
		    prefix = "",
		    frags  = [],
		    ptrmap = emptyFM,
		    objmap = emptyFM
		  }

-- set the dynamic library and library prefix
--
setContext            :: (Maybe String) -> (Maybe String) -> GB ()
setContext lib prefix  = 
  transCT $ \state -> (state {lib    = fromMaybe "" lib,
			      prefix = fromMaybe "" prefix},
		       ())

-- get the dynamic library
--
getLibrary :: GB String
getLibrary  = readCT lib

-- get the prefix string
--
getPrefix :: GB String
getPrefix  = readCT prefix

-- add code to the delayed fragments (the code is made to start at a new line)
--
-- * currently only code belonging to call hooks can be delayed
--
-- * if code for the same call hook (ie, same C function) is delayed
--   repeatedly only the first entry is stored; it is checked that the hooks
--   specify the same flags (ie, produce the same delayed code)
--
delayCode          :: CHSHook -> String -> GB ()
delayCode hook str  = 
  do
    frags <- readCT frags
    frags' <- delay hook frags
    transCT (\state -> (state {frags = frags'}, ()))
    where
      newEntry = (hook, (CHSVerb ("\n" ++ str) (posOf hook)))
      --
      delay hook@(CHSCall isFun isUns ide oalias _) frags =
	case find (\(hook', _) -> hook' == hook) frags of
	  Just (CHSCall isFun' isUns' ide' _ _, _) 
	    |    isFun == isFun' 
	      && isUns == isUns' 
	      && ide   == ide'   -> return frags
	    | otherwise		 -> err (posOf ide) (posOf ide')
	  Nothing                -> return $ frags ++ [newEntry]
      delay _ _                                  =
	interr "GBMonad.delayCode: Illegal delay!"
      --
      err = incompatibleCallHooksErr

-- get the complete list of delayed fragments
--
getDelayedCode :: GB [CHSFrag]
getDelayedCode  = readCT (map snd . frags)

-- add an entry to the pointer map
--
ptrMapsTo :: (Bool, Ident) -> HsPtrRep -> GB ()
(isStar, cName) `ptrMapsTo` hsRepr =
  transCT (\state -> (state { 
		        ptrmap = addToFM (ptrmap state) (isStar, cName) hsRepr
		      }, ()))

-- query the pointer map
--
queryPtr        :: (Bool, Ident) -> GB (Maybe HsPtrRep)
queryPtr pcName  = do
		     fm <- readCT ptrmap
		     return $ lookupFM fm pcName

-- add an entry to the Haskell object map
--
objIs :: Ident -> HsObject -> GB ()
hsName `objIs` obj =
  transCT (\state -> (state { 
		        objmap = addToFM (objmap state) hsName obj
		      }, ()))

-- query the Haskell object map
--
queryObj        :: Ident -> GB (Maybe HsObject)
queryObj hsName  = do
		     fm <- readCT objmap
		     return $ lookupFM fm hsName

-- query the Haskell object map for a class
--
-- * raise an error if the class cannot be found
--
queryClass        :: Ident -> GB HsObject
queryClass hsName  = do
		       let pos = posOf hsName
		       oobj <- queryObj hsName
		       case oobj of
		         Just obj@(Class _ _) -> return obj
			 Just _		      -> classExpectedErr hsName
			 Nothing	      -> hsObjExpectedErr hsName

-- query the Haskell object map for a pointer
--
-- * raise an error if the pointer cannot be found
--
queryPointer        :: Ident -> GB HsObject
queryPointer hsName  = do
		       let pos = posOf hsName
		       oobj <- queryObj hsName
		       case oobj of
		         Just obj@(Pointer _ _) -> return obj
			 Just _		        -> pointerExpectedErr hsName
			 Nothing	        -> hsObjExpectedErr hsName

-- merge the pointer and Haskell object maps
--
-- * currently, the read map overrides any entires for shared keys in the map
--   that is already in the monad; this is so that, if multiple import hooks
--   add entries for shared keys, the textually latest prevails; any local
--   entries are entered after all import hooks anyway
--
-- FIXME: This currently has several shortcomings:
--	  * It just dies in case of a corrupted .chi file
--	  * We should at least have the option to raise a warning if two
--	    entries collide in the `objmap'.  But it would be better to
--	    implement qualified names.
--	  * Do we want position information associated with the read idents?
--
mergeMaps     :: String -> GB ()
mergeMaps str  =
  transCT (\state -> (state { 
		        ptrmap = plusFM readPtrMap (ptrmap state),
		        objmap = plusFM readObjMap (objmap state)
		      }, ()))
  where
    (ptrAssoc, objAssoc) = read str
    readPtrMap           = listToFM [((isStar, onlyPosIdent nopos ide), repr)
			            | ((isStar, ide), repr) <- ptrAssoc]
    readObjMap           = listToFM [(onlyPosIdent nopos ide, obj)
			            | (ide, obj)            <- objAssoc]

-- convert the whole pointer and Haskell object maps into printable form
--
dumpMaps :: GB String
dumpMaps  = do
	      ptrFM <- readCT ptrmap
	      objFM <- readCT objmap
	      let dumpable = ([((isStar, identToLexeme ide), repr)
			      | ((isStar, ide), repr) <- fmToList ptrFM],
			      [(identToLexeme ide, obj)
			      | (ide, obj)            <- fmToList objFM])
	      return $ show dumpable


-- error messages
-- --------------

incompatibleCallHooksErr            :: Position -> Position -> GB a
incompatibleCallHooksErr here there  =
  raiseErrorCTExc here 
    ["Incompatible call hooks!",
     "There is a another call hook for the same C function at " ++ show there,
     "The flags and C function name of the two hooks should be identical,",
     "but they are not."]

classExpectedErr     :: Ident -> GB a
classExpectedErr ide  =
  raiseErrorCTExc (posOf ide)
    ["Expected a class name!",
     "Expected `" ++ identToLexeme ide ++ "' to refer to a class introduced",
     "by a class hook."]

pointerExpectedErr     :: Ident -> GB a
pointerExpectedErr ide  =
  raiseErrorCTExc (posOf ide)
    ["Expected a pointer name!",
     "Expected `" ++ identToLexeme ide ++ "' to be a type name introduced by",
     "a pointer hook."]

hsObjExpectedErr     :: Ident -> GB a
hsObjExpectedErr ide  =
  raiseErrorCTExc (posOf ide)
    ["Unknown name!",
     "`" ++ identToLexeme ide ++ "' is unknown; it has *not* been defined by",
     "a previous hook."]


--- NEW FILE: CInfo.hs ---
--  C->Haskell Compiler: information about the C implementation
--
--  Author : Manuel M T Chakravarty
--  Created: 5 February 01
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:41 $
--
--  Copyright (c) 2001 Manuel M T Chakravarty
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
--  This module provide some information about the specific implementation of
--  C that we are dealing with.
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  Bit fields
--  ~~~~~~~~~~
--  Bit fields in C can be signed and unsigned.  According to K&R A8.3, they
--  can only be formed from `int', `signed int', and `unsigned int', where for
--  `int' it is implementation dependent whether the field is signed or
--  unsigned.  Moreover, the following parameters are implementation
--  dependent:
--
--  * the direction of packing bits into storage units,
--  * the size of storage units, and
--  * whether when a field that doesn't fit a partially filled storage unit
--    is split across units or the partially filled unit is padded.
--
--  Generally, unnamed fields (those without an identifier) with a width of 0
--  are guaranteed to forces the above padding.  Note that in `CPrimType' we
--  only represent 0 width fields *if* they imply padding.  In other words,
--  whenever they are unnamed, they are represented by a `CPrimType', and if
--  they are named, they are represented by a `CPrimType' only if that
--  targeted C compiler chooses to let them introduce padding.  If a field
--  does not have any effect, it is dropped during the conversion of a C type
--  into a `CPrimType'-based representation.
--
--  In the code, we assume that the alignment of a bitfield (as determined by
--  `bitfieldAlignment') is independent of the size of the bitfield.
--
--- TODO ----------------------------------------------------------------------
--

module CInfo (
  CPrimType(..), size, alignment, 
  bitfieldDirection, bitfieldPadding, bitfieldIntSigned, bitfieldAlignment
) where 

import CForeign

-- we can't rely on the compiler used to compile c2hs already having the new
-- FFI, so this is system dependent
--
import C2HSConfig (Ptr, FunPtr, 
		   bitfieldDirection, bitfieldPadding, bitfieldIntSigned,
		   bitfieldAlignment)
import qualified  
       C2HSConfig as Storable
		  (Storable(sizeOf, alignment))


-- calibration of C's primitive types
-- ----------------------------------

-- C's primitive types (EXPORTED)
--
-- * `CFunPtrPT' doesn't occur in Haskell representations of C types, but we
--   need to know their size, which may be different from `CPtrPT'
--
data CPrimType = CPtrPT		-- void *
	       | CFunPtrPT	-- void *()
	       | CCharPT	-- char
	       | CUCharPT	-- unsigned char
	       | CSCharPT	-- signed char
	       | CIntPT		-- int
	       | CShortPT	-- short int
	       | CLongPT	-- long int
	       | CLLongPT	-- long long int
	       | CUIntPT	-- unsigned int
	       | CUShortPT	-- unsigned short int
	       | CULongPT	-- unsigned long int
	       | CULLongPT	-- unsigned long long int
	       | CFloatPT	-- float
	       | CDoublePT	-- double
	       | CLDoublePT	-- long double
	       | CSFieldPT  Int -- signed bit field
	       | CUFieldPT  Int -- unsigned bit field
	       deriving (Eq)

-- size of primitive type of C (EXPORTED)
--
-- * negative size implies that it is a bit, not an octet size
--
size                :: CPrimType -> Int
size CPtrPT          = Storable.sizeOf (undefined :: Ptr ())
size CFunPtrPT       = Storable.sizeOf (undefined :: FunPtr ())
size CCharPT         = 1
size CUCharPT        = 1
size CSCharPT        = 1
size CIntPT          = Storable.sizeOf (undefined :: CInt)
size CShortPT        = Storable.sizeOf (undefined :: CShort)
size CLongPT         = Storable.sizeOf (undefined :: CLong)
size CLLongPT        = Storable.sizeOf (undefined :: CLLong)
size CUIntPT         = Storable.sizeOf (undefined :: CUInt)
size CUShortPT       = Storable.sizeOf (undefined :: CUShort)
size CULongPT        = Storable.sizeOf (undefined :: CULong)
size CULLongPT       = Storable.sizeOf (undefined :: CLLong)
size CFloatPT        = Storable.sizeOf (undefined :: CFloat)
size CDoublePT       = Storable.sizeOf (undefined :: CDouble)
size CLDoublePT      = Storable.sizeOf (undefined :: CLDouble)
size (CSFieldPT bs)  = -bs
size (CUFieldPT bs)  = -bs

-- alignment of C's primitive types (EXPORTED)
--
-- * more precisely, the padding put before the type's member starts when the
--   preceding component is a char
--
alignment                :: CPrimType -> Int
alignment CPtrPT          = Storable.alignment (undefined :: Ptr ())
alignment CFunPtrPT       = Storable.alignment (undefined :: FunPtr ())
alignment CCharPT         = 1
alignment CUCharPT        = 1
alignment CSCharPT        = 1
alignment CIntPT          = Storable.alignment (undefined :: CInt)
alignment CShortPT        = Storable.alignment (undefined :: CShort)
alignment CLongPT         = Storable.alignment (undefined :: CLong)
alignment CLLongPT        = Storable.alignment (undefined :: CLLong)
alignment CUIntPT         = Storable.alignment (undefined :: CUInt)
alignment CUShortPT       = Storable.alignment (undefined :: CUShort)
alignment CULongPT        = Storable.alignment (undefined :: CULong)
alignment CULLongPT       = Storable.alignment (undefined :: CULLong)
alignment CFloatPT        = Storable.alignment (undefined :: CFloat)
alignment CDoublePT       = Storable.alignment (undefined :: CDouble)
alignment CLDoublePT      = Storable.alignment (undefined :: CLDouble)
alignment (CSFieldPT bs)  = fieldAlignment bs
alignment (CUFieldPT bs)  = fieldAlignment bs

-- alignment constraint for a C bitfield
--
-- * gets the bitfield size (in bits) as an argument
--
-- * alignments constraints smaller or equal to zero are reserved for bitfield
--   alignments
--
-- * bitfields of size 0 always trigger padding; thus, they get the maximal
--   size
--
-- * if bitfields whose size exceeds the space that is still available in a
--   partially filled storage unit trigger padding, the size of a storage unit
--   is provided as the alignment constraint; otherwise, it is 0 (meaning it
--   definitely starts at the current position)
--
-- * here, alignment constraint /= 0 are somewhat subtle; they mean that is
--   the given number of bits doesn't fit in what's left in the current
--   storage unit, alignment to the start of the next storage unit has to be
--   triggered
--
fieldAlignment                      :: Int -> Int
fieldAlignment 0                     = - (size CIntPT - 1)
fieldAlignment bs | bitfieldPadding  = - bs
		  | otherwise        = 0

--- NEW FILE: GenBind.hs ---
--  C->Haskell Compiler: binding generator
--
--  Author : Manuel M T Chakravarty
--  Created: 17 August 99
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:41 $
--
--  Copyright (c) [1999..2003] Manuel M T Chakravarty
--
--  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.
--
[...1992 lines suppressed...]
resMarshIllegalTwoCValErr     :: Position -> GB a
resMarshIllegalTwoCValErr pos  =
  raiseErrorCTExc pos 
    ["Malformed result marshalling!",
     "Two C values (i.e., the `&' symbol) are not allowed for the result."]

marshArgMismatchErr            :: Position -> String -> GB a
marshArgMismatchErr pos reason  =
  raiseErrorCTExc pos
    ["Function arity mismatch!",
     reason]

noDftMarshErr :: Position -> String -> String -> [ExtType] -> GB a
noDftMarshErr pos inOut hsTy cTys  =
  raiseErrorCTExc pos
    ["Missing " ++ inOut ++ " marshaller!",
     "There is no default marshaller for this combination of Haskell and \
     \C type:",
     "Haskell type: " ++ hsTy,
     "C type      : " ++ concat (intersperse " " (map showExtType cTys))]

[Gtk2hs-commit] gtk2hs/tools/c2hs/toplevel C2HSConfig.hs.in,NONE,1.1 Main.hs,NONE,1.1 Version.hs,NONE,1.1 c2hs_config.c,NONE,1.1 c2hs_config.h,NONE,1.1

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

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

Added Files:
	C2HSConfig.hs.in Main.hs Version.hs c2hs_config.c 
	c2hs_config.h 
Log Message:
Moved the c2hs directories one level up like it was in the old setup.


--- NEW FILE: C2HSConfig.hs.in ---
--								  -*-haskell-*-
--  ** @configure_input@ **
--  ===========================================================================
--  C -> Haskell Compiler: configuration
--
--  Author : Manuel M T Chakravarty
--  Created: 27 September 99
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:42 $
--
--  Copyright (c) [1999..2003] Manuel M T Chakravarty
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
--  Configuration options; largely set by `configure'.
--
--- TODO ----------------------------------------------------------------------
--

module C2HSConfig (
  --
  -- programs and paths
  --
  cpp, cppopts, hpaths, dlsuffix, tmpdir,
  --
  -- system-dependent definitions, as the New FFI isn't fully supported on all
  -- systems yet
  --
  Ptr, FunPtr, Storable(sizeOf, alignment),
  --
  -- parameters of the targeted C compiler
  --
  bitfieldDirection, bitfieldPadding, bitfieldIntSigned, bitfieldAlignment
) where

import Ix    (Ix)
import Array (Array, array)

import 
 Foreign (Ptr, FunPtr)  -- on an extra line to trick the stupid `mkdependHS'
import Foreign  (Storable(sizeOf, alignment), toBool)
import CForeign (CInt)

-- program settings
-- ----------------

-- C preprocessor executable (EXPORTED)
--
cpp :: FilePath
cpp  = "@CPP@"

-- C preprocessor options (EXPORTED)
--
-- * `-x c' forces CPP to regard the input as C code; this option seems to be
--   understood at least on Linux, FreeBSD, and Solaris and seems to make a
--   difference over the default language setting on FreeBSD
--
-- * `-P' would suppress `#line' directives
--
cppopts :: String
cppopts  = "-x c"

-- standard system search paths for header files (EXPORTED)
--
hpaths :: [FilePath]
hpaths  = [".", "/usr/include", "/usr/local/include"]

-- OS-dependent suffix for dynamic libraries
--
dlsuffix :: String
dlsuffix  = "@DLSUFFIX@"

-- possibly system-dependent location for temporary files
--
tmpdir :: String
tmpdir = "@TMPDIR@"


-- parameters of the targeted C compiler
-- -------------------------------------

-- indicates in which direction the C compiler fills bitfields (EXPORTED)
--
-- * the value is 1 or -1, depending on whether the direction is growing
--   towards the MSB
--
bitfieldDirection :: Int
bitfieldDirection  = fromIntegral bitfield_direction

foreign import ccall bitfield_direction :: CInt

-- indicates whether a bitfield that does not fit into a partially filled
-- storage unit in its entirety introduce padding or split over two storage
-- units (EXPORTED)
--
-- * `True' means that such a bitfield introduces padding (instead of being
--   split)
--
bitfieldPadding :: Bool
bitfieldPadding  = toBool bitfield_padding

foreign import ccall bitfield_padding :: CInt

-- indicates whether a bitfield of type `int' is signed in the targeted C
-- compiler (EXPORTED)
--
bitfieldIntSigned :: Bool
bitfieldIntSigned  = toBool bitfield_int_signed

foreign import ccall bitfield_int_signed :: CInt

-- the alignment constraint for a bitfield (EXPORTED)
--
-- * this makes the assumption that the alignment of a bitfield is independent
--   of the bitfield's size
--
bitfieldAlignment :: Int
bitfieldAlignment  = fromIntegral bitfield_alignment

foreign import ccall bitfield_alignment :: CInt

--- NEW FILE: Version.hs ---
module Version (version, copyright, disclaimer)
where

-- version number is major.minor.patchlvl; don't change the format of the
-- `versnum' line as it is `grep'ed for by a Makefile
--
idstr      = "$Id: Version.hs,v 1.1 2004/11/21 21:05:42 as49 Exp $"
name       = "C->Haskell Compiler"
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 \
	     \terms of the GNU Public Licence.\n\
	     \NO WARRANTY WHATSOEVER IS PROVIDED. \
	     \See the details in the documentation."

--- NEW FILE: c2hs_config.c ---
/*  C -> Haskell Compiler: configuration query routines
 *
 *  Author : Manuel M T Chakravarty
 *  Created: 12 November 1
 *
 *  Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:42 $
 *
 *  Copyright (c) [2001..2002] Manuel M T Chakravarty
 *
 *  This file is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This file is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  DESCRIPTION ---------------------------------------------------------------
 *
 *  Runtime configuration query functions
 *
 *  TODO ----------------------------------------------------------------------
 */

#include "c2hs_config.h"

/* compute the direction in which bitfields are growing
 * ====================================================
 */

union bitfield_direction_union {
  unsigned int			        allbits;
  struct {
    unsigned int first_bit  : 1;
    unsigned int second_bit : 1;
  }					twobits;
};

int bitfield_direction ()
{
  union bitfield_direction_union v;

  /* if setting the second bit in a bitfield makes the storeage unit contain
   * the value `2', the direction of bitfields must be increasing towards the
   * MSB 
   */
  v.allbits            = 0;
  v.twobits.second_bit = 1;

  return (2 == v.allbits ? 1 : -1);
}


/* use padding for overspilling bitfields?  
 * =======================================
 */

union bitfield_padding_union {
  struct {
    unsigned int allbits1;
    unsigned int allbits2;
  }					allbits;
  struct {
    unsigned int first_bit : 1;
	     int full_unit : sizeof (int) * 8;
  }					somebits;
};

int bitfield_padding ()
{
  union bitfield_padding_union v;

  /* test whether more than one bit of `full_unit' spills over into `allbits2'
   */
  v.allbits.allbits1   = 0;
  v.allbits.allbits2   = 0;
  v.somebits.full_unit = -1;

  return v.allbits.allbits2 == -1;
}

/* is an `int' bitfield signed?
 * ============================
 */

union bitfield_int_signed_union {
  struct {
    unsigned int first_bit  : 1;
    unsigned int second_bit : 1;
  }					two_single_bits;
  struct {
    int two_bits : 2;
  }					two_bits;
};

int bitfield_int_signed ()
{
  union bitfield_int_signed_union v;

  /* check whether a two bit field with both bits set, gives us a negative
   * number; then, `int' bitfields must be signed
   */
  v.two_single_bits.first_bit  = 1;
  v.two_single_bits.second_bit = 1;

  return v.two_bits.two_bits == -1;
}


/* alignment constraint for bitfields	    
 * ==================================
 */

struct bitfield_alignment_struct {
  char         start;
  unsigned int bit : 1;
  char	       end;
};

int bitfield_alignment ()
{
  struct bitfield_alignment_struct v;

  return ((int) (&v.end - &v.start)) - 1;
}

--- NEW FILE: c2hs_config.h ---
/*  C -> Haskell Compiler: configuration query header
 *
 *  Author : Manuel M T Chakravarty
 *  Created: 12 November 1
 *
 *  Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:42 $
 *
 *  Copyright (c) 2001 Manuel M T Chakravarty
 *
 *  This file is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This file is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  DESCRIPTION ---------------------------------------------------------------
 *
 *  Interface to the runtime configuration query functions.
 *
 *  TODO ----------------------------------------------------------------------
 */

#ifndef C2HS_CONFIG
#define C2HS_CONFIG

/* routines querying C compiler properties
 */
int bitfield_direction  ();	/* direction in which bitfields are growing */
int bitfield_padding    ();	/* use padding for overspilling bitfields?  */
int bitfield_int_signed ();     /* is an `int' bitfield signed?		    */
int bitfield_alignment  ();     /* alignment constraint for bitfields	    */

#endif /* C2HS_CONFIG*/

--- NEW FILE: Main.hs ---
--  C -> Haskell Compiler: main module
--
--  Author : Manuel M T Chakravarty
--  Derived: 12 August 99
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:42 $
--
--  Copyright (c) [1999..2004] Manuel M T Chakravarty
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
--  This is the main module of the compiler.  It sets the version, processes
--  the command line arguments, and controls the compilation process.
--
--  Originally, derived from `Main.hs' of the Nepal Compiler.
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  Usage:
--  ------
--
--    c2hs [ option... ] [header-file] binding-file
--
--  The compiler is supposed to emit a Haskell program that expands all hooks
--  in the given binding file.
--
--  File name suffix:
--  -----------------
--
--  Note: These also depend on suffixes defined in the compiler proper.
--
--  .h   C header file
--  .i   pre-processeed C header file
--  .hs	 Haskell file
--  .chs Haskell file with C->Haskell hooks (binding file)
--  .chi C->Haskell interface file
--
--  Options:
--  --------
--
--  -C CPPOPTS
--  --cppopts=CPPOPTS
--        Pass the additional options CPPOPTS to the C preprocessor.
--
--        Repeated occurences accumulate.
--
--  -c CPP
--  --cpp=CPP
--        Use the executable CPP to invoke CPP.
--
--        In the case of repeated occurences, the last takes effect.
--
--  -d TYPE
--  --dump=TYPE
--        Dump intermediate representation:
--
--	  + if TYPE is `trace', trace the compiler phases (to stderr)
--	  + if TYPE is `genbind', trace binding generation (to stderr)
--	  + if TYPE is `ctrav', trace C declaration traversal (to stderr)
--	  + if TYPE is `chs', dump the binding file (insert `.dump' into the
--	    file name to avoid overwriting the original file)
--
--  -h, -?
--  --help
--        Dump brief usage information to stderr.
--
--  -i DIRS
--  --include=DIRS
--        Search the colon separated list of directories DIRS when searching
--	  for .chi files.
--
--  -k
--  --keep
--        Keep the intermediate file that contains the pre-processed C header
--        (it carries the suffix `.i').
--
--  -o FILE
--  --output=FILE
--        Place output in file FILE.
--
--        If `-o' is not specified, the default is to put the output for
--	  `source.chs' in `source.hs' in the same directory that contains the
--	  binding file.  If specified, the emitted C header file is put into
--	  the same directory as the output file.  The same holds for
--	  C->Haskell interface file.  All generated files also share the
--	  basename. 
--
--  -t PATH
--  --output-dir=PATH
--        Place generated files in the directory PATH.
--
--        If this option as well as the `-o' option is given, the basename of
--        the file specified with `-o' is put in the directory specified with
--        `-t'. 
--
--  -v,
--  --version
--        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
--	  affects only call hooks where instead of `Addr' types 
--	  `Ptr <someOtherType>' is used.
--
--- TODO ----------------------------------------------------------------------
--

module Main (main)
where

-- standard libraries
import List	  (isPrefixOf)
import IO	  ()
import Monad      (when, unless, mapM)
import Maybe      (fromJust)

-- base libraries
import Common     (errorCodeFatal)
import GetOpt     (ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo,
		   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,
		   ExitCode(..), stderr, IOMode(..), putStrCIO, hPutStrCIO,
		   hPutStrLnCIO, exitWithCIO, getArgsCIO, getProgNameCIO,
		   ioeGetErrorString, ioeGetFileName, removeFileCIO,
		   systemCIO, fileFindInCIO, mktempCIO, openFileCIO, hCloseCIO,
		   SwitchBoard(..), Traces(..), setTraces,
		   traceSet, setSwitch, getSwitch, putTraceStr)
import C	  (AttrC, hsuffix, isuffix, loadAttrC)
import CHS	  (CHSModule, loadCHS, dumpCHS, hssuffix, chssuffix, dumpCHI)
import GenHeader  (genHeader)
import GenBind	  (expandHooks)
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
-- ============================

main :: IO ()
main  = runC2HS (version, copyright, disclaimer) compile


-- option handling
-- ===============

-- header is output in case of help, before the descriptions of the options;
-- errTrailer is output after an error message
--
header :: String -> String -> String -> String
header version copyright disclaimer  = 
  version ++ "\n" ++ copyright ++ "\n" ++ disclaimer
  ++ "\n\nUsage: c2hs [ option... ] [header-file] binding-file\n"

trailer, errTrailer :: String
trailer    = "\n\
	     \The header file must be a C header file matching the given \
	     \binding file.\n\
	     \The dump TYPE can be\n\
	     \  trace   -- trace compiler phases\n\
	     \  genbind -- trace binding generation\n\
	     \  ctrav   -- trace C declaration traversal\n\
	     \  chs     -- dump the binding file (adds `.dump' to the name)\n"
errTrailer = "Try the option `--help' on its own for more information.\n"

-- supported option types
--
data Flag = CPPOpts String      -- additional options for C preprocessor
	  | CPP     String      -- program name of C preprocessor
	  | Dump    DumpType    -- dump internal information
	  | Help	        -- print brief usage information
	  | Keep	        -- keep the .i file
	  | 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

data DumpType = Trace	      -- compiler trace
	      | GenBind	      -- trace `GenBind'
	      | CTrav	      -- trace `CTrav'
	      | CHS	      -- dump binding file
	      deriving Eq

-- option description suitable for `GetOpt'
--
options :: [OptDescr Flag]
options  = [
  Option ['C'] 
	 ["cppopts"] 
	 (ReqArg CPPOpts "CPPOPTS") 
	 "pass CPPOPTS to the C preprocessor",
  Option ['c'] 
	 ["cpp"] 
	 (ReqArg CPP "CPP") 
	 "use executable CPP to invoke C preprocessor",
  Option ['d'] 
	 ["dump"] 
	 (ReqArg dumpArg "TYPE") 
	 "dump internal information (for debugging)",
  Option ['h', '?'] 
	 ["help"] 
	 (NoArg Help) 
	 "brief help (the present message)",
  Option ['i']
	 ["include"]
	 (ReqArg Include "INCLUDE")
	 "include paths for .chi files",
  Option ['k'] 
	 ["keep"] 
	 (NoArg Keep) 
	 "keep pre-processed C header",
  Option ['o'] 
	 ["output"] 
	 (ReqArg Output "FILE") 
	 "output result to FILE (should end in .hs)",
  Option ['t'] 
	 ["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) 
	 "show version information"]

-- convert argument of `Dump' option
--
dumpArg           :: String -> Flag
dumpArg "trace"    = Dump Trace
dumpArg "genbind"  = Dump GenBind
dumpArg "ctrav"    = Dump CTrav
dumpArg "chs"      = Dump CHS
dumpArg _          = Error "Illegal dump type."

-- main process (set up base configuration, analyse command line, and execute
-- compilation process)
--
-- * Exceptions are caught and reported
--
compile :: CST s ()
compile  = 
  do
    setup
    cmdLine <- getArgsCIO
    case getOpt RequireOrder options cmdLine of
      ([Help]   , []  , []) -> doExecute [Help]    []
      ([Version], []  , []) -> doExecute [Version] []
      (opts     , args, []) 
        | properArgs (hasPreCompFlag opts) args -> doExecute opts args
        | otherwise                             -> raiseErrs [wrongNoOfArgsErr]
      (_   , _   , errs)    -> raiseErrs errs
  where
    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
			      `fatalsHandledBy` failureHandler
			    exitWithCIO ExitSuccess
    --
    wrongNoOfArgsErr = 
      "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
    --
    failureHandler err =
      do
	let msg   = ioeGetErrorString err
	    fnMsg = case ioeGetFileName err of
		       Nothing -> ""
		       Just s  -> " (file: `" ++ s ++ "')"
	hPutStrLnCIO stderr (msg ++ fnMsg)
	exitWithCIO $ ExitFailure 1

-- set up base configuration
--
setup :: CST s ()
setup  = do
	   setCPP     cpp
	   addCPPOpts cppopts
	   addHPaths  hpaths

-- output error message
--
raiseErrs      :: [String] -> CST s a
raiseErrs errs = do
		   hPutStrCIO stderr (concat errs)
		   hPutStrCIO stderr errTrailer
		   exitWithCIO $ ExitFailure 1

-- Process tasks
-- -------------

-- execute the compilation task
--
-- * if `Help' is present, emit the help message and ignore the rest
-- * if `Version' is present, do it first (and only once)
-- * actual compilation is only invoked if we have one or two extra arguments
--   (otherwise, it is just skipped)
--
execute :: [Flag] -> [FilePath] -> CST s ()
execute opts args | Help `elem` opts = help
		  | otherwise	     = 
  do
    let vs      = filter (== Version) opts
	opts'   = filter (/= Version) opts
    mapM_ processOpt (atMostOne vs ++ opts')

    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
      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 ()
help  = do
	  (version, copyright, disclaimer) <- getId
	  putStrCIO (usageInfo (header version copyright disclaimer) options)
	  putStrCIO trailer

-- process an option
--
-- * `Help' cannot occur 
--
processOpt                   :: Flag -> CST s ()
processOpt (CPPOpts cppopts)  = addCPPOpts cppopts
processOpt (CPP     cpp    )  = setCPP     cpp
processOpt (Dump    dt     )  = setDump    dt
processOpt (Keep           )  = setKeep
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")
processOpt (Error   msg    )  = abort      msg

-- emit error message and raise an error
--
abort     :: String -> CST s ()
abort msg  = do
	       hPutStrLnCIO stderr msg
	       hPutStrCIO stderr errTrailer
	       fatal "Error in command line options"

-- Compute the base name for all generated files (Haskell, C header, and .chi
-- file)
--
-- * The result is available from the `outputSB' switch
--
computeOutputName :: FilePath -> CST s ()
computeOutputName bndFileNoSuffix =
  do
    output <- getSwitch outputSB
    outDir <- getSwitch outDirSB
    let dir  = if      null outDir && null output then dirname bndFileNoSuffix
	       else if null outDir		  then dirname output
	       else				       outDir
    let base = if null output then basename bndFileNoSuffix
	       else                basename output
    setSwitch $ \sb -> sb {
		         outputSB = dir `addPath` base,
			 outDirSB = dir
		       }


-- set switches
-- ------------

-- set the options for the C proprocessor
--
-- * any header search path that is set with `-IDIR' is also added to
--   `hpathsSB'
--
addCPPOpts      :: String -> CST s ()
addCPPOpts opts  = 
  do
    let iopts = [opt | opt <- words opts, "-I" `isPrefixOf` opt, "-I-" /= opt]
    addHPaths . map (drop 2) $ iopts
    addOpts opts
  where
    addOpts opts  = setSwitch $ 
		      \sb -> sb {cppOptsSB = cppOptsSB sb ++ (' ':opts)}

-- set the program name of the C proprocessor
--
setCPP       :: FilePath -> CST s ()
setCPP fname  = setSwitch $ \sb -> sb {cppSB = fname}

-- add header file search paths
--
addHPaths       :: [FilePath] -> CST s ()
addHPaths paths  = setSwitch $ \sb -> sb {hpathsSB = paths ++ hpathsSB sb}

-- set the given dump option
--
setDump         :: DumpType -> CST s ()
setDump Trace    = setTraces $ \ts -> ts {tracePhasesSW  = True}
setDump GenBind  = setTraces $ \ts -> ts {traceGenBindSW = True}
setDump CTrav    = setTraces $ \ts -> ts {traceCTravSW   = True}
setDump CHS      = setTraces $ \ts -> ts {dumpCHSSW	 = True}

-- set flag to keep the pre-processed header file
--
setKeep :: CST s ()
setKeep  = setSwitch $ \sb -> sb {keepSB = True}

-- set the search directories for .chi files
--
-- * Several -i flags are accumulated. Later paths have higher priority.
--
-- * The current directory is always searched last because it is the
--   standard value in the compiler state.
--
setInclude :: String -> CST s ()
setInclude str = do
  let fp = makePath str ""
  setSwitch $ \sb -> sb {chiPathSB = fp ++ (chiPathSB sb)}
  where
    makePath ('\\':r:em)   path = makePath em (path ++ ['\\',r])
    makePath (' ':rem)	   path = makePath rem path
    makePath (':':rem)     ""   = makePath rem ""
    makePath (':':rem)	   path = path : makePath rem ""
    makePath ('/':':':rem) path = path : makePath rem ""
    makePath (r:emain)	   path = makePath emain (path ++ [r])
    makePath ""		   ""   = []
    makePath ""		   path = [path]

-- set the output file name
--
setOutput       :: FilePath -> CST s ()
setOutput fname  = do
		     when (suffix fname /= hssuffix) $
		       raiseErrs ["Output file should end in .hs!\n"]
		     setSwitch $ \sb -> sb {outputSB = stripSuffix fname}

-- set the output directory
--
setOutDir       :: FilePath -> CST s ()
setOutDir fname  = setSwitch $ \sb -> sb {outDirSB = fname}

-- set the name of the generated header file
--
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
-- -------------------

-- read the binding module, construct a header, run it through CPP, read it,
-- and finally generate the Haskell target
--
-- * the header file name (first argument) may be empty; otherwise, it already
--   contains the right suffix
--
-- * the binding file name has been stripped of the .chs suffix
--
process                    :: FilePath -> FilePath -> CST s ()
process headerFile bndFile  =
  do
    -- load the Haskell binding module
    --
    (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)
    --
    (header, strippedCHSMod, warnmsgs) <- genHeader chsMod
    putStrCIO warnmsgs
    --
    -- create new header file, make it #include `headerFile', and emit
    -- CPP and inline-C of .chs file into the new header
    --
    outFName <- getSwitch outputSB
    let newHeaderFile = outFName ++ hsuffix
	preprocFile   = basename newHeaderFile ++ isuffix
    newHeader <- openFileCIO newHeaderFile WriteMode
    unless (null headerFile) $
      hPutStrLnCIO newHeader $ "#include \"" ++ headerFile ++ "\""
    mapM (hPutStrCIO newHeader) header
    hCloseCIO newHeader
    setHeader newHeaderFile
    --
    -- run C preprocessor over the header
    --
    cpp     <- getSwitch cppSB
    cppOpts <- getSwitch cppOptsSB
    let cmd  = unwords [cpp, cppOpts, newHeaderFile, ">" ++ preprocFile]
    tracePreproc cmd
    exitCode <- systemCIO cmd
    case exitCode of 
      ExitFailure _ -> fatal "Error during preprocessing custom header file"
      _		    -> nop
    --
    -- load and analyse the C header file
    --
    (cheader, warnmsgs) <- loadAttrC preprocFile
    putStrCIO warnmsgs
    --
    -- remove the custom header and the pre-processed header
    --
    keep <- getSwitch keepSB
    unless keep $
      removeFileCIO preprocFile
    --
    -- expand binding hooks into plain Haskell
    --
    (hsMod, chi, warnmsgs) <- expandHooks cheader strippedCHSMod
    putStrCIO warnmsgs
    --
    -- output the result
    --
    dumpCHS outFName hsMod True
    dumpCHI outFName chi		-- different suffix will be appended
  where
    tracePreproc cmd = putTraceStr tracePhasesSW $
		         "Invoking cpp as `" ++ cmd ++ "'...\n"
    traceCHSDump mod = do
			 flag <- traceSet dumpCHSSW
			 when flag $
			   (do
			      putStrCIO ("...dumping CHS to `" ++ chsName 
					 ++ "'...\n")
			      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/state C2HSState.hs,1.1.1.1,NONE Makefile,1.1.1.1,NONE Switches.hs,1.2,NONE

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

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

Removed Files:
	C2HSState.hs Makefile Switches.hs 
Log Message:
Moved the c2hs directories one level up like it was in the old setup.


--- C2HSState.hs DELETED ---

--- Makefile DELETED ---

--- Switches.hs DELETED ---

[Gtk2hs-commit] gtk2hs/tools/c2hs/c2hs/chs CHS.hs,1.2,NONE CHSLexer.hs,1.1.1.1,NONE Makefile,1.1.1.1,NONE

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

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

Removed Files:
	CHS.hs CHSLexer.hs Makefile 
Log Message:
Moved the c2hs directories one level up like it was in the old setup.


--- CHSLexer.hs DELETED ---

--- CHS.hs DELETED ---

--- Makefile DELETED ---

[Gtk2hs-commit] gtk2hs/tools/c2hs/state C2HSState.hs,NONE,1.1 Switches.hs,NONE,1.1

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

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

Added Files:
	C2HSState.hs Switches.hs 
Log Message:
Moved the c2hs directories one level up like it was in the old setup.


--- NEW FILE: C2HSState.hs ---
--  C -> Haskell Compiler: C2HS's state
--
--  Author : Manuel M. T. Chakravarty
--  Created: 6 March 1999
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:41 $
--
--  Copyright (c) 1999 Manuel M. T. Chakravarty
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
--  This module instantiates the Compiler Toolkit's extra state with C2HS's
--  uncommon state information that should be stored in the Toolkit's base
--  state. 
--
--  This modules re-exports everything provided by `State', and thus, should be
--  used as the single reference to state related functionality within C2HS.
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  State components:
--
--    - compiler switches
--
--- TODO ----------------------------------------------------------------------
--

module C2HSState (-- re-exports all of `State'
		  --
		  module State,
		  --
		  -- instantiation of `PreCST' with C2HS's extra state
		  --
		  CST, runC2HS,
		  --
		  -- switches
		  --
		  SwitchBoard(..), Traces(..), setTraces, traceSet,
		  putTraceStr, setSwitch, getSwitch) 
where

import Monad    (when)

import State

import Switches (SwitchBoard(..), Traces(..), 
		 initialSwitchBoard)


-- instantiation of the extra state
-- --------------------------------

-- the extra state consists of the `SwitchBoard' (EXPORTED)
--
type CST s a = PreCST SwitchBoard s a

-- execution of c2hs starts with the initial `SwitchBoard'
--
runC2HS     :: (String, String, String) -> CST () a -> IO a
runC2HS vcd  = run vcd initialSwitchBoard


-- switch management
-- -----------------

-- set traces according to the given transformation function
--
setTraces   :: (Traces -> Traces) -> CST s ()
setTraces t  = updExtra (\es -> es {tracesSB = t (tracesSB es)})

-- inquire the status a trace using the given inquiry function
--
traceSet   :: (Traces -> Bool) -> CST s Bool
traceSet t  = readExtra (t . tracesSB)

-- output the given string to `stderr' when the trace determined by the inquiry
-- function is activated
--
putTraceStr       :: (Traces -> Bool) -> String -> CST s ()
putTraceStr t msg  = do
		       set <- traceSet t
		       when set $
			 hPutStrCIO stderr msg

-- set a switch value
--
setSwitch :: (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch  = updExtra

-- get a switch values
--
getSwitch :: (SwitchBoard -> a) -> CST s a
getSwitch  = readExtra

--- NEW FILE: Switches.hs ---
--  C -> Haskell Compiler: management of switches
--
--  Author : Manuel M T Chakravarty
--  Created: 6 March 99
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:41 $
--
--  Copyright (c) [1999..2004] Manuel M T Chakravarty
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
--  This module manages C2HS's compiler switches. It exports the data types
--  used to store the switches and operations on them.
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  Overview over the switches:
--
--  * The cpp options specify the options passed to the C preprocessor.
--
--  * The cpp filename gives the name of the executable of the C preprocessor.
--
--  * The `hpaths' switch lists all directories that should be considered when
--    searching for a header file.
--
--  * The `keep' flag says whether the intermediate file produced by the C
--    pre-processor should be retained or not.
--
--  * Traces specify which trace information should be output by the compiler.
--    Currently the following trace information is supported:
--
--    - information about phase activation and phase completion
--
--  * After processing the compiler options, `outputSB' contains the base name
--    for the generated Haskell, C header, and .chi files.  However, during
--    processing compiler options, `outputSB' contains arguments to the
--    `--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 ----------------------------------------------------------------------
--

module Switches (
  SwitchBoard(..), Traces(..), initialSwitchBoard
) where


-- the switch board contains all toolkit switches
-- ----------------------------------------------

-- all switches of the toolkit (EXPORTED)
--
data SwitchBoard = SwitchBoard {
		     cppOptsSB :: String,	-- cpp options
		     cppSB     :: FilePath,	-- cpp executable
		     hpathsSB  :: [FilePath],	-- header file directories
		       -- since 0.11.1 `hpathsSB' isn't really needed anymore..
		       -- ..remove from 0.12 series
		     keepSB    :: Bool,		-- keep intermediate file
		     tracesSB  :: Traces,	-- trace flags
		     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
		   }

-- switch states on startup (EXPORTED)
--
initialSwitchBoard :: SwitchBoard
initialSwitchBoard  = SwitchBoard {
			cppOptsSB = "",
			cppSB     = "cpp",
			hpathsSB  = [],
			keepSB	  = False,
		        tracesSB  = initialTraces,
			outputSB  = "",
			outDirSB  = "",
			headerSB  = "",
			preCompSB = Nothing,
			oldFFI	  = False,
			chiPathSB = ["."]
		      }


-- traces
-- ------

-- different kinds of traces possible (EXPORTED)
--
data Traces = Traces {
	        tracePhasesSW  :: Bool,
	        traceGenBindSW :: Bool,
	        traceCTravSW   :: Bool,
		dumpCHSSW      :: Bool
	      }

-- trace setting on startup
--
-- * all traces are initially off
--
initialTraces :: Traces
initialTraces  = Traces {
		   tracePhasesSW  = False,
		   traceGenBindSW = False,
		   traceCTravSW   = False,
		   dumpCHSSW	  = False
		 }

[Gtk2hs-commit] gtk2hs/tools/c2hs/c2hs/mk c2hs.pck.mk,1.1.1.1,NONE config.mk.in,1.1.1.1,NONE

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

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

Removed Files:
	c2hs.pck.mk config.mk.in 
Log Message:
Moved the c2hs directories one level up like it was in the old setup.


--- c2hs.pck.mk DELETED ---

--- config.mk.in DELETED ---

[Gtk2hs-commit] gtk2hs/tools/c2hs/c2hs/tests Calls.chs,1.1.1.1,NONE Calls.h,1.1.1.1,NONE Cpp.chs,1.1.1.1,NONE Cpp.dump.chs,1.1.1.1,NONE Cpp.h,1.1.1.1,NONE Cpp2.dump.chs,1.1.1.1,NONE Enums.chs,1.1.1.1,NONE Enums.h,1.1.1.1,NONE Makefile,1.1.1.1,NONE Marsh.chs,1.1.1.1,NONE Marsh.h,1.1.1.1,NONE Pointer.chs,1.1.1.1,NONE Pointer.h,1.1.1.1,NONE Simple.chs,1.1.1.1,NONE Simple.h,1.1.1.1,NONE Structs.chs,1.1.1.1,NONE Structs.h,1.1.1.1,NONE calls.h,1.1.1.1,NONE cpp.h,1.1.1.1,NONE enums.c,1.1.1.1,NONE enums.h,1.1.1.1,NONE marsh.h,1.1.1.1,NONE pointer.c,1.1.1.1,NONE pointer.h,1.1.1.1,NONE simple.c,1.1.1.1,NONE simple.h,1.1.1.1,NONE structs.c,1.1.1.1,NONE structs.h,1.1.1.1,NONE

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

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

Removed Files:
	Calls.chs Calls.h Cpp.chs Cpp.dump.chs Cpp.h Cpp2.dump.chs 
	Enums.chs Enums.h Makefile Marsh.chs Marsh.h Pointer.chs 
	Pointer.h Simple.chs Simple.h Structs.chs Structs.h calls.h 
	cpp.h enums.c enums.h marsh.h pointer.c pointer.h simple.c 
	simple.h structs.c structs.h 
Log Message:
Moved the c2hs directories one level up like it was in the old setup.


--- structs.h DELETED ---

--- Calls.chs DELETED ---

--- Makefile DELETED ---

--- structs.c DELETED ---

--- Cpp.dump.chs DELETED ---

--- Simple.h DELETED ---

--- Pointer.chs DELETED ---

--- Cpp.h DELETED ---

--- enums.c DELETED ---

--- Enums.h DELETED ---

--- pointer.c DELETED ---

--- marsh.h DELETED ---

--- Calls.h DELETED ---

--- pointer.h DELETED ---

--- Cpp2.dump.chs DELETED ---

--- Structs.h DELETED ---

--- Cpp.chs DELETED ---

--- Enums.chs DELETED ---

--- Marsh.chs DELETED ---

--- simple.c DELETED ---

--- simple.h DELETED ---

--- cpp.h DELETED ---

--- enums.h DELETED ---

--- Simple.chs DELETED ---

--- Marsh.h DELETED ---

--- calls.h DELETED ---

--- Structs.chs DELETED ---

--- Pointer.h DELETED ---

[Gtk2hs-commit] gtk2hs/tools/c2hs/c2hs AUTHORS,1.1.1.1,NONE COPYING,1.1.1.1,NONE COPYING.LIB,1.1.1.1,NONE ChangeLog,1.1.1.1,NONE INSTALL,1.1.1.1,NONE Makefile,1.1.1.1,NONE README,1.1.1.1,NONE TODO,1.1.1.1,NONE aclocal.m4,1.1.1.1,NONE c2hs-config.in,1.1.1.1,NONE c2hs.conf.in,1.1.1.1,NONE c2hs.spec.in,1.1.1.1,NONE configure,1.1.1.1,NONE configure.in,1.1.1.1,NONE

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

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

Removed Files:
	AUTHORS COPYING COPYING.LIB ChangeLog INSTALL Makefile README 
	TODO aclocal.m4 c2hs-config.in c2hs.conf.in c2hs.spec.in 
	configure configure.in 
Log Message:
Moved the c2hs directories one level up like it was in the old setup.


--- COPYING.LIB DELETED ---

--- c2hs.conf.in DELETED ---

--- configure DELETED ---

--- COPYING DELETED ---

--- configure.in DELETED ---

--- ChangeLog DELETED ---

--- Makefile DELETED ---

--- c2hs-config.in DELETED ---

--- aclocal.m4 DELETED ---

--- INSTALL DELETED ---

--- AUTHORS DELETED ---

--- README DELETED ---

--- c2hs.spec.in DELETED ---

--- TODO DELETED ---

[Gtk2hs-commit] gtk2hs/tools/c2hs/c2hs/c C.hs,1.2,NONE CAST.hs,1.2,NONE CAttrs.hs,1.2,NONE CBuiltin.hs,1.1.1.1,NONE CLexer.hs,1.2,NONE CNames.hs,1.1.1.1,NONE CParser.hs,1.2,NONE CPretty.hs,1.1.1.1,NONE CTrav.hs,1.1.1.1,NONE Makefile,1.1.1.1,NONE

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

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

Removed Files:
	C.hs CAST.hs CAttrs.hs CBuiltin.hs CLexer.hs CNames.hs 
	CParser.hs CPretty.hs CTrav.hs Makefile 
Log Message:
Moved the c2hs directories one level up like it was in the old setup.


--- C.hs DELETED ---

--- CLexer.hs DELETED ---

--- CBuiltin.hs DELETED ---

--- CAST.hs DELETED ---

--- CNames.hs DELETED ---

--- CParser.hs DELETED ---

--- CTrav.hs DELETED ---

--- CAttrs.hs DELETED ---

--- Makefile DELETED ---

--- CPretty.hs DELETED ---

[Gtk2hs-commit] gtk2hs/tools/c2hs/c2hs/gen CInfo.hs,1.1.1.1,NONE GBMonad.hs,1.2,NONE GenBind.hs,1.1.1.1,NONE GenHeader.hs,1.1.1.1,NONE Makefile,1.1.1.1,NONE

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

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

Removed Files:
	CInfo.hs GBMonad.hs GenBind.hs GenHeader.hs Makefile 
Log Message:
Moved the c2hs directories one level up like it was in the old setup.


--- CInfo.hs DELETED ---

--- GenHeader.hs DELETED ---

--- GBMonad.hs DELETED ---

--- Makefile DELETED ---

--- GenBind.hs DELETED ---

[Gtk2hs-commit] gtk2hs/tools/c2hs/toplevel - New directory

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

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

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

[Gtk2hs-commit] gtk2hs/tools/c2hs/c - New directory

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

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

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

[Gtk2hs-commit] gtk2hs/tools/c2hs/state - New directory

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

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

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

[Gtk2hs-commit] gtk2hs/tools/c2hs/chs - New directory

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

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

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

[Gtk2hs-commit] gtk2hs/tools/c2hs/gen - New directory

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

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

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

[Gtk2hs-commit] gtk2hs ChangeLog,1.233,1.234 Makefile.am,1.5,1.6 configure.ac,1.4,1.5

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

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

Modified Files:
	ChangeLog Makefile.am configure.ac 
Log Message:
Make the build run through.


Index: configure.ac
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/configure.ac,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- configure.ac	21 Nov 2004 15:06:12 -0000	1.4
+++ configure.ac	21 Nov 2004 20:54:58 -0000	1.5
@@ -537,8 +537,6 @@
 dnl write the results...
 AC_CONFIG_FILES([
   Makefile
-  tools/Makefile
-  tools/c2hs/Makefile
 ])
 
 AC_OUTPUT([

Index: Makefile.am
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/Makefile.am,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- Makefile.am	21 Nov 2004 15:06:12 -0000	1.5
+++ Makefile.am	21 Nov 2004 20:54:58 -0000	1.6
@@ -174,9 +174,9 @@
 # Fix automake - the subdir-objects option doesn't work here.
 am_tools_c2hs_c2hsLocal_OBJECTS = \
 	$(addsuffix .$(OBJEXT),$(basename $(tools_c2hs_c2hsLocal_SOURCES)))
-MOSTLYCLEANFILES+= $(tools_c2hs_c2hsLocal_HSFILES:.hs=.$(OBJEXT))
+MOSTLYCLEANFILES+= $(am_tools_c2hs_c2hsLocal_OBJECTS)
+MOSTLYCLEANFILES+= $(tools_c2hs_c2hsLocal_HSFILES:.hs=.hi)
 CLEANFILES+= $(tools_c2hs_c2hsLocal_BUILDSOURCES)
-CLEANFILES+=$(am_tools_c2hs_c2hsLocal_OBJECTS)
 DISTCLEANFILES+= tools_c2hs_c2hsLocal.deps
 -include tools_c2hs_c2hsLocal.deps
 
@@ -328,22 +328,26 @@
 	compat/LocalData.hs
 
 am_gtk_libgtk2hs_a_OBJECTS = \
-  $(addsuffix .$(OBJEXT),$(basename $(gtk_libgtk2hs_a_SOURCES)))
+  $(addsuffix .$(OBJEXT),$(basename $(basename $(gtk_libgtk2hs_a_SOURCES))))
 
-gtk_libgtk2hs_a_CHSFILES = $(filter %.chs %.chs.pp, $(gtk_libgtk2hs_a_SOURCES))
-gtk_libgtk2hs_a_CHSFILES_HS = $(patsubst %.chs,%.hs,\
-	$(patsubst %.chs.pp,%.hs,$(gtk_libgtk2hs_a_CHSFILES)))
+gtk_libgtk2hs_a_CHSPPFILES = $(filter %.chs.pp,$(gtk_libgtk2hs_a_SOURCES))
+gtk_libgtk2hs_a_CHSFILES = \
+  $(filter %.chs,$(gtk_libgtk2hs_a_SOURCES:.chs.pp=.chs))
+gtk_libgtk2hs_a_CHSFILES_HS = $(gtk_libgtk2hs_a_CHSFILES:.chs=.hs)
 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_CHSPPFILES:.chs.pp=.chs) \
 	$(gtk_libgtk2hs_a_CHSFILES_HS) \
 	$(gtk_libgtk2hs_a_HSCFILES_HS)
 gtk_libgtk2hs_a_HSFILES  = \
-	$(gtk_libgtk2hs_a_BUILDSOURCES) \
+	$(filter %.hs,$(gtk_libgtk2hs_a_BUILDSOURCES)) \
 	$(filter %.hs,$(gtk_libgtk2hs_a_SOURCES))
+.PRECIOUS: $(gtk_libgtk2hs_a_HSFILES:.hs=hi)
 
 MOSTLYCLEANFILES+ = $(am_gtk_libgtk2hs_a_OBJECTS)
-CLEANFILES+= $(gtk_libgtk2hs_a_BUILDSOURCES) $(gtk_libgtk2hs_a_HSFILES:.hs=.hi)
+MOSTLYCLEANFILES+ = $(gtk_libgtk2hs_a_HSFILES:.hs=.hi)
+CLEANFILES+= $(gtk_libgtk2hs_a_BUILDSOURCES)
 
 DISTCLEANFILES+= gtk_libgtk2hs_a.deps $(gtk_libgtk2hs_a_CHSFILES_HS:.hs=.dep)
 -include gtk_libgtk2hs_a.deps $(gtk_libgtk2hs_a_CHSFILES_HS:.hs=.dep)

Index: ChangeLog
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/ChangeLog,v
retrieving revision 1.233
retrieving revision 1.234
diff -u -d -r1.233 -r1.234
--- ChangeLog	21 Nov 2004 15:06:12 -0000	1.233
+++ ChangeLog	21 Nov 2004 20:54:58 -0000	1.234
@@ -1,5 +1,12 @@
 2004-11-21 Axel Simon <A....@ke...> 
 
+	* Makefile.am, tools/c2hs/gen/GenBind.hs,
+	tools/c2hs/gen/GBMonad.hs: Incorporate the patch so that Ptr,
+	ForeignPtr and StablePtr are expanded correctlyl independently of
+	whether they are wrapped in a newtype or just synonyms. Fixed
+	(hopefully) a bug in c2hs' get hook that didn't cope with
+	pointers.
+
 	* Makefile.am, configure.ac: Generating dependencies now involves
 	building c2hs on the fly. This is bad for saying make clean on a
 	clean tree, but so far I this is the cleanest solution.

[Gtk2hs-commit] gtk2hs/mk common.mk,1.34,1.35

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

Update of /cvsroot/gtk2hs/gtk2hs/mk
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7878/mk

Modified Files:
	common.mk 
Log Message:
Make the build run through.


Index: common.mk
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/mk/common.mk,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -d -r1.34 -r1.35
--- common.mk	21 Nov 2004 15:06:16 -0000	1.34
+++ common.mk	21 Nov 2004 20:54:59 -0000	1.35
@@ -43,11 +43,6 @@
 .o.hi:
 	@:
 
-# The cheeky rule for .hi files says that .hi files can be created as
-# side-effect of generating a .o file. Make sure the .hi files are not
-# deleted as normal intermediate files are.
-.PRECIOUS: %.hi
-
 HSTOOLFLAGS = -H500m
 
 .PHONY: debug
@@ -79,10 +74,11 @@
 	--include $(CONFIG_H) \
         --cc=$(HC) --lflag=-no-hs-main $<)
 
-.chs.hs:
-	$(strip if test -x $(C2HS); then :; else \
+.chs.hs: 
+	$(if $(subst no,,$(BUILT_IN_C2HS)),$(strip \
+	if test -x $(C2HS); then :; else \
 	  $(MAKE) $(AM_MAKEFLAGS) NAME="tools_c2hs_c2hsLocal" \
-	  tools/c2hs/c2hsLocal; fi;)
+	  tools/c2hs/c2hsLocal; fi;))
 	$(strip if test -f $($(NAME)_PRECOMP); then :; else \
 	  $(MAKE) $(AM_MAKEFLAGS) NAME="$(NAME)" $($(NAME)_PRECOMP); fi;)
 	$(strip $(C2HS) $(C2HS_FLAGS) \

[Gtk2hs-commit] gtk2hs ChangeLog,1.232,1.233 Makefile.am,1.4,1.5 configure.ac,1.3,1.4

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

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

Modified Files:
	ChangeLog Makefile.am configure.ac 
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++.



Index: configure.ac
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/configure.ac,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- configure.ac	28 Oct 2004 21:47:57 -0000	1.3
+++ configure.ac	21 Nov 2004 15:06:12 -0000	1.4
@@ -35,7 +35,7 @@
 AH_TOP([#include<gtk/gtkversion.h>])
 
 dnl Checks for programs.
-AC_PROG_CC
+AM_PROG_CC_C_O
 AC_PROG_CPP
 AC_PROG_INSTALL
 AC_PROG_LN_S
@@ -435,8 +435,7 @@
 if test $BUILT_IN_C2HS = yes; then
   AC_MSG_RESULT([built-in])
   dnl Use the local c2hs.
-  C2HS='$(TOP)/c2hs/c2hs';
-  MULTIPLE_CHS=yes;
+  C2HS='$(TOP)/tools/c2hs/c2hsLocal';
 
   dnl These are the settings needed to compile c2hs.
   LEGACY_FFI=no;
@@ -462,8 +461,8 @@
       AC_CACHE_CHECK([c2hs version], c2hs_version, [
         c2hs_version=`$C2HS --version | $SED "s/[[^0-9.]*\([0-9.]*\) .*]/\1/"`;
       ])
-      GTKHS_PROG_CHECK_VERSION($c2hs_version, -lt, 0.11.6,
-        AC_MSG_ERROR([You need C->Haskell version 0.11.6 upwards!
+      GTKHS_PROG_CHECK_VERSION($c2hs_version, -lt, 0.13.4,
+        AC_MSG_ERROR([You need C->Haskell version 0.13.4 upwards!
           ** Download from \"http://www.cse.unsw.edu.au/~chak/haskell/c2hs/\". **]))
       dnl C->Haskell configuration.
       } ;;
@@ -536,12 +535,17 @@
 AC_SUBST(END_NOT_NHC)
 
 dnl write the results...
-AC_OUTPUT([
+AC_CONFIG_FILES([
   Makefile
+  tools/Makefile
+  tools/c2hs/Makefile
+])
+
+AC_OUTPUT([
+  tools/c2hs/toplevel/C2HSConfig.hs
   gtk2hs.spec
-  mk/chsDepend
-  c2hs/toplevel/C2HSConfig.hs
-],[chmod a+x mk/chsDepend && chmod a+x install-sh])
+  mk/chsDepend],
+	[chmod a+x mk/chsDepend && chmod a+x install-sh])
 
 dnl ...and chat with the user
 echo "**************************************************"

Index: Makefile.am
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/Makefile.am,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- Makefile.am	28 Oct 2004 21:47:57 -0000	1.4
+++ Makefile.am	21 Nov 2004 15:06:12 -0000	1.5
@@ -1,7 +1,7 @@
 AUTOMAKE_OPTIONS = foreign subdir-objects
-SUFFIXES = .chs.cpp .chs .hsc .deps .dep
-DEPDIR = $(addsuffix /,@DEPDIR@)
-CLEANFILES = $(DEPDIR)*.dep
+SUFFIXES = .chs.pp .chs .hsc .deps .dep
+MOSTLYCLEANFILES =
+CLEANFILES =
 DISTCLEANFILES = *.precomp
 
 # Before chaning anything on dependency calculation:
@@ -9,8 +9,8 @@
 #   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.
+#   package a particular file belongs to. But the CPPFLAGS are needed for
+#   the .chs.pp rule which runs 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
@@ -21,11 +21,19 @@
 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 \
+# Build c2hs before anything else.
+
+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 \
-	tools/hierarchyGen tools/callbackGen tools/apicoverage
+	compat gtk/layout gtk/menuComboToolbar gtk/buttons gtk/windows	     \
+	tools/hierarchyGen tools/callbackGen tools/apicoverage		     \
+	tools/c2hs/base/admin tools/c2hs/base/errors			     \
+	tools/c2hs/base/general tools/c2hs/base/graphs			     \
+	tools/c2hs/base/state tools/c2hs/base/syms			     \
+	tools/c2hs/base/syntax tools/c2hs/base/sysdep tools/c2hs/c	     \
+	tools/c2hs/chs tools/c2hs/gen tools/c2hs/lib tools/c2hs/state	     \
+	tools/c2hs/toplevel
 
 # fixme: this should be in configure.ac:
 HSCPP = $(CPP) -x c -traditional-cpp -P
@@ -36,10 +44,11 @@
 
 # all packages and applications
 lib_LIBRARIES = gtk/libgtk2hs.a
-bin_PROGRAMS = \
+noinst_PROGRAMS = \
 	tools/hierarchyGen/TypeGenerator \
 	tools/callbackGen/HookGenerator \
-	tools/apicoverage/Exclude
+	tools/apicoverage/Exclude \
+	tools/c2hs/c2hsLocal
 
 # TypeGenerator
 
@@ -58,6 +67,7 @@
 # Fix automake - the subdir-objects option doesn't work here.
 am_tools_hierarchyGen_TypeGenerator_OBJECTS = $(addsuffix .$(OBJEXT),\
   $(basename $(tools_hierarchyGen_TypeGenerator_SOURCES)))
+MOSTLYCLEANFILES+= $(am_tools_hierarchyGen_TypeGenerator_OBJECTS)
 
 gtk/general/Hierarchy.chs : $(srcdir)/tools/hierarchyGen/hierarchy.list \
 			    $(srcdir)/tools/hierarchyGen/TypeGenerator
@@ -76,6 +86,7 @@
   tools/callbackGen/HookGenerator.hs
 am_tools_callbackGen_HookGenerator_OBJECTS = $(addsuffix .$(OBJEXT),\
   $(basename $(tools_callbackGen_HookGenerator_SOURCES)))
+MOSTLYCLEANFILES+= $(am_tools_callbackGen_HookGenerator_OBJECTS)
 
 
 gtk/general/Signal.chs : $(srcdir)/tools/callbackGen/Signal.chs-boot1 \
@@ -97,15 +108,83 @@
   tools/apicoverage/Exclude.hs
 am_tools_apicoverage_Exclude_OBJECTS = $(addsuffix .$(OBJEXT),\
   $(basename $(tools_apicoverage_Exclude_SOURCES)))
+MOSTLYCLEANFILES+= $(am_tools_apicoverage_Exclude_OBJECTS)
 
+# c2hs interface generator
+tools_c2hs_c2hsLocal_NAME = tools/c2hs/c2hsLocal
+$(tools_c2hs_c2hsLocal_NAME) : NAME = tools_c2hs_c2hsLocal
 
-# 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.
+tools_c2hs_c2hsLocal_MAIN = c2hs/toplevel/Main.hs
+tools_c2hs_c2hsLocal_PACKAGEDEPS	= lang
+tools_c2hs_c2hsLocal_HEADER		= tools/c2hs/toplevel/c2hs_config.h
+tools_c2hs_c2hsLocal_HCFLAGS		= -fglasgow-exts -fffi
+
+tools_c2hs_c2hsLocal_SOURCES =			\
+	tools/c2hs/base/admin/BaseVersion.hs	\
+	tools/c2hs/base/admin/Common.hs		\
+	tools/c2hs/base/admin/Config.hs		\
+	tools/c2hs/base/errors/Errors.hs	\
+	tools/c2hs/base/general/DLists.hs	\
+	tools/c2hs/base/general/FileOps.hs	\
+	tools/c2hs/base/general/FNameOps.hs	\
+	tools/c2hs/base/general/GetOpt.hs	\
+	tools/c2hs/base/general/UNames.hs	\
+	tools/c2hs/base/general/Utils.hs	\
+	tools/c2hs/base/general/Binary.hs	\
+	tools/c2hs/base/general/FastMutInt.hs	\
+	tools/c2hs/base/graphs/Marks.hs		\
+	tools/c2hs/base/state/CIO.hs		\
+	tools/c2hs/base/state/DynArrays.hs	\
+	tools/c2hs/base/state/StateBase.hs	\
+	tools/c2hs/base/state/State.hs		\
+	tools/c2hs/base/state/StateTrans.hs	\
+	tools/c2hs/base/syms/Attributes.hs	\
+	tools/c2hs/base/syms/Idents.hs		\
+	tools/c2hs/base/syms/NameSpaces.hs	\
+	tools/c2hs/base/syntax/Lexers.hs	\
+	tools/c2hs/base/syntax/ParserMonad.hs	\
+	tools/c2hs/base/syntax/Parsers.hs	\
+	tools/c2hs/base/syntax/Pretty.hs	\
+	tools/c2hs/base/sysdep/SysDep.hs	\
+	tools/c2hs/base/sysdep/SysDepPosix.hs	\
+	tools/c2hs/c/CAST.hs			\
+	tools/c2hs/c/CAttrs.hs			\
+	tools/c2hs/c/CBuiltin.hs		\
+	tools/c2hs/c/C.hs			\
+	tools/c2hs/c/CLexer.hs			\
+	tools/c2hs/c/CNames.hs			\
+	tools/c2hs/c/CParser.hs			\
+	tools/c2hs/c/CPretty.hs			\
+	tools/c2hs/c/CTrav.hs			\
+	tools/c2hs/chs/CHS.hs			\
+	tools/c2hs/chs/CHSLexer.hs		\
+	tools/c2hs/gen/CInfo.hs			\
+	tools/c2hs/gen/GBMonad.hs		\
+	tools/c2hs/gen/GenBind.hs		\
+	tools/c2hs/gen/GenHeader.hs		\
+	tools/c2hs/state/C2HSState.hs		\
+	tools/c2hs/state/Switches.hs		\
+	tools/c2hs/toplevel/Main.hs		\
+	tools/c2hs/toplevel/Version.hs		\
+	tools/c2hs/toplevel/C2HSConfig.hs	\
+	tools/c2hs/toplevel/c2hs_config.c
+
+tools_c2hs_c2hsLocal_HSFILES		= \
+	$(filter %.hs,$(tools_c2hs_c2hsLocal_SOURCES))
+# Fix automake - the subdir-objects option doesn't work here.
+am_tools_c2hs_c2hsLocal_OBJECTS = \
+	$(addsuffix .$(OBJEXT),$(basename $(tools_c2hs_c2hsLocal_SOURCES)))
+MOSTLYCLEANFILES+= $(tools_c2hs_c2hsLocal_HSFILES:.hs=.$(OBJEXT))
+CLEANFILES+= $(tools_c2hs_c2hsLocal_BUILDSOURCES)
+CLEANFILES+=$(am_tools_c2hs_c2hsLocal_OBJECTS)
+DISTCLEANFILES+= tools_c2hs_c2hsLocal.deps
+-include tools_c2hs_c2hsLocal.deps
+
+# gtk2hs GUI library
 gtk_libgtk2hs_a_NAME = gtk/libgtk2hs.a
 $(gtk_libgtk2hs_a_NAME) : NAME = gtk_libgtk2hs_a
 
+gtk_libgtk2hs_a : tools/c2hs/c2hs
 gtk_libgtk2hs_a_PACKAGECONF	= libgtk2hs.conf
 gtk_libgtk2hs_a_PACKAGE		= gtk2hs
 gtk_libgtk2hs_a_PACKAGEDEPS	= data
@@ -114,146 +193,146 @@
 gtk_libgtk2hs_a_LIBS		= @GTK_LIBS@
 gtk_libgtk2hs_a_HCFLAGS		= -fglasgow-exts
 
-gtk_libgtk2hs_a_SOURCES = \
-	gtk/general/Hierarchy.chs \
-	gtk/general/Signal.chs \
-	gtk/glib/GValue.chs \
-	gtk/glib/GList.chs \
-	gtk/glib/GObject.chspp \
-	gtk/pango/PangoTypes.chspp \
-	gtk/treeList/TreeModel.chspp \
-	gtk/treeList/TreeViewColumn.chs \
-	gtk/multiline/TextIter.chspp \
-	gtk/gdk/Region.chspp \
-	gtk/abstract/Bin.chs \
-	gtk/abstract/Box.chs \
-	gtk/abstract/ButtonBox.chspp \
-	gtk/abstract/Container.chs \
-	gtk/abstract/FileChooser.chs \
-	gtk/abstract/Misc.chs \
-	gtk/abstract/Object.chspp \
-	gtk/abstract/Paned.chs \
-	gtk/abstract/Range.chs \
-	gtk/abstract/Scale.chs \
-	gtk/abstract/Widget.chs \
-	gtk/buttons/Button.chspp \
-	gtk/buttons/CheckButton.chs \
-	gtk/buttons/RadioButton.chs \
-	gtk/buttons/ToggleButton.chs \
-	gtk/display/AccelLabel.chs \
-	gtk/display/Image.chs \
-	gtk/display/Label.chs \
-	gtk/display/ProgressBar.chs \
-	gtk/display/Statusbar.chs \
-	gtk/entry/Editable.chs \
-	gtk/entry/Entry.chspp \
-	gtk/entry/EntryCompletion.chspp \
-	gtk/entry/HScale.chs \
-	gtk/entry/SpinButton.chs \
-	gtk/entry/VScale.chs \
-	gtk/general/Enums.chspp \
-	gtk/general/General.chs \
-	gtk/general/IconFactory.chspp \
-	gtk/general/Style.chs \
-	gtk/layout/Alignment.chspp \
-	gtk/layout/AspectFrame.chs \
-	gtk/layout/Expander.chspp \
-	gtk/layout/Fixed.chs \
-	gtk/layout/HBox.chs \
-	gtk/layout/HButtonBox.chs \
-	gtk/layout/HPaned.chs \
-	gtk/layout/Layout.chs \
-	gtk/layout/Notebook.chspp \
-	gtk/layout/Table.chs \
-	gtk/layout/VBox.chs \
-	gtk/layout/VButtonBox.chs \
-	gtk/layout/VPaned.chs \
-	gtk/menuComboToolbar/CheckMenuItem.chspp \
-	gtk/menuComboToolbar/Combo.chspp \
-	gtk/menuComboToolbar/ComboBox.chspp \
-	gtk/menuComboToolbar/ComboBoxEntry.chspp \
-	gtk/menuComboToolbar/ImageMenuItem.chs \
-	gtk/menuComboToolbar/Menu.chspp \
-	gtk/menuComboToolbar/MenuBar.chs \
-	gtk/menuComboToolbar/MenuItem.chs \
-	gtk/menuComboToolbar/MenuShell.chs \
-	gtk/menuComboToolbar/OptionMenu.chspp \
-	gtk/menuComboToolbar/RadioMenuItem.chs \
-	gtk/menuComboToolbar/TearoffMenuItem.chs \
-	gtk/menuComboToolbar/ToolItem.chspp \
-	gtk/menuComboToolbar/Toolbar.chspp \
-	gtk/misc/Adjustment.chs \
-	gtk/misc/Calendar.chspp \
-	gtk/misc/DrawingArea.chs \
-	gtk/misc/EventBox.chspp \
-	gtk/misc/FileChooserWidget.chspp \
-	gtk/misc/GArrow.chs \
-	gtk/misc/HandleBox.chs \
-	gtk/misc/SizeGroup.chs \
-	gtk/misc/Tooltips.chspp \
-	gtk/misc/Viewport.chs \
-	gtk/multiline/TextBuffer.chs \
-	gtk/multiline/TextMark.chs \
-	gtk/multiline/TextTag.chspp \
-	gtk/multiline/TextTagTable.chs \
-	gtk/multiline/TextView.chs \
-	gtk/ornaments/Frame.chs \
-	gtk/ornaments/HSeparator.chs \
-	gtk/ornaments/VSeparator.chs \
-	gtk/scrolling/HScrollbar.chs \
-	gtk/scrolling/ScrolledWindow.chs \
-	gtk/scrolling/VScrollbar.chs \
-	gtk/selectors/ColorSelection.chs \
-	gtk/selectors/ColorSelectionDialog.chs \
-	gtk/selectors/FontSelection.chs \
-	gtk/selectors/FontSelectionDialog.chs \
-	gtk/treeList/CellRendererPixbuf.chs \
-	gtk/treeList/CellRendererText.chs \
-	gtk/treeList/CellRendererToggle.chs \
-	gtk/treeList/ListStore.chspp \
-	gtk/treeList/TreeModelSort.chs \
-	gtk/treeList/TreeSelection.chs \
-	gtk/treeList/TreeStore.chspp \
-	gtk/treeList/TreeView.chspp \
-	gtk/windows/Dialog.chs \
-	gtk/windows/FileChooserDialog.chspp \
-	gtk/windows/FileSel.chs \
-	gtk/windows/Window.chspp \
-	gtk/gdk/Drawable.chspp \
-	gtk/gdk/GC.chs \
-	gtk/gdk/Gdk.chs \
-	gtk/gdk/GdkEnums.chs \
-	gtk/gdk/Keys.chs \
-	gtk/gdk/Pixbuf.chs \
-	gtk/glib/GError.chspp \
-	gtk/glib/GType.chs \
-	gtk/glib/GValueTypes.chs \
-	gtk/pango/PangoLayout.chs \
-	gtk/pango/Rendering.chs \
-	gtk/embedding/Plug.chs \
-	gtk/embedding/Socket.chs \
-	gtk/general/StockItems.hsc \
-	gtk/general/Structs.hsc \
-	gtk/treeList/StoreValue.hsc \
-	gtk/gdk/Events.hsc \
-	gtk/glib/GParameter.hsc \
-	gtk/embedding/Embedding.hsc \
-	gtk/abstract/Scrollbar.hs \
-	gtk/abstract/Separator.hs \
-	gtk/general/FFI.hs \
-	gtk/general/Gtk.hs \
-	gtk/treeList/CellRenderer.hs \
-	gtk/gdk/DrawWindow.hs \
-	gtk/pango/Markup.hs \
-	compat/LocalControl.hs \
+gtk_libgtk2hs_a_SOURCES =			  \
+	gtk/general/Hierarchy.chs		  \
+	gtk/general/Signal.chs			  \
+	gtk/glib/GValue.chs			  \
+	gtk/glib/GList.chs			  \
+	gtk/glib/GObject.chs.pp			  \
+	gtk/pango/PangoTypes.chs.pp		  \
+	gtk/treeList/TreeModel.chs.pp		  \
+	gtk/treeList/TreeViewColumn.chs		  \
+	gtk/multiline/TextIter.chs.pp		  \
+	gtk/gdk/Region.chs.pp			  \
+	gtk/abstract/Bin.chs			  \
+	gtk/abstract/Box.chs			  \
+	gtk/abstract/ButtonBox.chs.pp		  \
+	gtk/abstract/Container.chs		  \
+	gtk/abstract/FileChooser.chs		  \
+	gtk/abstract/Misc.chs			  \
+	gtk/abstract/Object.chs.pp		  \
+	gtk/abstract/Paned.chs			  \
+	gtk/abstract/Range.chs			  \
+	gtk/abstract/Scale.chs			  \
+	gtk/abstract/Widget.chs			  \
+	gtk/buttons/Button.chs.pp		  \
+	gtk/buttons/CheckButton.chs		  \
+	gtk/buttons/RadioButton.chs		  \
+	gtk/buttons/ToggleButton.chs		  \
+	gtk/display/AccelLabel.chs		  \
+	gtk/display/Image.chs			  \
+	gtk/display/Label.chs			  \
+	gtk/display/ProgressBar.chs		  \
+	gtk/display/Statusbar.chs		  \
+	gtk/entry/Editable.chs			  \
+	gtk/entry/Entry.chs.pp			  \
+	gtk/entry/EntryCompletion.chs.pp	  \
+	gtk/entry/HScale.chs			  \
+	gtk/entry/SpinButton.chs		  \
+	gtk/entry/VScale.chs			  \
+	gtk/general/Enums.chs.pp		  \
+	gtk/general/General.chs			  \
+	gtk/general/IconFactory.chs.pp		  \
+	gtk/general/Style.chs			  \
+	gtk/layout/Alignment.chs.pp		  \
+	gtk/layout/AspectFrame.chs		  \
+	gtk/layout/Expander.chs.pp		  \
+	gtk/layout/Fixed.chs			  \
+	gtk/layout/HBox.chs			  \
+	gtk/layout/HButtonBox.chs		  \
+	gtk/layout/HPaned.chs			  \
+	gtk/layout/Layout.chs			  \
+	gtk/layout/Notebook.chs.pp		  \
+	gtk/layout/Table.chs			  \
+	gtk/layout/VBox.chs			  \
+	gtk/layout/VButtonBox.chs		  \
+	gtk/layout/VPaned.chs			  \
+	gtk/menuComboToolbar/CheckMenuItem.chs.pp \
+	gtk/menuComboToolbar/Combo.chs.pp	  \
+	gtk/menuComboToolbar/ComboBox.chs.pp	  \
+	gtk/menuComboToolbar/ComboBoxEntry.chs.pp \
+	gtk/menuComboToolbar/ImageMenuItem.chs	  \
+	gtk/menuComboToolbar/Menu.chs.pp	  \
+	gtk/menuComboToolbar/MenuBar.chs	  \
+	gtk/menuComboToolbar/MenuItem.chs	  \
+	gtk/menuComboToolbar/MenuShell.chs	  \
+	gtk/menuComboToolbar/OptionMenu.chs.pp	  \
+	gtk/menuComboToolbar/RadioMenuItem.chs	  \
+	gtk/menuComboToolbar/TearoffMenuItem.chs  \
+	gtk/menuComboToolbar/ToolItem.chs.pp	  \
+	gtk/menuComboToolbar/Toolbar.chs.pp	  \
+	gtk/misc/Adjustment.chs			  \
+	gtk/misc/Calendar.chs.pp		  \
+	gtk/misc/DrawingArea.chs		  \
+	gtk/misc/EventBox.chs.pp		  \
+	gtk/misc/FileChooserWidget.chs.pp	  \
+	gtk/misc/GArrow.chs			  \
+	gtk/misc/HandleBox.chs			  \
+	gtk/misc/SizeGroup.chs			  \
+	gtk/misc/Tooltips.chs.pp		  \
+	gtk/misc/Viewport.chs			  \
+	gtk/multiline/TextBuffer.chs		  \
+	gtk/multiline/TextMark.chs		  \
+	gtk/multiline/TextTag.chs.pp		  \
+	gtk/multiline/TextTagTable.chs		  \
+	gtk/multiline/TextView.chs		  \
+	gtk/ornaments/Frame.chs			  \
+	gtk/ornaments/HSeparator.chs		  \
+	gtk/ornaments/VSeparator.chs		  \
+	gtk/scrolling/HScrollbar.chs		  \
+	gtk/scrolling/ScrolledWindow.chs	  \
+	gtk/scrolling/VScrollbar.chs		  \
+	gtk/selectors/ColorSelection.chs	  \
+	gtk/selectors/ColorSelectionDialog.chs	  \
+	gtk/selectors/FontSelection.chs		  \
+	gtk/selectors/FontSelectionDialog.chs	  \
+	gtk/treeList/CellRendererPixbuf.chs	  \
+	gtk/treeList/CellRendererText.chs	  \
+	gtk/treeList/CellRendererToggle.chs	  \
+	gtk/treeList/ListStore.chs.pp		  \
+	gtk/treeList/TreeModelSort.chs		  \
+	gtk/treeList/TreeSelection.chs		  \
+	gtk/treeList/TreeStore.chs.pp		  \
+	gtk/treeList/TreeView.chs.pp		  \
+	gtk/windows/Dialog.chs			  \
+	gtk/windows/FileChooserDialog.chs.pp	  \
+	gtk/windows/FileSel.chs			  \
+	gtk/windows/Window.chs.pp		  \
+	gtk/gdk/Drawable.chs.pp			  \
+	gtk/gdk/GC.chs				  \
+	gtk/gdk/Gdk.chs				  \
+	gtk/gdk/GdkEnums.chs			  \
+	gtk/gdk/Keys.chs			  \
+	gtk/gdk/Pixbuf.chs			  \
+	gtk/glib/GError.chs.pp			  \
+	gtk/glib/GType.chs			  \
+	gtk/glib/GValueTypes.chs		  \
+	gtk/pango/PangoLayout.chs		  \
+	gtk/pango/Rendering.chs			  \
+	gtk/embedding/Plug.chs			  \
+	gtk/embedding/Socket.chs		  \
+	gtk/general/StockItems.hsc		  \
+	gtk/general/Structs.hsc			  \
+	gtk/treeList/StoreValue.hsc		  \
+	gtk/gdk/Events.hsc			  \
+	gtk/glib/GParameter.hsc			  \
+	gtk/embedding/Embedding.hsc		  \
+	gtk/abstract/Scrollbar.hs		  \
+	gtk/abstract/Separator.hs		  \
+	gtk/general/FFI.hs			  \
+	gtk/general/Gtk.hs			  \
+	gtk/treeList/CellRenderer.hs		  \
+	gtk/gdk/DrawWindow.hs			  \
+	gtk/pango/Markup.hs			  \
+	compat/LocalControl.hs			  \
 	compat/LocalData.hs
 
 am_gtk_libgtk2hs_a_OBJECTS = \
   $(addsuffix .$(OBJEXT),$(basename $(gtk_libgtk2hs_a_SOURCES)))
 
-gtk_libgtk2hs_a_CHSFILES = $(filter %.chs %.chspp, $(gtk_libgtk2hs_a_SOURCES))
+gtk_libgtk2hs_a_CHSFILES = $(filter %.chs %.chs.pp, $(gtk_libgtk2hs_a_SOURCES))
 gtk_libgtk2hs_a_CHSFILES_HS = $(patsubst %.chs,%.hs,\
-	$(patsubst %.chspp,%.hs,$(gtk_libgtk2hs_a_CHSFILES)))
+	$(patsubst %.chs.pp,%.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 = \
@@ -262,96 +341,15 @@
 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
+MOSTLYCLEANFILES+ = $(am_gtk_libgtk2hs_a_OBJECTS)
+CLEANFILES+= $(gtk_libgtk2hs_a_BUILDSOURCES) $(gtk_libgtk2hs_a_HSFILES:.hs=.hi)
 
-# The local GHC package file for compiling files that depend on packages
-# that we have built but not yet installed.
-LOCALPACKAGE = localpackages.conf
+DISTCLEANFILES+= gtk_libgtk2hs_a.deps $(gtk_libgtk2hs_a_CHSFILES_HS:.hs=.dep)
+-include gtk_libgtk2hs_a.deps $(gtk_libgtk2hs_a_CHSFILES_HS:.hs=.dep)
 
-EMPTY =
-SPACE = $(EMPTY) $(EMPTY)
-VPATH = $(subst $(SPACE),:,$(strip \
-	$(if $(subst .,,$(srcdir)),$(addprefix $(srcdir)/,$(SOURCEDIRS)), \
-	$(SOURCEDIRS))))
 
+# All generated source files go here.
 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)
-	$(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:
-	@:
-
-HSTOOLFLAGS = -H500m
-
-.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,$(CFLAGS) $(CPPFLAGS)) \
-	--precomp=$($(NAME)_PRECOMP) $($(NAME)_HEADER))
-
-.chs.cpp.chs: $(CONFIG_H)
-	$(strip $(HSCPP) $(AM_CPPFLAGS) \
-	$(EXTRA_CPPFLAGS) $(CPPFLAGS) \
-	$(EXTRA_CFLAGS) $(CFLAGS) \
-	$(addprefix -include ,$(CONFIG_H) $($(NAME)_EXTRA_HFILES)) \
-	$< -o $@)
-
-.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)) \
-	$(EXTRA_CFLAGS) $(CFLAGS))\
-        $(filter -I%,$(AM_CPPFLAGS)) \
-	$(EXTRA_CPPFLAGS) $(CPPFLAGS)\
-	--include $(CONFIG_H) \
-        --cc=$(HC) --lflag=-no-hs-main $<)
-
-.chs.hs:
-	if test -f $($(NAME)_PRECOMP); then :; else \
-	  $(MAKE) $(AM_MAKEFLAGS) NAME="$(NAME)" $($(NAME)_PRECOMP); fi;
-	$(strip $(C2HS) $(C2HS_FLAGS) +RTS $(HSTOOLFLAGS) -RTS \
-	-i$(VPATH) --precomp=$($(NAME)_PRECOMP) -o $@ $<)
-	$(CHSDEPEND) -i$(VPATH) $<
-
-
+include mk/common.mk

Index: ChangeLog
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/ChangeLog,v
retrieving revision 1.232
retrieving revision 1.233
diff -u -d -r1.232 -r1.233
--- ChangeLog	28 Oct 2004 21:47:57 -0000	1.232
+++ ChangeLog	21 Nov 2004 15:06:12 -0000	1.233
@@ -1,3 +1,12 @@
+2004-11-21 Axel Simon <A....@ke...> 
+
+	* Makefile.am, configure.ac: Generating dependencies now involves
+	building c2hs on the fly. This is bad for saying make clean on a
+	clean tree, but so far I this is the cleanest solution.
+
+	* gtk/*/*.chs.cpp: Renamed all these files to .chs.pp since
+	automake otherwise thinks they are C++ sources.
+
 2004-10-28  Axel Simon <A....@ke...>
 
 	* mk/mkDepend.in: Undo changes. Dependencies are again where the

[Gtk2hs-commit] gtk2hs/mk chsDepend.in,1.7,1.8 common.mk,1.33,1.34

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

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

Modified Files:
	chsDepend.in common.mk 
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++.



Index: chsDepend.in
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/mk/chsDepend.in,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- chsDepend.in	28 Oct 2004 21:47:57 -0000	1.7
+++ chsDepend.in	21 Nov 2004 15:06:16 -0000	1.8
@@ -1,9 +1,11 @@
 #!/bin/sh
 # Write dependency information for a c2hs file.
 # Usage:
-# chsDepend [-i<seachPath>] [File1.chs [File2.chs [...]]]
-# Generate dependency information for FileN.chs looking for dependant files
-# in the colon-separated search path <searchPath>.
+# chsDepend [-i<seachPath>] {<file>(.hs|.chs|.chs.pp)}
+
+# Generate dependency information for the given files looking for
+# dependant files in the colon-separated search path <searchPath>.
+
 SED=@SED@;
 GREP=@GREP@;
 DEPDIR=@DEPDIR@;
@@ -18,7 +20,6 @@
  -[iI]*) SEARCHPATH=`echo "$1" | $SED 's/-[iI]//'`; shift ;;
 esac
 
-
 for FULLNAME in $@; do
   FULLNAMEDEP=`echo "$FULLNAME" | $SED 's/\.chs/.dep/'`;
   FULLNAMEHS=`echo "$FULLNAME" | $SED 's/\.chs/.hs/'`;

Index: common.mk
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/mk/common.mk,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -d -r1.33 -r1.34
--- common.mk	24 Oct 2004 17:19:26 -0000	1.33
+++ common.mk	21 Nov 2004 15:06:16 -0000	1.34
@@ -1,345 +1,93 @@
 # --*Makefile*--
 
-# regular expressions to eliminate ../ and ./ in paths
-SEDNOUP		:= 's+\(.*\)/.*/\.\./\(.*\)+\1/\2+'
-SEDNOID		:= 's+\(.*\)\./\(.*\)+\1\2+'
-SEDPIPE		:= $(SED) -e $(SEDNOUP) -e $(SEDNOID) -e $(PATHSED)
-
-# directories of interest
-ABS_TOP		:= $(shell echo $(ABS_TOP) | $(SEDPIPE))
-CURDIR		:= $(shell $(PWD) | $(SEDPIPE))
-TARDIR		:= $(subst $(ABS_TOP),$(TARNAME),$(CURDIR))/
-
-# directories of source files
-SUBDIRS			?= .
-
-SUBDIRSOK		:= $(dir $(addsuffix /,$(SUBDIRS)))
-
-# The user supplied subdirectory where the installed files should go.
-INSTALLDIROK		= $(strip $(if $(INSTALLDIR),\
-			/$(patsubst %/,%,$(dir $(INSTALLDIR)/))))
-
-# directories of installation
-INST_LIBDIR		= $(shell echo $(addsuffix $(INSTALLDIROK),$(libdir)) | $(SEDPIPE))
-INST_HIDIR		= $(INST_LIBDIR)/hi
-INST_INCLDIR		= $(INST_HIDIR)
-INST_BINDIR		= $(shell echo $(addsuffix $(INSTALLDIROK),$(bindir)) | $(SEDPIPE))
-INST_DOCDIR		= $(datadir)/doc/gtk2hs
-
-# these values are used for building a library in-place
-INPL_HIDIR		:= $(sort $(patsubst %/.,%,$(patsubst %/,%,\
-			   $(dir $(addprefix $(CURDIR)/,$(SUBDIRSOK))))))
-INPL_LIBDIR		:= $(patsubst %/,%,$(CURDIR))
-INPL_INCLDIR		:= $(INPL_HIDIR)
-
-
-
-# CHSFILES = EXPLICIT_HEADER \dotcup STANDARD_HEADER, in the right order
-# EXTRA_CHSFILES contains generated .chs files. It is important that the
-# sequence reflects the dependencies of the files because this information
-# is extracted from the files themselves (and generated files don't exist
-# in a clean tree).
-CHSFILES 		:= $(filter-out $(EXTRA_CHSFILES),\
-			$(patsubst ./%,%,\
-			$(foreach DIR,$(SUBDIRSOK),$(wildcard $(DIR)*.chs))))
-
-ALLCHSFILES		:= $(NEEDCHI:=.chs) $(filter-out $(NEEDCHI:=.chs), \
-			$(CHSFILES) $(EXTRA_CHSFILES))
-
-# all .chs files that have a .chs-HEADER variable defined
-EXPLICIT_HEADER         := $(foreach FILE,$(ALLCHSFILES),\
-                        $(if $(findstring undefined,\
-                        $(origin $(notdir $(basename $(FILE)))-HEADER)),,\
-			$(FILE)))
-
-# all .chs files that use the common header file in HEADER
-STANDARD_HEADER         := $(filter-out $(EXPLICIT_HEADER),$(ALLCHSFILES))
-
-# HSC files
-HSCFILES                := $(filter-out $(EXTRA_HSCFILES),\
-			$(patsubst ./%,%,\
-                        $(foreach DIR,$(SUBDIRSOK),$(wildcard $(DIR)*.hsc))))\
-                        $(EXTRA_HSCFILES)
-
-# These are all .hs files that are not generated in any way.
-HSFILES  		:= $(filter-out $(ALLCHSFILES:.chs=.hs)\
-			$(HSCFILES:.hsc=.hs) $(EXTRA_HSFILES),\
-			$(patsubst ./%,%,\
-			$(foreach DIR,$(SUBDIRSOK),$(wildcard $(DIR)*.hs))))
-
-# These are all .hs files in the project. This is not the same as *.hs in
-# all subdirs because in a clean tree there is e.g. no .hs for a .chs file.
-ALLHSFILES		:= $(HSFILES) $(ALLCHSFILES:.chs=.hs) \
-			$(HSCFILES:.hsc=.hs) $(EXTRA_HSFILES)
-
-# Possibly useful: These are the files that are hand-crafted:
-ALLSOURCEFILES		:= $(ALLCHSFILES) $(HSCFILES) $(HSFILES) \
-			$(EXTRA_HSFILES)
-
-EXTRA_HFILESOK		:= $(sort $(EXTRA_HFILES) $(EXTRA_CFILES:.c=.h))
-
-# C include file paths and other options to CPP.
-EXTRA_CPPFLAGS_ONLY_I	:= $(filter -I%,$(EXTRA_CPPFLAGS))
-
-EXTRA_LIBS_ONLY_Ll	:= $(filter -L% -l%,$(EXTRA_LIBS))
-
-EXTRA_LIBS_ONLY_L	:= $(filter -L%,$(EXTRA_LIBS_ONLY_Ll))
-
-CPPFLAGS_ONLY_I		:= $(filter -I%,$(CPPFLAGS))
-
-LIBS_ONLY_L		:= $(filter -L% -l%,$(CFLAGS))
-
-
-# Ensure that the user-supplied target is valid. If there is a nice way to
-# capitalize the first letter, do that to $(APPNAME).hs and add that here.
-MAIN			?= Main.hs $(APPNAME).hs
-
-MAINOK			:= $(filter $(MAIN) $(addsuffix $(MAIN),$(SUBDIRSOK)),\
-			$(patsubst ./%,%,$(ALLHSFILES)))
-
-EMPTY			:=
-
-COMMA			:= ,
-
-SPACE			:= $(EMPTY) $(EMPTY)
-
-# Turn a space separated directory list into a colon separated one.
-HIDIRSOK		:= $(subst $(SPACE),:,$(strip \
-			$(patsubst %/,%,$(HIDIRS) $(SUBDIRSOK))))
-
-NEEDPACKAGESOK		:= $(addprefix -package ,$(strip $(NEEDPACKAGES)))
-
-HCINCLUDES		:= $(addprefix '-\#include<,$(addsuffix >',$(HEADER) \
-			$(EXTRA_HFILESOK)))
-
-
-# Specify how hsc should be run.
-HSCFLAGGED	:= $(strip $(HSC) $(HSCFLAGS) +RTS $(HSTOOLFLAGS) -RTS \
-		$(EXTRA_CPPFLAGS_ONLY_I) $(CPPFLAGS_ONLY_I) \
-		$(addprefix --lflag=,$(EXTRA_LIBS_ONLY_Ll) $(LIBS_ONLY_L)\
-		$(addprefix --cflag=,$(CPPFLAGS) $(EXTRA_CPP_FLAGS)))\
-		--cc=$(HC) --lflag=-no-hs-main)
-
-# Specify how c2hs should be run.
-C2HSFLAGGED	:= $(C2HS) $(C2HSFLAGS) +RTS $(HSTOOLFLAGS) -RTS \
-		$(addprefix -C,$(EXTRA_CPPFLAGS_ONLY_I) $(CPPFLAGS_ONLY_I)) \
-		-i$(HIDIRSOK) $(C2HS_EXTRA_FLAGS)
+# A file with CPP "defines" that reflect the current configuration.
+CONFIG_H = config.h
 
-# Read in all extra dependencies between .chs files.
--include $(ALLCHSFILES:.chs=.dep)
+EMPTY =
+SPACE = $(EMPTY) $(EMPTY)
+VPATH = $(subst $(SPACE),:,$(strip \
+	$(if $(subst .,,$(srcdir)),$(addprefix $(srcdir)/,$(SOURCEDIRS)), \
+	$(SOURCEDIRS))))
 
-# Quick and dirty dependency to force the compilation of .chs file if
-# a current version of the .chi file is needed.
-%.chi : %.hs
+LINK = 	$(strip $(HC) -o $@ $($(NAME)_HCFLAGS) \
+  $(addprefix -package ,$($(NAME)_PACKAGEDEPS)) \
+  $(AM_LDFLAGS) $($(NAME)_EXTRA_LDFLAGS) $($(NAME)_LDFLAGS))
 
-define runC2HS
-@if test -f .depend; then \
-  echo "$(C2HSFLAGGED) -o : $(HEADER)" `cat .depend` && \
-  ($(C2HSFLAGGED) -o : $(HEADER) `cat .depend` || \
-  (echo removing `cat .depend | "$(SED) s/\(.*\)\.chs/\1.hs/"`; \
-  $(RM) `cat .depend | $(SED) "s/\(.*\)\.chs/\1.hs/"` .depend; \
-  exit 1)) && \
-  echo "$(TOP)/mk/chsDepend -i$(HIDIRSOK)" `cat .depend` && \
-  $(TOP)/mk/chsDepend -i$(HIDIRSOK) `cat .depend` && \
-  $(RM) .depend; \
-fi
-endef
+.hs.o: $(CONFIG_H)
+	$(strip $(HC) -c $< -o $@ $($(NAME)_HCFLAGS) -i$(VPATH) \
+	$(addprefix -package ,$($(NAME)_PACKAGEDEPS)) \
+	$(addprefix -package-name ,$($(NAME)_PACKAGE)) \
+	$(addprefix '-\#include<,$(addsuffix >',$(CONFIG_H) \
+	$($(NAME)_HEADER))) \
+	$(AM_CPPFLAGS) $(EXTRA_CPPFLAGS) $(CPPFLAGS))
 
-# How to build <blah.hs> from <blah.chs>: Since <blah.chs-HEADER> is defined
-# we will use the specified header file. We invoke c2hs for each .chs file
-# anew.
-$(EXPLICIT_HEADER:.chs=.hs) : %.hs : %.chs
-	$(runC2HS)
-	$(strip $(C2HSFLAGGED) -o $(addsuffix .hs,$(basename $<)) \
-	  $($(addsuffix -HEADER,$(notdir $(basename $@)))) $<)
-	$(TOP)/mk/chsDepend -i$(HIDIRSOK) $<
+.DELETE_ON_ERROR : %.deps
 
-# As above, but <blah.chs-HEADER> is not defined so we use the variable
-# HEADER which contains the name of the header file common to all
-# files in STANDARD_HEADER. This is a major performance improvment as
-# c2hs has to parse the header file only once in order to translate
-# several .chs files.
-# The actual rebuilt of the files is delayed until either c2hs needs the
-# .chi or ghc needs the .hs files. Until then, all files that need to be
-# rebuilt are stored in .depend . This is a kind of hack; make is good in
-# breaking down larger dependencies into smaller one, but the other way round
-# seems to be impossible: The variable @? does indeed contain all the
-# targets that need to be updated, but updating these files does not convince
-# make not to rerun the rule for another file in @?.
-$(STANDARD_HEADER:.chs=.hs) : %.hs : %.chs
-	echo $< >> .depend
+%.deps :
 	touch $@
+	$(if $($*_BUILDSOURCES),$(strip \
+	$(MAKE) $(AM_MAKEFLAGS) NAME="$*" $($*_BUILDSOURCES) \
+	&&))\
+	$(strip $(HC) -M $(addprefix -optdep,-f $*.deps) \
+	$($*_HCFLAGS) -i$(VPATH) \
+	$(addprefix -package ,$($*_PACKAGEDEPS)) \
+	$(addprefix '-\#include<,$(addsuffix >',$(CONFIG_H) \
+	$($*_HEADER))) \
+	$(AM_CPPFLAGS) $(EXTRA_CPPFLAGS) $(CPPFLAGS) \
+	$($*_HSFILES))
 
-# How to build <blah.hs> from <blah.hsc>
-$(HSCFILES:.hsc=.hs) : %.hs : %.hsc
-	$(HSCFLAGGED) $<
-
-
-# Goals for applications and libraries.
-
-.PHONY: errorNoTarget noTarget
-
-errorNoTarget	:
-		@echo You need to set PACKAGENAME to build a library or
-		@echo APPNAME to build an executable. 
-
-
-inplaceinit	:
-	@if test ! -f $(LOCALPKGCONF); then \
-	  echo [ Package {\
-	  name = \"defaultPackage\",\
-	  import_dirs     = [],\
-	  source_dirs     = [],\
-	  library_dirs    = [],\
-	  hs_libraries    = [],\
-	  extra_libraries = [],\
-	  include_dirs    = [],\
-	  c_includes      = [],\
-	  package_deps    = [],\
-	  extra_ghc_opts  = [],\
-	  extra_cc_opts   = [],\
-	  extra_ld_opts   = []}] > $(LOCALPKGCONF); \
-	  echo Generating new local package file \"$(LOCALPKGCONF)\".; \
-	fi
-
-ifneq ($(strip $(PACKAGENAME)),)
-
-include $(TOP)/mk/library.mk
-
-inplace	: $(TARGETOK)
-
-all	: inplace
-
-else
-ifneq ($(strip $(APPNAME)),)
-
-include $(TOP)/mk/application.mk
-
-all	: $(TARGETOK)
-
-else
-
-TARGETOK		= errorNoTarget
-
-endif
-endif
-
-
-targets :
-	@echo all	in subdirs: builds libraries/applications
-	@echo		in toplevel: equivalent to "make all" in all subdirs
-	@echo inplace	"all" in all subdirs and entry to local package file
-	@echo noinplace removes the entry from the local package file
-	@echo install	"all", installs files, add entry to GHC's package file
-	@echo uninstall reverts install and entry-adding effects of "install"
-	@echo mostlyclean remove all object, libraries and application files
-	@echo clean     "mostlyclean" and remove all generated .hs files
-	@echo distclean "clean" and remove generated .chs files
-
-.PHONY: debug 
-debug 	:
-	@echo top: $(TOP)
-	@echo SED: $(SEDPIPE)
-	@echo cur dir: $(CURDIR)
-	@echo tar into: $(TARDIR)
-	@echo install into: $(INSTALLDIROK)
-#	@echo Goal: $(MAINOK)
-#	@echo Target: $(TARGETOK)
-#	@echo Library: $(LIBNAME)
-#	@echo Application: $(APPNAME)
-	@echo EXTRA_CPPFLAGS: $(EXTRA_CPPFLAGS_ONLY_I)
-#	@echo all CHS files: $(CHSFILES)
-	@echo Standard header: $(STANDARD_HEADER)
-	@echo Explicit header: $(EXPLICIT_HEADER)
-#	@echo all HSC files: $(HSCFILES)
-#	@echo all other HS files: $(HSFILES)
-	@echo stub-o files: $(filter-out %*_stub.o,\
-	  $(shell echo $(addsuffix *_stub.o,$(SUBDIRSOK))))
-	@echo hi: $(INST_HIDIR) lib: $(INST_LIBDIR) 
-	@echo incl: $(INST_INCLDIR) bin: $(INST_BINDIR)
-#	@echo user install dir: $(INSTALLDIR)
-	@echo subdirs: $(SUBDIRSOK)
-	@echo $(ALLSOURCEFILES) > sourcefiles.txt
-#	@cvs status $(CLEANFILES) 2> /dev/null | $(GREP) File | $(GREP) Unknown
-
-# Create a source tar achive. Do this by adding files to the tar file in the
-# top-level directory.
-tarsource :
-	$(strip $(TAR) rf $(TOP)/$(TARNAME).tar -C $(TOP)\
-	  $(foreach FILE,Makefile $(CHSFILES)\
-	    $(filter-out $(EXTRA_HSCFILES), $(HSCFILES))\
-	    $(filter-out $(EXTRA_HSFILES), $(HSFILES))\
-	    $(EXTRA_CFILES) $(EXTRA_HFILESOK) $(EXTRA_TARFILES),\
-	    $(shell echo $(TARDIR)$(FILE) | $(SEDPIPE))))
-	  
-
+.chs.dep :
+	@if test -f $@; then touch $@; else $(CHSDEPEND) -i$(VPATH) $<; fi;
 
-.PHONY: install installdirs installcheck uninstall
 
+.o.hi:
+	@:
 
-# from `info standards':
-#
-#`clean'
-#     Delete all files from the current directory that are normally
-#     created by building the program.  Don't delete the files that
-#     record the configuration.  Also preserve files that could be made
-#     by building, but normally aren't because the distribution comes
-#     with them.
-#
-#     Delete `.dvi' files here if they are not part of the distribution.
-#
-#`distclean'
-#     Delete all files from the current directory that are created by
-#     configuring or building the program.  If you have unpacked the
-#     source and built the program without creating any other files,
-#     `make distclean' should leave only the files that were in the
-#     distribution.
-#
-#`mostlyclean'
-#     Like `clean', but may refrain from deleting a few files that people
-#     normally don't want to recompile.  For example, the `mostlyclean'
-#     target for GCC does not delete `libgcc.a', because recompiling it
-#     is rarely necessary and takes a lot of time.
-#
-#`maintainer-clean'
-#     Delete almost everything from the current directory that can be
-#     reconstructed with this Makefile.  This typically includes
-#     everything deleted by `distclean', plus more: C source files
-#     produced by Bison, tags tables, Info files, and so on.
-#
-#     The reason we say "almost everything" is that running the command
-#     `make maintainer-clean' should not delete `configure' even if
-#     `configure' can be remade using a rule in the Makefile.  More
-#     generally, `make maintainer-clean' should not delete anything that
-#     needs to exist in order to run `configure' and then begin to build
-#     the program.  This is the only exception; `maintainer-clean' should
-#     delete everything else that can be rebuilt.
-#
-#      The `maintainer-clean' target is intended to be used by a
-#     maintainer of the package, not by ordinary users.  You may need
-#     special tools to reconstruct some of the files that `make
-#     maintainer-clean' deletes.  Since these files are normally
-#     included in the distribution, we don't take care to make them easy
-#     to reconstruct.  If you find you need to unpack the full
-#     distribution again, don't blame us.
+# The cheeky rule for .hi files says that .hi files can be created as
+# side-effect of generating a .o file. Make sure the .hi files are not
+# deleted as normal intermediate files are.
+.PRECIOUS: %.hi
 
+HSTOOLFLAGS = -H500m
 
-.PHONY: clean distclean mostlyclean maintainer-clean
+.PHONY: debug
+debug	:
+	@echo VPATH: $(VPATH)
+	@echo dep files: $(gtk_libgtk2hs_a_CHSFILES_HS:.hs=.dep)
 
-mostlyclean : noinplace
-	-$(strip $(RM) -rf $(TARGETOK) $(ALLHSFILES:.hs=.o) $(ALLHSFILES:.hs=.hi) \
-	  $(EXTRA_CFILES:.c=.o) $(ALLHSFILES:.hs=_stub.*) .depend \
-	  $(ALLCHSFILES:.chs=.dep))
+%.precomp :
+	$(strip $(C2HS) $(C2HS_FLAGS)		\
+	+RTS $(HSTOOLFLAGS) $(PROFFLAGS) -RTS		\
+	$(addprefix -C,$(CFLAGS) $(CPPFLAGS))		\
+	--precomp=$($(NAME)_PRECOMP) $($(NAME)_HEADER))
 
-clean	: mostlyclean
-	-$(strip $(RM) -rf $(ALLCHSFILES:.chs=.hs) $(ALLCHSFILES:.chs=.chi) \
-	  $(HSCFILES:.hsc=.hs) $(EXTRA_CLEANFILES))
+.chs.pp.chs: $(CONFIG_H)
+	$(strip $(HSCPP) $(AM_CPPFLAGS) \
+	$(EXTRA_CPPFLAGS) $(CPPFLAGS) \
+	$(EXTRA_CFLAGS) $(CFLAGS) \
+	$(addprefix -include ,$(CONFIG_H) $($(NAME)_EXTRA_HFILES)) \
+	$< -o $@)
 
-distclean : clean
-	-$(strip $(RM) -rf $(EXTRA_HSFILES) $(EXTRA_CHSFILES) \
-	  $(ALLCHSFILES:.chs=.dep) $(LOCALPKGCONF) $(LOCALPKGCONF).old \
-	  $(EXTRA_DISTCLEANFILES))
+.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)) \
+	$(EXTRA_CFLAGS) $(CFLAGS))\
+        $(filter -I%,$(AM_CPPFLAGS)) \
+	$(EXTRA_CPPFLAGS) $(CPPFLAGS)\
+	--include $(CONFIG_H) \
+        --cc=$(HC) --lflag=-no-hs-main $<)
 
-maintainer-clean : distclean
+.chs.hs:
+	$(strip if test -x $(C2HS); then :; else \
+	  $(MAKE) $(AM_MAKEFLAGS) NAME="tools_c2hs_c2hsLocal" \
+	  tools/c2hs/c2hsLocal; fi;)
+	$(strip if test -f $($(NAME)_PRECOMP); then :; else \
+	  $(MAKE) $(AM_MAKEFLAGS) NAME="$(NAME)" $($(NAME)_PRECOMP); fi;)
+	$(strip $(C2HS) $(C2HS_FLAGS) \
+	+RTS $(HSTOOLFLAGS) -RTS \
+	-i$(VPATH) --precomp=$($(NAME)_PRECOMP) -o $@ $<)
+	$(CHSDEPEND) -i$(VPATH) $<
 
 

[Gtk2hs-commit] gtk2hs/gtk/windows FileChooserDialog.chs.pp,NONE,1.1 Window.chs.pp,NONE,1.1 FileChooserDialog.chs.cpp,1.1,NONE Window.chs.cpp,1.1,NONE

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

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

Added Files:
	FileChooserDialog.chs.pp Window.chs.pp 
Removed Files:
	FileChooserDialog.chs.cpp Window.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: Window.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Window
--
--  Author : Manuel M. T. Chakravarty, Axel Simon
--          
--  Created: 27 April 2001
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:16 $
--
--  Copyright (c) 2001 Manuel M. T. Chakravarty, 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.
--
-- |
--
-- TODO
--
-- * missing but possibly useful methods are commented out
--      
module Window(
  Window,
  WindowClass,
  castToWindow,
  windowNew,
  windowSetTitle,
  windowSetResizable,
  windowGetResizable,
--  windowAddAccelGroup, 
--  windowRemoveAccelGroup,
  windowActivateFocus,
  windowActivateDefault,
  windowSetModal,
  windowSetDefaultSize,
--  windowSetGeometryHints,
#ifndef DISABLE_DEPRECATED
  windowSetPolicy,
#endif
  windowSetPosition,
  WindowPosition(..),
  windowSetTransientFor,
  windowSetDestroyWithParent,
-- windowListToplevels,
-- windowAddMnemonic,
-- windowRemoveMnemonic,
-- windowSetMnemonicModifier,
  windowDeiconify,
  windowIconify,
  windowMaximize,
  windowUnmaximize,
  windowSetDecorated,
-- windowSetDecorationsHint,
  windowSetFrameDimensions,
-- windowSetFunctionHint,
  windowSetRole,
  windowStick,
  windowUnstick,
  onFrameEvent,
  afterFrameEvent,
  onSetFocus,
  afterSetFocus
  ) where

import Monad	(liftM)
import FFI

import Enums	(WindowType(WindowToplevel), WindowPosition(..))
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Events	(Event, marshalEvent)

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

-- methods

-- | Create a new window of the given type.
--
windowNew :: IO Window
windowNew = makeNewObject mkWindow $ liftM castPtr $
  {#call window_new#} ((fromIntegral.fromEnum) WindowToplevel)

-- | set the title string of the given window
--
windowSetTitle :: WindowClass w => w -> String -> IO ()
windowSetTitle w str = 
  withUTFString str ({#call window_set_title#} (toWindow w))

-- | Sets whether the user can resize a window.
--
-- * Windows are user resizable by default.
--
windowSetResizable :: WindowClass w => w -> Bool -> IO ()
windowSetResizable w res = 
  {#call window_set_resizable#} (toWindow w) (fromBool res)

-- | Retrieve the value set by
-- 'windowSetResizable'.
--
windowGetResizable :: WindowClass w => w -> IO Bool
windowGetResizable w = liftM toBool $ 
  {#call unsafe window_get_resizable#} (toWindow w)

-- | dunno
--
windowActivateFocus :: WindowClass w => w -> IO Bool
windowActivateFocus w = 
  liftM toBool $ {#call window_activate_focus#} (toWindow w)

-- | dunno
--
windowActivateDefault :: WindowClass w => w -> IO Bool
windowActivateDefault w = 
  liftM toBool $ {#call window_activate_default#} (toWindow w)

#ifndef DISABLE_DEPRECATED
{-# DEPRECATED windowSetPolicy "Use windowSetResizable instead." #-}
-- windowSetPolicy: set the window policy
--
windowSetPolicy :: WindowClass w => w -> Bool -> Bool -> Bool -> IO ()
windowSetPolicy w shrink grow auto = {#call window_set_policy#} 
  (toWindow w) (fromBool shrink) (fromBool grow) (fromBool auto)
#endif

-- | make a window application modal
--
windowSetModal :: WindowClass w => w -> Bool -> IO ()
windowSetModal w m = {#call window_set_modal#} (toWindow w) (fromBool m)

-- | set window default size
--
-- * Sets the default size of a window. If the window's \"natural\" size (its
--   size request) is larger than the default, the default will be ignored.
--   More generally, if the default size does not obey the geometry hints for
--   the window ('windowSetGeometryHints' can be used to set these
--   explicitly), the default size will be clamped to the nearest permitted
--   size.
--
-- * Unlike @widgetSetSizeRequest@, which sets a size request for a
--   widget and thus would keep users from shrinking the window, this function
--   only sets the initial size, just as if the user had resized the window
--   themselves. Users can still shrink the window again as they normally
--   would. Setting a default size of -1 means to use the \"natural\" default
--   size (the size request of the window).
--
-- * For more control over a window's initial size and how resizing works,
--   investigate 'windowSetGeometryHints'.
--
-- * For some uses, 'windowResize' is a more appropriate function.
--   'windowResize' changes the current size of the window, rather
--   than the size to be used on initial display. 'windowResize'
--   always affects the window itself, not the geometry widget.The default
--   size of a window only affects the first time a window is shown; if a
--   window is hidden and re-shown, it will remember the size it had prior to
--   hiding, rather than using the default size. Windows can't actually be 0x0
--   in size, they must be at least 1x1, but passing 0 for width and height is
--   OK, resulting in a 1x1 default size.
--
windowSetDefaultSize :: WindowClass w => w -> Int -> Int -> IO ()
windowSetDefaultSize w height width =
  {#call window_set_default_size#} (toWindow w) (fromIntegral height)
  (fromIntegral width)

-- | set the window position policy
--
windowSetPosition :: WindowClass w => w -> WindowPosition -> IO ()
windowSetPosition w pos = 
  {#call window_set_position#} (toWindow w) ((fromIntegral.fromEnum) pos)

-- | set transient window
--
windowSetTransientFor :: (WindowClass win, WindowClass parent) => win ->
                         parent -> IO ()
windowSetTransientFor w p = 
  {#call window_set_transient_for#} (toWindow w) (toWindow p)

-- | destory transient window with parent
--
windowSetDestroyWithParent :: WindowClass w => w -> Bool -> IO ()
windowSetDestroyWithParent w b = 
  {#call window_set_destroy_with_parent#} (toWindow w) (fromBool b)

-- | restore the window
--
windowDeiconify :: WindowClass w => w -> IO ()
windowDeiconify w = {#call window_deiconify#} (toWindow w)

-- | minimize the window
--
windowIconify :: WindowClass w => w -> IO ()
windowIconify w = {#call window_iconify#} (toWindow w)

-- | maximize the window
--
windowMaximize :: WindowClass w => w -> IO ()
windowMaximize w = {#call window_maximize#} (toWindow w)

-- | unmaximize the window
--
windowUnmaximize :: WindowClass w => w -> IO ()
windowUnmaximize w = {#call window_unmaximize#} (toWindow w)

-- | remove the border
--
windowSetDecorated :: WindowClass w => w -> Bool -> IO ()
windowSetDecorated w b =
  {#call window_set_decorated#} (toWindow w) (fromBool b)

-- | set border widths
--
windowSetFrameDimensions :: WindowClass w => w -> Int -> Int -> Int -> Int ->
                            IO ()
windowSetFrameDimensions w left top right bottom =
 {#call window_set_frame_dimensions#} (toWindow w) (fromIntegral left)
 (fromIntegral top) (fromIntegral right) (fromIntegral bottom)

-- | set role (additional window name for the WM)
--
windowSetRole :: WindowClass w => w -> String -> IO ()
windowSetRole w str = 
  withUTFString str ({#call window_set_role#} (toWindow w))

-- | show the window on every workspace
--
windowStick :: WindowClass w => w -> IO ()
windowStick w = {#call window_stick#} (toWindow w)

-- | do not show the window on every workspace
--
windowUnstick :: WindowClass w => w -> IO ()
windowUnstick w = {#call window_unstick#} (toWindow w)

-- signals

-- | 
--
onFrameEvent, afterFrameEvent :: WindowClass w => w -> (Event -> IO Bool) ->
                                 IO (ConnectId w)
onFrameEvent = connect_BOXED__BOOL "frame_event" marshalEvent False
afterFrameEvent = connect_BOXED__BOOL "frame_event" marshalEvent True

-- | 
--
onSetFocus, afterSetFocus :: (WindowClass w, WidgetClass foc) => w ->
                             (foc -> IO ()) -> IO (ConnectId w)
onSetFocus = connect_OBJECT__NONE "set_focus" False
afterSetFocus = connect_OBJECT__NONE "set_focus" True




--- NEW FILE: FileChooserDialog.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) entry Widget FileChooserDialog
--
--  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 dialog variant of the "FileChooser"
--
-- * Added in GTK+ 2.4
--
module FileChooserDialog (
#if GTK_CHECK_VERSION(2,4,0)
  FileChooserDialogClass,
  FileChooserDialog,
  fileChooserDialogNew,
  fileChooserDialogNewWithBackend
#endif
) where

#if GTK_CHECK_VERSION(2,4,0)

import Monad (liftM, when)
import Maybe (isJust, fromJust)
import FFI
{#import Hierarchy#}
{#import FileChooser#}
import GObject (objectNew)
import Object (makeNewObject)
import Window
import Dialog
import GValue
import StoreValue

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

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

fileChooserDialogNew
  :: Maybe String            -- ^ Title of the dialog (or default)
  -> Maybe Window            -- ^ Transient parent of the dialog (or none)
  -> FileChooserAction       -- ^ Open or save mode for the dialog
  -> [(String, ResponseId)]  -- ^ Buttons and their response codes
  -> IO FileChooserDialog
fileChooserDialogNew title parent action buttons =
  internalFileChooserDialogNew title parent action buttons Nothing


fileChooserDialogNewWithBackend
  :: Maybe String              -- ^ Title of the dialog (or default)
  -> Maybe Window              -- ^ Transient parent of the dialog (or none)
  -> FileChooserAction         -- ^ Open or save mode for the dialog
  -> [(String, ResponseId)]    -- ^ Buttons and their response codes
  -> String                    -- ^ The name of the filesystem backend to use
  -> IO FileChooserDialog
fileChooserDialogNewWithBackend title parent action buttons backend =
  internalFileChooserDialogNew title parent action buttons (Just backend)
  

-- Annoyingly, the constructor for FileChooserDialog uses varargs so we can't
-- call it using the Haskell FFI. The GTK people do not consider this an api
-- bug, see <http://bugzilla.gnome.org/show_bug.cgi?id=141004>
-- The solution is to call objectNew and add the buttons manually.

internalFileChooserDialogNew ::
  Maybe String ->           -- Title of the dialog (or default)
  Maybe Window ->           -- Transient parent of the dialog (or none)
  FileChooserAction ->      -- Open or save mode for the dialog
  [(String, ResponseId)] -> -- Buttons and their response codes
  Maybe String ->           -- The name of the backend to use (optional)
  IO FileChooserDialog
internalFileChooserDialogNew title parent action buttons backend = do
  objType <- {# call unsafe gtk_file_chooser_dialog_get_type #}
  dialog <-makeNewObject mkFileChooserDialog $ liftM castPtr $
           if (isJust backend)
             then with (GVstring backend) $ \backendGValue ->
                  objectNew objType [("file-system-backend", backendGValue)]
             else objectNew objType []
  when (isJust title)
       (dialog `windowSetTitle` fromJust title)
  when (isJust parent)
       (dialog `windowSetTransientFor` fromJust parent)
  dialog `fileChooserSetAction` action
  mapM_ (\(btnName, btnResponse) ->
          dialogAddButton dialog btnName btnResponse) buttons
  return dialog

#endif

--- FileChooserDialog.chs.cpp DELETED ---

--- Window.chs.cpp DELETED ---

[Gtk2hs-commit] gtk2hs/gtk/pango PangoTypes.chs.pp,NONE,1.1 PangoTypes.chs.cpp,1.1,NONE

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

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

Added Files:
	PangoTypes.chs.pp 
Removed Files:
	PangoTypes.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: PangoTypes.chs.pp ---
--  GIMP Toolkit (GTK) - pango non-GObject types PangoTypes
--
--  Author : Axel Simon
--          
--  Created: 9 Feburary 2003
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 15:06:16 $
--
--  Copyright (c) 1999..2003 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.
--
-- |
--
-- Define types used in Pango which are not derived from GObject.
--
module PangoTypes(
  LayoutIter(LayoutIter),
  layout_iter_free,
  LayoutLine(LayoutLine),
  mkLayoutLine
  ) where

import Monad    (liftM)
import FFI

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

-- entry PangoLayout

-- | An iterator to examine a layout.
--
{#pointer *PangoLayoutIter as LayoutIter foreign newtype #}

-- | A single line in a 'PangoLayout'.
--
{#pointer *PangoLayoutLine as LayoutLine foreign newtype #}

mkLayoutLine :: Ptr LayoutLine -> IO LayoutLine
mkLayoutLine llPtr = do
  pango_layout_line_ref llPtr
  liftM LayoutLine $ newForeignPtr llPtr (pango_layout_line_unref llPtr)


#if __GLASGOW_HASKELL__>=600

foreign import ccall unsafe "&pango_layout_iter_free"
  layout_iter_free' :: FinalizerPtr LayoutIter

layout_iter_free :: Ptr LayoutIter -> FinalizerPtr LayoutIter
layout_iter_free _ = layout_iter_free'

#elif __GLASGOW_HASKELL__>=504

foreign import ccall unsafe "pango_layout_iter_free"
  layout_iter_free :: Ptr LayoutIter -> IO ()

#else

foreign import ccall "pango_layout_iter_free" unsafe
  layout_iter_free :: Ptr LayoutIter -> IO ()

#endif

#if __GLASGOW_HASKELL__>=600

foreign import ccall unsafe "&pango_layout_line_unref"
  pango_layout_line_unref' :: FinalizerPtr LayoutLine

pango_layout_line_unref :: Ptr LayoutLine -> FinalizerPtr LayoutLine
pango_layout_line_unref _ = pango_layout_line_unref'

#elif __GLASGOW_HASKELL__>=504

foreign import ccall unsafe "pango_layout_line_unref"
  pango_layout_line_unref :: Ptr LayoutLine -> IO ()

#else

foreign import ccall "pango_layout_line_unref" unsafe
  pango_layout_line_unref :: Ptr LayoutLine -> IO ()

#endif

#if __GLASGOW_HASKELL__>=504

foreign import ccall unsafe "pango_layout_line_ref"
  pango_layout_line_ref :: Ptr LayoutLine -> IO ()

#else

foreign import ccall "pango_layout_line_ref" unsafe
  pango_layout_line_ref :: Ptr LayoutLine -> IO ()

#endif


--- PangoTypes.chs.cpp DELETED ---