[Gtk2hs-commit] gtk2hs/tools/apiGen Api.hs,NONE,1.1 FormatDocs.hs,NONE,1.1 Marshal.hs,NONE,1.1 StringUtils.hs,NONE,1.1

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

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

Added Files:
	Api.hs FormatDocs.hs Marshal.hs StringUtils.hs 
Log Message:
Split ApiGen.hs into several modules to make it easier to manage and understand.


--- NEW FILE: StringUtils.hs ---
module StringUtils where

import Prelude hiding (lines)
import Char   (toLower, toUpper, isSpace, isAlpha, isAlphaNum, isUpper)

-------------------------------------------------------------------------------
-- 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
upperCaseFirstChar (c:cs) = toUpper c : 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) = sc '@' . doSubst cs
        doSubst ('@':cs) = let (var,_:cs') = span ('@'/=) cs
                            in varSubst var . doSubst cs'
        doSubst (c:cs) = sc c . doSubst cs

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

-- wraps a list of words to lines of words
wrapText :: Int -> Int -> [String] -> [[String]]
wrapText initialCol width = wrap initialCol []
  
  where wrap :: Int -> [String] -> [String] -> [[String]]
        wrap 0   []   (word:words) |       length word + 1 > width = wrap (length word) [word] words
        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]

--- NEW FILE: Api.hs ---
module Api (
  API,
  NameSpace(..),
  Enum(..),
  Member(..),
  Object(..),
  Constructor(..),
  Parameter(..),
  Method(..),
  Property(..),
  Signal(..),
  extractAPI
  ) where

import Prelude hiding (Enum)
import Maybe  (catMaybes)

import qualified Text.XML.HaXml as Xml

-------------------------------------------------------------------------------
-- 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],
    object_properties :: [Property],
    object_signals :: [Signal]
  } 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

data Property = Property {
    property_name :: String,
    property_cname :: String,
    property_type :: String,
    property_readable :: Bool,
    property_writable :: Bool,
    property_constructonly :: Bool
  } deriving Show

data Signal = Signal {
    signal_name :: String,
    signal_cname :: String,
    signal_when :: String,
    signal_return_type :: String,
    signal_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 = catMaybes (map extractEnum content)
  }
extractNameSpace _ = Nothing

extractEnum :: Xml.Content -> Maybe Enum
extractEnum (Xml.CElem (Xml.Elem "enum"
                     [("name", Xml.AttValue name),
                      ("cname", Xml.AttValue cname),
                      ("type", Xml.AttValue variety)] members)) =
  Just $ Enum {
    enum_name = Xml.verbatim name,
    enum_cname = Xml.verbatim cname,
    enum_variety = Xml.verbatim variety,
    enum_members = map extractEnumMember members
  }
extractEnum _ = Nothing

extractEnumMember :: Xml.Content -> Member
extractEnumMember (Xml.CElem (Xml.Elem "enum"
                     (("name", Xml.AttValue name):
                      ("cname", Xml.AttValue cname):value) [])) =
  Member {
    member_name = Xml.verbatim name,
    member_cname = Xml.verbatim cname,
    member_value =
      case value of
        [] -> ""
        [("cname", Xml.AttValue value)] -> Xml.verbatim value
  }

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),
    object_properties = catMaybes (map extractProperty content),
    object_signals = catMaybes (map extractSignal content)
  }
extractObject (Xml.CElem (Xml.Elem "interface"
                     [("name", Xml.AttValue name),
                      ("cname", Xml.AttValue cname)] content)) =
  Just $ Object {
    object_name = Xml.verbatim name,
    object_cname = Xml.verbatim cname,
    object_parent = "GObject",
    object_constructors = catMaybes (map extractConstructor content),
    object_methods = catMaybes (map extractMethod content),
    object_properties = catMaybes (map extractProperty content),
    object_signals = catMaybes (map extractSignal 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"
                        [("ellipsis", _)
                        ,("printf_format_args", _)] [])) = 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_),
                         ("name", Xml.AttValue name),
                         ("printf_format" ,_)] [])) =
  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
   }
extractParameter (Xml.CElem (Xml.Elem "callback"
                        [("cname", Xml.AttValue cname)] _)) =
   Parameter {
     parameter_type = "callback",
     parameter_name = Xml.verbatim cname,
     parameter_isArray = False
   }
  
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

