{-# LANGUAGE 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 HookGenerator(hookGen) where

import Data.Char   (showLitChar)
import Data.List   (nub, isPrefixOf)
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
           | Tgstring
           | Tmgstring
           | 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 Types -> Types -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Types -> Types -> Bool
$c/= :: Types -> Types -> Bool
== :: Types -> Types -> Bool
$c== :: Types -> Types -> Bool
Eq

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

-------------------------------------------------------------------------------
-- Parsing
-------------------------------------------------------------------------------

parseSignatures :: String -> Signatures
parseSignatures :: String -> Signatures
parseSignatures String
content = (forall a. Eq a => [a] -> [a]
nubforall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> [Token] -> Signatures
parseSig Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> [Token]
scan) String
content

data Token = TokColon
           | TokType Types
           | TokComma
           | TokEOL

instance Show Token where
  showsPrec :: Int -> Token -> ShowS
showsPrec Int
_ Token
TokColon = forall a. Show a => a -> ShowS
shows String
":"
  showsPrec Int
_ (TokType Types
_) = forall a. Show a => a -> ShowS
shows String
"<type>"
  showsPrec Int
_ Token
TokComma = forall a. Show a => a -> ShowS
shows String
","
  showsPrec Int
_ Token
TokEOL = forall a. Show a => a -> ShowS
shows String
"<EOL>"

parseSig :: Int -> [Token] -> Signatures
parseSig :: Int -> [Token] -> Signatures
parseSig Int
l [] = []
parseSig Int
l (Token
TokEOL: [Token]
rem) = Int -> [Token] -> Signatures
parseSig (Int
lforall a. Num a => a -> a -> a
+Int
1) [Token]
rem
parseSig Int
l (TokType Types
ret: Token
TokColon: TokType Types
Tunit:[Token]
rem) =
  (Types
ret,[])forall a. a -> [a] -> [a]
:Int -> [Token] -> Signatures
parseSig Int
l [Token]
rem
parseSig Int
l (TokType Types
ret: Token
TokColon: [Token]
rem) =
  let ([Types]
args,[Token]
rem') = Int -> [Token] -> ([Types], [Token])
parseArg Int
l [Token]
rem in
  (Types
ret,[Types]
args)forall a. a -> [a] -> [a]
: Int -> [Token] -> Signatures
parseSig (Int
lforall a. Num a => a -> a -> a
+Int
1) [Token]
rem'
parseSig Int
l [Token]
rem = forall a. HasCallStack => String -> a
error (String
"parse error on line "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show Int
lforall a. [a] -> [a] -> [a]
++
                       String
": expected type and colon, found\n"forall a. [a] -> [a] -> [a]
++
                       forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Show a => a -> String
show (forall a. Int -> [a] -> [a]
take Int
5 [Token]
rem))

parseArg :: Int -> [Token] -> ([Types],[Token])
parseArg :: Int -> [Token] -> ([Types], [Token])
parseArg Int
l [TokType Types
ty] = ([Types
ty],[])
parseArg Int
l (TokType Types
ty: Token
TokEOL:[Token]
rem) = ([Types
ty],[Token]
rem)
parseArg Int
l (TokType Types
ty: Token
TokComma:[Token]
rem) =
  let ([Types]
args,[Token]
rem') = Int -> [Token] -> ([Types], [Token])
parseArg Int
l [Token]
rem in
  (Types
tyforall a. a -> [a] -> [a]
:[Types]
args, [Token]
rem')
parseArg Int
l [Token]
rem = forall a. HasCallStack => String -> a
error (String
"parse error on line "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show Int
lforall a. [a] -> [a] -> [a]
++String
": expected type"forall a. [a] -> [a] -> [a]
++
                        String
" followed by comma or EOL, found\n "forall a. [a] -> [a] -> [a]
++
                       forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Show a => a -> String
show (forall a. Int -> [a] -> [a]
take Int
5 [Token]
rem))

scan :: String -> [Token]
scan :: String -> [Token]
scan String
"" = []
scan (Char
'#':String
xs) = (String -> [Token]
scanforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/=Char
'\n'))  String
xs
scan (Char
'\n':String
xs) = Token
TokEOLforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
' ':String
xs) = String -> [Token]
scan String
xs
scan (Char
'\t':String
xs) = String -> [Token]
scan String
xs
scan (Char
':':String
xs) = Token
TokColonforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
',':String
xs) = Token
TokCommaforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'V':Char
'O':Char
'I':Char
'D':String
xs) = Types -> Token
TokType Types
Tunitforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'B':Char
'O':Char
'O':Char
'L':Char
'E':Char
'A':Char
'N':String
xs) = Types -> Token
TokType Types
Tboolforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'C':Char
'H':Char
'A':Char
'R':String
xs) = Types -> Token
TokType Types
Tcharforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'U':Char
'C':Char
'H':Char
'A':Char
'R':String
xs) = Types -> Token
TokType Types
Tucharforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'I':Char
'N':Char
'T':String
xs) = Types -> Token
TokType Types
Tintforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'U':Char
'I':Char
'N':Char
'T':String
xs) = Types -> Token
TokType Types
Tuintforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'L':Char
'O':Char
'N':Char
'G':String
xs) = Types -> Token
TokType Types
Tuintforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'U':Char
'L':Char
'O':Char
'N':Char
'G':String
xs) = Types -> Token
TokType Types
Tulongforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'E':Char
'N':Char
'U':Char
'M':String
xs) = Types -> Token
TokType Types
Tenumforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'F':Char
'L':Char
'A':Char
'G':Char
'S':String
xs) = Types -> Token
TokType Types
Tflagsforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'F':Char
'L':Char
'O':Char
'A':Char
'T':String
xs) = Types -> Token
TokType Types
Tfloatforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'D':Char
'O':Char
'U':Char
'B':Char
'L':Char
'E':String
xs) = Types -> Token
TokType Types
Tdoubleforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'S':Char
'T':Char
'R':Char
'I':Char
'N':Char
'G':String
xs) = Types -> Token
TokType Types
Tstringforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'M':Char
'S':Char
'T':Char
'R':Char
'I':Char
'N':Char
'G':String
xs) = Types -> Token
TokType Types
Tmstringforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'G':Char
'L':Char
'I':Char
'B':Char
'S':Char
'T':Char
'R':Char
'I':Char
'N':Char
'G':String
xs) = Types -> Token
TokType Types
Tgstringforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'M':Char
'G':Char
'L':Char
'I':Char
'B':Char
'S':Char
'T':Char
'R':Char
'I':Char
'N':Char
'G':String
xs) = Types -> Token
TokType Types
Tmgstringforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'B':Char
'O':Char
'X':Char
'E':Char
'D':String
xs) = Types -> Token
TokType Types
Tboxedforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'P':Char
'O':Char
'I':Char
'N':Char
'T':Char
'E':Char
'R':String
xs) = Types -> Token
TokType Types
Tptrforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'T':Char
'O':Char
'B':Char
'J':Char
'E':Char
'C':Char
'T':String
xs) = Types -> Token
TokType Types
Ttobjectforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'M':Char
'T':Char
'O':Char
'B':Char
'J':Char
'E':Char
'C':Char
'T':String
xs) = Types -> Token
TokType Types
Tmtobjectforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'O':Char
'B':Char
'J':Char
'E':Char
'C':Char
'T':String
xs) = Types -> Token
TokType Types
Tobjectforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'M':Char
'O':Char
'B':Char
'J':Char
'E':Char
'C':Char
'T':String
xs) = Types -> Token
TokType Types
Tmobjectforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'N':Char
'O':Char
'N':Char
'E':String
xs) = Types -> Token
TokType Types
Tunitforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'B':Char
'O':Char
'O':Char
'L':String
xs) = Types -> Token
TokType Types
Tboolforall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan String
str = forall a. HasCallStack => String -> a
error (String
"Invalid character in input file:\n"forall a. [a] -> [a] -> [a]
++
           forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> ShowS
showLitChar) String
"") (forall a. Int -> [a] -> [a]
take Int
5 String
str))


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

