[Gtk2hs-commit] gtk2hs/tools/signals HookGenerator.hs,NONE,1.1 Makefile,NONE,1.2 Signal.chs-boot1,NONE,1.1 Signal.chs-boot2,NONE,1.1 gtkmarshal.list,NONE,1.1

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

Update of /cvsroot/gtk2hs/gtk2hs/tools/signals
In directory sc8-pr-cvs1:/tmp/cvs-serv19933/tools/signals

Added Files:
	HookGenerator.hs Makefile Signal.chs-boot1 Signal.chs-boot2 
	gtkmarshal.list 
Log Message:


--- NEW FILE: HookGenerator.hs ---
{-# 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 Char(showLitChar)
import List(nub, partition)
import Maybe(catMaybes)
import System(getArgs, exitWith, ExitCode(..))

-- 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
	   | Tboxed  		-- a struct which is passed by value
	   | Tptr		-- pointer
	   | Tobject		-- foreign with GObjectClass context
	   deriving Eq

type Signature = (Types,[Types])
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
-------------------------------------------------------------------------------
     
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 ('B':'O':'X':'E':'D':xs) = TokType Tboxed:scan xs
scan ('P':'O':'I':'N':'T':'E':'R':xs) = TokType Tptr:scan xs
scan ('O':'B':'J':'E':'C':'T':xs) = TokType Tobject: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 "BYTE"
identifier Tuchar   = ss "UBYTE"
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 Tboxed   = ss "BOXED"
identifier Tptr	    = ss "PTR"
identifier Tobject  = ss "OBJECT"

-- 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 Tboxed   = ss "Ptr ()"
rawtype Tptr	 = ss "Ptr ()"
rawtype Tobject  = ss "Ptr GObject"

-- 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 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 Tboxed   (c:cs) = (sc c,cs)
usertype Tptr	  (c:cs) = (ss "Ptr ".sc c,cs)
usertype Tobject  (c:cs) = (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 (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 (Tobject:ts)  (c:cs) = ss "GObjectClass ".sc c.sc '\'': context ts cs
context (_:ts)	      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)        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 _	  _ = 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 Tboxed   c = ss "box".shows c
nameArg Tptr     c = ss "ptr".shows c
nameArg Tobject  c = ss "obj".shows c


-- 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

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.\")"

-------------------------------------------------------------------------------
-- 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
  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 (.) id $ mkMarshArg sig

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

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).
  ss "IO (".rawtype ret.sc ')'

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

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


usage = do
 putStr $ "Program to generate callback hook for Gtk signals. Usage:\n"++
   "HookGenerator <signatureFile> <bootPath> <outFile> [--broken]\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"++
   "  <outFile>	      is the name and path of the output file.\n"++
   "  --broken	      do not ask for callbacks with more than 4 words\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))

generateHooks :: String -> String -> String -> BrokenSolaris -> IO ()
generateHooks typesFile bootPath outFile brokenSolaris = do
    content <- readFile typesFile
    let sigs = parseSignatures content
    boot1 <- readFile (bootPath++"Signal.chs-boot1")
    boot2 <- readFile (bootPath++"Signal.chs-boot2")
    let result = ss boot1. 
		 genExport sigs.
		 ss boot2.
		 foldl (.) id (map (generate brokenSolaris) sigs)
    writeFile outFile (result "")

    



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

genExport :: Signatures -> ShowS
genExport sigs = foldl (.) id (map mkId sigs)
  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".
#if __GLASGOW_HASKELL__>=504
    ss " import ccall \"wrapper\" ").ss "mkHandler_".ident.ss " ::".
#else
    ss " export dynamic ").ss "mkHandler_".ident.ss " ::".
#endif
  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.
  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 "-> do".
  mkMarshExec sig.
  indent 4.ss "liftM ".mkMarshRet sig.ss " $".
  indent 5.ss "user".mkFuncArgs sig.
  indent 3.sc ')'.
  indent 2.ss "dRef <- newIORef nullFunPtr".
  indent 2.ss "dPtr <- mkDestructor $ do".
  indent 3.ss "freeHaskellFunPtr hPtr".
  indent 3.ss "dPtr <- readIORef dRef".
  indent 3.ss "freeHaskellFunPtr dPtr".
  indent 2.ss "writeIORef dRef dPtr".
  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




--- NEW FILE: Makefile ---
TOP = ../..

include $(TOP)/mk/config.mk

APPNAME = HookGenerator

EXTRA_TARFILES	+= gtkmarshal.list Signal.chs-boot1 Signal.chs-boot2

include $(TOP)/mk/common.mk


