[Gtk2hs-commit] gtk2hs/tools/apiGen ApiGen.hs,NONE,1.1 README,NONE,1.1 Template.chs,NONE,1.1 format-docs.xsl,NONE,1.1 gapi2xml.pl,NONE,1.1 gapi_pp.pl,NONE,1.1 gen-all.sh,NONE,1.1

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

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

Added Files:
	ApiGen.hs README Template.chs format-docs.xsl gapi2xml.pl 
	gapi_pp.pl gen-all.sh 
Log Message:
Add new tool for semi-automaticly generating .chs binding modules.


--- NEW FILE: gapi_pp.pl ---
#!/usr/bin/perl
#
# gapi_pp.pl : A source preprocessor for the extraction of API info from a
#	       C library source directory.
#
# Authors: Mike Kestner <mke...@sp...>
# 	   Martin Willemoes Hansen <mw...@sy...>
#
# Copyright (c) 2001 Mike Kestner
# Copyright (c) 2003 Martin Willemoes Hansen
# Copyright (c) 2003 Novell, Inc.
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of version 2 of the GNU General Public
# License as published by the Free Software Foundation.
#
# This program 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.
#
# You should have received a copy of the GNU General Public
# License along with this program; if not, write to the
# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.

$private_regex = "^#if.*(ENABLE_BACKEND|ENABLE_ENGINE)";
$eatit_regex = "^#if.*(__cplusplus|DEBUG|DISABLE_(DEPRECATED|COMPAT)|ENABLE_BROKEN|COMPILATION)";
$ignoreit_regex = '^\s+\*|#ident|#\s*include|#\s*else|#\s*endif|#\s*undef|G_(BEGIN|END)_DECLS|extern|GDKVAR|GTKVAR|GTKMAIN_C_VAR|GTKTYPEUTILS_VAR|VARIABLE|GTKTYPEBUILTIN';

foreach $arg (@ARGV) {
	if (-d $arg && -e $arg) {
		@hdrs = (@hdrs, `ls $arg/*.h`);
		@srcs = (@srcs, `ls $arg/*.c`);
	} elsif (-f $arg && -e $arg) {
		@hdrs = (@hdrs, $arg) if ($arg =~ /\.h$/);
		@srcs = (@srcs, $arg) if ($arg =~ /\.c$/);
	} else {
		die "unable to process arg: $arg";
	}
}