ss :: String -> ShowS
ss = String -> ShowS
showString
sc :: Char -> ShowS
sc = Char -> ShowS
showChar

indent :: Int -> ShowS
indent :: Int -> ShowS
indent Int
c = String -> ShowS
ss (String
"\n"forall a. [a] -> [a] -> [a]
++forall a. Int -> a -> [a]
replicate (Int
2forall a. Num a => a -> a -> a
*Int
c) Char
' ')

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

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

#ifdef USE_GCLOSURE_SIGNALS_IMPL

-- The monomorphic type which is used to export the function signature.
rawtype :: Types -> ShowS
rawtype :: Types -> ShowS
rawtype Types
Tunit    = String -> ShowS
ss String
"()"
rawtype Types
Tbool    = String -> ShowS
ss String
"Bool"
rawtype Types
Tchar    = String -> ShowS
ss String
"Char"
rawtype Types
Tuchar   = String -> ShowS
ss String
"Char"
rawtype Types
Tint     = String -> ShowS
ss String
"Int"
rawtype Types
Tuint    = String -> ShowS
ss String
"Word"
rawtype Types
Tlong    = String -> ShowS
ss String
"Int"
rawtype Types
Tulong   = String -> ShowS
ss String
"Word"
rawtype Types
Tenum    = String -> ShowS
ss String
"Int"
rawtype Types
Tflags   = String -> ShowS
ss String
"Word"
rawtype Types
Tfloat   = String -> ShowS
ss String
"Float"
rawtype Types
Tdouble  = String -> ShowS
ss String
"Double"
rawtype Types
Tstring  = String -> ShowS
ss String
"CString"
rawtype Types
Tmstring  = String -> ShowS
ss String
"CString"
rawtype Types
Tgstring  = String -> ShowS
ss String
"CString"
rawtype Types
Tmgstring  = String -> ShowS
ss String
"CString"
rawtype Types
Tboxed   = String -> ShowS
ss String
"Ptr ()"
rawtype Types
Tptr     = String -> ShowS
ss String
"Ptr ()"
rawtype Types
Ttobject  = String -> ShowS
ss String
"Ptr GObject"
rawtype Types
Tmtobject  = String -> ShowS
ss String
"Ptr GObject"
rawtype Types
Tobject  = String -> ShowS
ss String
"Ptr GObject"
rawtype Types
Tmobject  = String -> ShowS
ss String
"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 Tgstring  = ss "CString"
rawtype Tmgstring  = 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 :: Types -> String -> (ShowS, String)
usertype Types
Tunit    String
cs = (String -> ShowS
ss String
"()",String
cs)
usertype Types
Tbool    (Char
c:String
cs) = (String -> ShowS
ss String
"Bool",String
cs)
usertype Types
Tchar    (Char
c:String
cs) = (String -> ShowS
ss String
"Char",String
cs)
usertype Types
Tuchar   (Char
c:String
cs) = (String -> ShowS
ss String
"Char",String
cs)
usertype Types
Tint     (Char
c:String
cs) = (String -> ShowS
ss String
"Int",String
cs)
usertype Types
Tuint    (Char
c:String
cs) = (String -> ShowS
ss String
"Word",String
cs)
usertype Types
Tlong    (Char
c:String
cs) = (String -> ShowS
ss String
"Int",String
cs)
usertype Types
Tulong   (Char
c:String
cs) = (String -> ShowS
ss String
"Int",String
cs)
usertype Types
Tenum    (Char
c:String
cs) = (Char -> ShowS
sc Char
c,String
cs)
usertype Types
Tflags   String
cs = Types -> String -> (ShowS, String)
usertype Types
Tenum String
cs
usertype Types
Tfloat   (Char
c:String
cs) = (String -> ShowS
ss String
"Float",String
cs)
usertype Types
Tdouble  (Char
c:String
cs) = (String -> ShowS
ss String
"Double",String
cs)
usertype Types
Tstring  (Char
c:String
cs) = (String -> ShowS
ss String
"String",String
cs)
usertype Types
Tmstring  (Char
c:String
cs) = (String -> ShowS
ss String
"Maybe String",String
cs)
usertype Types
Tgstring  (Char
c:String
cs) = (Char -> ShowS
sc Char
cforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\'',String
cs)
usertype Types
Tmgstring  (Char
c:String
cs) = (String -> ShowS
ss String
"Maybe "forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\'',String
cs)
usertype Types
Tboxed   (Char
c:String
cs) = (Char -> ShowS
sc Char
c,String
cs)
usertype Types
Tptr     (Char
c:String
cs) = (String -> ShowS
ss String
"Ptr "forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
c,String
cs)
usertype Types
Ttobject  (Char
c:String
cs) = (Char -> ShowS
sc Char
cforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\'',String
cs)
usertype Types
Tmtobject  (Char
c:String
cs) = (String -> ShowS
ss String
"Maybe "forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\'',String
cs)
usertype Types
Tobject  (Char
c:String
cs) = (Char -> ShowS
sc Char
cforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\'',String
cs)
usertype Types
Tmobject  (Char
c:String
cs) = (String -> ShowS
ss String
"Maybe "forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\'',String
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 :: [Types] -> String -> [ShowS]
context (Types
Tenum:[Types]
ts)    (Char
c:String
cs) = String -> ShowS
ss String
"Enum "forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cforall a. a -> [a] -> [a]
: [Types] -> String -> [ShowS]
context [Types]
ts String
cs
context (Types
Tflags:[Types]
ts)   (Char
c:String
cs) = String -> ShowS
ss String
"Flags "forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cforall a. a -> [a] -> [a]
: [Types] -> String -> [ShowS]
context [Types]
ts String
cs
context (Types
Ttobject:[Types]
ts)  (Char
c:String
cs) = String -> ShowS
ss String
"GObjectClass "forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\''forall a. a -> [a] -> [a]
: [Types] -> String -> [ShowS]
context [Types]
ts String
cs
context (Types
Tmtobject:[Types]
ts)  (Char
c:String
cs) = String -> ShowS
ss String
"GObjectClass "forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\''forall a. a -> [a] -> [a]
: [Types] -> String -> [ShowS]
context [Types]
ts String
cs
context (Types
Tobject:[Types]
ts)  (Char
c:String
cs) = String -> ShowS
ss String
"GObjectClass "forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\''forall a. a -> [a] -> [a]
: [Types] -> String -> [ShowS]
context [Types]
ts String
cs
context (Types
Tmobject:[Types]
ts)  (Char
c:String
cs) = String -> ShowS
ss String
"GObjectClass "forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\''forall a. a -> [a] -> [a]
: [Types] -> String -> [ShowS]
context [Types]
ts String
cs
context (Types
Tgstring:[Types]
ts)  (Char
c:String
cs) = String -> ShowS
ss String
"Glib.GlibString "forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\''forall a. a -> [a] -> [a]
: [Types] -> String -> [ShowS]
context [Types]
ts String
cs
context (Types
Tmgstring:[Types]
ts)  (Char
c:String
cs) = String -> ShowS
ss String
"Glib.GlibString "forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\''forall a. a -> [a] -> [a]
: [Types] -> String -> [ShowS]
context [Types]
ts String
cs
context (Types
_:[Types]
ts)        (Char
c:String
cs) = [Types] -> String -> [ShowS]
context [Types]
ts String
cs
context []            String
_      = []


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

-- arguments for user defined marshalling

type ArgNo = Int

marshArg :: Types -> ArgNo -> ShowS
marshArg :: Types -> Int -> ShowS
marshArg Types
Tboxed   Int
c = String -> ShowS
ss String
"boxedPre"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
cforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
' '
marshArg Types
_        Int
_ = forall a. a -> a
id

-- generate a name for every passed argument,
nameArg :: Types -> ArgNo -> ShowS
nameArg :: Types -> Int -> ShowS
nameArg Types
Tunit    Int
_ = forall a. a -> a
id
nameArg Types
Tbool    Int
c = String -> ShowS
ss String
"bool"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tchar    Int
c = String -> ShowS
ss String
"char"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tuchar   Int
c = String -> ShowS
ss String
"char"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tint     Int
c = String -> ShowS
ss String
"int"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tuint    Int
c = String -> ShowS
ss String
"int"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tlong    Int
c = String -> ShowS
ss String
"long"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tulong   Int
c = String -> ShowS
ss String
"long"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tenum    Int
c = String -> ShowS
ss String
"enum"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tflags   Int
c = String -> ShowS
ss String
"flags"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tfloat   Int
c = String -> ShowS
ss String
"float"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tdouble  Int
c = String -> ShowS
ss String
"double"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tstring  Int
c = String -> ShowS
ss String
"str"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tmstring Int
c = String -> ShowS
ss String
"str"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tgstring         Int
c = String -> ShowS
ss String
"str"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tmgstring Int
c = String -> ShowS
ss String
"str"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tboxed   Int
c = String -> ShowS
ss String
"box"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tptr     Int
c = String -> ShowS
ss String
"ptr"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Ttobject  Int
c = String -> ShowS
ss String
"obj"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tmtobject  Int
c = String -> ShowS
ss String
"obj"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tobject  Int
c = String -> ShowS
ss String
"obj"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tmobject  Int
c = String -> ShowS
ss String
"obj"forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> ShowS
shows Int
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 :: Types -> ShowS -> Int -> ShowS -> ShowS
marshExec Types
Tbool   ShowS
arg Int
_ ShowS
body = ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tchar   ShowS
arg Int
_ ShowS
body = ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tuchar  ShowS
arg Int
_ ShowS
body = ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tint    ShowS
arg Int
_ ShowS
body = ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tuint   ShowS
arg Int
_ ShowS
body = ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tlong   ShowS
arg Int
_ ShowS
body = ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tulong  ShowS
arg Int
_ ShowS
body = ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tenum   ShowS
arg Int
_ ShowS
body = ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" (toEnum "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
')'
marshExec Types
Tflags  ShowS
arg Int
_ ShowS
body = ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" (toFlags "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
')'
marshExec Types
Tfloat  ShowS
arg Int
_ ShowS
body = ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tdouble ShowS
arg Int
_ ShowS
body = ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tstring ShowS
arg Int
_ ShowS
body = Int -> ShowS
indent Int
5forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"peekUTFString "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" >>= \\"forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
'\''
marshExec Types
Tmstring ShowS
arg Int
_ ShowS
body = Int -> ShowS
indent Int
5forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"maybePeekUTFString "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" >>= \\"forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
'\''
marshExec Types
Tgstring ShowS
arg Int
_ ShowS
body = Int -> ShowS
indent Int
5forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"peekUTFString "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" >>= \\"forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
'\''
marshExec Types
Tmgstring ShowS
arg Int
_ ShowS
body = Int -> ShowS
indent Int
5forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"maybePeekUTFString "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" >>= \\"forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
'\''
marshExec Types
Tboxed  ShowS
arg Int
n ShowS
body = Int -> ShowS
indent Int
5forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"boxedPre"forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss (forall a. Show a => a -> String
show Int
n)forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" (castPtr "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
") >>= \\"forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
'\''
marshExec Types
Tptr    ShowS
arg Int
_ ShowS
body = ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" (castPtr "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
')'
marshExec Types
Ttobject ShowS
arg Int
_ ShowS
body = Int -> ShowS
indent Int
5forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"makeNewGObject (GObject, objectUnrefFromMainloop) (return "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
") >>= \\"forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" (unsafeCastGObject "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\')"
marshExec Types
Tmtobject ShowS
arg Int
_ ShowS
body = Int -> ShowS
indent Int
5forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"maybeNull (makeNewGObject (GObject, objectUnrefFromMainloop)) (return "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
") >>= \\"forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" (liftM unsafeCastGObject "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\')"
marshExec Types
Tobject ShowS
arg Int
_ ShowS
body = Int -> ShowS
indent Int
5forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"makeNewGObject (GObject, objectUnref) (return "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
") >>= \\"forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" (unsafeCastGObject "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\')"
marshExec Types
Tmobject ShowS
arg Int
_ ShowS
body = Int -> ShowS
indent Int
5forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"maybeNull (makeNewGObject (GObject, objectUnref)) (return "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
") >>= \\"forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" (liftM unsafeCastGObject "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\')"

marshRet :: Types -> (ShowS -> ShowS)
marshRet :: Types -> ShowS -> ShowS
marshRet Types
Tunit   ShowS
body = ShowS
body
marshRet Types
Tbool   ShowS
body = ShowS
body
marshRet Types
Tint    ShowS
body = ShowS
body
marshRet Types
Tuint   ShowS
body = ShowS
body
marshRet Types
Tlong   ShowS
body = ShowS
body
marshRet Types
Tulong  ShowS
body = ShowS
body
marshRet Types
Tenum   ShowS
body = Int -> ShowS
indent Int
5forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"liftM fromEnum $ "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
body
marshRet Types
Tflags  ShowS
body = Int -> ShowS
indent Int
5forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"liftM fromFlags $ "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
body
marshRet Types
Tfloat  ShowS
body = ShowS
body
marshRet Types
Tdouble ShowS
body = ShowS
body
marshRet Types
Tstring ShowS
body = ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
indent Int
5forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
">>= newUTFString"
marshRet Types
Tgstring ShowS
body = ShowS
bodyforall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
indent Int
5forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
">>= newUTFString"
marshRet Types
Tptr    ShowS
body = Int -> ShowS
indent Int
5forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"liftM castPtr $ "forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
body
marshRet Types
_       ShowS
_    = forall a. HasCallStack => String -> a
error String
"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 Tgstring n = indent 4.ss "str".shows n.
                      ss "' <- peekCString str".shows n
marshExec Tmgstring 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 :: Signature -> ShowS
mkUserType (Types
ret,[Types]
ts) = let
  (ShowS
str,String
cs) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\(ShowS
str,String
cs) Types
t ->
            let (ShowS
str',String
cs') = Types -> String -> (ShowS, String)
usertype Types
t String
cs in (ShowS
strforall b c a. (b -> c) -> (a -> b) -> a -> c
.ShowS
str'forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" -> ",String
cs'))
            (Char -> ShowS
sc Char
'(',[Char
'a'..]) [Types]
ts
  (ShowS
str',String
_) = Types -> String -> (ShowS, String)
usertype Types
ret String
cs
  str'' :: ShowS
str'' = if Char
' ' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (ShowS
str' String
"") then (Char -> ShowS
sc Char
'('forall b c a. (b -> c) -> (a -> b) -> a -> c
.ShowS
str'forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
')') else ShowS
str'
  in ShowS
strforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"IO "forall b c a. (b -> c) -> (a -> b) -> a -> c
.ShowS
str''forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
')'

mkContext :: Signature -> ShowS
mkContext :: Signature -> ShowS
mkContext (Types
ret,[Types]
ts) = let ctxts :: [ShowS]
ctxts = [Types] -> String -> [ShowS]
context ([Types]
tsforall a. [a] -> [a] -> [a]
++[Types
ret]) [Char
'a'..] in
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ShowS]
ctxts then String -> ShowS
ss String
"GObjectClass obj =>" else Char -> ShowS
sc Char
'('forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\ShowS
a ShowS
b -> ShowS
aforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
", "forall b c a. (b -> c) -> (a -> b) -> a -> c
.ShowS
b) [ShowS]
ctxtsforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
", GObjectClass obj) =>"

mkMarshType :: Signature -> [ShowS]
mkMarshType :: Signature -> [ShowS]
mkMarshType (Types
ret,[Types]
ts) = [Types] -> String -> [ShowS]
marshType ([Types]
tsforall a. [a] -> [a] -> [a]
++[Types
ret]) [Char
'a'..]

mkType :: Signature -> ShowS
mkType Signature
sig = let types :: [ShowS]
types = Signature -> [ShowS]
mkMarshType Signature
sig in
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ShowS]
types then forall a. a -> a
id else forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (Int -> ShowS
indent Int
1) [ShowS]
types

