{-# 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 content :: 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 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 _ TokColon = String -> ShowS
forall a. Show a => a -> ShowS
shows ":"
  showsPrec _ (TokType _) = String -> ShowS
forall a. Show a => a -> ShowS
shows "<type>"
  showsPrec _ TokComma = String -> ShowS
forall a. Show a => a -> ShowS
shows ","
  showsPrec _ TokEOL = String -> ShowS
forall a. Show a => a -> ShowS
shows "<EOL>"

parseSig :: Int -> [Token] -> Signatures
parseSig :: Int -> [Token] -> Signatures
parseSig l :: Int
l [] = []
parseSig l :: Int
l (TokEOL: rem :: [Token]
rem) = Int -> [Token] -> Signatures
parseSig (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) [Token]
rem
parseSig l :: Int
l (TokType ret :: Types
ret: TokColon: TokType Tunit:rem :: [Token]
rem) =
  (Types
ret,[])(Types, [Types]) -> Signatures -> Signatures
forall a. a -> [a] -> [a]
:Int -> [Token] -> Signatures
parseSig Int
l [Token]
rem
parseSig l :: Int
l (TokType ret :: Types
ret: TokColon: rem :: [Token]
rem) =
  let (args :: [Types]
args,rem' :: [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
+1) [Token]
rem'
parseSig l :: Int
l rem :: [Token]
rem = String -> Signatures
forall a. HasCallStack => String -> a
error ("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]
++
                       ": 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 5 [Token]
rem))

parseArg :: Int -> [Token] -> ([Types],[Token])
parseArg :: Int -> [Token] -> ([Types], [Token])
parseArg l :: Int
l [TokType ty :: Types
ty] = ([Types
ty],[])
parseArg l :: Int
l (TokType ty :: Types
ty: TokEOL:rem :: [Token]
rem) = ([Types
ty],[Token]
rem)
parseArg l :: Int
l (TokType ty :: Types
ty: TokComma:rem :: [Token]
rem) =
  let (args :: [Types]
args,rem' :: [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 l :: Int
l rem :: [Token]
rem = String -> ([Types], [Token])
forall a. HasCallStack => String -> a
error ("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]
++": expected type"String -> ShowS
forall a. [a] -> [a] -> [a]
++
                        " 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 5 [Token]
rem))

