[Gtk2hs-commit] gtk2hs/tools/callbackGen HookGenerator.hs,1.5,1.6 Signal.chs.template,1.1,1.2

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

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

Modified Files:
	HookGenerator.hs Signal.chs.template 
Log Message:
Modify the callback marshaler code generator to generate marshalers that use
	the new GClosure-based marshaling system.

Change the signals template so that it imports the System.Glib.Signals code
	rather than defining everything locally.

Also parameterise by the module name so we can have more than a single global
	Signals module.

The code dealing with the Sparc 4 word marshaling restriction has been dropped
	as it is no longer a problem.


Index: Signal.chs.template
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/callbackGen/Signal.chs.template,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- Signal.chs.template	23 Mar 2005 19:34:55 -0000	1.1
+++ Signal.chs.template	6 Apr 2005 20:47:00 -0000	1.2
@@ -1,4 +1,3 @@
-{-# OPTIONS -cpp #-}
 -- -*-haskell-*-
 -- -------------------- automatically generated file - do not edit ------------
 --  Callback installers for the GIMP Toolkit (GTK) Binding for Haskell
@@ -23,74 +22,39 @@
 --
 -- #hide
 
--- |
---    These functions are used to connect signals to widgets. They are auto-
---    matically created through HookGenerator.hs which takes a list of possible
---    function signatures that are included in the GTK sources 
---    (gtkmarshal.list).
---
---  * The object system in the second version of GTK is based on GObject from
---    GLIB. This base class is rather primitive in that it only implements
---    ref and unref methods (and others that are not interesting to us). If
---    the marshall list mentions OBJECT it refers to an instance of this 
---    GObject which is automatically wrapped with a ref and unref call.
---    Structures which are not derived from GObject have to be passed as
---    BOXED which gives the signal connect function a possiblity to do the
---    conversion into a proper ForeignPtr type. In special cases the signal
---    connect function use a PTR type which will then be mangled in the
---    user function directly. The latter is needed if a signal delivers a
---    pointer to a string and its length in a separate integer.
---
--- TODO
+-- | These functions are used to connect signals to widgets. They are auto-
+-- matically created through HookGenerator.hs which takes a list of possible
+-- function signatures that are included in the GTK sources (gtkmarshal.list).
 --
---  * Check if we need all prototypes mentioned in gtkmarshal.list.
+-- The object system in the second version of GTK is based on GObject from
+-- GLIB. This base class is rather primitive in that it only implements
+-- ref and unref methods (and others that are not interesting to us). If
+-- the marshall list mentions OBJECT it refers to an instance of this 
+-- GObject which is automatically wrapped with a ref and unref call.
+-- Structures which are not derived from GObject have to be passed as
+-- BOXED which gives the signal connect function a possiblity to do the
+-- conversion into a proper ForeignPtr type. In special cases the signal
+-- connect function use a PTR type which will then be mangled in the
+-- user function directly. The latter is needed if a signal delivers a
+-- pointer to a string and its length in a separate integer.
 --
-module Graphics.UI.Gtk.Signals (
+module @MODULE_NAME@ (
+  module System.Glib.Signals,
 
-  @MODULE_EXPORTS@SignalName,
-  ConnectAfter,
-  ConnectId,
-  disconnect
+  @MODULE_EXPORTS@
   ) where
 
 import Monad	(liftM)
-import Data.IORef
 
 import System.Glib.FFI
-import System.Glib.GError   (failOnGError)
-{#import System.Glib.GObject#} hiding (mkFunPtrDestructor)
+import System.Glib.UTFString   (peekUTFString, newUTFString)
+import System.Glib.GError      (failOnGError)
+{#import System.Glib.Signals#}
+{#import System.Glib.GObject#}
 
 {#context lib="gtk" prefix="gtk" #}
 
 
--- Specify if the handler is to run before (False) or after (True) the
--- default handler.
-
-type ConnectAfter = Bool
-
-type SignalName = String
-
-data GObjectClass o => ConnectId o = ConnectID {#type gulong#} o
-
-{#pointer GClosureNotify#}
-
-foreign import ccall "wrapper" mkDestructor :: IO () -> IO GClosureNotify
-
-mkFunPtrDestructor :: FunPtr a -> IO GClosureNotify
-mkFunPtrDestructor hPtr = do
-  dRef <- newIORef nullFunPtr
-  dPtr <- mkDestructor $ do
-    freeHaskellFunPtr hPtr
-    dPtr <- readIORef dRef
-    freeHaskellFunPtr dPtr
-  writeIORef dRef dPtr
-  return dPtr
-
-disconnect :: GObjectClass obj => ConnectId obj -> IO ()
-disconnect (ConnectID handler obj) =
-  withForeignPtr  ((unGObject.toGObject) obj) $ \objPtr ->
-  {#call unsafe g_signal_handler_disconnect#} (castPtr objPtr) handler
-
 -- Here are the generators that turn a Haskell function into
 -- a C function pointer. The fist Argument is always the widget,
 -- the last one is the user g_pointer. Both are ignored.

Index: HookGenerator.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/callbackGen/HookGenerator.hs,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- HookGenerator.hs	23 Mar 2005 19:34:56 -0000	1.5
+++ HookGenerator.hs	6 Apr 2005 20:47:00 -0000	1.6
@@ -32,38 +32,6 @@
 type Signatures = [Signature]
 
 -------------------------------------------------------------------------------
--- Handle broken Solaris
--------------------------------------------------------------------------------
-
--- If this type of arguement is True then we are compiling for
--- Sparc Solaris for which ghc does not know how to generate dynamic callbacks
--- with more than four arguments.
-type BrokenSolaris = Bool
-
--- Each callback is given a pointer to the object is was emitted from.
--- We need to take this into account when we talk about 4 arguments.
-fakeSignature :: BrokenSolaris -> Signature -> Bool
-fakeSignature brokenSolaris (_,args) = brokenSolaris &&
-				       sum (map sizeOf args) > 3
-  where
-    sizeOf Tunit   = 0
-    sizeOf Tbool   = 1
-    sizeOf Tchar   = 1
-    sizeOf Tuchar  = 1
-    sizeOf Tint    = 1
-    sizeOf Tuint   = 1
-    sizeOf Tlong   = 2
-    sizeOf Tulong  = 1
-    sizeOf Tenum   = 1
-    sizeOf Tflags  = 1
-    sizeOf Tfloat  = 2
-    sizeOf Tdouble = 4
-    sizeOf Tstring = 1
-    sizeOf Tboxed  = 1
-    sizeOf Tptr	   = 1
-    sizeOf Tobject = 1
-
--------------------------------------------------------------------------------
 -- Parsing
 -------------------------------------------------------------------------------
      
@@ -150,8 +118,8 @@
 identifier :: Types -> ShowS
 identifier Tunit    = ss "NONE"
 identifier Tbool    = ss "BOOL"
-identifier Tchar    = ss "BYTE"
-identifier Tuchar   = ss "UBYTE"
+identifier Tchar    = ss "CHAR"
+identifier Tuchar   = ss "UCHAR"
 identifier Tint	    = ss "INT"
 identifier Tuint    = ss "WORD"
 identifier Tlong    = ss "LONG"
@@ -168,17 +136,17 @@
 -- 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 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 Tboxed   = ss "Ptr ()"
 rawtype Tptr	 = ss "Ptr ()"
@@ -187,18 +155,18 @@
 -- The possibly polymorphic type which 
 usertype :: Types -> [Char] -> (ShowS,[Char])
 usertype Tunit	  cs = (ss "()",cs)
-usertype Tbool	  cs = (ss "Bool",cs)
-usertype Tchar	  cs = (ss "Char",cs)
-usertype Tuchar	  cs = (ss "Int",cs)
-usertype Tint	  (c:cs) = (sc c,cs) 
-usertype Tuint	  (c:cs) = (sc c,cs)
-usertype Tlong	  cs = (ss "Integer",cs)
-usertype Tulong	  cs = (ss "Integer",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	  cs = (ss "Float",cs)
-usertype Tdouble  cs = (ss "Double",cs)
-usertype Tstring  cs = (ss "String",cs)
+usertype Tfloat	  (c:cs) = (ss "Float",cs)
+usertype Tdouble  (c:cs) = (ss "Double",cs)
+usertype Tstring  (c:cs) = (ss "String",cs)
 usertype Tboxed   (c:cs) = (sc c,cs)
 usertype Tptr	  (c:cs) = (ss "Ptr ".sc c,cs)
 usertype Tobject  (c:cs) = (sc c.sc '\'',cs)
@@ -210,16 +178,10 @@
 --   to the context. Grrr.
 --
 context :: [Types] -> [Char] -> [ShowS]
-context (Tint:ts)     (c:cs) = ss "Num ".sc c.ss ", Integral ".sc c: 
-			       context ts cs
-context (Tuint:ts)    (c:cs) = ss "Num ".sc c: context ts cs
 context (Tenum:ts)    (c:cs) = ss "Enum ".sc c: context ts cs
-context (Tflags:ts)   cs     = context (Tenum:ts) cs
-context (Tboxed:ts)   (c:cs) = context ts cs
-context (Tptr:ts)     (c:cs) = --ss "Storable ".sc c:
-			       context ts cs
+context (Tflags:ts)   (c:cs) = ss "Flags ".sc c: context ts cs
 context (Tobject:ts)  (c:cs) = ss "GObjectClass ".sc c.sc '\'': context ts cs
-context (_:ts)	      cs     = context ts cs
+context (_:ts)	      (c:cs) = context ts cs
 context []	      _	     = []
 
 
@@ -229,32 +191,19 @@
 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 ") ->":
+				 sc c.ss ") -> ":
 				 marshType ts cs
 marshType (Tptr:ts)	(c:cs) = marshType ts cs
 marshType (Tobject:ts)	(c:cs) = marshType ts cs
-marshType (_:ts)        cs     = marshType ts cs
+marshType (_:ts)        (c:cs) = marshType ts cs
 marshType []		_      = []
 
-tyVarMapping :: [Types] -> [Char]
-tyVarMapping ts = tvm ts 'a'
-  where
-    tvm (Tint:ts)      c = c:tvm ts (succ c)
-    tvm (Tuint:ts)     c = c:tvm ts (succ c)	
-    tvm (Tenum:ts)     c = c:tvm ts (succ c)
-    tvm (Tflags:ts)    c = c:tvm ts (succ c)
-    tvm (Tboxed:ts)    c = c:tvm ts (succ c)
-    tvm (Tptr:ts)      c = c:tvm ts (succ c)
-    tvm (Tobject:ts)   c = c:tvm ts (succ c)
-    tvm (_:ts)	       c = c:tvm ts c
-    tvm _	       c = [] 
-
 -- arguments for user defined marshalling
 
 type ArgNo = Int
 
 marshArg :: Types -> ArgNo -> ShowS
-marshArg Tboxed   c = indent 1.ss "boxedPre".shows c.sc ' '
+marshArg Tboxed   c = ss "boxedPre".shows c.sc ' '
 marshArg _	  _ = id
 
 -- generate a name for every passed argument,
@@ -280,54 +229,40 @@
 -- describe marshalling between the data passed from the registered function
 -- to the user supplied Haskell function
 
-marshExec :: Types -> (Char,ArgNo) -> ShowS
-marshExec Tbool	   (c,n) = indent 4.ss "let bool".shows n.
-		    ss "' = toBool bool".shows n
-marshExec Tchar	   (c,n) = indent 4.ss "let char".shows n.
-		    ss "' = (toEnum.fromEnum) char".shows n
-marshExec Tuchar   (c,n) = indent 4.ss "let char".shows n.
-		    ss "' = (toEnum.fromEnum) char".shows n
-marshExec Tint	   (c,n) = indent 4.ss "let int".shows n.
-		    ss "' = fromIntegral int".shows n
-marshExec Tuint	   (c,n) = indent 4.ss "let int".shows n.
-		    ss "' = fromIntegral int".shows n
-marshExec Tlong	   (c,n) = indent 4.ss "let long".shows n.
-		    ss "' = toInteger long".shows n
-marshExec Tulong   (c,n) = indent 4.ss "let long".shows n.
-		    ss "' = toInteger long".shows n
-marshExec Tenum	   (c,n) = indent 4.ss "let enum".shows n.
-		    ss "' = (toEnum.fromEnum) enum".shows n
-marshExec Tflags   (c,n) = indent 4.ss "let flags".shows n.
-		    ss "' = (toEnum.fromEnum) flags".shows n
-marshExec Tfloat   (c,n) = indent 4.ss "let float".shows n.
-		    ss "' = (fromRational.toRational) float".shows n
-marshExec Tdouble   (c,n) = indent 4.ss "let double".shows n.
-		    ss "' = (fromRational.toRational) double".shows n
-marshExec Tstring  (c,n) = indent 4.ss "str".shows n.
-		    ss "' <- peekCString str".shows n
-marshExec Tboxed   (c,n) = indent 4.ss "box".shows n.ss "' <- boxedPre".
-		    shows n.ss " $ castPtr box".shows n
-marshExec Tptr	   (c,n) = indent 4.ss "let ptr".shows n.ss "' = castPtr ptr".
-		    shows n
-marshExec Tobject  (c,n) = indent 4.ss "objectRef obj".shows n.
-		    indent 4.ss "obj".shows n.
-		    ss "' <- liftM (fromGObject.mkGObject) $".
-		    indent 5.ss "newForeignPtr obj".shows n.
-		    ss " (objectUnref obj".shows n.sc ')'
-marshExec _	   _     = id
+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 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 Tobject arg _ body = indent 5.ss "makeNewGObject mkGObject (return ". arg. ss ") >>= \\". arg. ss "\' ->".
+                               body. ss " (fromGObject ". arg. ss "\')"
+--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 _  = ss "(error \"Signal handlers cannot return structured types.\")"
+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 _       _    = error "Signal handlers cannot return structured types."
 
 -------------------------------------------------------------------------------
 -- generation of parameterized fragments
@@ -355,11 +290,13 @@
 mkMarshArg :: Signature -> [ShowS]
 mkMarshArg (ret,ts) = zipWith marshArg (ts++[ret]) [1..]
 
-mkArg sig = foldl (.) id $ mkMarshArg sig
+mkArg sig = foldl (.) (sc ' ') $ mkMarshArg sig
 
 mkMarshExec :: Signature -> ShowS
-mkMarshExec (_,ts) = foldl (.) id $ 
-		     zipWith marshExec ts (zip (tyVarMapping ts) [1..])
+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
 
 mkIdentifier :: Signature -> ShowS
 mkIdentifier (ret,[]) = identifier Tunit . ss "__".identifier ret
@@ -369,18 +306,18 @@
 mkRawtype :: Signature -> ShowS
 mkRawtype (ret,ts) = 
   foldl (.) id (map (\ty -> rawtype ty.ss " -> ") ts).
-  ss "IO (".rawtype ret.sc ')'
+  (case ret of
+      Tboxed  -> ss "IO (".rawtype ret.sc ')'
+      Tptr    -> ss "IO (".rawtype ret.sc ')'
+      Tobject -> 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..]
 
-mkFuncArgs :: Signature -> ShowS
-mkFuncArgs (_,ts) = foldl (.) id $ 
-		    zipWith (\a b -> sc ' '.nameArg a b.sc '\'') ts [1..]
-
-mkMarshRet :: Signature -> ShowS
-mkMarshRet (ret,_) = marshRet ret
+--mkMarshRet :: Signature -> ShowS
+--mkMarshRet (ret,_) = marshRet ret
 
 -------------------------------------------------------------------------------
 -- start of code generation
@@ -389,35 +326,31 @@
 
 usage = do
  putStr $ "Program to generate callback hook for Gtk signals. Usage:\n"++
-   "HookGenerator <signatureFile> <bootPath> <outFile> [--broken]\n"++
+   "HookGenerator <signatureFile> <templateFile> <outFile> <moduleName>\n"++
    "where\n"++
    "  <signatureFile> is gtkmarshal.list from the the source Gtk+ tree\n"++
-   "  <bootPath>      the path where Signal.chs-boot? file can be found\n"++
+   "  <templateFile>  the name and path of the Signal.chs.template file\n"++
    "  <outFile>	      is the name and path of the output file.\n"++
-   "  --broken	      do not ask for callbacks with more than 4 words\n"
+   "  <moduleName>    the module name for <outFile>\n"
  exitWith $ ExitFailure 1
 
 main = do
   args <- getArgs
-  if (length args<3 || length args>4) then usage else do
-    let (br,[typesFile, bootPath, outFile]) = partition (=="--broken") args
-    let bootPath' = case reverse bootPath of
-	              [] -> "./"
-		      ('/':_) -> bootPath
-		      ('\\':_) -> bootPath
-		      _ -> bootPath++"/"
-    generateHooks typesFile bootPath' outFile (not (null br))
+  if (length args /= 4) then usage else do
+    let [typesFile, templateFile, outFile, outModuleName] = args
+    generateHooks typesFile templateFile outFile outModuleName
 
-generateHooks :: String -> String -> String -> BrokenSolaris -> IO ()
-generateHooks typesFile bootPath outFile brokenSolaris = do
+generateHooks :: String -> String -> String -> String -> IO ()
+generateHooks typesFile templateFile outFile outModuleName = do
     content <- readFile typesFile
     let sigs = parseSignatures content
-    template <- readFile (bootPath++"Signal.chs.template")
+    template <- readFile templateFile
     writeFile outFile $
       templateSubstitute template (\var ->
         case var of
+	  "MODULE_NAME"    -> ss outModuleName
           "MODULE_EXPORTS" -> genExport sigs
-          "MODULE_BODY"    -> foldl (.) id (map (generate brokenSolaris) sigs)
+          "MODULE_BODY"    -> foldl (.) id (map generate sigs)
           _ -> error var 
       ) ""
 
@@ -438,43 +371,19 @@
   where
     mkId sig = ss "connect_".mkIdentifier sig.sc ','.indent 1
 
-generate :: BrokenSolaris -> Signature -> ShowS
-generate bs sig = let ident = mkIdentifier sig in
-  indent 0.ss "type Tag_".ident.ss " = Ptr () -> ".
-  indent 1.mkRawtype sig.
-  indent 0.
-  (if fakeSignature bs sig then id else 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 ')'.
-  (if fakeSignature bs sig then 
-  indent 0.ss "mkHandler_".ident.ss " _ =".
-  indent 1.ss "error \"Callbacks of signature ".ident.ss "\\n\\".
-  indent 1.ss "\\are not supported on this architecture.\"" else id).
-  indent 0.
+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.
-  indent 1.ss "after obj user =".
-  indent 1.ss "do".
-  indent 2.ss "hPtr <- mkHandler_".ident.
-  indent 3.ss "(\\_ ".mkLambdaArgs sig.ss "-> failOnGError $ do".
+  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 4.ss "liftM ".mkMarshRet sig.ss " $".
-  indent 5.ss "user".mkFuncArgs sig.
-  indent 3.sc ')'.
-  indent 2.ss "dPtr <- mkFunPtrDestructor 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 5.mkMarshRet sig. ss "user"
   indent 0
-
-
-