{-# 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
(Types -> Types -> Bool) -> (Types -> Types -> Bool) -> Eq Types
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 = (Signatures -> Signatures
forall a. Eq a => [a] -> [a]
nub(Signatures -> Signatures)
-> (String -> Signatures) -> String -> Signatures
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> [Token] -> Signatures
parseSig Int
1([Token] -> Signatures)
-> (String -> [Token]) -> String -> Signatures
forall 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 = String -> ShowS
forall a. Show a => a -> ShowS
shows String
":"
  showsPrec Int
_ (TokType Types
_) = String -> ShowS
forall a. Show a => a -> ShowS
shows String
"<type>"
  showsPrec Int
_ Token
TokComma = String -> ShowS
forall a. Show a => a -> ShowS
shows String
","
  showsPrec Int
_ Token
TokEOL = String -> ShowS
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
lInt -> Int -> Int
forall 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,[])(Types, [Types]) -> Signatures -> Signatures
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)(Types, [Types]) -> Signatures -> Signatures
forall a. a -> [a] -> [a]
: Int -> [Token] -> Signatures
parseSig (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Token]
rem'
parseSig Int
l [Token]
rem = String -> Signatures
forall a. HasCallStack => String -> a
error (String
"parse error on line "String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
lString -> ShowS
forall a. [a] -> [a] -> [a]
++
                       String
": expected type and colon, found\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       (Token -> String) -> [Token] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Token -> String
forall a. Show a => a -> String
show (Int -> [Token] -> [Token]
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
tyTypes -> [Types] -> [Types]
forall a. a -> [a] -> [a]
:[Types]
args, [Token]
rem')
parseArg Int
l [Token]
rem = String -> ([Types], [Token])
forall a. HasCallStack => String -> a
error (String
"parse error on line "String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
lString -> ShowS
forall a. [a] -> [a] -> [a]
++String
": expected type"String -> ShowS
forall a. [a] -> [a] -> [a]
++
                        String
" followed by comma or EOL, found\n "String -> ShowS
forall a. [a] -> [a] -> [a]
++
                       (Token -> String) -> [Token] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Token -> String
forall a. Show a => a -> String
show (Int -> [Token] -> [Token]
forall a. Int -> [a] -> [a]
take Int
5 [Token]
rem))

scan :: String -> [Token]
scan :: String -> [Token]
scan String
"" = []
scan (Char
'#':String
xs) = (String -> [Token]
scan(String -> [Token]) -> ShowS -> String -> [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n'))  String
xs
scan (Char
'\n':String
xs) = Token
TokEOLToken -> [Token] -> [Token]
forall 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
TokColonToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
',':String
xs) = Token
TokCommaToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'V':Char
'O':Char
'I':Char
'D':String
xs) = Types -> Token
TokType Types
TunitToken -> [Token] -> [Token]
forall 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
TboolToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'C':Char
'H':Char
'A':Char
'R':String
xs) = Types -> Token
TokType Types
TcharToken -> [Token] -> [Token]
forall 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
TucharToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'I':Char
'N':Char
'T':String
xs) = Types -> Token
TokType Types
TintToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'U':Char
'I':Char
'N':Char
'T':String
xs) = Types -> Token
TokType Types
TuintToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'L':Char
'O':Char
'N':Char
'G':String
xs) = Types -> Token
TokType Types
TuintToken -> [Token] -> [Token]
forall 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
TulongToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'E':Char
'N':Char
'U':Char
'M':String
xs) = Types -> Token
TokType Types
TenumToken -> [Token] -> [Token]
forall 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
TflagsToken -> [Token] -> [Token]
forall 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
TfloatToken -> [Token] -> [Token]
forall 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
TdoubleToken -> [Token] -> [Token]
forall 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
TstringToken -> [Token] -> [Token]
forall 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
TmstringToken -> [Token] -> [Token]
forall 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
TgstringToken -> [Token] -> [Token]
forall 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
TmgstringToken -> [Token] -> [Token]
forall 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
TboxedToken -> [Token] -> [Token]
forall 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
TptrToken -> [Token] -> [Token]
forall 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
TtobjectToken -> [Token] -> [Token]
forall 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
TmtobjectToken -> [Token] -> [Token]
forall 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
TobjectToken -> [Token] -> [Token]
forall 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
TmobjectToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'N':Char
'O':Char
'N':Char
'E':String
xs) = Types -> Token
TokType Types
TunitToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (Char
'B':Char
'O':Char
'O':Char
'L':String
xs) = Types -> Token
TokType Types
TboolToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan String
str = String -> [Token]
forall a. HasCallStack => String -> a
error (String
"Invalid character in input file:\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
           (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Char -> ShowS) -> String -> Char -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> ShowS
showLitChar) String
"") (Int -> ShowS
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"String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
2Int -> Int -> Int
forall 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
cShowS -> ShowS -> ShowS
forall 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 "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cShowS -> ShowS -> ShowS
forall 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 "ShowS -> ShowS -> ShowS
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
cShowS -> ShowS -> ShowS
forall 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 "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cShowS -> ShowS -> ShowS
forall 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
cShowS -> ShowS -> ShowS
forall 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 "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cShowS -> ShowS -> ShowS
forall 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 "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cShowS -> [ShowS] -> [ShowS]
forall 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 "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cShowS -> [ShowS] -> [ShowS]
forall 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 "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\''ShowS -> [ShowS] -> [ShowS]
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 "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\''ShowS -> [ShowS] -> [ShowS]
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 "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\''ShowS -> [ShowS] -> [ShowS]
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 "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\''ShowS -> [ShowS] -> [ShowS]
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 "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\''ShowS -> [ShowS] -> [ShowS]
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 "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'\''ShowS -> [ShowS] -> [ShowS]
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
TenumTypes -> [Types] -> [Types]
forall a. a -> [a] -> [a]
:[Types]
ts) String
cs
marshType (Types
Tboxed:[Types]
ts)   (Char
c:String
cs) = String -> ShowS
ss String
"(Ptr "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
cShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"' -> IO "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                 Char -> ShowS
sc Char
cShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
") -> "ShowS -> [ShowS] -> [ShowS]
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"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
cShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
' '
marshArg Types
_        Int
_ = ShowS
forall a. a -> a
id