scan :: String -> [Token]
scan :: String -> [Token]
scan "" = []
scan ('#':xs :: 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
/='\n'))  String
xs
scan ('\n':xs :: String
xs) = Token
TokEOLToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (' ':xs :: String
xs) = String -> [Token]
scan String
xs
scan ('\t':xs :: String
xs) = String -> [Token]
scan String
xs
scan (':':xs :: String
xs) = Token
TokColonToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan (',':xs :: String
xs) = Token
TokCommaToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('V':'O':'I':'D':xs :: String
xs) = Types -> Token
TokType Types
TunitToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('B':'O':'O':'L':'E':'A':'N':xs :: String
xs) = Types -> Token
TokType Types
TboolToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('C':'H':'A':'R':xs :: String
xs) = Types -> Token
TokType Types
TcharToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('U':'C':'H':'A':'R':xs :: String
xs) = Types -> Token
TokType Types
TucharToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('I':'N':'T':xs :: String
xs) = Types -> Token
TokType Types
TintToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('U':'I':'N':'T':xs :: String
xs) = Types -> Token
TokType Types
TuintToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('L':'O':'N':'G':xs :: String
xs) = Types -> Token
TokType Types
TuintToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('U':'L':'O':'N':'G':xs :: String
xs) = Types -> Token
TokType Types
TulongToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('E':'N':'U':'M':xs :: String
xs) = Types -> Token
TokType Types
TenumToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('F':'L':'A':'G':'S':xs :: String
xs) = Types -> Token
TokType Types
TflagsToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('F':'L':'O':'A':'T':xs :: String
xs) = Types -> Token
TokType Types
TfloatToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('D':'O':'U':'B':'L':'E':xs :: String
xs) = Types -> Token
TokType Types
TdoubleToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('S':'T':'R':'I':'N':'G':xs :: String
xs) = Types -> Token
TokType Types
TstringToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('M':'S':'T':'R':'I':'N':'G':xs :: String
xs) = Types -> Token
TokType Types
TmstringToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('G':'L':'I':'B':'S':'T':'R':'I':'N':'G':xs :: String
xs) = Types -> Token
TokType Types
TgstringToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('M':'G':'L':'I':'B':'S':'T':'R':'I':'N':'G':xs :: String
xs) = Types -> Token
TokType Types
TmgstringToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('B':'O':'X':'E':'D':xs :: String
xs) = Types -> Token
TokType Types
TboxedToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('P':'O':'I':'N':'T':'E':'R':xs :: String
xs) = Types -> Token
TokType Types
TptrToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('T':'O':'B':'J':'E':'C':'T':xs :: String
xs) = Types -> Token
TokType Types
TtobjectToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('M':'T':'O':'B':'J':'E':'C':'T':xs :: String
xs) = Types -> Token
TokType Types
TmtobjectToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('O':'B':'J':'E':'C':'T':xs :: String
xs) = Types -> Token
TokType Types
TobjectToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('M':'O':'B':'J':'E':'C':'T':xs :: String
xs) = Types -> Token
TokType Types
TmobjectToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('N':'O':'N':'E':xs :: String
xs) = Types -> Token
TokType Types
TunitToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan ('B':'O':'O':'L':xs :: String
xs) = Types -> Token
TokType Types
TboolToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:String -> [Token]
scan String
xs
scan str :: String
str = String -> [Token]
forall a. HasCallStack => String -> a
error ("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) "") (Int -> ShowS
forall a. Int -> [a] -> [a]
take 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 c :: Int
c = String -> ShowS
ss ("\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> Char -> String
forall a. Int -> a -> [a]
replicate (2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
c) ' ')

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

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

#ifdef USE_GCLOSURE_SIGNALS_IMPL

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


#else

-- The monomorphic type which is used to export the function signature.
rawtype :: Types -> ShowS
rawtype Tunit    = ss "()"
rawtype Tbool    = ss "{#type gboolean#}"
rawtype Tchar    = ss "{#type gchar#}"
rawtype Tuchar   = ss "{#type guchar#}"
rawtype Tint       = ss "{#type gint#}"
rawtype Tuint    = ss "{#type guint#}"
rawtype Tlong    = ss "{#type glong#}"
rawtype Tulong   = ss "{#type gulong#}"
rawtype Tenum    = ss "{#type gint#}"
rawtype Tflags   = ss "{#type guint#}"
rawtype Tfloat   = ss "{#type gfloat#}"
rawtype Tdouble  = ss "{#type gdouble#}"
rawtype Tstring  = ss "CString"
rawtype Tmstring  = ss "CString"
rawtype 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 Tunit    cs :: String
cs = (String -> ShowS
ss "()",String
cs)
usertype Tbool    (c :: Char
c:cs :: String
cs) = (String -> ShowS
ss "Bool",String
cs)
usertype Tchar    (c :: Char
c:cs :: String
cs) = (String -> ShowS
ss "Char",String
cs)
usertype Tuchar   (c :: Char
c:cs :: String
cs) = (String -> ShowS
ss "Char",String
cs)
usertype Tint     (c :: Char
c:cs :: String
cs) = (String -> ShowS
ss "Int",String
cs)
usertype Tuint    (c :: Char
c:cs :: String
cs) = (String -> ShowS
ss "Word",String
cs)
usertype Tlong    (c :: Char
c:cs :: String
cs) = (String -> ShowS
ss "Int",String
cs)
usertype Tulong   (c :: Char
c:cs :: String
cs) = (String -> ShowS
ss "Int",String
cs)
usertype Tenum    (c :: Char
c:cs :: String
cs) = (Char -> ShowS
sc Char
c,String
cs)
usertype Tflags   cs :: String
cs = Types -> String -> (ShowS, String)
usertype Types
Tenum String
cs
usertype Tfloat   (c :: Char
c:cs :: String
cs) = (String -> ShowS
ss "Float",String
cs)
usertype Tdouble  (c :: Char
c:cs :: String
cs) = (String -> ShowS
ss "Double",String
cs)
usertype Tstring  (c :: Char
c:cs :: String
cs) = (String -> ShowS
ss "String",String
cs)
usertype Tmstring  (c :: Char
c:cs :: String
cs) = (String -> ShowS
ss "Maybe String",String
cs)
usertype Tgstring  (c :: Char
c:cs :: String
cs) = (Char -> ShowS
sc Char
cShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc '\'',String
cs)
usertype Tmgstring  (c :: Char
c:cs :: String
cs) = (String -> ShowS
ss "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 '\'',String
cs)
usertype Tboxed   (c :: Char
c:cs :: String
cs) = (Char -> ShowS
sc Char
c,String
cs)
usertype Tptr     (c :: Char
c:cs :: String
cs) = (String -> ShowS
ss "Ptr "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
c,String
cs)
usertype Ttobject  (c :: Char
c:cs :: String
cs) = (Char -> ShowS
sc Char
cShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc '\'',String
cs)
usertype Tmtobject  (c :: Char
c:cs :: String
cs) = (String -> ShowS
ss "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 '\'',String
cs)
usertype Tobject  (c :: Char
c:cs :: String
cs) = (Char -> ShowS
sc Char
cShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc '\'',String
cs)
usertype Tmobject  (c :: Char
c:cs :: String
cs) = (String -> ShowS
ss "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 '\'',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 (Tenum:ts :: [Types]
ts)    (c :: Char
c:cs :: String
cs) = String -> ShowS
ss "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 (Tflags:ts :: [Types]
ts)   (c :: Char
c:cs :: String
cs) = String -> ShowS
ss "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 (Ttobject:ts :: [Types]
ts)  (c :: Char
c:cs :: String
cs) = String -> ShowS
ss "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 '\''ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
: [Types] -> String -> [ShowS]
context [Types]
ts String
cs
context (Tmtobject:ts :: [Types]
ts)  (c :: Char
c:cs :: String
cs) = String -> ShowS
ss "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 '\''ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
: [Types] -> String -> [ShowS]
context [Types]
ts String
cs
context (Tobject:ts :: [Types]
ts)  (c :: Char
c:cs :: String
cs) = String -> ShowS
ss "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 '\''ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
: [Types] -> String -> [ShowS]
context [Types]
ts String
cs
context (Tmobject:ts :: [Types]
ts)  (c :: Char
c:cs :: String
cs) = String -> ShowS
ss "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 '\''ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
: [Types] -> String -> [ShowS]
context [Types]
ts String
cs
context (Tgstring:ts :: [Types]
ts)  (c :: Char
c:cs :: String
cs) = String -> ShowS
ss "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 '\''ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
: [Types] -> String -> [ShowS]
context [Types]
ts String
cs
context (Tmgstring:ts :: [Types]
ts)  (c :: Char
c:cs :: String
cs) = String -> ShowS
ss "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 '\''ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
: [Types] -> String -> [ShowS]
context [Types]
ts String
cs
context (_:ts :: [Types]
ts)        (c :: Char
c:cs :: String
cs) = [Types] -> String -> [ShowS]
context [Types]
ts String
cs
context []            _      = []


