diff --git a/c2hs/c/CParser.y b/c2hs/c/CParser.y --- a/c2hs/c/CParser.y +++ b/c2hs/c/CParser.y @@ -1814,9 +1814,13 @@ attribute_params :: { () } attribute_params - : constant_expression { () } - | attribute_params ',' constant_expression { () } + : attribute_param { () } + | attribute_params ',' attribute_param { () } +attribute_param :: { () } +attribute_param + : constant_expression { () } + | ident '=' cfloat { () } { diff --git a/c2hs/toplevel/Version.hs b/c2hs/toplevel/Version.hs --- a/c2hs/toplevel/Version.hs +++ b/c2hs/toplevel/Version.hs @@ -6,7 +6,7 @@ -- idstr = "$Id: Version.hs,v 1.1 2012/05/27 16:49:07 dmwit Exp $" name = "C->Haskell Compiler" -versnum = "0.13.9 (gtk2hs branch)" +versnum = "0.13.10 (gtk2hs branch)" versnick = "\"Bin IO\"" date = "27 May 2012" version = name ++ ", version " ++ versnum ++ " " ++ versnick ++ ", " ++ date diff --git a/callbackGen/HookGenerator.hs b/callbackGen/HookGenerator.hs --- a/callbackGen/HookGenerator.hs +++ b/callbackGen/HookGenerator.hs @@ -26,7 +26,9 @@ | Tfloat | Tdouble | Tstring - | Tmstring + | Tmstring + | Tgstring + | Tmgstring | Tboxed -- a struct which is passed by value | Tptr -- pointer | Ttobject -- foreign with WidgetClass context @@ -41,7 +43,7 @@ ------------------------------------------------------------------------------- -- Parsing ------------------------------------------------------------------------------- - + parseSignatures :: String -> Signatures parseSignatures content = (nub.parseSig 1.scan) content @@ -75,7 +77,7 @@ let (args,rem') = parseArg l rem in (ty:args, rem') parseArg l rem = error ("parse error on line "++show l++": expected type"++ - " followed by comma or EOL, found\n "++ + " followed by comma or EOL, found\n "++ concatMap show (take 5 rem)) scan :: String -> [Token] @@ -100,6 +102,8 @@ scan ('D':'O':'U':'B':'L':'E':xs) = TokType Tdouble:scan xs scan ('S':'T':'R':'I':'N':'G':xs) = TokType Tstring:scan xs scan ('M':'S':'T':'R':'I':'N':'G':xs) = TokType Tmstring:scan xs +scan ('G':'L':'I':'B':'S':'T':'R':'I':'N':'G':xs) = TokType Tgstring:scan xs +scan ('M':'G':'L':'I':'B':'S':'T':'R':'I':'N':'G':xs) = TokType Tmgstring:scan xs scan ('B':'O':'X':'E':'D':xs) = TokType Tboxed:scan xs scan ('P':'O':'I':'N':'T':'E':'R':xs) = TokType Tptr:scan xs scan ('T':'O':'B':'J':'E':'C':'T':xs) = TokType Ttobject:scan xs @@ -141,6 +145,8 @@ identifier Tdouble = ss "DOUBLE" identifier Tstring = ss "STRING" identifier Tmstring = ss "MSTRING" +identifier Tgstring = ss "GLIBSTRING" +identifier Tmgstring = ss "MGLIBSTRING" identifier Tboxed = ss "BOXED" identifier Tptr = ss "PTR" identifier Ttobject = ss "OBJECT" @@ -166,6 +172,8 @@ rawtype Tdouble = ss "Double" 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" @@ -192,6 +200,8 @@ 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" @@ -201,13 +211,13 @@ #endif --- The possibly polymorphic type which +-- The possibly polymorphic type which usertype :: Types -> [Char] -> (ShowS,[Char]) usertype Tunit cs = (ss "()",cs) usertype Tbool (c:cs) = (ss "Bool",cs) usertype Tchar (c:cs) = (ss "Char",cs) usertype Tuchar (c:cs) = (ss "Char",cs) -usertype Tint (c:cs) = (ss "Int",cs) +usertype Tint (c:cs) = (ss "Int",cs) usertype Tuint (c:cs) = (ss "Word",cs) usertype Tlong (c:cs) = (ss "Int",cs) usertype Tulong (c:cs) = (ss "Int",cs) @@ -217,6 +227,8 @@ usertype Tdouble (c:cs) = (ss "Double",cs) usertype Tstring (c:cs) = (ss "String",cs) usertype Tmstring (c:cs) = (ss "Maybe String",cs) +usertype Tgstring (c:cs) = (sc c.sc '\'',cs) +usertype Tmgstring (c:cs) = (ss "Maybe ".sc c.sc '\'',cs) usertype Tboxed (c:cs) = (sc c,cs) usertype Tptr (c:cs) = (ss "Ptr ".sc c,cs) usertype Ttobject (c:cs) = (sc c.sc '\'',cs) @@ -237,6 +249,8 @@ context (Tmtobject:ts) (c:cs) = ss "GObjectClass ".sc c.sc '\'': context ts cs context (Tobject:ts) (c:cs) = ss "GObjectClass ".sc c.sc '\'': context ts cs context (Tmobject:ts) (c:cs) = ss "GObjectClass ".sc c.sc '\'': context ts cs +context (Tgstring:ts) (c:cs) = ss "Glib.GlibString ".sc c.sc '\'': context ts cs +context (Tmgstring:ts) (c:cs) = ss "Glib.GlibString ".sc c.sc '\'': context ts cs context (_:ts) (c:cs) = context ts cs context [] _ = [] @@ -278,6 +292,8 @@ nameArg Tdouble c = ss "double".shows c nameArg Tstring c = ss "str".shows c nameArg Tmstring c = ss "str".shows c +nameArg Tgstring c = ss "str".shows c +nameArg Tmgstring c = ss "str".shows c nameArg Tboxed c = ss "box".shows c nameArg Tptr c = ss "ptr".shows c nameArg Ttobject c = ss "obj".shows c @@ -307,6 +323,10 @@ body. sc ' '. arg. sc '\'' marshExec Tmstring arg _ body = indent 5. ss "maybePeekUTFString ". arg. ss " >>= \\". arg. ss "\' ->". body. sc ' '. arg. sc '\'' +marshExec Tgstring arg _ body = indent 5. ss "peekUTFString ". arg. ss " >>= \\". arg. ss "\' ->". + body. sc ' '. arg. sc '\'' +marshExec Tmgstring arg _ body = indent 5. ss "maybePeekUTFString ". arg. ss " >>= \\". arg. ss "\' ->". + body. sc ' '. arg. sc '\'' marshExec Tboxed arg n body = indent 5. ss "boxedPre". ss (show n). ss " (castPtr ". arg. ss ") >>= \\". arg. ss "\' ->". body. sc ' '. arg. sc '\'' marshExec Tptr arg _ body = body. ss " (castPtr ". arg. sc ')' @@ -331,6 +351,7 @@ marshRet Tfloat body = body marshRet Tdouble body = body marshRet Tstring body = body. indent 5. ss ">>= newUTFString" +marshRet Tgstring body = body. indent 5. ss ">>= newUTFString" marshRet Tptr body = indent 5. ss "liftM castPtr $ ". body marshRet _ _ = error "Signal handlers cannot return structured types." @@ -363,6 +384,10 @@ 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". @@ -399,7 +424,7 @@ mkUserType :: Signature -> ShowS mkUserType (ret,ts) = let - (str,cs) = foldl (\(str,cs) t -> + (str,cs) = foldl (\(str,cs) t -> let (str',cs') = usertype t cs in (str.str'.ss " -> ",cs')) (sc '(',['a'..]) ts (str',_) = usertype ret cs @@ -413,7 +438,7 @@ mkMarshType :: Signature -> [ShowS] mkMarshType (ret,ts) = marshType (ts++[ret]) ['a'..] - + mkType sig = let types = mkMarshType sig in if null types then id else foldl (.) (indent 1) types @@ -433,7 +458,7 @@ #else mkMarshExec :: Signature -> ShowS -mkMarshExec (_,ts) = foldl (.) id $ +mkMarshExec (_,ts) = foldl (.) id $ zipWith marshExec ts [1..] #endif @@ -444,7 +469,7 @@ ss "__".identifier ret mkRawtype :: Signature -> ShowS -mkRawtype (ret,ts) = +mkRawtype (ret,ts) = foldl (.) id (map (\ty -> rawtype ty.ss " -> ") ts). (case ret of Tboxed -> ss "IO (".rawtype ret.sc ')' @@ -456,13 +481,13 @@ _ -> ss "IO ".rawtype ret) mkLambdaArgs :: Signature -> ShowS -mkLambdaArgs (_,ts) = foldl (.) id $ +mkLambdaArgs (_,ts) = foldl (.) id $ zipWith (\a b -> nameArg a b.sc ' ') ts [1..] #ifndef USE_GCLOSURE_SIGNALS_IMPL mkFuncArgs :: Signature -> ShowS -mkFuncArgs (_,ts) = foldl (.) id $ +mkFuncArgs (_,ts) = foldl (.) id $ zipWith (\a b -> sc ' '.nameArg a b.sc '\'') ts [1..] mkMarshRet :: Signature -> ShowS @@ -511,11 +536,11 @@ "MODULE_EXPORTS" -> genExport sigs "MODULE_IMPORTS" -> genImports extraImports "MODULE_BODY" -> foldl (.) id (map generate sigs) - _ -> error var + _ -> error var ) "" templateSubstitute :: String -> (String -> ShowS) -> ShowS -templateSubstitute template varSubst = doSubst template +templateSubstitute template varSubst = doSubst template where doSubst [] = id doSubst ('\\':'@':cs) = sc '@' . doSubst cs doSubst ('@':cs) = let (var,_:cs') = span ('@'/=) cs diff --git a/callbackGen/Signal.chs.template b/callbackGen/Signal.chs.template --- a/callbackGen/Signal.chs.template +++ b/callbackGen/Signal.chs.template @@ -28,7 +28,7 @@ -- The object system in the second version of GTK is based on GObject from -- GLIB. This base class is rather primitive in that it only implements -- ref and unref methods (and others that are not interesting to us). If --- the marshall list mentions OBJECT it refers to an instance of this +-- the marshall list mentions OBJECT it refers to an instance of this -- GObject which is automatically wrapped with a ref and unref call. -- Structures which are not derived from GObject have to be passed as -- BOXED which gives the signal connect function a possibility to do the @@ -47,9 +47,10 @@ import System.Glib.FFI import System.Glib.UTFString (peekUTFString,maybePeekUTFString) +import qualified System.Glib.UTFString as Glib import System.Glib.GError (failOnGError) {#import System.Glib.Signals#} -{#import System.Glib.GObject#} +{#import System.Glib.GObject#} @MODULE_IMPORTS@ {#context lib="gtk" prefix="gtk" #} diff --git a/gtk2hs-buildtools.cabal b/gtk2hs-buildtools.cabal --- a/gtk2hs-buildtools.cabal +++ b/gtk2hs-buildtools.cabal @@ -1,5 +1,5 @@ Name: gtk2hs-buildtools -Version: 0.12.5.2 +Version: 0.13.0.0 License: GPL-2 License-file: COPYING Copyright: (c) 2001-2010 The Gtk2Hs Team