extractProperty :: Xml.Content -> Maybe Property
extractProperty (Xml.CElem (Xml.Elem "property"
                     (("name", Xml.AttValue name):
                      ("cname", Xml.AttValue cname):
                      ("type", Xml.AttValue type_):others) [])) =
  Just $ Property {
    property_name = Xml.verbatim name,
    property_cname = Xml.verbatim cname,
    property_type = Xml.verbatim type_,
    property_readable = (not.null) [ () | ("readable", _) <- others],
    property_writable = (not.null) [ () | ("writable", _) <- others],
    property_constructonly  = (not.null) [ () | ("construct-only", _) <- others]
  }
extractProperty _ = Nothing

extractSignal :: Xml.Content -> Maybe Signal
extractSignal (Xml.CElem (Xml.Elem "signal"
                     (("name", Xml.AttValue name):
                      ("cname", Xml.AttValue cname):when)
                     (Xml.CElem (Xml.Elem "return-type"
                            [("type", Xml.AttValue return_type)] [])
                      :content))) =
  Just $ Signal {
    signal_name = Xml.verbatim name,
    signal_cname = Xml.verbatim cname,
    signal_when = case when of
                    [] -> ""
                    [("when", Xml.AttValue when)] -> Xml.verbatim when,
    signal_return_type = Xml.verbatim return_type,
    signal_parameters =
      case content of
        [] -> []
        [Xml.CElem (Xml.Elem "parameters" [] parameters)]
           -> map extractParameter parameters
  }
extractSignal _ = Nothing

--- NEW FILE: FormatDocs.hs ---
-- ApiGen: takes an xml description of a GObject-style API and produces a .chs
-- binding module. Optionally it can be supplied with an xml documentation file
-- in which case the .chs file will contain haddock-format documentation too.

-- If you want to teach ApiGen how to marshal new types, the function you want
-- to modify is either genMarshalParameter or genMarshalResult near the end of
-- this file.

module FormatDocs (
  genModuleDocumentation,
  cFuncNameToHsName,
  cParamNameToHsName,
  haddocFormatParas,
  haddocFormatSpan,
  changeIllegalNames,
  addVersionParagraphs
) where

import Api (NameSpace(namespace_name))
import Docs
import Marshal (stripKnownPrefixes)
import StringUtils

import qualified List (lines)

-------------------------------------------------------------------------------
-- Functions for formatting haddock documentation
-------------------------------------------------------------------------------

genModuleDocumentation :: ModuleDoc -> ShowS
genModuleDocumentation moduledoc =
  (if null (moduledoc_description moduledoc)
     then id
     else comment.ss "* Description".nl.
          comment.nl.
          comment.ss "| ".haddocFormatParas (moduledoc_description moduledoc).nl).
  (if null (moduledoc_sections moduledoc)
     then id
     else nl.comment.haddocFormatSections (moduledoc_sections moduledoc).nl.comment.nl).
  (if null (moduledoc_hierarchy moduledoc)
     then id
     else nl.comment.ss "* Class Hierarchy".nl.
          comment.ss "|".nl.
          comment.ss "@".nl.
          comment.ss "|  ".haddocFormatHierarchy (moduledoc_hierarchy moduledoc).nl.
          comment.ss "@".nl)

haddocFormatHierarchy :: [DocParaSpan] -> ShowS
haddocFormatHierarchy =
    sepBy "\n-- |"
  . Prelude.lines
  . concatMap haddocFormatSpan

addVersionParagraphs :: NameSpace -> ModuleDoc -> ModuleDoc
addVersionParagraphs namespace apiDoc =
  apiDoc {
    moduledoc_description = moduledoc_description apiDoc ++ moduleVersionParagraph,
    moduledoc_functions = functionVersionParagraphs moduleVersion (moduledoc_functions apiDoc)
  }
  where functionVersionParagraphs :: String -> [FuncDoc] -> [FuncDoc]
        functionVersionParagraphs baseVersion funcdocs =
          [ if funcdoc_since funcdoc > baseVersion
              then funcdoc {
                     funcdoc_paragraphs = funcdoc_paragraphs funcdoc ++
                       let line = "* Available since " ++ namespace_name namespace
                              ++ " version " ++ funcdoc_since funcdoc
                        in [DocParaText [DocText line]]
                   }
              else funcdoc
          | funcdoc <- funcdocs ]
  
        moduleVersionParagraph =
          case moduleVersion of
            "" -> []
            since ->
              let line = "* Module available since " ++ namespace_name namespace
                      ++ " version " ++ since
               in [DocParaText [DocText line]]
  
        -- figure out if the whole module appeared in some version of gtk later 
        -- than the original version
        moduleVersion :: String
        moduleVersion = case [ funcdoc_since funcdoc
                             | funcdoc <- moduledoc_functions apiDoc ] of
                          [] -> ""
                          versions -> minimum versions
  