mkMarshArg :: Signature -> [ShowS]
mkMarshArg :: Signature -> [ShowS]
mkMarshArg (Types
ret,[Types]
ts) = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Types -> Int -> ShowS
marshArg ([Types]
tsforall a. [a] -> [a] -> [a]
++[Types
ret]) [Int
1..]

mkArg :: Signature -> ShowS
mkArg Signature
sig = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (Char -> ShowS
sc Char
' ') forall a b. (a -> b) -> a -> b
$ Signature -> [ShowS]
mkMarshArg Signature
sig

#ifdef USE_GCLOSURE_SIGNALS_IMPL

mkMarshExec :: Signature -> ShowS
mkMarshExec :: Signature -> ShowS
mkMarshExec (Types
ret,[Types]
ts) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ShowS
body ShowS -> ShowS
marshaler -> ShowS -> ShowS
marshaler ShowS
body) (Int -> ShowS
indent Int
5forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"user")
                             ([ShowS -> ShowS]
paramMarshalersforall a. [a] -> [a] -> [a]
++[ShowS -> ShowS
returnMarshaler])
  where paramMarshalers :: [ShowS -> ShowS]
paramMarshalers = [ Types -> ShowS -> Int -> ShowS -> ShowS
marshExec Types
t (Types -> Int -> ShowS
nameArg Types
t Int
n) Int
n | (Types
t,Int
n) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Types]
ts [Int
1..] ]
        returnMarshaler :: ShowS -> ShowS