--- NEW FILE: Signal.chs-boot1 ---
{-# OPTIONS -cpp #-}
-- -*-haskell-*-
-- ******************** automatically generated file - do not edit ************
--  Callback installers for the GIMP Toolkit (GTK) Binding for Haskell
--
--  Author : Axel Simon
--          
--  Created: 1 July 2000
--
--  Version $Revision: 1.1 $ from $Date: 2003/10/21 23:42:03 $
--
--  Copyright (c) 2000 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
--  * 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).
--
--- DOCU ----------------------------------------------------------------------
--
--  * 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 ----------------------------------------------------------------------
--
--  * Check if we need all prototypes mentioned in gtkmarshal.list.
--
module Signal(
  
--- NEW FILE: Signal.chs-boot2 ---
SignalName,
  ConnectAfter,
  ConnectId,
  disconnect
  ) where

import Monad	(liftM)
import FFI
import LocalData
import GObject	(objectRef, objectUnref)
{#import Hierarchy#}

{#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#}

#if __GLASGOW_HASKELL__>=600

foreign import ccall "wrapper" mkDestructor :: IO () -> IO GClosureNotify

#else

foreign export dynamic mkDestructor :: IO () -> IO GClosureNotify

#endif

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.


--- NEW FILE: gtkmarshal.list ---
# see glib-genmarshal(1) for a detailed description of the file format,
# possible parameter types are:
#   VOID        indicates   no   return   type,  or  no  extra
#               parameters. if VOID is used as  the  parameter
#               list, no additional parameters may be present.
#   BOOLEAN     for boolean types (gboolean)
#   CHAR        for signed char types (gchar)
#   UCHAR       for unsigned char types (guchar)
#   INT         for signed integer types (gint)
#   UINT        for unsigned integer types (guint)
#   LONG        for signed long integer types (glong)
#   ULONG       for unsigned long integer types (gulong)
#   ENUM        for enumeration types (gint)
#   FLAGS       for flag enumeration types (guint)
#   FLOAT       for single-precision float types (gfloat)
#   DOUBLE      for double-precision float types (gdouble)
#   STRING      for string types (gchar*)
#   BOXED       for boxed (anonymous but reference counted) types (GBoxed*)
#   POINTER     for anonymous pointer types (gpointer)
#   OBJECT      for GObject or derived types (GObject*)
#   NONE        deprecated alias for VOID
#   BOOL        deprecated alias for BOOLEAN

BOOLEAN:BOXED
BOOLEAN:BOXED,BOXED
BOOLEAN:OBJECT,INT,INT,UINT
BOOLEAN:OBJECT,STRING,STRING,BOXED
BOOLEAN:OBJECT,BOXED,BOXED
BOOLEAN:VOID
BOOLEAN:BOOLEAN
ENUM:ENUM
NONE:ENUM,ENUM
INT:POINTER
NONE:BOOL
NONE:INT
NONE:INT,INT
NONE:NONE
NONE:POINTER
NONE:STRING,INT,POINTER
VOID:BOOLEAN
VOID:BOXED
VOID:BOXED,BOXED
VOID:BOXED,BOXED,BOXED,BOXED
VOID:BOXED,BOXED,POINTER
VOID:BOXED,POINTER
VOID:BOXED,OBJECT
VOID:BOXED,STRING,INT
VOID:BOXED,UINT
VOID:BOXED,UINT,FLAGS
VOID:BOXED,UINT,UINT
VOID:ENUM
VOID:ENUM,FLOAT
VOID:ENUM,FLOAT,BOOL
VOID:ENUM,INT
VOID:ENUM,INT,BOOLEAN
VOID:INT
VOID:INT,INT
VOID:INT,INT,BOXED
VOID:INT,INT,INT
VOID:OBJECT
VOID:OBJECT,BOOLEAN
VOID:OBJECT,BOXED,BOXED
VOID:OBJECT,BOXED,UINT,UINT
VOID:OBJECT,INT,INT
VOID:OBJECT,INT,INT,BOXED,UINT,UINT
VOID:OBJECT,OBJECT
VOID:OBJECT,STRING,STRING
VOID:OBJECT,UINT
VOID:POINTER
VOID:POINTER,INT
VOID:POINTER,POINTER,POINTER
VOID:POINTER,UINT
VOID:STRING
VOID:STRING,INT,POINTER
VOID:UINT,BOXED,UINT,FLAGS,FLAGS
VOID:UINT,STRING
VOID:VOID
# This marshaller is necessary to marshal a string with explicit length in a
# callback "text-insert" in TextBuffer.
VOID:BOXED,POINTER,INT
# This one is needed in TextView:
VOID:INT,BOOL
# This is for the "edited" signal in CellRendererText:
VOID:POINTER,STRING