marshType :: [Types] -> [Char] -> [ShowS]
marshType :: [Types] -> String -> [ShowS]
marshType (Tint:ts :: [Types]
ts)     (c :: Char
c:cs :: String
cs) = [Types] -> String -> [ShowS]
marshType [Types]
ts String
cs
marshType (Tuint:ts :: [Types]
ts)    (c :: Char
c:cs :: String
cs) = [Types] -> String -> [ShowS]
marshType [Types]
ts String
cs
marshType (Tenum:ts :: [Types]
ts)    (c :: Char
c:cs :: String
cs) = [Types] -> String -> [ShowS]
marshType [Types]
ts String
cs
marshType (Tflags:ts :: [Types]
ts)   cs :: String
cs     = [Types] -> String -> [ShowS]
marshType (Types
TenumTypes -> [Types] -> [Types]
forall a. a -> [a] -> [a]
:[Types]
ts) String
cs
marshType (Tboxed:ts :: [Types]
ts)   (c :: Char
c:cs :: String
cs) = String -> ShowS
ss "(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 "' -> 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 ") -> "ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
:
                                 [Types] -> String -> [ShowS]
marshType [Types]
ts String
cs
marshType (Tptr:ts :: [Types]
ts)     (c :: Char
c:cs :: String
cs) = [Types] -> String -> [ShowS]
marshType [Types]
ts String
cs
marshType (Tobject:ts :: [Types]
ts)  (c :: Char
c:cs :: String
cs) = [Types] -> String -> [ShowS]
marshType [Types]
ts String
cs
marshType (_:ts :: [Types]
ts)        (c :: Char
c:cs :: String
cs) = [Types] -> String -> [ShowS]
marshType [Types]
ts String
cs
marshType []            _      = []