-- generate a name for every passed argument,
nameArg :: Types -> ArgNo -> ShowS
nameArg :: Types -> Int -> ShowS
nameArg Types
Tunit    Int
_ = ShowS
forall a. a -> a
id
nameArg Types
Tbool    Int
c = String -> ShowS
ss String
"bool"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tchar    Int
c = String -> ShowS
ss String
"char"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tuchar   Int
c = String -> ShowS
ss String
"char"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tint     Int
c = String -> ShowS
ss String
"int"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tuint    Int
c = String -> ShowS
ss String
"int"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tlong    Int
c = String -> ShowS
ss String
"long"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tulong   Int
c = String -> ShowS
ss String
"long"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tenum    Int
c = String -> ShowS
ss String
"enum"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tflags   Int
c = String -> ShowS
ss String
"flags"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tfloat   Int
c = String -> ShowS
ss String
"float"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tdouble  Int
c = String -> ShowS
ss String
"double"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tstring  Int
c = String -> ShowS
ss String
"str"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tmstring Int
c = String -> ShowS
ss String
"str"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tgstring         Int
c = String -> ShowS
ss String
"str"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tmgstring Int
c = String -> ShowS
ss String
"str"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tboxed   Int
c = String -> ShowS
ss String
"box"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tptr     Int
c = String -> ShowS
ss String
"ptr"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Ttobject  Int
c = String -> ShowS
ss String
"obj"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tmtobject  Int
c = String -> ShowS
ss String
"obj"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tobject  Int
c = String -> ShowS
ss String
"obj"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
c
nameArg Types
Tmobject  Int
c = String -> ShowS
ss String
"obj"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
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
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tchar   ShowS
arg Int
_ ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tuchar  ShowS
arg Int
_ ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tint    ShowS
arg Int
_ ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tuint   ShowS
arg Int
_ ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tlong   ShowS
arg Int
_ ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tulong  ShowS
arg Int
_ ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tenum   ShowS
arg Int
_ ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" (toEnum "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
')'
marshExec Types
Tflags  ShowS
arg Int
_ ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" (toFlags "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
')'
marshExec Types
Tfloat  ShowS
arg Int
_ ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tdouble ShowS
arg Int
_ ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Types
Tstring ShowS
arg Int
_ ShowS
body = Int -> ShowS
indent Int
5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"peekUTFString "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" >>= \\"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall 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
5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"maybePeekUTFString "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" >>= \\"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall 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
5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"peekUTFString "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" >>= \\"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall 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
5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"maybePeekUTFString "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" >>= \\"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall 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
5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"boxedPre"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss (Int -> String
forall a. Show a => a -> String
show Int
n)ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" (castPtr "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
") >>= \\"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc Char
'\''
marshExec Types
Tptr    ShowS
arg Int
_ ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" (castPtr "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall 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
5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"makeNewGObject (GObject, objectUnrefFromMainloop) (return "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
") >>= \\"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" (unsafeCastGObject "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall 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
5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"maybeNull (makeNewGObject (GObject, objectUnrefFromMainloop)) (return "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
") >>= \\"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" (liftM unsafeCastGObject "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall 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
5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"makeNewGObject (GObject, objectUnref) (return "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
") >>= \\"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" (unsafeCastGObject "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall 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
5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"maybeNull (makeNewGObject (GObject, objectUnref)) (return "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
") >>= \\"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"\' ->"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
" (liftM unsafeCastGObject "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
argShowS -> ShowS -> ShowS
forall 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
5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"liftM fromEnum $ "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
body
marshRet Types
Tflags  ShowS
body = Int -> ShowS
indent Int
5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"liftM fromFlags $ "ShowS -> ShowS -> ShowS
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
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
indent Int
5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
">>= newUTFString"
marshRet Types
Tgstring ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
indent Int
5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
">>= newUTFString"
marshRet Types
Tptr    ShowS
body = Int -> ShowS
indent Int
5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"liftM castPtr $ "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
body
marshRet Types
_       ShowS
_    = String -> 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 :: (Types, [Types]) -> ShowS
mkUserType (Types
ret,[Types]
ts) = let
  (ShowS
str,String
cs) = ((ShowS, String) -> Types -> (ShowS, String))
-> (ShowS, String) -> [Types] -> (ShowS, String)
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
strShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ShowS
str'ShowS -> ShowS -> ShowS
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
' ' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (ShowS
str' String
"") then (Char -> ShowS
sc Char
'('ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ShowS
str'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
')') else ShowS
str'
  in ShowS
strShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"IO "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ShowS
str''ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
')'

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

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

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

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

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

#ifdef USE_GCLOSURE_SIGNALS_IMPL

mkMarshExec :: Signature -> ShowS
mkMarshExec :: (Types, [Types]) -> ShowS
mkMarshExec (Types
ret,[Types]
ts) = (ShowS -> (ShowS -> ShowS) -> ShowS)
-> ShowS -> [ShowS -> ShowS] -> ShowS
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
5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"user")
                             ([ShowS -> ShowS]
paramMarshalers[ShowS -> ShowS] -> [ShowS -> ShowS] -> [ShowS -> ShowS]
forall 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) <- [Types] -> [Int] -> [(Types, Int)]
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 :: (Types, [Types]) -> ShowS
mkIdentifier (Types
ret,[]) = Types -> ShowS
identifier Types
Tunit ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
"__"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Types -> ShowS
identifier Types
ret
mkIdentifier (Types
ret,[Types]
ts) = (ShowS -> ShowS -> ShowS) -> [ShowS] -> ShowS
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\ShowS
a ShowS
b -> ShowS
aShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
'_'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ShowS
b) ((Types -> ShowS) -> [Types] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map Types -> ShowS
identifier [Types]
ts)ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                        String -> ShowS
ss String
"__"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Types -> ShowS
identifier Types
ret

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

mkLambdaArgs :: Signature -> ShowS
mkLambdaArgs :: (Types, [Types]) -> ShowS
mkLambdaArgs (Types
_,[Types]
ts) = (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id ([ShowS] -> ShowS) -> [ShowS] -> ShowS
forall a b. (a -> b) -> a -> b
$
                      (Types -> Int -> ShowS) -> [Types] -> [Int] -> [ShowS]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Types
a Int
b -> Types -> Int -> ShowS
nameArg Types
a Int
bShowS -> ShowS -> ShowS
forall 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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
   String
"Program to generate callback hook for Gtk signals. Usage:\n\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
   String
"HookGenerator [--template=<template-file>] --types=<types-file>\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
   String
"              [--import=<import>]  --modname=<moduleName> > <outFile>\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
   String
"where\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
   String
"  <moduleName>    the module name for <outFile>\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
   String
"  <template-file> a path to the Signal.chs.template file\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
   String
"  <types-file>    a path to a gtkmarshal.list file\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
   String
"  <import>        a module to be imported into the template file\n"
 ExitCode -> IO b
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO b) -> ExitCode -> IO b
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 ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"-h" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
args[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                            (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--help" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
args)) Bool -> Bool -> Bool
|| [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args
  if Bool
showHelp then IO String
forall b. IO b
usage else do
  let outModuleName :: String
outModuleName = case ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
10) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--modname=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)  [String]
args) of
                        (String
modName:[String]
_) -> String
modName
  String
templateFile <- case ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
11) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--template=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)  [String]
args) of
                    [String
tplName] -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
tplName
                    [String]
_ -> String -> IO String
getDataFileName String
"callbackGen/Signal.chs.template"
  String
typesFile <- case ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
8) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--types=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)  [String]
args) of
                 [String
typName] -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
typName
                 [String]
_ -> IO String
forall b. IO b
usage
  let extraImports :: [String]
extraImports = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
9) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--import=" String -> String -> Bool
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
  String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
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"    -> (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id (((Types, [Types]) -> ShowS) -> Signatures -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map (Types, [Types]) -> ShowS
generate Signatures
sigs)
        String
_ -> String -> ShowS
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 [] = ShowS
forall a. a -> a
id
        doSubst (Char
'\\':Char
'@':String
cs) = Char -> ShowS
sc Char
'@' ShowS -> ShowS -> ShowS
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') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char
'@'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=) String
cs
                            in String -> ShowS
varSubst String
var ShowS -> ShowS -> ShowS
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 ShowS -> ShowS -> ShowS
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 = (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id (((Types, [Types]) -> ShowS) -> Signatures -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map (Types, [Types]) -> ShowS
mkId Signatures
sigs)
  where
    mkId :: (Types, [Types]) -> ShowS
mkId (Types, [Types])
sig = String -> ShowS
ss String
"connect_"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Types, [Types]) -> ShowS
mkIdentifier (Types, [Types])
sigShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
','ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
indent Int
1

genImports :: [String] -> ShowS
genImports :: [String] -> ShowS
genImports [String]
mods = (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id ((String -> ShowS) -> [String] -> [ShowS]
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 " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
m ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
indent Int
0

#ifdef USE_GCLOSURE_SIGNALS_IMPL

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