foreach $fname (@hdrs) {

	if ($fname =~ /test|private|internals|gtktextlayout|gtkmarshalers/) {
		@privhdrs = (@privhdrs, $fname);
		next;
	}

	open(INFILE, $fname) || die "Could open $fname\n";

	$braces = 0;
	$prepend = "";
	while ($line = <INFILE>) {
		$braces++ if ($line =~ /{/ and $line !~ /}/);
		$braces-- if ($line =~ /}/ and $line !~ /{/);
		
		next if ($line =~ /$ignoreit_regex/);

		$line =~ s/\/\*.*?\*\///g;

		next if ($line !~ /\S/);

		$line = $prepend . $line;
		$prepend = "";

		if ($line =~ /#\s*define\s+\w+\s+\"/) {
			$def = $line;
			while ($def !~ /\".*\"/) {$def .= ($line = <INFILE>);}
			print $def;
		} elsif ($line =~ /#\s*define\s+\w+\s*\D+/) {
			$def = $line;
			while ($line =~ /\\\n/) {$def .= ($line = <INFILE>);}
			if ($def =~ /_CHECK_\w*CAST|INSTANCE_GET_INTERFACE/) {
				$def =~ s/\\\n//g;
				print $def;
			}
		} elsif ($line =~ /^\s*\/\*/) {
			while ($line !~ /\*\//) {$line = <INFILE>;}
		} elsif ($line =~ /^#ifndef\s+\w+_H_*\b/) {
			while ($line !~ /#define/) {$line = <INFILE>;}
		} elsif ($line =~ /$private_regex/) {
			$nested = 0;
			while ($line = <INFILE>) {
				last if (!$nested && ($line =~ /#else|#endif/));
				if ($line =~ /#if/) {
					$nested++;
				} elsif ($line =~ /#endif/) {
					$nested--
				}
				next if ($line !~ /^struct/);

				print "private$line";
				do {
					$line = <INFILE>;
					print $line;
				} until ($line =~ /^\}/);
			}
		} elsif ($line =~ /$eatit_regex/) {
			$nested = 0;
			while ($line = <INFILE>) {
				last if (!$nested && ($line =~ /#else|#endif/));
				if ($line =~ /#if/) {
					$nested++;
				} elsif ($line =~ /#endif/) {
					$nested--
				}
			}
		} elsif ($line =~ /^#\s*ifn?\s*\!?def/) {
			#warn "Ignored #if:\n$line";
		} elsif ($line =~ /typedef struct\s*\{/) {
			my $first_line = $line;
			my @lines = ();
			$line = <INFILE>;
			while ($line !~ /^}\s*(\w+);/) {
				push @lines, $line;
				$line = <INFILE>;
			}
			$line =~ /^}\s*(\w+);/;
			my $name = $1;
			print "typedef struct _$name $name;\n";
			print "struct _$name {\n";
			foreach $line (@lines) {
				if ($line =~ /(\s*.+\;)/) {
					$field = $1;
					$field =~ s/(\w+) const/const $1/;
					print "$field\n";
				}
			}
			print "};\n";
		} elsif ($line =~ /^enum\s+\{/) {
			while ($line !~ /^};/) {$line = <INFILE>;}
		} elsif ($line =~ /(\s+)union\s*{/) {
			# this is a hack for now, but I need it for the fields to work
			$indent = $1;
			$do_print = 1;
			while ($line !~ /^$indent}\s*\w+;/) {
				$line = <INFILE>;
				next if ($line !~ /;/);
				print $line if $do_print;
				$do_print = 0;
			}
		} else {
			if ($braces or $line =~ /;/) {
				print $line;
			} else {
				$prepend = $line;
				$prepend =~ s/\n/ /g;
			}
		}
	}
}

foreach $fname (@srcs, @privhdrs) {

	open(INFILE, $fname) || die "Could open $fname\n";

	if ($fname =~ /builtins_ids/) {
		while ($line = <INFILE>) {
			next if ($line !~ /\{/);

			chomp($line);
			$builtin = "BUILTIN" . $line;
			$builtin .= <INFILE>;
			print $builtin;
		}
		next;
	}

	while ($line = <INFILE>) {
		#next if ($line !~ /^(struct|\w+_class_init)|g_boxed_type_register_static/);
		next if ($line !~ /^(struct|\w+_class_init|\w+_base_init|\w+_get_type)/);

		if ($line =~ /^struct/) {
			# need some of these to parse out parent types
			print "private";
		}

		$comment = 0;
		$begin = 0;
		$end = 0;
		do {
			# Following ifs strips out // and /* */ C comments
			if ($line =~ /\/\*/) {
				$comment = 1;
				$begin = 1;
			}

			if ($comment != 1) {
				$line =~ s/\/\/.*//;
				print $line;
			}

			if ($line =~ /\*\//) {
				$comment = 0;
				$end = 1;
			}

			if ($begin == 1 && $end == 1) {
				$line =~ s/\/\*.*\*\///;
				print $line;
			}

			$begin = 0;
			$end = 0;
		} until (($line = <INFILE>) =~ /^}/);
		print $line;
	}
}


--- NEW FILE: Template.chs ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget @OBJECT_NAME@
--
--  Author : [Insert your full name here]
--
--  Created: @DATE@
--
--  Copyright (C) @YEAR@ [Insert your full name here]
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- | @MODULE_DOCUMENTATION@ @MODULE_TODO@
--
module @MODULE_NAME@ (
@MODULE_EXPORTS@
  ) where

import Monad (liftM)
import Foreign
import Foreign.C
@IMPORTS@
{#context lib="@CONTEXT_LIB@" prefix="@CONTEXT_PREFIX@" #}

@MODULE_BODY@

--- NEW FILE: gen-all.sh ---
#!/bin/bash

DOCBOOKDIR=../apicoverage/tars/gtk+-2.4.13/docs/reference/gtk/xml
HEADDERS=/usr/include/gtk-2.0/gtk/*.h

mkdirhier doc api modules
echo > modules/missing_docs

for HEADDER in $HEADDERS
do
	APIFILE=api/$(basename $HEADDER).xml
	DOCBOOKFRAG=$DOCBOOKDIR/$(basename ${HEADDER%.h}).xml
	DOCBOOKFILE=doc/$(basename ${HEADDER%.h}).docbook
	DOCFILE=doc/$(basename ${HEADDER%.h}).xml
	echo Processing $HEADDER
	
	./gapi_pp.pl $HEADDER | ./gapi2xml.pl Gtk $APIFILE gtk+ >> /dev/null || exit
#	./gapi_format_xml $APIFILE.tmp $APIFILE || exit
	rm  $APIFILE.tmp

        if test -f $DOCBOOKFRAG; then
		cat <(echo \
		'<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.1.2//EN"
		"http://www.oasis-open.org/docbook/xml/4.1.2/docbookx.dtd">
		<book>') $DOCBOOKFRAG <(echo '</book>') \
		> $DOCBOOKFILE || exit
		echo "xsltproc format-docs.xsl $DOCBOOKFILE > $DOCFILE"
		xsltproc format-docs.xsl $DOCBOOKFILE > $DOCFILE || exit

		echo ./ApiGen $APIFILE Template.chs --doc=$DOCFILE --outdir=modules
		./ApiGen $APIFILE Template.chs --doc=$DOCFILE --outdir=modules || exit
	else
		echo ./ApiGen $APIFILE Template.chs --outdir=modules
		./ApiGen $APIFILE Template.chs --outdir=modules || exit
		echo $HEADDER: could not find $DOCBOOKFRAG >> modules/missing_docs
	fi
done


--- NEW FILE: ApiGen.hs ---
-- ApiGen: takes an xml description of a GObject-style API and produces a .chs
-- binding module.

--module Main (main) where

import Prelude hiding (Enum, lines)
import Monad  (when)
import Maybe  (catMaybes)
import Char   (toLower, toUpper, isAlpha, isAlphaNum, isUpper)
import List   (isPrefixOf, groupBy, sortBy)
import System (getArgs, exitWith, ExitCode(..))

import qualified Text.XML.HaXml as Xml
import qualified Text.XML.HaXml.Parse as Xml
import qualified Text.XML.HaXml.Escape as Xml

import qualified System.Time

-------------------------------------------------------------------------------
-- Types representing the content of the API XML file
-------------------------------------------------------------------------------
type API = [NameSpace]

data NameSpace = NameSpace {
    namespace_name :: String,
    namespace_library :: String,
    namespace_objects :: [Object],
    namespace_enums :: [Enum]
  } deriving Show

data Enum = Enum {
    enum_name :: String,
    enum_cname :: String,
    enum_variety :: String,
    enum_members :: [Member]
 } deriving Show

data Member = Member {
    member_name :: String,
    member_cname :: String,
    member_value :: String
  } deriving Show

data Object = Object {
    object_name :: String,
    object_cname :: String,
    object_parent :: String,
    object_constructors :: [Constructor],
    object_methods :: [Method]
  } deriving Show

data Constructor = Constructor {
    constructor_cname :: String,
    constructor_parameters :: [Parameter]
  } deriving Show

data Parameter = Parameter {
    parameter_type :: String,
    parameter_name :: String,
    parameter_isArray :: Bool
  }
               | VarArgs
  deriving Show

data Method = Method {
    method_name :: String,
    method_cname :: String,
    method_return_type :: String,
    method_parameters :: [Parameter]
  } deriving Show

-------------------------------------------------------------------------------
-- extract functions to convert the api xml file to the internal representation
-------------------------------------------------------------------------------
extractAPI :: Xml.Document -> API
extractAPI (Xml.Document _ _ (Xml.Elem "api" [] namespaces)) =
  catMaybes (map extractNameSpace namespaces)

extractNameSpace :: Xml.Content -> Maybe NameSpace
extractNameSpace (Xml.CElem (Xml.Elem "namespace"
                        [("name", Xml.AttValue name),
                         ("library", Xml.AttValue lib)] content)) =
  Just $ NameSpace {
    namespace_name = Xml.verbatim name,
    namespace_library = Xml.verbatim lib,
    namespace_objects = catMaybes (map extractObject content),
    namespace_enums = []
  }
extractNameSpace _ = Nothing

extractObject :: Xml.Content -> Maybe Object
extractObject (Xml.CElem (Xml.Elem "object"
                     [("name", Xml.AttValue name),
                      ("cname", Xml.AttValue cname),
                      ("parent", Xml.AttValue parent)] content)) =
  Just $ Object {
    object_name = Xml.verbatim name,
    object_cname = Xml.verbatim cname,
    object_parent = Xml.verbatim parent,
    object_constructors = catMaybes (map extractConstructor content),
    object_methods = catMaybes (map extractMethod content)
  }
extractObject _ = Nothing

extractMethod :: Xml.Content -> Maybe Method
extractMethod (Xml.CElem (Xml.Elem "method"
                     [("name", Xml.AttValue name),
                      ("cname", Xml.AttValue cname)]
                     (Xml.CElem (Xml.Elem "return-type"
                            [("type", Xml.AttValue return_type)] [])
                      :content))) =
  Just $ Method {
    method_name = Xml.verbatim name,
    method_cname = Xml.verbatim cname,
    method_return_type = Xml.verbatim return_type,
    method_parameters =
      case content of
        [] -> []
        [Xml.CElem (Xml.Elem "parameters" [] parameters)]
           -> map extractParameter parameters
  }
extractMethod _ = Nothing

extractParameter :: Xml.Content -> Parameter
extractParameter (Xml.CElem (Xml.Elem "parameter"
                        [("ellipsis", _)] [])) = VarArgs
extractParameter (Xml.CElem (Xml.Elem "parameter"
                        [("type", Xml.AttValue type_),
                         ("name", Xml.AttValue name)] [])) =
  Parameter {
    parameter_type = Xml.verbatim type_,
    parameter_name = Xml.verbatim name,
    parameter_isArray = False
  }
extractParameter (Xml.CElem (Xml.Elem "parameter"
                        [("type", Xml.AttValue type_),
			 ("array", _),
                         ("name", Xml.AttValue name)] [])) =
   Parameter {
     parameter_type = Xml.verbatim type_,
     parameter_name = Xml.verbatim name,
     parameter_isArray = True
   }
								 

extractConstructor :: Xml.Content -> Maybe Constructor
extractConstructor (Xml.CElem (Xml.Elem "constructor"
                     [("cname", Xml.AttValue cname)] content)) =
  Just $ Constructor {
    constructor_cname = Xml.verbatim cname,
    constructor_parameters =
      case content of
        [] -> []
        [Xml.CElem (Xml.Elem "parameters" [] parameters)]
           -> map extractParameter parameters
  }
extractConstructor _ = Nothing

-------------------------------------------------------------------------------
-- extract functions to convert the doc xml file to the internal representation
-------------------------------------------------------------------------------

data ApiDoc = ApiDoc {
    doc_target :: String,		-- C function name
    doc_paragraphs :: [DocPara],	-- documentation markup
    doc_since :: Maybe String		-- which version of the api the
  }					-- function is avaliable from, eg "2.4"

type DocPara = [DocParaSpan]
data DocParaSpan = DocText String       -- just simple text
                 | DocFuncXRef String   -- cross reference to a function name
                 | DocTypeXRef String   -- cross reference to a type name
                 | DocOtherXRef String  -- xref format not directly supported
                 | DocEmphasis String   -- emphasised text, usually italic
		 | DocLiteral String    -- some literal like numbers
		 | DocArg  String       -- function argument names

extractDocumentation :: Xml.Document -> [ApiDoc]
extractDocumentation (Xml.Document _ _ (Xml.Elem "apidoc" [] functions)) =
  map extractDocFunc functions

extractDocFunc :: Xml.Content -> ApiDoc
extractDocFunc
  (Xml.CElem (Xml.Elem "function" []
    [Xml.CElem (Xml.Elem "name" [] [Xml.CString _ name])
    ,Xml.CElem (Xml.Elem "since" [] since')
    ,Xml.CElem (Xml.Elem "doc" [] paras)]
  )) =
  let since = case since' of
                [] -> Nothing
		[Xml.CString _ since] -> Just since
   in ApiDoc {
          doc_target = name,
	  doc_paragraphs = map extractDocPara paras,
	  doc_since = since
        }

extractDocPara :: Xml.Content -> DocPara
extractDocPara (Xml.CElem elem@(Xml.Elem "para" [] _)) =
  case Xml.xmlUnEscape Xml.stdXmlEscaper elem of
    (Xml.Elem _ [] spans) -> map extractDocParaSpan spans

extractDocParaSpan :: Xml.Content -> DocParaSpan
extractDocParaSpan (Xml.CString _ text) = DocText text
extractDocParaSpan (Xml.CElem (Xml.Elem tag [] (CString _ text))) =
  case tag of
    "xref-func"  -> DocFuncXRef text
    "xref-type"  -> DocTypeXRef text
    "xref-other" -> DocOtherXRef text
    "emphasis"   -> DocEmphasis text
    "literal"    -> DocLiteral text
    "arg"        -> DocArg text
extractDocParaSpan other = error $ "extractDocParaSpan: " ++ Xml.verbatim other
 
haddocFormatParas :: [DocPara] -> ShowS
haddocFormatParas =
    ((ss "-- | ". drop 3).)
  . cat
  . map ((.(ss "--\n"))
       . cat
       . map (\line -> (ss "-- ").line.ss "\n")
       . map (sepBy " ")
       . wrapText 77
       . words
       . concatMap haddocFormatSpan)

haddocFormatSpan :: DocParaSpan -> String
haddocFormatSpan (DocText text)    = escapeHaddockSpecialChars text
haddocFormatSpan (DocTypeXRef text)    = "\"" ++ text ++ "\""
haddocFormatSpan (DocFuncXRef text)    = "'" ++ cFuncNameToHsName text ++ "'"
haddocFormatSpan (DocOtherXRef text)    = "'{FIXME: gtk-doc cross reference to:" ++ text ++ "}'"
haddocFormatSpan (DocEmphasis text)  = "/" ++ text ++ "/"
haddocFormatSpan (DocLiteral "TRUE")  = "@True@"
haddocFormatSpan (DocLiteral "FALSE") = "@False@"
  --likely that something should be changed to a Maybe type if this is emitted:
haddocFormatSpan (DocLiteral "NULL")  = "@CHECKME: Nothing@"
haddocFormatSpan (DocLiteral text) = "@" ++ text ++ "@"
haddocFormatSpan (DocArg  text)    = "@" ++ text ++ "@"

cFuncNameToHsName :: String -> String
cFuncNameToHsName =
    lowerCaseFirstChar
  . stripKnownPrefixes
  . concatMap (upperCaseFirstChar "cFuncNameToHsName")
  . splitBy '_'
  . takeWhile ('('/=)

escapeHaddockSpecialChars = escape
  where escape [] = []
        escape (''':'s':cs) = ''' : 's' : escape cs --often don't need to escape
        escape (c:cs) | c == '/' || c == '`'
                     || c == '"' || c == '@'
                     || c == '<' || c == '''
                      = '\\': c : escape cs
        escape (c:cs) =       c : escape cs              

-- wraps a list of words to lines of words
wrapText :: Int -> [String] -> [[String]]
wrapText width = wrap 3 []
  
  where wrap :: Int -> [String] -> [String] -> [[String]]
        wrap col line (word:words) | col + length word + 1 > width = reverse line : wrap 0 [] (word:words)
        wrap col line (word:words) = wrap (col + length word + 1) (word:line) words
        wrap _ []   [] = []
        wrap _ line [] = [reverse line]

-------------------------------------------------------------------------------
-- Now lets actually generate some code fragments based on the api info
-------------------------------------------------------------------------------
genFunction :: Object -> Method -> Maybe ApiDoc -> ShowS
genFunction object method doc =
  formattedDoc.
  ss functionName. ss " :: ". functionType. nl.
  ss functionName. sc ' '. sepBy " " paramNames. ss " =".
  indent 1. body. nl

  where functionName = lowerCaseFirstChar (method_name method)
	(classConstraints', paramTypes', paramMarshalers) =
	  unzip3 [ genMarshalParameter (changeParamNames (parameter_name p))
	  			       (parameter_type p)
		 | p <- method_parameters method ]
	classConstraints = [ c | Just c <- classConstraints' ]
	paramTypes = [ c | Just c <- paramTypes' ]
	paramNames = [ changeParamNames (parameter_name p)
		     | (Just _, p) <- zip paramTypes' (method_parameters method) ]
	(returnType, returnMarshaler) =
		genMarshalResult (method_return_type method)
	functionType = (case classConstraints of
	                  []  -> id
			  [c] -> ss c. ss " => "
			  cs  -> sc '('. sepBy ", " classConstraints. ss ") => ").
		       sepBy " -> " (paramTypes ++ [returnType])
	body = foldl (\body marshaler -> marshaler body) call (paramMarshalers++[returnMarshaler])
	call = ss "{# call ". ss (method_cname method). ss " #}"
        formattedDoc = case doc of
          Nothing -> ss "-- | \n-- \n"
          Just doc -> haddocFormatParas (doc_paragraphs doc)

genMethods :: Object -> [ApiDoc] -> [(ShowS, Maybe ApiDoc)]
genMethods object apiDoc = 
  [ (genFunction object method doc, doc)
  | (method, doc) <- methods object apiDoc ]

methods :: Object -> [ApiDoc] -> [(Method, Maybe ApiDoc)]
methods object docs =
  map snd $
  sortBy (\(i,_) (j,_) -> i `compare` j)
  [ case method_cname method `lookup` docmap of
      Nothing             -> (0,(mungeMethod object method, Nothing))
      (Just (doc, index)) -> (index,(mungeMethod object method, Just doc))
  | method <- object_methods object
  , null [ () | VarArgs <- method_parameters method] ] --exclude VarArgs methods
  where docmap = [ (doc_target doc, (doc,index)) | (doc,index) <- zip docs [1..]]
        

mungeMethod :: Object -> Method -> Method
mungeMethod object method =
  let self = Parameter {
               parameter_type = object_cname object ++ "*",
               parameter_name = "obj",
               parameter_isArray = False
             }
   in method {
        method_name = object_name object ++ method_name method,
        method_parameters = self : method_parameters method
      } 

genConstructors :: Object -> [ApiDoc] -> [(ShowS, Maybe ApiDoc)]
genConstructors object apiDoc =
  [ (genFunction object constructor doc, doc)
  | (constructor, doc) <- constructors object apiDoc ]

constructors :: Object -> [ApiDoc] -> [(Method, Maybe ApiDoc)]
constructors object docs =
  [ (mungeConstructor object constructor, constructor_cname constructor `lookup` docmap)
  | constructor <- object_constructors object
  , null [ () | VarArgs <- constructor_parameters constructor] ]
  where docmap = [ (doc_target doc, doc) | doc <- docs ]

mungeConstructor :: Object -> Constructor -> Method
mungeConstructor object constructor =
  Method {
    method_name = (object_name object++)
                . drop (length (object_cname object))
                . concatMap (upperCaseFirstChar "mungeConstructor")
                . splitBy '_'
                . constructor_cname
                $ constructor,
    method_cname = constructor_cname constructor,
    method_return_type = object_cname object ++ "*",
    method_parameters = constructor_parameters constructor
  }  

genExports :: Object -> [ApiDoc] -> ShowS
genExports object docs =
  doVersionIfDefs
    [ (ss "  ". ss (lowerCaseFirstChar (method_name constructor)). sc ',', doc)
    | (constructor, doc) <- constructors object docs ++ methods object docs]

genTodoItems :: Object -> ShowS
genTodoItems object =
  let varargsFunctions = 
        [ ss (constructor_cname constructor)
        | constructor <- object_constructors object
        , not $ null [ () | VarArgs <- constructor_parameters constructor] ]
       ++
        [ ss (method_cname method)
        | method <- object_methods object
        , not $ null [ () | VarArgs <- method_parameters method] ]
   in if null varargsFunctions
        then id
        else nl. comment. nl. comment.
             ss "TODO: the following varargs functions were not bound\n".
             lines (map (ss "-- * ".) varargsFunctions)

doVersionIfDefs :: [(ShowS, Maybe ApiDoc)] -> ShowS
doVersionIfDefs =
    lines
  . map (\group -> sinceVersion (snd (head group))
                                (lines (map fst group)))
  . groupBy (\(_,a) (_,b) -> fmap doc_since a == fmap doc_since b)
 
sinceVersion :: Maybe ApiDoc -> ShowS -> ShowS
sinceVersion (Just (ApiDoc _ _ (Just (major:'.':minor:[])))) body =
  ss "#if GTK_CHECK_VERSION(". sc major. ss ",". sc minor. ss ",0)\n".
  body.
  ss "\n#endif"
sinceVersion _ body = body

splitBy :: Char -> String -> [String]
splitBy sep str =
  case span (sep/=) str of
    (remainder,[]) -> [remainder]
    (word,_:remainder) -> word : splitBy sep remainder

-------------------------------------------------------------------------------
-- Here's the interesting bit that generates the fragments of mashaling code
-------------------------------------------------------------------------------

genMarshalParameter ::
	String ->	--parameter name suggestion (will be unique)
	String -> 	--C type decleration for the parameter we will marshal
	(Maybe String,	--parameter class constraints (or none)
	Maybe String,	--parameter type (or none if the arg is not exposed)
	ShowS -> ShowS)	--marshaling code (\body -> ... body ...)

genMarshalParameter name "gboolean" =
	(Nothing, Just "Bool",
	\body -> body. ss " (fromBool ". ss name. ss ")")

genMarshalParameter name typeName | typeName == "guint"  --these two are unsigned types
				 || typeName == "gint"
				 || typeName == "gsize"  --should they be Word or Int?
				 || typeName == "gssize" =
	(Nothing, Just "Int",
	\body -> body. ss " (fromIntegral ". ss name. ss ")")

genMarshalParameter name "const-gchar*" =
	(Nothing, Just "String",
	\body -> ss "withUTFString ". ss name. ss " $ \\". ss name. ss "Ptr ->".
		 indent 1. body. sc ' '. ss name. ss "Ptr")

genMarshalParameter name "GError**" =
	(Nothing, Nothing,
	\body -> ss "propagateGError $ \\". ss name. ss "Ptr ->".
	         indent 1. body. sc ' '. ss name. ss "Ptr")

genMarshalParameter name typeName | isUpper (head typeName)
                                 && last typeName == '*'
                                 && last (init typeName) /= '*'  = --then assume it is an object
	let typeName' = stripKnownPrefixes (init typeName) in
	(Just $ typeName' ++ "Class " ++ name, Just name,
	\body -> body. ss " (to". ss typeName'. sc ' '. ss name. ss ")")

genMarshalParameter name unknownType =
	(Nothing, Just $ "{-" ++ unknownType ++ "-}",
	\body -> body. ss " {-". ss name. ss "-}")

-- Takes the type string and returns the Haskell Type and the marshaling code
--
genMarshalResult :: String -> (String, ShowS -> ShowS)
genMarshalResult "gboolean" = ("IO Bool", \body -> ss "liftM toBool $". indent 1. body)
genMarshalResult "gint"     = ("IO Int",  \body -> ss "liftM fromIntegral $". indent 1. body)
genMarshalResult "guint"    = ("IO Int",  \body -> ss "liftM fromIntegral $". indent 1. body)
genMarshalResult "void"     = ("IO ()", id)
genMarshalResult "const-gchar*"  = ("IO String", \body -> body.
                                                          indent 1. ss  ">>= peekUTFString")
genMarshalResult "const-GSList*" =
  ("[{- element type -}]",
  \body -> body.
           indent 1. ss ">>= readGSList".
           indent 1. ss ">>= mapM (\\elemPtr -> {-marshal elem-})")
genMarshalResult "GSList*" =
  ("[{- element type -}]",
  \body -> body.
           indent 1. ss ">>= fromGSList".
           indent 1. ss ">>= mapM (\\elemPtr -> {-marshal elem-})")
genMarshalResult "GList*" =
  ("[{- element type -}]",
  \body -> body.
           indent 1. ss ">>= fromGList".
           indent 1. ss ">>= mapM (\\elemPtr -> {-marshal elem-})")

genMarshalResult typeName | isUpper (head typeName)
                         && last typeName == '*'
                         && last (init typeName) /= '*'  = --then assume it is an object
  
  let typeName' = stripKnownPrefixes (init typeName) in
  ("IO " ++ typeName',
  \body -> ss "makeNewGObject mk". ss typeName'. ss " $".
           indent 1. body)

genMarshalResult unknownType = ("{-" ++ unknownType ++ "-}", id)

stripKnownPrefixes :: String -> String
stripKnownPrefixes ('G':'t':'k':remainder) = remainder
stripKnownPrefixes ('G':'d':'k':remainder) = remainder
stripKnownPrefixes ('P':'a':'n':'g':'o':remainder) = remainder
stripKnownPrefixes other = other

changeParamNames :: String -> String
changeParamNames "type" = "type_"  --this is a common variable name in C but of
                                   --course a keyword in Haskell
changeParamNames other  =          --change "gtk_foo_bar" to "gtkFooBar"
    lowerCaseFirstChar
  . concatMap (upperCaseFirstChar $ "changeParamNames" ++ other)
  . filter (not.null) --to ignore tailing underscores
  . splitBy '_'
  $ other

-------------------------------------------------------------------------------
-- Top level stuff
-------------------------------------------------------------------------------

main = do
  args <- getArgs
  when (length args < 2) usage

  -----------------------------------------------------------------------------
  -- Parse command line parameters
  --
  let (apiFile: templateFile: rem) = args
  let docFile = case map (drop 6) (filter ("--doc=" `isPrefixOf`)  rem) of
                  [] -> ""
		  (docFile:_) -> docFile
  let lib = case map (drop 6) (filter ("--lib=" `isPrefixOf`)  rem) of
              [] -> "gtk"
	      (lib:_) -> lib
  let prefix = case map (drop 9) (filter ("--prefix=" `isPrefixOf`)  rem) of
                 [] -> "gtk"
                 (prefix:_) -> prefix
  let modPrefix = case map (drop 12) (filter ("--modprefix=" `isPrefixOf`)  rem) of
                    [] -> ""
		    (modPrefix:_) -> modPrefix ++ "."
  let outdir = case map (drop 9) (filter ("--outdir=" `isPrefixOf`)  rem) of
                 [] -> ""
                 (outdir:_) -> if last outdir == '/' then outdir else outdir ++ "/"

  -----------------------------------------------------------------------------
  -- Read in the input files
  --
  content <- if apiFile == "-"
               then getContents	      -- read stdin
	       else readFile apiFile
  template <- readFile templateFile

  -----------------------------------------------------------------------------
  -- Parse the contents of the xml api file
  --
  let document = Xml.xmlParse apiFile content
      api = extractAPI document

  -----------------------------------------------------------------------------
  -- Read in the documentation xml file if supplied
  --
  apiDoc <- if null docFile
              then return []
              else do content <- readFile docFile
                      return $ extractDocumentation (Xml.xmlParse docFile content)

  -----------------------------------------------------------------------------
  -- A few values that are used in the template
  --
  time <- System.Time.getClockTime
  calendarTime <- System.Time.toCalendarTime time
  let day   = show (System.Time.ctDay calendarTime)
      month = show (System.Time.ctMonth calendarTime)
      year  = show (System.Time.ctYear calendarTime)
      date  = day ++ " " ++ month ++ " " ++ year

  -----------------------------------------------------------------------------
  -- Write the result file(s) by substituting values into the template file
  --
  mapM 
    (\object -> writeFile (outdir ++ object_name object ++ ".chs") $
    templateSubstitute template (\var ->
      case var of
	"YEAR"           -> ss year
	"DATE"           -> ss date
	"OBJECT_NAME"    -> ss (object_name object)
	"MODULE_DOCUMENTATION" -> ss "$MODULE_DOCUMENTATION"
        "MODULE_TODO"    -> genTodoItems object
        "MODULE_NAME"    -> ss (modPrefix ++ object_name object)
        "MODULE_EXPORTS" -> genExports object apiDoc
	"MODULE_IMPORTS" -> ss "$imports"
	"CONTEXT_LIB"    -> ss lib
	"CONTEXT_PREFIX" -> ss prefix
	"MODULE_BODY"    -> doVersionIfDefs (genConstructors object apiDoc
                                          ++ genMethods object apiDoc)
	_ -> ss ""
    ) "") [ object | namespace <- api,
		     object <- namespace_objects namespace ]
    

usage = do
  putStr "\nProgram to generate a .chs Haskell binding module from an xml\n\
	\description of a GObject-style API. Usage:\n\
	\ApiGen <xmlFile> <templateFile>\n\
	\         {--doc=<docFile>} {--lib=<lib>} {--prefix=<prefix>}\n\
	\         {--outdir=<outDir>} {--modprefix=<modPrefix>}\n\
	\where\n\
	\  <apiFile>       an xml api file produced by gapi2xml\n\
	\  <templateFile>  is the name and path of the output template file\n\
	\  <outDir>        is the name and path of the output file\n\
	\  <docFile>       api doc file output from format-doc.xsl\n\
	\  <lib>           set the lib to use in the c2hs {#context #}\n\
	\                  declaration (the default is \"gtk\")\n\
	\  <prefix>        set the prefix to use in the c2hs {#context #}\n\
	\                  declaration (the default is \"gtk\")\n\
	\  <modPrefix>     specify module name prefix, eg if using\n\
	\                  hierarchical module names\n"
  exitWith $ ExitFailure 1


-------------------------------------------------------------------------------
-- Helper functions
-------------------------------------------------------------------------------

ss = showString
sc = showChar

nl = sc '\n'

indent :: Int -> ShowS
indent c = ss ("\n"++replicate (2*c) ' ')

comment :: ShowS
comment = ss "-- "

lowerCaseFirstChar :: String -> String
lowerCaseFirstChar (c:cs) = toLower c : cs

upperCaseFirstChar :: String -> String -> String
upperCaseFirstChar _ (c:cs) = toUpper c : cs
upperCaseFirstChar dbgMesg cs = error $ "upperCaseFirstChar: " ++ dbgMesg ++ cs ++ " !!"

cat :: [ShowS] -> ShowS
cat = foldl (.) id

lines :: [ShowS] -> ShowS
lines []     = id
lines [x]    = x
lines (x:xs) = x. sc '\n'. lines xs

sepBy :: String -> [String] -> ShowS
sepBy s []     = id
sepBy s [x]    = ss x
sepBy s (x:xs) = ss x. ss s. sepBy s xs

sepBy' :: String -> [ShowS] -> ShowS
sepBy' s []     = id
sepBy' s [x]    = x
sepBy' s (x:xs) = x. ss s. sepBy' s xs

templateSubstitute :: String -> (String -> ShowS) -> ShowS
templateSubstitute template varSubst = doSubst template
  where doSubst [] = id
        doSubst ('@':cs) = let (var,_:cs') = span ('@'/=) cs
                            in varSubst var . doSubst cs'
        doSubst (c:cs) = sc c . doSubst cs


--- NEW FILE: README ---
The tool in this directory are to semi-automatically generate binding modules
complete with haddock format documentation for all gtk modules. With a little
modification it should work for any other GObject-based api.

It works by extracting an api description from the C headder files and
extracting documentation from the docbook documentation produced by gtk-doc.

It is semi-automatic in the sense that the resulting binding module will need
some hand tweaking and it is not intended that this tool be used automatically
as part of the build process. It is mainly a time saving tool to relieve much
manual work involved in writing binding modules.

Some things that may need to be edited by hand:
  * Add your name at the top for new modules!
  * Some type signatures and marshaling code
      eg for possibly NULL Strings you would want to change to use Maybe String
      also it is not possible to automatically determine the element type of
      GLists so this will have to be determined manually.
  * Some functions have multiple out parameters which would be better done in
    Haskell by returning a tuple (this may be possible to do automatically but
    currently it is not).
  * Documentation. This is converted directly from the C documentation so there
    are usually things that you would want to change to make things make sense
    in Haskell. Code samples should be converted for example.

== For users: ==
At the moment you will need to edit the gen-all.sh script and adjust the
DOCBOOKDIR and HEADDERS variables to your system.

The HEADDERS variable should be a list of .h headder files to scan and generate
bindings for. It is probably better to use the installed headder files since
there are many private headder files in the gtk source directory.

The DOCBOOKDIR should be a directory containing docbook xml files coresponding
to the HEADDERS. The gen-all.sh script will look for an $FOO.xml file for every
$FOO.h file in HEADDERS. To generate the docbook format documentation you will
need to build (but not install) a version of gtk (preferably the same version
as the .h files came from). The gtk+-$VER/docs/reference/gtk/xml directory is
where the docbook files end up for gtk (there is also gdk and gtk-pixbuf).

The documentation is optional. If no docbook xml file is found the binding file
will still be generated but without any haddock documentation.

When this is done just run
./gen-all.sh
The final .chs binding files are put in the modules/ directory.
Intermediate api description files and documentation files are left under api/
and doc/.

== For hackers: ==
There are a few components to the system:

There are a couple perl scripts written by the mono/gtk-sharp authors. These
extract information from GObject-based .h files and generate xml descriptions.
To read these files you may want to build the gapi_format_xml tool also from
the gtk-sharp source tree. The xml files assume an object oreinted target
language (C#) but it does preserve all the information ok. These scripts are
GPL so should probably not be distributed in tarballs, just left in cvs.
Besides they're just gtk2hs hacker tools.

There is an XSLT program to extract per function documentation from docbook xml
files into a more convenient format. It is pretty specific to the format of
docbook document generated by gtk-doc (version 1.2). No doubt it will require
changes if gtk-doc changes.

The major component to the system is a Haskell program ApiGen.hs that reads in
the api xml file and the documentation xml file and spits out .chs binding
file(s) using the Template.chs file. The files are named the same as the object
they bind.

Some improvements that would be good:
 * Complete marshaling code for more types
 * Emit top level module documentation, including:
    - module summary / description
    - object heirarchy
 * Add a Haddock contents annotations (eg: constructors, methods, signals)
 * Emit signal and property bindings with documentation

--- NEW FILE: format-docs.xsl ---
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<xsl:transform
  xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
  version="1.0">
  <xsl:output method="xml" indent="yes"/>

<xsl:template match="link/function">
<xref-func><xsl:value-of select="."/></xref-func>
</xsl:template>

<xsl:template match="link/type">
<xref-type><xsl:value-of select="."/></xref-type>
</xsl:template>

<xsl:template match="xref">
<xref-other><xsl:value-of select="."/></xref-other>
</xsl:template>

<xsl:template match="emphasis">
<emphasis><xsl:value-of select="."/></emphasis>
</xsl:template>

<xsl:template match="literal">
<literal><xsl:value-of select="."/></literal>
</xsl:template>

<xsl:template match="parameter">
<arg><xsl:value-of select="."/></arg>
</xsl:template>

<xsl:template match="/">
  <apidoc>
  <xsl:for-each select="/book/refentry/refsect1[title='Details']/refsect2[contains(title,' ()')]">
    <function>
      <name><xsl:value-of select="indexterm/primary"/></name>
      <since>
               <xsl:value-of select="number(substring-after(para[starts-with(text(),'Since')], 'Since  '))"/>
      </since>
      <doc>
	 <xsl:for-each select="para[not(starts-with(text(),'Since')) and normalize-space(text())!='']">
	    <!--<xsl:copy-of select="."/>-->
	    <para><xsl:apply-templates/></para>
	 </xsl:for-each>
      </doc>
    </function>
  </xsl:for-each>
  </apidoc>
</xsl:template>
</xsl:transform>


--- NEW FILE: gapi2xml.pl ---
#!/usr/bin/perl
#
# gapi2xml.pl : Generates an XML representation of GObject based APIs.
#
# Author: Mike Kestner <mke...@sp...>
#
# Copyright (c) 2001-2003 Mike Kestner
# Copyright (c) 2003-2004 Novell, Inc.
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of version 2 of the GNU General Public
# License as published by the Free Software Foundation.
#
# This program 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.
#
# You should have received a copy of the GNU General Public
# License along with this program; if not, write to the
# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.
##############################################################

$debug=0;

use XML::LibXML;

if (!$ARGV[2]) {
	die "Usage: gapi_pp.pl <srcdir> | gapi2xml.pl <namespace> <outfile> <libname>\n";
}

$ns = $ARGV[0];
$libname = $ARGV[2];

##############################################################
# Check if the filename provided exists.  We parse existing files into
# a tree and append the namespace to the root node.  If the file doesn't 
# exist, we create a doc tree and root node to work with.
##############################################################

if (-e $ARGV[1]) {
	#parse existing file and get root node.
	$doc = XML::LibXML->new->parse_file($ARGV[1]);
	$root = $doc->getDocumentElement();
} else {
	$doc = XML::LibXML::Document->new();
	$root = $doc->createElement('api');
	$doc->setDocumentElement($root);
	$warning_node = XML::LibXML::Comment->new ("\n\n        This file was automatically generated.\n        Please DO NOT MODIFY THIS FILE, modify .metadata files instead.\n\n");
	$root->appendChild($warning_node);
}

$ns_elem = $doc->createElement('namespace');
$ns_elem->setAttribute('name', $ns);
$ns_elem->setAttribute('library', $libname);
$root->appendChild($ns_elem);

##############################################################
# First we parse the input for typedefs, structs, enums, and class_init funcs
# and put them into temporary hashes.
##############################################################

while ($line = <STDIN>) {
	if ($line =~ /typedef\s+(struct\s+\w+\s+)\*+(\w+);/) {
		$ptrs{$2} = $1;
	} elsif ($line =~ /typedef\s+(struct\s+\w+)\s+(\w+);/) {
		next if ($2 =~ /Private$/);
		# fixme: siiigh
		$2 = "GdkDrawable" if ($1 eq "_GdkDrawable");
		$types{$2} = $1;
	} elsif ($line =~ /typedef\s+struct/) {
		$sdef = $line;
		while ($line = <STDIN>) {
			$sdef .= $line;
			last if ($line =~ /^}/);
		}
		$sdef =~ s!/\*.*?(\*/|\n)!!g;
		$sdef =~ s/\n\s*//g;
		$types{$1} = $sdef if ($sdef =~ /.*\}\s*(\w+);/);
	} elsif ($line =~ /typedef\s+(unsigned\s+\w+)\s+(\**)(\w+);/) {
		$types{$3} = $1 . $2;
	} elsif ($line =~ /typedef\s+(\w+)\s+(\**)(\w+);/) {
		$types{$3} = $1 . $2;
	} elsif ($line =~ /typedef\s+enum\s+(\w+)\s+(\w+);/) {
		$etypes{$1} = $2;
	} elsif ($line =~ /^(typedef\s+)?\benum\b/) {
		$edef = $line;
		while ($line = <STDIN>) {
			$edef .= $line;
			last if ($line =~ /^}\s*(\w+)?;/);
		}
		$edef =~ s/\n\s*//g;
		$edef =~ s|/\*.*?\*/||g;
		if ($edef =~ /typedef.*}\s*(\w+);/) {
			$ename = $1;
		} elsif ($edef =~ /^enum\s+(\w+)\s*{/) {
			$ename = $1;
		} else {
			print "Unexpected enum format\n$edef";
			next;
		}
		$edefs{$ename} = $edef;
	} elsif ($line =~ /typedef\s+\w+\s*\**\s*\(\*\s*(\w+)\)\s*\(/) {
		$fname = $1;
		$fdef = "";
		while ($line !~ /;/) {
			$fdef .= $line;
			$line = <STDIN>;
		}
		$fdef .= $line;
		$fdef =~ s/\n\s+//g;
		$fpdefs{$fname} = $fdef;
	} elsif ($line =~ /^(private)?struct\s+(\w+)/) {
		next if ($line =~ /;/);
		$sname = $2;
		$sdef = $line;
		while ($line = <STDIN>) {
			$sdef .= $line;
			last if ($line =~ /^}/);
		}
		$sdef =~ s!/\*.*?(\*/|\n)!!g;
		$sdef =~ s/\n\s*//g;
		$sdefs{$sname} = $sdef;
	} elsif ($line =~ /^(\w+)_(class|base)_init\b/) {
		$class = StudlyCaps($1);
		$pedef = $line;
		while ($line = <STDIN>) {
			$pedef .= $line;
			last if ($line =~ /^}/);
		}
		$pedefs{lc($class)} = $pedef;
	} elsif ($line =~ /^(\w+)_get_type\b/) {
		$class = StudlyCaps($1);
		$pedef = $line;
		while ($line = <STDIN>) {
			$pedef .= $line;
			if ($line =~ /g_boxed_type_register_static/) {
				$boxdef = $line;
				while ($line !~ /;/) {
					$boxdef .= ($line = <STDIN>);
				}
				$boxdef =~ s/\n\s*//g;
				$boxdef =~ /\(\"(\w+)\"/;
				my $boxtype = $1;
				$boxtype =~ s/($ns)Type(\w+)/$ns$2/;
				$boxdefs{$boxtype} = $boxdef;
			}
			last if ($line =~ /^}/);
		}
		$typefuncs{lc($class)} = $pedef;
	} elsif ($line =~ /^(const|G_CONST_RETURN)?\s*\w+\s*\**\s*(\w+)\s*\(/) {
		$fname = $2;
		$fdef = "";
		while ($line !~ /;/) {
			$fdef .= $line;
			$line = <STDIN>;
		}
		$fdef .= $line;
		$fdef =~ s/\n\s*//g;
		if ($fdef !~ /^_/) {
			$fdefs{$fname} = $fdef;
		}
	} elsif ($line =~ /CHECK_(\w*)CAST/) {
		$cast_macro = $line;
		while ($line =~ /\\$/) {
			$line = <STDIN>;
			$cast_macro .= $line;
		}
		$cast_macro =~ s/\\\n\s*//g;
		$cast_macro =~ s/\s+/ /g;
		if ($cast_macro =~ /G_TYPE_CHECK_(\w+)_CAST.*,\s*(\w+),\s*(\w+)/) {
			if ($1 eq "INSTANCE") {
				$objects{$2} = $3 . $objects{$2};
			} else {
				$objects{$2} .= ":$3";
			}
		} elsif ($cast_macro =~ /GTK_CHECK_CAST.*,\s*(\w+),\s*(\w+)/) {
			$objects{$1} = $2 . $objects{$1};
		} elsif ($cast_macro =~ /GTK_CHECK_CLASS_CAST.*,\s*(\w+),\s*(\w+)/) {
			$objects{$1} .= ":$2";
		}
	} elsif ($line =~ /INSTANCE_GET_INTERFACE.*,\s*(\w+),\s*(\w+)/) {
		$ifaces{$1} = $2;
	} elsif ($line =~ /^BUILTIN\s*\{\s*\"(\w+)\".*GTK_TYPE_BOXED/) {
		$boxdefs{$1} = $line;
	} elsif ($line =~ /^BUILTIN\s*\{\s*\"(\w+)\".*GTK_TYPE_(ENUM|FLAGS)/) {
		# ignoring these for now.
	} elsif ($line =~ /^\#define/) {
		my $test_ns = uc ($ns);
		if ($line =~ /\#define\s+(\w+)\s+\"(.*)\"/) {
			$defines{$1} = $2;
		}
	} else {
		print $line;
	}
}

##############################################################
# Produce the enum definitions.
##############################################################
%enums = ();

foreach $cname (sort(keys(%edefs))) {
	$ecnt++;
	$def = $edefs{$cname};
	$cname = $etypes{$cname} if (exists($etypes{$cname}));
	$enums{lc($cname)} = $cname;
	$enum_elem = addNameElem($ns_elem, 'enum', $cname, $ns);
	if ($def =~ /=\s*1\s*<<\s*\d+/) {
		$enum_elem->setAttribute('type', "flags");
	} else {
		$enum_elem->setAttribute('type', "enum");
	}
	$def =~ /\{(.*)\}/;
	@vals = split(/,\s*/, $1);
	@v0 = split(/_/, $vals[0]);
	if (@vals > 1) {
		$done = 0;
		for ($idx = 0, $regex = ""; $idx < @v0; $idx++) {
			$regex .= ($v0[$idx] . "_");
			foreach $val (@vals) {
				$done = 1 if ($val !~ /$regex/);
			}
			last if $done;
		}
		$common = join("_", @v0[0..$idx-1]);
	} else {
		$common = join("_", @v0[0..$#v0-1]);
	}
	
	foreach $val (@vals) {
		if ($val =~ /$common\_?(\w+)\s*=\s*(\-?\d+.*)/) {
			$name = $1;
			if ($2 =~ /1u?\s*<<\s*(\d+)/) {
				$enumval = "1 << $1";
			} else {
				$enumval = $2;
			}
		} elsif ($val =~ /$common\_?(\w+)/) {
			$name = $1; $enumval = "";
		} else {
			die "Unexpected enum value: $val for common value $common\n";
		}

		$val_elem = addNameElem($enum_elem, 'member');
		$val_elem->setAttribute('cname', "$common\_$name");
		$val_elem->setAttribute('name', StudlyCaps(lc($name)));
		if ($enumval) {
			$val_elem->setAttribute('value', $enumval);
		}
	}
}

##############################################################
# Parse the callbacks.
##############################################################

foreach $cbname (sort(keys(%fpdefs))) {
	next if ($cbname !~ /$ns/);
	$cbcnt++;
	$fdef = $cb = $fpdefs{$cbname};
	$cb_elem = addNameElem($ns_elem, 'callback', $cbname, $ns);
	$cb =~ /typedef\s+(.*)\(.*\).*\((.*)\);/;
	$ret = $1; $params = $2;
	addReturnElem($cb_elem, $ret);
	if ($params && ($params ne "void")) {
		addParamsElem($cb_elem, split(/,/, $params));
	}
}


##############################################################
# Parse the interfaces list.   
##############################################################

foreach $type (sort(keys(%ifaces))) {

	$iface = $ifaces{$type};
	($inst, $dontcare) = split(/:/, delete $objects{$type});
	$initfunc = $pedefs{lc($inst)};
	$ifacetype = delete $types{$iface};
	delete $types{$inst};
	
	$ifacecnt++;
	$iface_el = addNameElem($ns_elem, 'interface', $inst, $ns);

	$elem_table{lc($inst)} = $iface_el;

	$classdef = $sdefs{$1} if ($ifacetype =~ /struct\s+(\w+)/);
	if ($initfunc) {
		parseInitFunc($iface_el, $initfunc, 0);
	} else {
		warn "Don't have an init func for $inst.\n" if $debug;
	}
}


##############################################################
# Parse the classes by walking the objects list.   
##############################################################

foreach $type (sort(keys(%objects))) {
	
	($inst, $class) = split(/:/, $objects{$type});
	$class = $inst . "Class" if (!$class);
	$initfunc = $pedefs{lc($inst)};
	$typefunc = $typefuncs{lc($inst)};
	$insttype = delete $types{$inst};
	$classtype = delete $types{$class};

	$instdef = $classdef = "";
	$instdef = $sdefs{$1} if ($insttype =~ /struct\s+(\w+)/);
	$classdef = $sdefs{$1} if ($classtype =~ /struct\s+(\w+)/);
	$instdef =~ s/\s+(\*+)/\1 /g;
	warn "Strange Class $inst\n" if (!$instdef && $debug);

	$classcnt++;
	$obj_el = addNameElem($ns_elem, 'object', $inst, $ns);

	$elem_table{lc($inst)} = $obj_el;

	# Extract parent and fields from the struct
	if ($instdef =~ /^struct/) {
		$instdef =~ /\{(.*)\}/;
		$fieldstr = $1;
		$fieldstr =~ s|/\*.*?\*/||g;
		@fields = split(/;/, $fieldstr);
		$fields[0] =~ /(\w+)/;
		$obj_el->setAttribute('parent', "$1");
		addFieldElems($obj_el, @fields[1..$#fields]);
	} elsif ($instdef =~ /privatestruct/) {
		# just get the parent for private structs
		$instdef =~ /\{\s*(\w+)/;
		$obj_el->setAttribute('parent', "$1");
	}

	# Get the props from the class_init func.
	if ($initfunc) {
		parseInitFunc($obj_el, $initfunc, 1);
	} else {
		warn "Don't have an init func for $inst.\n" if $debug;
	}

	# Get the interfaces from the class_init func.
	if ($typefunc) {
		parseTypeFunc($obj_el, $typefunc);
	} else {
		warn "Don't have a GetType func for $inst.\n" if $debug;
	}

}

##############################################################
# Parse the remaining types.
##############################################################

foreach $key (sort (keys (%types))) {

	$lasttype = $type = $key;
	while ($type && ($types{$type} !~ /struct/)) {
		$lasttype = $type;
		$type = $types{$type};
	}

	if ($types{$type} =~ /struct\s+(\w+)/) {
		$type = $1;
		if (exists($sdefs{$type})) {
			$def = $sdefs{$type};
		} else {
			$def = "privatestruct";
		}
	} elsif ($types{$type} =~ /struct/ && $type =~ /^$ns/) {
		$def = $types{$type};
	} else {
		$elem = addNameElem($ns_elem, 'alias', $key, $ns);
		$elem->setAttribute('type', $lasttype);
		warn "alias $key to $lasttype\n" if $debug;
		next;
	}

	# fixme: hack
	if ($key eq "GdkBitmap") {
		$struct_el = addNameElem($ns_elem, 'object', $key, $ns);
	} elsif (exists($boxdefs{$key})) {
		$struct_el = addNameElem($ns_elem, 'boxed', $key, $ns);
	} else {
		$struct_el = addNameElem($ns_elem, 'struct', $key, $ns);
	}

	$elem_table{lc($key)} = $struct_el;

	$def =~ s/\s+/ /g;
	if ($def =~ /privatestruct/) {
		$struct_el->setAttribute('opaque', 'true');
	} else {
		$def =~ /\{(.+)\}/;
		addFieldElems($struct_el, split(/;/, $1));
	}
}

# really, _really_ opaque structs that aren't even defined in sources. Lovely.
foreach $key (sort (keys (%ptrs))) {
	next if $ptrs{$key} !~ /struct\s+(\w+)/;
	$type = $1;
	$struct_el = addNameElem ($ns_elem, 'struct', $key, $ns);
	$struct_el->setAttribute('opaque', 'true');
	$elem_table{lc($key)} = $struct_el;
}

addFuncElems();
addStaticFuncElems();

# This should probably be done in a more generic way
foreach $define (sort (keys (%defines))) {
	next if $define !~ /[A-Z]_STOCK_/;
	if ($stocks{$ns}) {
		$stock_el = $stocks{$ns};
	} else {
		$stock_el = addNameElem($ns_elem, "object", $ns . "Stock", $ns);
		$stocks{$ns} = $stock_el;
	}
	$string_el = addNameElem ($stock_el, "static-string", $define);
	$string_name = lc($define);
	$string_name =~ s/\w+_stock_//;
	$string_el->setAttribute('name', StudlyCaps($string_name));
	$string_el->setAttribute('value', $defines{$define});
}

##############################################################
# Output the tree
##############################################################

if ($ARGV[1]) {
	open(XMLFILE, ">$ARGV[1]") || 
				die "Couldn't open $ARGV[1] for writing.\n";
	print XMLFILE $doc->toString();
	close(XMLFILE);
} else {
	print $doc->toString();
}

##############################################################
# Generate a few stats from the parsed source.
##############################################################

$scnt = keys(%sdefs); $fcnt = keys(%fdefs); $tcnt = keys(%types);
print "structs: $scnt  enums: $ecnt  callbacks: $cbcnt\n";
print "funcs: $fcnt types: $tcnt  classes: $classcnt\n";
print "props: $propcnt signals: $sigcnt\n\n";

sub addFieldElems
{
	my ($parent, @fields) = @_;

	foreach $field (@fields) {
		next if ($field !~ /\S/);
		$field =~ s/\s+(\*+)/\1 /g;
		$field =~ s/(\w+)\s+const /const \1 /g;
		$field =~ s/const /const\-/g;
		$field =~ s/struct /struct\-/g;
		$field =~ s/.*\*\///g;
		next if ($field !~ /\S/);

		if ($field =~ /(\S+\s+\*?)\(\*\s*(.+)\)\s*\((.*)\)/) {
			$elem = addNameElem($parent, 'callback', $2);
			addReturnElem($elem, $1);
			addParamsElem($elem, $3);
		} elsif ($field =~ /(unsigned )?(\S+)\s+(.+)/) {
			my $type = $1 . $2; $symb = $3;
			foreach $tok (split (/,\s*/, $symb)) {
				if ($tok =~ /(\w+)\s*\[(.*)\]/) {
					$elem = addNameElem($parent, 'field', $1);
					$elem->setAttribute('array_len', "$2");
				} elsif ($tok =~ /(\w+)\s*\:\s*(\d+)/) {
					$elem = addNameElem($parent, 'field', $1);
					$elem->setAttribute('bits', "$2");
				} else {
					$elem = addNameElem($parent, 'field', $tok);
				}
				$elem->setAttribute('type', "$type");
			}
		} else {
			die "$field\n";
		}
	}
}

sub addFuncElems
{
	my ($obj_el, $inst, $prefix);

	$fcnt = keys(%fdefs);

	foreach $mname (sort (keys (%fdefs))) {
		next if ($mname =~ /^_/);
		$obj_el = "";
		$prefix = $mname;
		$prepend = undef;
		while ($prefix =~ /(\w+)_/) {
			$prefix = $key = $1;
			$key =~ s/_//g;
			# FIXME: lame Gdk API hack
			if ($key eq "gdkdraw") {
				$key = "gdkdrawable";
				$prepend = "draw_";
			}
			if (exists ($elem_table{$key})) {
				$prefix .= "_";
				$obj_el = $elem_table{$key};
				$inst = $key;
				last;
			} elsif (exists ($enums{$key}) && ($mname =~ /_get_type/)) {
				delete $fdefs{$mname};
				last;
			}
		}
		next if (!$obj_el);

		$mdef = delete $fdefs{$mname};

		if ($mname =~ /$prefix(new)/) {
			$el = addNameElem($obj_el, 'constructor', $mname); 
			$drop_1st = 0;
		} else {
			$el = addNameElem($obj_el, 'method', $mname, $prefix, $prepend);
			$mdef =~ /(.*?)\w+\s*\(/;
			addReturnElem($el, $1);
			$mdef =~ /\(\s*(const)?\s*(\w+)/;
			if (lc($2) ne $inst) {
				$el->setAttribute("shared", "true");
				$drop_1st = 0;
			} else {
				$drop_1st = 1;
			}
		}

		parseParms ($el, $mdef, $drop_1st);

	}
}

sub parseParms
{
	my ($el, $mdef, $drop_1st) = @_;

	if (($mdef =~ /\((.*)\)/) && ($1 ne "void")) {
		@parms = ();
		$parm = "";
		$pcnt = 0;
		foreach $char (split(//, $1)) {
			if ($char eq "(") {
				$pcnt++;
			} elsif ($char eq ")") {
				$pcnt--;
			} elsif (($pcnt == 0) && ($char eq ",")) {
				@parms = (@parms, $parm);
				$parm = "";
				next;
			}
			$parm .= $char;
		}

		if ($parm) {
			@parms = (@parms, $parm);
		}
		# @parms = split(/,/, $1);
		($dump, @parms) = @parms if $drop_1st;
		if (@parms > 0) {
			addParamsElem($el, @parms);
		}
	}
}

sub addStaticFuncElems
{
	my ($global_el, $ns_prefix);

	@mnames = sort (keys (%fdefs));
	$mcount = @mnames;

	return if ($mcount == 0);

	$ns_prefix = "";
	$global_el = "";

	for ($i = 0; $i < $mcount; $i++) {
		$mname = $mnames[$i];
		$prefix = $mname;
		next if ($prefix =~ /^_/);

		if ($ns_prefix eq "") {
			my (@toks) = split(/_/, $prefix);
			for ($j = 0; $j < @toks; $j++) {
				if (join ("", @toks[0 .. $j]) eq lc($ns)) {
					$ns_prefix = join ("_", @toks[0 .. $j]);
					last;
				}
			}
			next if ($ns_prefix eq "");
		}
		next if ($mname !~ /^$ns_prefix/);

		if ($mname =~ /($ns_prefix)_([a-zA-Z]+)_\w+/) {
			$classname = $2;
			$key = $prefix = $1 . "_" . $2 . "_";
			$key =~ s/_//g;
			$cnt = 1;
			if (exists ($enums{$key})) {
				$cnt = 1; 
			} elsif ($classname ne "set" && $classname ne "get" &&
			    $classname ne "scan" && $classname ne "find" &&
			    $classname ne "add" && $classname ne "remove" &&
			    $classname ne "free" && $classname ne "register" &&
			    $classname ne "execute" && $classname ne "show" &&
			    $classname ne "parse" && $classname ne "paint" &&
			    $classname ne "string") {
				while ($mnames[$i+$cnt] =~ /$prefix/) { $cnt++; }
			}
			if ($cnt == 1) {
				$mdef = delete $fdefs{$mname};

				if (!$global_el) {
					$global_el = $doc->createElement('class');
					$global_el->setAttribute('name', "Global");
					$global_el->setAttribute('cname', $ns . "Global");
					$ns_elem->appendChild($global_el);
				}
				$el = addNameElem($global_el, 'method', $mname, $ns_prefix);
				$mdef =~ /(.*?)\w+\s*\(/;
				addReturnElem($el, $1);
				$el->setAttribute("shared", "true");
				parseParms ($el, $mdef, 0);
				next;
			} else {
				$class_el = $doc->createElement('class');
				$class_el->setAttribute('name', StudlyCaps($classname));
				$class_el->setAttribute('cname', StudlyCaps($prefix));
				$ns_elem->appendChild($class_el);

				for ($j = 0; $j < $cnt; $j++) {
					$mdef = delete $fdefs{$mnames[$i+$j]};

					$el = addNameElem($class_el, 'method', $mnames[$i+$j], $prefix);
					$mdef =~ /(.*?)\w+\s*\(/;
					addReturnElem($el, $1);
					$el->setAttribute("shared", "true");
					parseParms ($el, $mdef, 0);
				}
				$i += ($cnt - 1);
				next;
			}
		}
	}
}

sub addNameElem
{
	my ($node, $type, $cname, $prefix, $prepend) = @_;

	my $elem = $doc->createElement($type);
	$node->appendChild($elem);
	if ($prefix) {
		my $match;
		if ($cname =~ /$prefix(\w+)/) {
			$match = $1;
		} else {
			$match = $cname;
		}
		if ($prepend) {
			$name = $prepend . $match;
		} else {
			$name = $match;
		}
		$elem->setAttribute('name', StudlyCaps($name));
	}
	if ($cname) {
		$elem->setAttribute('cname', $cname);
	}
	return $elem;
}

sub addParamsElem
{
	my ($parent, @params) = @_;

	my $parms_elem = $doc->createElement('parameters');
	$parent->appendChild($parms_elem);
	my $parm_num = 0;
	foreach $parm (@params) {
		$parm_num++;
		$parm =~ s/\s+(\*+)/\1 /g;
		$parm =~ s/(\w+)\s+const /const \1 /g;
		$parm =~ s/(\*+)\s*const\s+/\1 /g;
		$parm =~ s/const\s+/const-/g;
		if ($parm =~ /(.*)\(\s*\**\s*(\w+)\)\s+\((.*)\)/) {
			my $ret = $1; my $cbn = $2; my $params = $3;
			$cb_elem = addNameElem($parms_elem, 'callback', $cbn);
			addReturnElem($cb_elem, $ret);
			if ($params && ($params ne "void")) {
				addParamsElem($cb_elem, split(/,/, $params));
			}
			next;
		} elsif ($parm =~ /\.\.\./) {
			$parm_elem = $doc->createElement('parameter');
			$parms_elem->appendChild($parm_elem);
			$parm_elem->setAttribute('ellipsis', 'true');
			next;
		}
		$parm_elem = $doc->createElement('parameter');
		$parms_elem->appendChild($parm_elem);
		my $name = "";
		if ($parm =~ /struct\s+(\S+)\s+(\S+)/) {
			$parm_elem->setAttribute('type', $1);
			$name = $2;
		}elsif ($parm =~ /(unsigned )?(\S+)\s+(\S+)/) {
			$parm_elem->setAttribute('type', $1 . $2);
			$name = $3;
		} elsif ($parm =~ /(\S+)/) {
			$parm_elem->setAttribute('type', $1);
			$name = "arg" . $parm_num;
		}
		if ($name =~ /(\w+)\[.*\]/) {
			$name = $1;
			$parm_elem->setAttribute('array', "true");
		}
		$parm_elem->setAttribute('name', $name);
	}
}

sub addReturnElem
{
	my ($parent, $ret) = @_;

	$ret =~ s/const|G_CONST_RETURN/const-/g;
	$ret =~ s/\s+//g;
	my $ret_elem = $doc->createElement('return-type');
	$parent->appendChild($ret_elem);
	$ret_elem->setAttribute('type', $ret);
	return $ret_elem;
}

sub addPropElem
{
	my ($spec, $node) = @_;
	my ($name, $mode, $docs);
	$spec =~ /g_param_spec_(\w+)\s*\((.*)\s*\)\s*\)/;
	my $type = $1;
	my @params = split(/,/, $2);

	$name = $params[0];
	if ($defines{$name}) {
		$name = $defines{$name};
	} else {
		$name =~ s/\s*\"//g;
	}

	$mode = $params[$#params];

	if ($type =~ /boolean|float|double|^u?int|pointer/) {
		$type = "g$type";
	} elsif ($type =~ /string/) {
		$type = "gchar*";
	} elsif ($type =~ /boxed|object/) {
		$type = $params[$#params-1];
		$type =~ s/TYPE_//;
		$type =~ s/\s+//g;
		$type = StudlyCaps(lc($type));
	} elsif ($type =~ /enum|flags/) {
		$type = $params[$#params-2];
		$type =~ s/TYPE_//;
		$type =~ s/\s+//g;
		$type = StudlyCaps(lc($type));
	}

	$prop_elem = $doc->createElement('property');
	$node->appendChild($prop_elem);
	$prop_elem->setAttribute('name', StudlyCaps($name));
	$prop_elem->setAttribute('cname', $name);
	$prop_elem->setAttribute('type', $type);

	$prop_elem->setAttribute('readable', "true") if ($mode =~ /READ/);
	$prop_elem->setAttribute('writeable', "true") if ($mode =~ /WRIT/);
	$prop_elem->setAttribute('construct-only', "true") if ($mode =~ /CONS/);
}

sub parseTypeToken
{
	my ($tok) = @_;

	if ($tok =~ /G_TYPE_(\w+)/) {
		my $type = $1;
		if ($type eq "NONE") {
			return "void";
		} elsif ($type eq "INT") {
			return "gint32";
		} elsif ($type eq "UINT") {
			return "guint32";
		} elsif ($type eq "ENUM" || $type eq "FLAGS") {
			return "gint32";
		} elsif ($type eq "STRING") {
			return "gchar*";
		} elsif ($type eq "OBJECT") {
			return "GObject*";
		} else {
			return "g" . lc ($type);
		}
	} else {
		$tok =~ s/_TYPE//; 
		$tok =~ s/\|.*STATIC_SCOPE//; 
		$tok =~ s/\s+//g;
		return StudlyCaps (lc($tok));
	}
}

sub addSignalElem
{
	my ($spec, $class, $node) = @_;
	$spec =~ s/\n\s*//g; $class =~ s/\n\s*//g;

	$sig_elem = $doc->createElement('signal');
	$node->appendChild($sig_elem);

	if ($spec =~ /\(\"([\w\-]+)\"/) {
		$sig_elem->setAttribute('name', StudlyCaps($1));
		$sig_elem->setAttribute('cname', $1);
	}
	$sig_elem->setAttribute('when', $1) if ($spec =~ /_RUN_(\w+)/);

	my $method = "";
	if ($spec =~ /_OFFSET\s*\(\w+,\s*(\w+)\)/) {
		$method = $1;
	} else {
		@args = split(/,/, $spec);
		my $rettype = parseTypeToken ($args[7]);
		addReturnElem($sig_elem, $rettype);
		$parmcnt = $args[8];
		$parmcnt =~ s/.*(\d+).*/\1/;
		$parms_elem = $doc->createElement('parameters');
		$sig_elem->appendChild($parms_elem);
		$parm_elem = $doc->createElement('parameter');
		$parms_elem->appendChild($parm_elem);
		$parm_elem->setAttribute('name', "inst");
		$parm_elem->setAttribute('type', "$inst*");
		for (my $idx = 0; $idx < $parmcnt; $idx++) {
			my $a...
 
[truncated message content]