returnMarshaler = Types -> ShowS -> ShowS
marshRet Types
ret

#else

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

#endif

mkIdentifier :: Signature -> ShowS
mkIdentifier :: Signature -> ShowS
mkIdentifier (Types
ret,[]) = Types -> ShowS
identifier Types
Tunit forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"__"forall b c a. (b -> c) -> (a -> b) -> a -> c
.Types -> ShowS
identifier Types
ret
mkIdentifier (Types
ret,[Types]
ts) = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\ShowS
a ShowS
b -> ShowS
aforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'_'forall b c a. (b -> c) -> (a -> b) -> a -> c
.ShowS
b) (forall a b. (a -> b) -> [a] -> [b]
map Types -> ShowS
identifier [Types]
ts)forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                        String -> ShowS
ss String
"__"forall b c a. (b -> c) -> (a -> b) -> a -> c
.Types -> ShowS
identifier Types
ret

mkRawtype :: Signature -> ShowS
mkRawtype :: Signature -> ShowS
mkRawtype (Types
ret,[Types]
ts) =
  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id (forall a b. (a -> b) -> [a] -> [b]
map (\Types
ty -> Types -> ShowS
rawtype Types
tyforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" -> ") [Types]
ts)forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (case Types
ret of
      Types
Tboxed  -> String -> ShowS
ss String
"IO ("forall b c a. (b -> c) -> (a -> b) -> a -> c
.Types -> ShowS
rawtype Types
retforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
')'
      Types
Tptr    -> String -> ShowS
ss String
"IO ("forall b c a. (b -> c) -> (a -> b) -> a -> c
.Types -> ShowS
rawtype Types
retforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
')'
      Types
Ttobject -> String -> ShowS
ss String
"IO ("forall b c a. (b -> c) -> (a -> b) -> a -> c
.Types -> ShowS
rawtype Types
retforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
')'
      Types
Tmtobject -> String -> ShowS
ss String
"IO ("forall b c a. (b -> c) -> (a -> b) -> a -> c
.Types -> ShowS
rawtype Types
retforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
')'
      Types
Tobject -> String -> ShowS
ss String
"IO ("forall b c a. (b -> c) -> (a -> b) -> a -> c
.Types -> ShowS
rawtype Types
retforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
')'
      Types
Tmobject -> String -> ShowS
ss String
"IO ("forall b c a. (b -> c) -> (a -> b) -> a -> c
.Types -> ShowS
rawtype Types
retforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
')'
      Types
_       -> String -> ShowS
ss String
"IO "forall b c a. (b -> c) -> (a -> b) -> a -> c
.Types -> ShowS
rawtype Types
ret)