haddocFormatSections :: [DocSection] -> ShowS
haddocFormatSections = 
    sepBy' "\n\n-- "
  . map (\section ->
         ss "** ". ss (section_title section). nl.
         comment.nl.
         comment.ss "| ".haddocFormatParas (section_paras section))

haddocFormatParas :: [DocPara] -> ShowS
haddocFormatParas =
    sepBy' "\n--\n-- "
  . map haddocFormatPara

haddocFormatPara :: DocPara -> ShowS
haddocFormatPara (DocParaText spans) = haddocFormatSpans 3 spans
haddocFormatPara (DocParaProgram prog) =
    ((ss "* FIXME: if the follwing is a C code example, port it to Haskell or remove it".nl.
      comment).)
  . sepBy "\n-- > "
  . List.lines
  $ prog
haddocFormatPara (DocParaTitle title) =
    ss "* ". ss title
haddocFormatPara (DocParaDefItem term spans) =
  let def = (unwords . words . escape . concatMap haddocFormatSpan) term in
  sc '['. ss def. ss "] ".
  haddocFormatSpans (length def + 6) spans
  where escape [] = []
        escape (']':cs) = '\\': ']' : escape cs --we must escape ] in def terms
        escape (c:cs)   =        c  : escape cs
haddocFormatPara (DocParaListItem spans) =
  ss "* ".
  haddocFormatSpans 5 spans

haddocFormatSpans :: Int -> [DocParaSpan] -> ShowS
haddocFormatSpans initialCol =
    sepBy' "\n-- "
  . map (sepBy " ")
  . wrapText initialCol 77
  . words
  . concatMap haddocFormatSpan

haddocFormatSpan :: DocParaSpan -> String
haddocFormatSpan (DocText text)    = escapeHaddockSpecialChars text
haddocFormatSpan (DocTypeXRef text)    = "\"" ++ stripKnownPrefixes 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")  = "{@NULL@, FIXME: this should probably be converted"
                                                     ++ " to a Maybe data type}"
haddocFormatSpan (DocLiteral text) = "@" ++ escapeHaddockSpecialChars text ++ "@"
haddocFormatSpan (DocArg  text)    = "@" ++ cParamNameToHsName text ++ "@"

cFuncNameToHsName :: String -> String
cFuncNameToHsName =
    lowerCaseFirstChar
  . stripKnownPrefixes
  . concatMap upperCaseFirstChar
  . filter (not.null) --to ignore leading underscores
  . splitBy '_'
  . takeWhile ('('/=)

cParamNameToHsName :: String -> String
cParamNameToHsName  =          --change "gtk_foo_bar" to "gtkFooBar"
    lowerCaseFirstChar
  . concatMap upperCaseFirstChar
  . filter (not.null) --to ignore tailing underscores
  . splitBy '_'

changeIllegalNames :: String -> String
changeIllegalNames "type" = "type_"  --this is a common variable name in C but of
                                     --course a keyword in Haskell
changeIllegalNames other = other

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              

--- NEW FILE: Marshal.hs ---
module Marshal (
  KnownTypes,
  CTypeKind(..),
  stripKnownPrefixes,
  genMarshalParameter,
  genMarshalResult,
  genMarshalProperty
  ) where

import StringUtils
import Char (isUpper)

type KnownTypes = [(String, CTypeKind)]

data CTypeKind = GObjectKind
               | GtkObjectKind
               | EnumKind
               | FlagsKind
  deriving (Eq, Show)


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

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

genMarshalParameter ::
        KnownTypes ->   --a collection of types we know to be objects or enums
	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.
                 indent 2. ss " (fromBool ". ss name. ss ")")

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

genMarshalParameter _ name "gdouble" =
	(Nothing, Just "Double",
	\body -> body.
                 indent 2. ss " (realToFrac ". ss name. ss ")")

genMarshalParameter _ name "gfloat" =
	(Nothing, Just "Float",
	\body -> body.
                 indent 2. ss " (realToFrac ". ss name. ss ")")

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

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