-- arguments for user defined marshalling

type ArgNo = Int

marshArg :: Types -> ArgNo -> ShowS
marshArg :: Types -> Int -> ShowS
marshArg Tboxed   c :: Int
c = String -> ShowS
ss "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 ' '
marshArg _        _ = ShowS
forall a. a -> a
id

-- generate a name for every passed argument,
nameArg :: Types -> ArgNo -> ShowS
nameArg :: Types -> Int -> ShowS
nameArg Tunit    _ = ShowS
forall a. a -> a
id
nameArg Tbool    c :: Int
c = String -> ShowS
ss "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 Tchar    c :: Int
c = String -> ShowS
ss "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 Tuchar   c :: Int
c = String -> ShowS
ss "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 Tint     c :: Int
c = String -> ShowS
ss "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 Tuint    c :: Int
c = String -> ShowS
ss "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 Tlong    c :: Int
c = String -> ShowS
ss "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 Tulong   c :: Int
c = String -> ShowS
ss "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 Tenum    c :: Int
c = String -> ShowS
ss "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 Tflags   c :: Int
c = String -> ShowS
ss "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 Tfloat   c :: Int
c = String -> ShowS
ss "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 Tdouble  c :: Int
c = String -> ShowS
ss "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 Tstring  c :: Int
c = String -> ShowS
ss "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 Tmstring c :: Int
c = String -> ShowS
ss "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 Tgstring         c :: Int
c = String -> ShowS
ss "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 Tmgstring c :: Int
c = String -> ShowS
ss "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 Tboxed   c :: Int
c = String -> ShowS
ss "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 Tptr     c :: Int
c = String -> ShowS
ss "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 Ttobject  c :: Int
c = String -> ShowS
ss "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 Tmtobject  c :: Int
c = String -> ShowS
ss "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 Tobject  c :: Int
c = String -> ShowS
ss "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 Tmobject  c :: Int
c = String -> ShowS
ss "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 Tbool   arg :: ShowS
arg _ body :: ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc ' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Tchar   arg :: ShowS
arg _ body :: ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc ' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Tuchar  arg :: ShowS
arg _ body :: ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc ' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Tint    arg :: ShowS
arg _ body :: ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc ' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Tuint   arg :: ShowS
arg _ body :: ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc ' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Tlong   arg :: ShowS
arg _ body :: ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc ' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Tulong  arg :: ShowS
arg _ body :: ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc ' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Tenum   arg :: ShowS
arg _ body :: ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss " (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 ')'
marshExec Tflags  arg :: ShowS
arg _ body :: ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss " (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 ')'
marshExec Tfloat  arg :: ShowS
arg _ body :: ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc ' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Tdouble arg :: ShowS
arg _ body :: ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
sc ' 'ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
arg
marshExec Tstring arg :: ShowS
arg _ body :: ShowS
body = Int -> ShowS
indent 5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss "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 " >>= \\"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 "\' ->"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 ' '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 '\''
marshExec Tmstring arg :: ShowS
arg _ body :: ShowS
body = Int -> ShowS
indent 5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss "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 " >>= \\"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 "\' ->"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 ' '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 '\''
marshExec Tgstring arg :: ShowS
arg _ body :: ShowS
body = Int -> ShowS
indent 5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss "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 " >>= \\"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 "\' ->"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 ' '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 '\''
marshExec Tmgstring arg :: ShowS
arg _ body :: ShowS
body = Int -> ShowS
indent 5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss "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 " >>= \\"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 "\' ->"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 ' '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 '\''
marshExec Tboxed  arg :: ShowS
arg n :: Int
n body :: ShowS
body = Int -> ShowS
indent 5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss "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 " (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 ") >>= \\"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 "\' ->"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 ' '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 '\''
marshExec Tptr    arg :: ShowS
arg _ body :: ShowS
body = ShowS
bodyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss " (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 ')'
marshExec Ttobject arg :: ShowS
arg _ body :: ShowS
body = Int -> ShowS
indent 5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss "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 ") >>= \\"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 "\' ->"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 " (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 "\')"
marshExec Tmtobject arg :: ShowS
arg _ body :: ShowS
body = Int -> ShowS
indent 5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss "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 ") >>= \\"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 "\' ->"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 " (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 "\')"
marshExec Tobject arg :: ShowS
arg _ body :: ShowS
body = Int -> ShowS
indent 5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss "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 ") >>= \\"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 "\' ->"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 " (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 "\')"
marshExec Tmobject arg :: ShowS
arg _ body :: ShowS
body = Int -> ShowS
indent 5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss "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 ") >>= \\"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 "\' ->"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 " (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 "\')"

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