mkLambdaArgs :: Signature -> ShowS
mkLambdaArgs :: Signature -> ShowS
mkLambdaArgs (Types
_,[Types]
ts) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
                      forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Types
a Int
b -> Types -> Int -> ShowS
nameArg Types
a Int
bforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
' ') [Types]
ts [Int
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 :: IO b
usage = do
 Handle -> String -> IO ()
hPutStr Handle
stderr forall a b. (a -> b) -> a -> b
$
   String
"Program to generate callback hook for Gtk signals. Usage:\n\n"forall a. [a] -> [a] -> [a]
++
   String
"HookGenerator [--template=<template-file>] --types=<types-file>\n"forall a. [a] -> [a] -> [a]
++
   String
"              [--import=<import>]  --modname=<moduleName> > <outFile>\n"forall a. [a] -> [a] -> [a]
++
   String
"where\n"forall a. [a] -> [a] -> [a]
++
   String
"  <moduleName>    the module name for <outFile>\n"forall a. [a] -> [a] -> [a]
++
   String
"  <template-file> a path to the Signal.chs.template file\n"forall a. [a] -> [a] -> [a]
++
   String
"  <types-file>    a path to a gtkmarshal.list file\n"forall a. [a] -> [a] -> [a]
++
   String
"  <import>        a module to be imported into the template file\n"
 forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1

hookGen :: [String] -> IO String
hookGen :: [String] -> IO String
hookGen [String]
args = do
  let showHelp :: Bool
showHelp = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. (a -> Bool) -> [a] -> [a]
filter (String
"-h" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
argsforall a. [a] -> [a] -> [a]
++
                            forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--help" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
args)) Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args
  if Bool
