{-# OPTIONS -cpp #-}
-- HookGenerator.hs -*-haskell-*-
-- Takes a type list of possible hooks from the GTK+ distribution and produces
-- Haskell functions to connect to these callbacks.
module Main(main) where

import Data.Char   (showLitChar)
import Data.List   (nub, isPrefixOf)
import System.Environment (getArgs)
import System.Exit (exitWith, ExitCode(..))
import System.IO (stderr, hPutStr)
import Paths_gtk2hs_buildtools (getDataFileName)

-- Define all possible data types the GTK will supply in callbacks.
--
data Types = Tunit		-- ()
	   | Tbool		-- Bool
	   | Tchar
	   | Tuchar
	   | Tint		-- Int
	   | Tuint
	   | Tlong
	   | Tulong
	   | Tenum
	   | Tflags
	   | Tfloat
	   | Tdouble
	   | Tstring
       | Tmstring      
	   | Tboxed  		-- a struct which is passed by value
	   | Tptr		-- pointer
	   | Ttobject		-- foreign with WidgetClass context
	   | Tmtobject		-- foreign with WidgetClass context using a Maybe type
	   | Tobject		-- foreign with GObjectClass context
	   | Tmobject		-- foreign with GObjectClass context using a Maybe type
	   deriving Eq

type Signature = (Types,[Types])
type Signatures = [Signature]

-------------------------------------------------------------------------------
-- Parsing
-------------------------------------------------------------------------------
     
parseSignatures :: String -> Signatures
parseSignatures content = (nub.parseSig 1.scan) content

data Token = TokColon
	   | TokType Types
	   | TokComma
	   | TokEOL

instance Show Token where
  showsPrec _ TokColon = shows ":"
  showsPrec _ (TokType _) = shows "<type>"
  showsPrec _ TokComma = shows ","
  showsPrec _ TokEOL = shows "<EOL>"

parseSig :: Int -> [Token] -> Signatures
parseSig l [] = []
parseSig l (TokEOL: rem) = parseSig (l+1) rem
parseSig l (TokType ret: TokColon: TokType Tunit:rem) =
  (ret,[]):parseSig l rem
parseSig l (TokType ret: TokColon: rem) =
  let (args,rem') = parseArg l rem in
  (ret,args): parseSig (l+1) rem'
parseSig l rem = error ("parse error on line "++show l++
		       ": expected type and colon, found\n"++
		       concatMap show (take 5 rem))

parseArg :: Int -> [Token] -> ([Types],[Token])
parseArg l [TokType ty] = ([ty],[])
parseArg l (TokType ty: TokEOL:rem) = ([ty],rem)
parseArg l (TokType ty: TokComma:rem) =
  let (args,rem') = parseArg l rem in
  (ty:args, rem')
parseArg l rem = error ("parse error on line "++show l++": expected type"++
                        " followed by comma or EOL, found\n "++ 
		       concatMap show (take 5 rem))

scan :: String -> [Token]
scan "" = []
scan ('#':xs) = (scan.dropWhile (/='\n'))  xs
scan ('\n':xs) = TokEOL:scan xs
scan (' ':xs) = scan xs
scan ('\t':xs) = scan xs
scan (':':xs) = TokColon:scan xs
scan (',':xs) = TokComma:scan xs
scan ('V':'O':'I':'D':xs) = TokType Tunit:scan xs
scan ('B':'O':'O':'L':'E':'A':'N':xs) = TokType Tbool:scan xs
scan ('C':'H':'A':'R':xs) = TokType Tchar:scan xs
scan ('U':'C':'H':'A':'R':xs) = TokType Tuchar:scan xs
scan ('I':'N':'T':xs) = TokType Tint:scan xs
scan ('U':'I':'N':'T':xs) = TokType Tuint:scan xs
scan ('L':'O':'N':'G':xs) = TokType Tuint:scan xs
scan ('U':'L':'O':'N':'G':xs) = TokType Tulong:scan xs
scan ('E':'N':'U':'M':xs) = TokType Tenum:scan xs
scan ('F':'L':'A':'G':'S':xs) = TokType Tflags:scan xs
scan ('F':'L':'O':'A':'T':xs) = TokType Tfloat:scan xs
scan ('D':'O':'U':'B':'L':'E':xs) = TokType Tdouble:scan xs
scan ('S':'T':'R':'I':'N':'G':xs) = TokType Tstring:scan xs
scan ('M':'S':'T':'R':'I':'N':'G':xs) = TokType Tmstring:scan xs
scan ('B':'O':'X':'E':'D':xs) = TokType Tboxed:scan xs
scan ('P':'O':'I':'N':'T':'E':'R':xs) = TokType Tptr:scan xs
scan ('T':'O':'B':'J':'E':'C':'T':xs) = TokType Ttobject:scan xs
scan ('M':'T':'O':'B':'J':'E':'C':'T':xs) = TokType Tmtobject:scan xs
scan ('O':'B':'J':'E':'C':'T':xs) = TokType Tobject:scan xs
scan ('M':'O':'B':'J':'E':'C':'T':xs) = TokType Tmobject:scan xs
scan ('N':'O':'N':'E':xs) = TokType Tunit:scan xs
scan ('B':'O':'O':'L':xs) = TokType Tbool:scan xs
scan str = error ("Invalid character in input file:\n"++
	   concatMap ((flip showLitChar) "") (take 5 str))


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

ss = showString
sc = showChar

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

-------------------------------------------------------------------------------
-- Tables of code fragments
-------------------------------------------------------------------------------

identifier :: Types -> ShowS
identifier Tunit    = ss "NONE"
identifier Tbool    = ss "BOOL"
identifier Tchar    = ss "CHAR"
identifier Tuchar   = ss "UCHAR"
identifier Tint	    = ss "INT"
identifier Tuint    = ss "WORD"
identifier Tlong    = ss "LONG"
identifier Tulong   = ss "ULONG"
identifier Tenum    = ss "ENUM"
identifier Tflags   = ss "FLAGS"
identifier Tfloat   = ss "FLOAT"
identifier Tdouble  = ss "DOUBLE"
identifier Tstring  = ss "STRING"
identifier Tmstring = ss "MSTRING"
identifier Tboxed   = ss "BOXED"
identifier Tptr	    = ss "PTR"
identifier Ttobject  = ss "OBJECT"
identifier Tmtobject = ss "MOBJECT"
identifier Tobject  = ss "OBJECT"
identifier Tmobject = ss "MOBJECT"

#ifdef USE_GCLOSURE_SIGNALS_IMPL

-- The monomorphic type which is used to export the function signature.
rawtype :: Types -> ShowS
rawtype Tunit    = ss "()"
rawtype Tbool    = ss "Bool"
rawtype Tchar    = ss "Char"
rawtype Tuchar   = ss "Char"
rawtype Tint	 = ss "Int"
rawtype Tuint    = ss "Word"
rawtype Tlong    = ss "Int"
rawtype Tulong   = ss "Word"
rawtype Tenum    = ss "Int"
rawtype Tflags   = ss "Word"
rawtype Tfloat   = ss "Float"
rawtype Tdouble  = ss "Double"
rawtype Tstring  = ss "CString"
rawtype Tmstring  = ss "CString"
rawtype Tboxed   = ss "Ptr ()"
rawtype Tptr	 = ss "Ptr ()"
rawtype Ttobject  = ss "Ptr GObject"
rawtype Tmtobject  = ss "Ptr GObject"
rawtype Tobject  = ss "Ptr GObject"
rawtype Tmobject  = ss "Ptr GObject"


#else

-- The monomorphic type which is used to export the function signature.
rawtype :: Types -> ShowS
rawtype Tunit    = ss "()"
rawtype Tbool    = ss "{#type gboolean#}"
rawtype Tchar    = ss "{#type gchar#}"
rawtype Tuchar   = ss "{#type guchar#}"
rawtype Tint	   = ss "{#type gint#}"
rawtype Tuint    = ss "{#type guint#}"
rawtype Tlong    = ss "{#type glong#}"
rawtype Tulong   = ss "{#type gulong#}"
rawtype Tenum    = ss "{#type gint#}"
rawtype Tflags   = ss "{#type guint#}"
rawtype Tfloat   = ss "{#type gfloat#}"
rawtype Tdouble  = ss "{#type gdouble#}"
rawtype Tstring  = ss "CString"
rawtype Tmstring  = ss "CString"
rawtype Tboxed   = ss "Ptr ()"
rawtype Tptr	   = ss "Ptr ()"
rawtype Ttobject  = ss "Ptr GObject"
rawtype Tmtobject = ss "Ptr GObject"
rawtype Tobject  = ss "Ptr GObject"
rawtype Tmobject = ss "Ptr GObject"

#endif

-- The possibly polymorphic type which 
usertype :: Types -> [Char] -> (ShowS,[Char])
usertype Tunit	  cs = (ss "()",cs)
usertype Tbool	  (c:cs) = (ss "Bool",cs)
usertype Tchar	  (c:cs) = (ss "Char",cs)
usertype Tuchar	  (c:cs) = (ss "Char",cs)
usertype Tint	  (c:cs) = (ss "Int",cs) 
usertype Tuint	  (c:cs) = (ss "Word",cs)
usertype Tlong	  (c:cs) = (ss "Int",cs)
usertype Tulong	  (c:cs) = (ss "Int",cs)
usertype Tenum	  (c:cs) = (sc c,cs)
usertype Tflags   cs = usertype Tenum cs
usertype Tfloat	  (c:cs) = (ss "Float",cs)
usertype Tdouble  (c:cs) = (ss "Double",cs)
usertype Tstring  (c:cs) = (ss "String",cs)
usertype Tmstring  (c:cs) = (ss "Maybe String",cs)
usertype Tboxed   (c:cs) = (sc c,cs)
usertype Tptr	  (c:cs) = (ss "Ptr ".sc c,cs)
usertype Ttobject  (c:cs) = (sc c.sc '\'',cs)
usertype Tmtobject  (c:cs) = (ss "Maybe ".sc c.sc '\'',cs)
usertype Tobject  (c:cs) = (sc c.sc '\'',cs)
usertype Tmobject  (c:cs) = (ss "Maybe ".sc c.sc '\'',cs)


-- type declaration: only consume variables when they are needed
--
-- * Tint is used as return value as well. Therefore Integral has to be added
--   to the context. Grrr.
--
context :: [Types] -> [Char] -> [ShowS]
context (Tenum:ts)    (c:cs) = ss "Enum ".sc c: context ts cs
context (Tflags:ts)   (c:cs) = ss "Flags ".sc c: context ts cs
context (Ttobject:ts)  (c:cs) = ss "GObjectClass ".sc c.sc '\'': context ts cs
context (Tmtobject:ts)  (c:cs) = ss "GObjectClass ".sc c.sc '\'': context ts cs
context (Tobject:ts)  (c:cs) = ss "GObjectClass ".sc c.sc '\'': context ts cs
context (Tmobject:ts)  (c:cs) = ss "GObjectClass ".sc c.sc '\'': context ts cs
context (_:ts)	      (c:cs) = context ts cs
context []	      _	     = []


marshType :: [Types] -> [Char] -> [ShowS]
marshType (Tint:ts)     (c:cs) = marshType ts cs
marshType (Tuint:ts)	(c:cs) = marshType ts cs
marshType (Tenum:ts)	(c:cs) = marshType ts cs
marshType (Tflags:ts)	cs     = marshType (Tenum:ts) cs
marshType (Tboxed:ts)	(c:cs) = ss "(Ptr ".sc c.ss "' -> IO ".
				 sc c.ss ") -> ":
				 marshType ts cs
marshType (Tptr:ts)	(c:cs) = marshType ts cs
marshType (Tobject:ts)	(c:cs) = marshType ts cs
marshType (_:ts)        (c:cs) = marshType ts cs
marshType []		_      = []

-- arguments for user defined marshalling

type ArgNo = Int

marshArg :: Types -> ArgNo -> ShowS
marshArg Tboxed   c = ss "boxedPre".shows c.sc ' '
marshArg _	  _ = id

-- generate a name for every passed argument,
nameArg :: Types -> ArgNo -> ShowS
nameArg Tunit	 _ = id
nameArg Tbool	 c = ss "bool".shows c
nameArg Tchar    c = ss "char".shows c
nameArg Tuchar   c = ss "char".shows c
nameArg Tint	 c = ss "int".shows c
nameArg Tuint	 c = ss "int".shows c
nameArg Tlong	 c = ss "long".shows c
nameArg Tulong	 c = ss "long".shows c
nameArg Tenum	 c = ss "enum".shows c
nameArg Tflags	 c = ss "flags".shows c
nameArg Tfloat	 c = ss "float".shows c
nameArg Tdouble	 c = ss "double".shows c
nameArg Tstring	 c = ss "str".shows c
nameArg Tmstring c = ss "str".shows c
nameArg Tboxed   c = ss "box".shows c
nameArg Tptr     c = ss "ptr".shows c
nameArg Ttobject  c = ss "obj".shows c
nameArg Tmtobject  c = ss "obj".shows c
nameArg Tobject  c = ss "obj".shows c
nameArg Tmobject  c = ss "obj".shows c


-- describe marshalling between the data passed from the registered function
-- to the user supplied Haskell function

#ifdef USE_GCLOSURE_SIGNALS_IMPL

marshExec :: Types -> ShowS -> Int -> (ShowS -> ShowS)
marshExec Tbool	  arg _ body = body. sc ' '. arg
marshExec Tchar	  arg _ body = body. sc ' '. arg
marshExec Tuchar  arg _ body = body. sc ' '. arg
marshExec Tint	  arg _ body = body. sc ' '. arg
marshExec Tuint	  arg _ body = body. sc ' '. arg
marshExec Tlong	  arg _ body = body. sc ' '. arg
marshExec Tulong  arg _ body = body. sc ' '. arg
marshExec Tenum	  arg _ body = body. ss " (toEnum ". arg. sc ')'
marshExec Tflags  arg _ body = body. ss " (toFlags ". arg. sc ')'
marshExec Tfloat  arg _ body = body. sc ' '. arg
marshExec Tdouble arg _ body = body. sc ' '. arg
marshExec Tstring arg _ body = indent 5. ss "peekUTFString ". arg. ss " >>= \\". arg. ss "\' ->".
                               body. sc ' '. arg. sc '\''
marshExec Tmstring arg _ body = indent 5. ss "maybePeekUTFString ". arg. ss " >>= \\". arg. ss "\' ->".
                               body. sc ' '. arg. sc '\''
marshExec Tboxed  arg n body = indent 5. ss "boxedPre". ss (show n). ss " (castPtr ". arg. ss ") >>= \\". arg. ss "\' ->".
                               body. sc ' '. arg. sc '\''
marshExec Tptr	  arg _ body = body. ss " (castPtr ". arg. sc ')'
marshExec Ttobject arg _ body = indent 5.ss "makeNewGObject (GObject, objectUnrefFromMainloop) (return ". arg. ss ") >>= \\". arg. ss "\' ->".
                               body. ss " (unsafeCastGObject ". arg. ss "\')"
marshExec Tmtobject arg _ body = indent 5.ss "maybeNull (makeNewGObject (GObject, objectUnrefFromMainloop)) (return ". arg. ss ") >>= \\". arg. ss "\' ->".
                               body. ss " (liftM unsafeCastGObject ". arg. ss "\')"
marshExec Tobject arg _ body = indent 5.ss "makeNewGObject (GObject, objectUnref) (return ". arg. ss ") >>= \\". arg. ss "\' ->".
                               body. ss " (unsafeCastGObject ". arg. ss "\')"
marshExec Tmobject arg _ body = indent 5.ss "maybeNull (makeNewGObject (GObject, objectUnref)) (return ". arg. ss ") >>= \\". arg. ss "\' ->".
                               body. ss " (liftM unsafeCastGObject ". arg. ss "\')"

marshRet :: Types -> (ShowS -> ShowS)
marshRet Tunit	 body = body
marshRet Tbool	 body = body
marshRet Tint	 body = body
marshRet Tuint	 body = body
marshRet Tlong	 body = body
marshRet Tulong	 body = body
marshRet Tenum	 body = indent 5. ss "liftM fromEnum $ ". body
marshRet Tflags	 body = indent 5. ss "liftM fromFlags $ ". body
marshRet Tfloat	 body = body
marshRet Tdouble body = body
marshRet Tstring body = body. indent 5. ss ">>= newUTFString"
marshRet Tptr    body = indent 5. ss "liftM castPtr $ ". body
marshRet _       _    = error "Signal handlers cannot return structured types."

#else

marshExec :: Types -> ArgNo -> ShowS
marshExec Tbool	  n = indent 4.ss "let bool".shows n.
		      ss "' = toBool bool".shows n
marshExec Tchar	  n = indent 4.ss "let char".shows n.
		      ss "' = (toEnum.fromEnum) char".shows n
marshExec Tuchar  n = indent 4.ss "let char".shows n.
		      ss "' = (toEnum.fromEnum) char".shows n
marshExec Tint	  n = indent 4.ss "let int".shows n.
		      ss "' = fromIntegral int".shows n
marshExec Tuint	  n = indent 4.ss "let int".shows n.
		      ss "' = fromIntegral int".shows n
marshExec Tlong	  n = indent 4.ss "let long".shows n.
		      ss "' = toInteger long".shows n
marshExec Tulong  n = indent 4.ss "let long".shows n.
		      ss "' = toInteger long".shows n
marshExec Tenum	  n = indent 4.ss "let enum".shows n.
		      ss "' = (toEnum.fromEnum) enum".shows n
marshExec Tflags  n = indent 4.ss "let flags".shows n.
		      ss "' = (toEnum.fromEnum) flags".shows n
marshExec Tfloat  n = indent 4.ss "let float".shows n.
		      ss "' = (fromRational.toRational) float".shows n
marshExec Tdouble n = indent 4.ss "let double".shows n.
		      ss "' = (fromRational.toRational) double".shows n
marshExec Tstring n = indent 4.ss "str".shows n.
		      ss "' <- peekCString str".shows n
marshExec Tmstring n = indent 4.ss "str".shows n.
		      ss "' <- maybePeekCString str".shows n
marshExec Tboxed  n = indent 4.ss "box".shows n.ss "' <- boxedPre".
		      shows n.ss " $ castPtr box".shows n
marshExec Tptr	  n = indent 4.ss "let ptr".shows n.ss "' = castPtr ptr".
		      shows n
marshExec Ttobject n = indent 4.ss "objectRef obj".shows n.
		      indent 4.ss "obj".shows n.
		      ss "' <- liftM (unsafeCastGObject. fst mkGObject) $".
		      indent 5.ss "newForeignPtr obj".shows n.ss " (snd mkGObject)"
marshExec Tobject n = indent 4.ss "objectRef obj".shows n.
		      indent 4.ss "obj".shows n.
		      ss "' <- liftM (unsafeCastGObject. fst mkGObject) $".
		      indent 5.ss "newForeignPtr obj".shows n.ss " (snd mkGObject)"
marshExec _	  _ = id

marshRet :: Types -> ShowS
marshRet Tunit	  = ss "id"
marshRet Tbool	  = ss "fromBool"
marshRet Tint	  = ss "fromIntegral"
marshRet Tuint	  = ss "fromIntegral"
marshRet Tlong	  = ss "fromIntegral"
marshRet Tulong	  = ss "fromIntegral"
marshRet Tenum	  = ss "(toEnum.fromEnum)"
marshRet Tflags	  = ss "fromFlags"
marshRet Tfloat	  = ss "(toRational.fromRational)"
marshRet Tdouble  = ss "(toRational.fromRational)"
marshRet Tptr     = ss "castPtr"
marshRet _  = ss "(error \"Signal handlers cannot return structured types.\")"

#endif

-------------------------------------------------------------------------------
-- generation of parameterized fragments
-------------------------------------------------------------------------------

mkUserType :: Signature -> ShowS
mkUserType (ret,ts) = let
  (str,cs) = foldl (\(str,cs) t -> 
	    let (str',cs') = usertype t cs in (str.str'.ss " -> ",cs'))
	    (sc '(',['a'..]) ts
  (str',_) = usertype ret cs
  str'' = if ' ' `elem` (str' "") then (sc '('.str'.sc ')') else str'
  in str.ss "IO ".str''.sc ')'

mkContext :: Signature -> ShowS
mkContext (ret,ts) = let ctxts = context (ts++[ret]) ['a'..] in
  if null ctxts then ss "GObjectClass obj =>" else sc '('.
    foldl1 (\a b -> a.ss ", ".b) ctxts.ss ", GObjectClass obj) =>"

mkMarshType :: Signature -> [ShowS]
mkMarshType (ret,ts) = marshType (ts++[ret]) ['a'..]
  
mkType sig = let types = mkMarshType sig in
  if null types then id else foldl (.) (indent 1) types

mkMarshArg :: Signature -> [ShowS]
mkMarshArg (ret,ts) = zipWith marshArg (ts++[ret]) [1..]

mkArg sig = foldl (.) (sc ' ') $ mkMarshArg sig

#ifdef USE_GCLOSURE_SIGNALS_IMPL

mkMarshExec :: Signature -> ShowS
mkMarshExec (ret,ts) = foldl (\body marshaler -> marshaler body) (indent 5.ss "user")
                             (paramMarshalers++[returnMarshaler])
  where paramMarshalers = [ marshExec t (nameArg t n) n | (t,n) <- zip ts [1..] ]
        returnMarshaler = marshRet ret

#else

mkMarshExec :: Signature -> ShowS
mkMarshExec (_,ts) = foldl (.) id $ 
		     zipWith marshExec ts [1..]

#endif

mkIdentifier :: Signature -> ShowS
mkIdentifier (ret,[]) = identifier Tunit . ss "__".identifier ret
mkIdentifier (ret,ts) = foldl1 (\a b -> a.sc '_'.b) (map identifier ts).
			ss "__".identifier ret

mkRawtype :: Signature -> ShowS
mkRawtype (ret,ts) = 
  foldl (.) id (map (\ty -> rawtype ty.ss " -> ") ts).
  (case ret of
      Tboxed  -> ss "IO (".rawtype ret.sc ')'
      Tptr    -> ss "IO (".rawtype ret.sc ')'
      Ttobject -> ss "IO (".rawtype ret.sc ')'
      Tmtobject -> ss "IO (".rawtype ret.sc ')'
      Tobject -> ss "IO (".rawtype ret.sc ')'
      Tmobject -> ss "IO (".rawtype ret.sc ')'
      _       -> ss "IO ".rawtype ret)

mkLambdaArgs :: Signature -> ShowS
mkLambdaArgs (_,ts) = foldl (.) id $ 
		      zipWith (\a b -> nameArg a b.sc ' ') ts [1..]

#ifndef USE_GCLOSURE_SIGNALS_IMPL

mkFuncArgs :: Signature -> ShowS
mkFuncArgs (_,ts) = foldl (.) id $ 
		    zipWith (\a b -> sc ' '.nameArg a b.sc '\'') ts [1..]

mkMarshRet :: Signature -> ShowS
mkMarshRet (ret,_) = marshRet ret

#endif

-------------------------------------------------------------------------------
-- start of code generation
-------------------------------------------------------------------------------


usage = do
 hPutStr stderr $
   "Program to generate callback hook for Gtk signals. Usage:\n\n"++
   "HookGenerator [--template=<template-file>] --types=<types-file>\n"++
   "              [--import=<import>]  --modname=<moduleName> > <outFile>\n"++
   "where\n"++
   "  <moduleName>    the module name for <outFile>\n"++
   "  <template-file> a path to the Signal.chs.template file\n"++
   "  <types-file>    a path to a gtkmarshal.list file\n"++
   "  <import>        a module to be imported into the template file\n"
 exitWith $ ExitFailure 1

main = do
  args <- getArgs
  let showHelp = not (null (filter ("-h" `isPrefixOf`) args++
                            filter ("--help" `isPrefixOf`) args)) || null args
  if showHelp then usage else do
  let outModuleName = case map (drop 10) (filter ("--modname=" `isPrefixOf`)  args) of
		        (modName:_) -> modName
  templateFile <- case map (drop 11) (filter ("--template=" `isPrefixOf`)  args) of
		    [tplName] -> return tplName
  		    _ -> getDataFileName "callbackGen/Signal.chs.template"
  typesFile <- case map (drop 8) (filter ("--types=" `isPrefixOf`)  args) of
		 [typName] -> return typName
  		 _ -> usage
  let extraImports = map (drop 9) (filter ("--import=" `isPrefixOf`) args)
  content <- readFile typesFile
  let sigs = parseSignatures content
  template <- readFile templateFile
  putStr $
    templateSubstitute template (\var ->
      case var of
        "MODULE_NAME"    -> ss outModuleName
        "MODULE_EXPORTS" -> genExport sigs
        "MODULE_IMPORTS" -> genImports extraImports
        "MODULE_BODY"    -> foldl (.) id (map generate sigs)
        _ -> error var 
    ) ""

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

-------------------------------------------------------------------------------
-- generate dynamic fragments
-------------------------------------------------------------------------------

genExport :: Signatures -> ShowS
genExport sigs = foldl (.) id (map mkId sigs)
  where
    mkId sig = ss "connect_".mkIdentifier sig.sc ','.indent 1

genImports :: [String] -> ShowS
genImports mods = foldl (.) id (map mkImp mods)
  where
    mkImp m = ss "import " . ss m . indent 0

#ifdef USE_GCLOSURE_SIGNALS_IMPL

generate :: Signature -> ShowS
generate sig = let ident = mkIdentifier sig in
  indent 0.ss "connect_".ident.ss " :: ".
  indent 1.mkContext sig.ss " SignalName ->".
  mkType sig.
  indent 1.ss "ConnectAfter -> obj ->".
  indent 1.mkUserType sig.ss " ->".
  indent 1.ss "IO (ConnectId obj)".
  indent 0.ss "connect_".ident.ss " signal". mkArg sig. ss "after obj user =".
  indent 1.ss "connectGeneric signal after obj action".
  indent 1.ss "where action :: Ptr GObject -> ".mkRawtype sig.
  indent 1.ss "      action _ ".mkLambdaArgs sig. sc '='.
  indent 5.ss "failOnGError $".
  mkMarshExec sig.
  indent 0


#else

generate :: Signature -> ShowS
generate sig = let ident = mkIdentifier sig in
  indent 0.ss "type Tag_".ident.ss " = Ptr () -> ".
  indent 1.mkRawtype sig.
  indent 0.
  indent 0.ss "foreign".ss " import ccall \"wrapper\" ".ss "mkHandler_".ident.ss " ::".
  indent 1.ss "Tag_".ident.ss " -> ".
  indent 1.ss "IO (FunPtr ".ss "Tag_".ident.sc ')'.
  indent 0.
  indent 0.ss "connect_".ident.ss " :: ".
  indent 1.mkContext sig.ss " SignalName ->".
  mkType sig.
  indent 1.ss "ConnectAfter -> obj ->".
  indent 1.mkUserType sig.ss " ->".
  indent 1.ss "IO (ConnectId obj)".
  indent 0.ss "connect_".ident.ss " signal".
  mkArg sig.
  indent 1.ss "after obj user =".
  indent 1.ss "do".
  indent 2.ss "hPtr <- mkHandler_".ident.
  indent 3.ss "(\\_ ".mkLambdaArgs sig.ss "-> failOnGError $ do".
  mkMarshExec sig.
  indent 4.ss "liftM ".mkMarshRet sig.ss " $".
  indent 5.ss "user".mkFuncArgs sig.
  indent 3.sc ')'.
  indent 2.ss "dPtr <- mkFunPtrClosureNotify hPtr".
  indent 2.ss "sigId <- withCString signal $ \\nPtr ->".
  indent 3.ss "withForeignPtr ((unGObject.toGObject) obj) $ \\objPtr ->".
  indent 4.ss "{#call unsafe g_signal_connect_data#} (castPtr objPtr)".
  indent 5.ss "nPtr (castFunPtr hPtr) nullPtr dPtr (fromBool after)".
  indent 2.ss "return $ ConnectId sigId obj".
  indent 0

#endif