genMarshalParameter knownTypes name typeName'
            | isUpper (head typeName')
           && last typeName' == '*'
           && last typeName /= '*'
           && (typeKind == Just GObjectKind
           ||  typeKind == Just GtkObjectKind) =
	(Just $ shortTypeName ++ "Class " ++ name, Just name,
	\body -> body.
                 indent 2. ss " (to". ss shortTypeName. sc ' '. ss name. ss ")")
  where typeName = init typeName'
        shortTypeName = stripKnownPrefixes typeName
        typeKind = shortTypeName `lookup` knownTypes

genMarshalParameter knownTypes name typeName
            | isUpper (head typeName)
           && typeKind == Just EnumKind =
	(Nothing, Just shortTypeName,
	\body -> body.
                 indent 2. ss " ((fromIntegral . fromEnum) ". ss name. ss ")")
  where shortTypeName = stripKnownPrefixes typeName
        typeKind = shortTypeName `lookup` knownTypes

genMarshalParameter knownTypes name typeName
            | isUpper (head typeName)
           && typeKind == Just FlagsKind =
	(Nothing, Just shortTypeName,
	\body -> body.
                 indent 2. ss " ((fromIntegral . fromFlags) ". ss name. ss ")")
  where shortTypeName = stripKnownPrefixes typeName
        typeKind = shortTypeName `lookup` knownTypes

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

-- Takes the type string and returns the Haskell Type and the marshaling code
--
genMarshalResult :: KnownTypes -> 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 _ "gchar*"        = ("IO String", \body -> body.
                                                            indent 1. ss  ">>= readUTFString")
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 knownTypes typeName'
            | isUpper (head typeName')
           && last typeName' == '*'
           && last typeName /= '*'
           && (typeKind == Just GObjectKind
           ||  typeKind == Just GtkObjectKind) =
  ("IO " ++ shortTypeName,
  \body -> ss constructor. ss " mk". ss shortTypeName. ss " $".
           indent 1. body)
  where typeName = init typeName'
        shortTypeName = stripKnownPrefixes typeName
        typeKind = shortTypeName `lookup` knownTypes
        constructor | typeKind == Just GObjectKind = "makeNewGObject"
                    | typeKind == Just GtkObjectKind = "makeNewObject"
        
genMarshalResult knownTypes typeName
            | isUpper (head typeName)
           && typeKind == Just EnumKind =
  ("IO " ++ shortTypeName,
  \body -> ss "liftM (toEnum . fromIntegral) $".
           indent 1. body)
  where shortTypeName = stripKnownPrefixes typeName
        typeKind = shortTypeName `lookup` knownTypes

genMarshalResult knownTypes typeName
            | isUpper (head typeName)
           && typeKind == Just FlagsKind =
  ("IO " ++ shortTypeName,
  \body -> ss "liftM (toFlags . fromIntegral) $".
           indent 1. body)
  where shortTypeName = stripKnownPrefixes typeName
        typeKind = shortTypeName `lookup` knownTypes

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

genMarshalProperty :: KnownTypes -> String -> (String, String)
genMarshalProperty _ "gint"      = ("Int",    "GVint")
genMarshalProperty _ "guint"     = ("Int",    "GVuint")
genMarshalProperty _ "gfloat"    = ("Float",  "GVfloat")
genMarshalProperty _ "gdouble"   = ("Double", "GVdouble")
genMarshalProperty _ "gboolean"  = ("Bool",   "GVboolean")
genMarshalProperty _ "gchar*"    = ("String", "GVstring")

genMarshalProperty knownTypes typeName
            | isUpper (head typeName)
           && (typeKind == Just GObjectKind
           ||  typeKind == Just GtkObjectKind) =
  (shortTypeName, "GVobject")
  where shortTypeName = stripKnownPrefixes typeName
        typeKind = shortTypeName `lookup` knownTypes

genMarshalProperty knownTypes typeName
            | isUpper (head typeName)
           && typeKind == Just EnumKind =
  (shortTypeName, "GVenum")
  where shortTypeName = stripKnownPrefixes typeName
        typeKind = shortTypeName `lookup` knownTypes

genMarshalProperty knownTypes typeName
            | isUpper (head typeName)
           && typeKind == Just FlagsKind =
  (shortTypeName, "GVflags")
  where shortTypeName = stripKnownPrefixes typeName
        typeKind = shortTypeName `lookup` knownTypes

genMarshalProperty _ unknown = ("{-" ++ unknown ++ "-}", "{-" ++ unknown ++ "-}")