showHelp then forall {b}. IO b
usage else do
  let outModuleName :: String
outModuleName = case forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop Int
10) (forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--modname=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)  [String]
args) of
                        (String
modName:[String]
_) -> String
modName
  String
templateFile <- case forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop Int
11) (forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--template=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)  [String]
args) of
                    [String
tplName] -> forall (m :: * -> *) a. Monad m => a -> m a
return String
tplName
                    [String]
_ -> String -> IO String
getDataFileName String
"callbackGen/Signal.chs.template"
  String
typesFile <- case forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop Int
8) (forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--types=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)  [String]
args) of
                 [String
typName] -> forall (m :: * -> *) a. Monad m => a -> m a
return String
typName
                 [String]
_ -> forall {b}. IO b
usage
  let extraImports :: [String]
extraImports = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop Int
9) (forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--import=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
args)
  String
content <- String -> IO String
readFile String
typesFile
  let sigs :: Signatures
sigs = String -> Signatures
parseSignatures String
content
  String
template <- String -> IO String
readFile String
templateFile
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    String -> (String -> ShowS) -> ShowS
templateSubstitute String
template (\String
var ->
      case String
var of
        String
"MODULE_NAME"    -> String -> ShowS
ss String
outModuleName
        String
"MODULE_EXPORTS" -> Signatures -> ShowS
genExport Signatures
sigs
        String
"MODULE_IMPORTS" -> [String] -> ShowS
genImports [String]
extraImports
        String
"MODULE_BODY"    -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id (forall a b. (a -> b) -> [a] -> [b]
map Signature -> ShowS
generate Signatures
sigs)
        String
_ -> forall a. HasCallStack => String -> a
error String
var
    ) String