#else

marshExec :: Types -> ArgNo -> ShowS
marshExec Tbool   n = indent 4.ss "let bool".shows n.
                      ss "' = toBool bool".shows n
marshExec Tchar   n = indent 4.ss "let char".shows n.
                      ss "' = (toEnum.fromEnum) char".shows n
marshExec Tuchar  n = indent 4.ss "let char".shows n.
                      ss "' = (toEnum.fromEnum) char".shows n
marshExec Tint    n = indent 4.ss "let int".shows n.
                      ss "' = fromIntegral int".shows n
marshExec Tuint   n = indent 4.ss "let int".shows n.
                      ss "' = fromIntegral int".shows n
marshExec Tlong   n = indent 4.ss "let long".shows n.
                      ss "' = toInteger long".shows n
marshExec Tulong  n = indent 4.ss "let long".shows n.
                      ss "' = toInteger long".shows n
marshExec Tenum   n = indent 4.ss "let enum".shows n.
                      ss "' = (toEnum.fromEnum) enum".shows n
marshExec Tflags  n = indent 4.ss "let flags".shows n.
                      ss "' = (toEnum.fromEnum) flags".shows n
marshExec Tfloat  n = indent 4.ss "let float".shows n.
                      ss "' = (fromRational.toRational) float".shows n
marshExec Tdouble n = indent 4.ss "let double".shows n.
                      ss "' = (fromRational.toRational) double".shows n
marshExec Tstring n = indent 4.ss "str".shows n.
                      ss "' <- peekCString str".shows n
marshExec Tmstring n = indent 4.ss "str".shows n.
                      ss "' <- maybePeekCString str".shows n