""

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

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

genExport :: Signatures -> ShowS
genExport :: Signatures -> ShowS
genExport Signatures
sigs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id (forall a b. (a -> b) -> [a] -> [b]
map Signature -> ShowS
mkId Signatures
sigs)
  where
    mkId :: Signature -> ShowS
mkId Signature
sig = String -> ShowS
ss String
"connect_"forall b c a. (b -> c) -> (a -> b) -> a -> c
.Signature -> ShowS
mkIdentifier Signature
sigforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
','forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
indent Int
1

genImports :: [String] -> ShowS
genImports :: [String] -> ShowS
genImports [String]
mods = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id (forall a b. (a -> b) -> [a] -> [b]
map String -> ShowS
mkImp [String]
mods)
  where
    mkImp :: String -> ShowS
mkImp String
m = String -> ShowS
ss String
"import " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
indent Int
0

#ifdef USE_GCLOSURE_SIGNALS_IMPL

generate :: Signature -> ShowS
generate :: Signature -> ShowS
generate Signature
sig = let ident :: ShowS
ident = Signature -> ShowS
mkIdentifier Signature
sig in
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"connect_"forall b c a. (b -> c) -> (a -> b) -> a -> c
.ShowS
identforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" :: "forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.Signature -> ShowS
mkContext Signature
sigforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" SignalName ->"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Signature -> ShowS
mkType Signature
sigforall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"ConnectAfter -> obj ->"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.Signature -> ShowS
mkUserType Signature
sigforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" ->"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"IO (ConnectId obj)"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"connect_"forall b c a. (b -> c) -> (a -> b) -> a -> c
.ShowS
identforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" signal"forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signature -> ShowS
mkArg Signature
sigforall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"after obj user ="forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"connectGeneric signal after obj action"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"where action :: Ptr GObject -> "forall b c a. (b -> c) -> (a -> b) -> a -> c
.Signature -> ShowS
mkRawtype Signature
sigforall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"      action _ "forall b c a. (b -> c) -> (a -> b) -> a -> c
.Signature -> ShowS
mkLambdaArgs Signature
sigforall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
'='forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
5forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"failOnGError $"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Signature -> ShowS
mkMarshExec Signature
sigforall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
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