marshExec 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 (ret :: Types
ret,ts :: [Types]
ts) = let
  (str :: ShowS
str,cs :: 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 (\(str :: ShowS
str,cs :: String
cs) t :: Types
t ->
            let (str' :: ShowS
str',cs' :: 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
cs'))
            (Char -> ShowS
sc '(',['a'..]) [Types]
ts
  (str' :: ShowS
str',_) = Types -> String -> (ShowS, String)
usertype Types
ret String
cs
  str'' :: ShowS
str'' = if ' ' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (ShowS
str' "") then (Char -> ShowS
sc '('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 ')') else ShowS
str'
  in ShowS
strShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss "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 ')'

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

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

mkType :: (Types, [Types]) -> ShowS
mkType sig :: (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 1) [ShowS]
types

mkMarshArg :: Signature -> [ShowS]
mkMarshArg :: (Types, [Types]) -> [ShowS]
mkMarshArg (ret :: Types
ret,ts :: [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]) [1..]

mkArg :: (Types, [Types]) -> ShowS
mkArg sig :: (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 ' ') ([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 (ret :: Types
ret,ts :: [Types]
ts) = (ShowS -> (ShowS -> ShowS) -> ShowS)
-> ShowS -> [ShowS -> ShowS] -> ShowS
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\body :: ShowS
body marshaler :: ShowS -> ShowS
marshaler -> ShowS -> ShowS
marshaler ShowS
body) (Int -> ShowS
indent 5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss "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 | (t :: Types
t,n :: Int
n) <- [Types] -> [Int] -> [(Types, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Types]
ts [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 (ret :: Types
ret,[]) = Types -> ShowS
identifier Types
Tunit ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss "__"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Types -> ShowS
identifier Types
ret
mkIdentifier (ret :: Types
ret,ts :: [Types]
ts) = (ShowS -> ShowS -> ShowS) -> [ShowS] -> ShowS
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\a :: ShowS
a b :: ShowS
b -> ShowS
aShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc '_'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 "__"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 (ret :: Types
ret,ts :: [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 (\ty :: Types
ty -> Types -> ShowS
rawtype Types
tyShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss " -> ") [Types]
ts)ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (case Types
ret of
      Tboxed  -> String -> ShowS
ss "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 ')'
      Tptr    -> String -> ShowS
ss "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 ')'
      Ttobject -> String -> ShowS
ss "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 ')'
      Tmtobject -> String -> ShowS
ss "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 ')'
      Tobject -> String -> ShowS
ss "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 ')'
      Tmobject -> String -> ShowS
ss "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 ')'
      _       -> String -> ShowS
ss "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 (_,ts :: [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 (\a :: Types
a b :: 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 ' ') [Types]
ts [1..]

#ifndef USE_GCLOSURE_SIGNALS_IMPL

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

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

#endif

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


usage :: IO b
usage = do
 Handle -> String -> IO ()
hPutStr Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
   "Program to generate callback hook for Gtk signals. Usage:\n\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
   "HookGenerator [--template=<template-file>] --types=<types-file>\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
   "              [--import=<import>]  --modname=<moduleName> > <outFile>\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
   "where\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
   "  <moduleName>    the module name for <outFile>\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
   "  <template-file> a path to the Signal.chs.template file\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
   "  <types-file>    a path to a gtkmarshal.list file\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
   "  <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 1

hookGen :: [String] -> IO String
hookGen :: [String] -> IO String
hookGen args :: [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 ("-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 ("--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 10) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ("--modname=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)  [String]
args) of
                        (modName :: String
modName:_) -> String
modName
  String
templateFile <- case ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> ShowS
forall a. Int -> [a] -> [a]
drop 11) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ("--template=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)  [String]
args) of
                    [tplName :: String
tplName] -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
tplName
                    _ -> String -> IO String
getDataFileName "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 8) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ("--types=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)  [String]
args) of
                 [typName :: String
typName] -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
typName
                 _ -> 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 9) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ("--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 (\var :: String
var ->
      case String
var of
        "MODULE_NAME"    -> String -> ShowS
ss String
outModuleName
        "MODULE_EXPORTS" -> Signatures -> ShowS
genExport Signatures
sigs
        "MODULE_IMPORTS" -> [String] -> ShowS
genImports [String]
extraImports
        "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 -> ShowS
forall a. HasCallStack => String -> a
error String
var
    ) ""

templateSubstitute :: String -> (String -> ShowS) -> ShowS
templateSubstitute :: String -> (String -> ShowS) -> ShowS
templateSubstitute template :: String
template varSubst :: String -> ShowS
varSubst = String -> ShowS
doSubst String
template
  where doSubst :: String -> ShowS
doSubst [] = ShowS
forall a. a -> a
id
        doSubst ('\\':'@':cs :: String
cs) = Char -> ShowS
sc '@' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
doSubst String
cs
        doSubst ('@':cs :: String
cs) = let (var :: String
var,_:cs' :: String
cs') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ('@'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 (c :: Char
c:cs :: 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 sigs :: 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 sig :: (Types, [Types])
sig = String -> ShowS
ss "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 ','ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
indent 1

genImports :: [String] -> ShowS
genImports :: [String] -> ShowS
genImports mods :: [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 m :: String
m = String -> ShowS
ss "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 0

#ifdef USE_GCLOSURE_SIGNALS_IMPL

generate :: Signature -> ShowS
generate :: (Types, [Types]) -> ShowS
generate sig :: (Types, [Types])
sig = let ident :: ShowS
ident = (Types, [Types]) -> ShowS
mkIdentifier (Types, [Types])
sig in
  Int -> ShowS
indent 0ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss "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 " :: "ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent 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 " 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 1ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss "ConnectAfter -> obj ->"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent 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 " ->"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent 1ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss "IO (ConnectId obj)"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent 0ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss "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 " 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 "after obj user ="ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent 1ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss "connectGeneric signal after obj action"ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent 1ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss "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 1ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss "      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 '='ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent 5ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss "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 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