Menu
▾
▴
[Gtk2hs-commit] gtk2hs/tools/apiGen Makefile,1.12,1.13 CodeGen.hs,1.14,1.15 Marshal.hs,1.9,1.10
|
From: Duncan C. <dun...@us...> - 2005-03-31 16:39:35
|
Update of /cvsroot/gtk2hs/gtk2hs/tools/apiGen In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23496/tools/apiGen Modified Files: Makefile CodeGen.hs Marshal.hs Log Message: ApiGen update: Makefile: update to latest versions of source code for all packages. CodeGen.hs: generalise parameter marshaling to include 'out' parameters as well as ordinary 'in' parameters and hidden / internal parameters. Also deal with 'shared' methods. These methods are like Java static methods. They take no self/object parameter. Marshal.hs: add support for marshaling the most common out parameter types: gboolean*, gint*, guint*, gfloat*, gdouble* and gchar**. Also add 'in' and return marshaling for a couple other misc types like fixed width integral types: guint16 and guint32. Index: Marshal.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/Marshal.hs,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- Marshal.hs 25 Mar 2005 19:14:55 -0000 1.9 +++ Marshal.hs 31 Mar 2005 16:39:19 -0000 1.10 @@ -2,7 +2,9 @@ KnownSymbols, CSymbol(..), EnumKind(..), + ParameterKind(..), genMarshalParameter, + genMarshalOutParameter, genMarshalResult, genMarshalProperty, convertSignalType, @@ -47,59 +49,76 @@ -- Here's the interesting bit that generates the fragments of mashaling code ------------------------------------------------------------------------------- +data ParameterKind = InParam String + | OutParam String + | UnusedParam + genMarshalParameter :: KnownSymbols -> --a collection of types we know to be objects or enums String -> --function name (useful to lookup per-func fixup info) String -> --parameter name suggestion (will be unique) String -> --C type decleration for the parameter we will marshal (Maybe String, --parameter class constraints (or none) - Maybe String, --parameter type (or none if the arg is not exposed) + ParameterKind, --parameter type (or UnusedParam if the arg is not exposed) ShowS -> ShowS) --marshaling code (\body -> ... body ...) genMarshalParameter _ _ name "gboolean" = - (Nothing, Just "Bool", + (Nothing, InParam "Bool", \body -> body. indent 2. ss "(fromBool ". ss name. ss ")") genMarshalParameter _ _ name typeName - | typeName == "guint" --these two are unsigned types - || typeName == "gint" - || typeName == "int" - || typeName == "gsize" --should they be Word or Int? - || typeName == "gssize" = - (Nothing, Just "Int", + | typeName == "guint" --these two are unsigned types + || typeName == "gint" + || typeName == "glong" + || typeName == "int" + || typeName == "gsize" --should they be Word or Int? + || typeName == "gssize" = + (Nothing, InParam "Int", \body -> body. indent 2. ss "(fromIntegral ". ss name. ss ")") -genMarshalParameter _ _ name "gdouble" = - (Nothing, Just "Double", +genMarshalParameter _ _ name "guint16" = + (Nothing, InParam "Word16", + \body -> body. + indent 2. ss "(fromIntegral ". ss name. ss ")") + +genMarshalParameter _ _ name "guint32" = + (Nothing, InParam "Word32", + \body -> body. + indent 2. ss "(fromIntegral ". ss name. ss ")") + +genMarshalParameter _ _ name typeName + | typeName == "gdouble" + || typeName == "double" = + (Nothing, InParam "Double", \body -> body. indent 2. ss "(realToFrac ". ss name. ss ")") genMarshalParameter _ _ name "gfloat" = - (Nothing, Just "Float", + (Nothing, InParam "Float", \body -> body. indent 2. ss "(realToFrac ". ss name. ss ")") genMarshalParameter _ _ name "gunichar" = - (Nothing, Just "Char", + (Nothing, InParam "Char", \body -> body. indent 2. ss "((fromIntegral . ord) ". ss name. ss ")") genMarshalParameter _ funcName name typeName | typeName == "const-gchar*" || typeName == "const-char*" = if maybeNullParameter funcName name - then (Nothing, Just "Maybe String", + then (Nothing, InParam "Maybe String", \body -> ss "maybeWith withUTFString ". ss name. ss " $ \\". ss name. ss "Ptr ->". indent 1. body. indent 2. ss name. ss "Ptr") - else (Nothing, Just "String", + else (Nothing, InParam "String", \body -> ss "withUTFString ". ss name. ss " $ \\". ss name. ss "Ptr ->". indent 1. body. indent 2. ss name. ss "Ptr") genMarshalParameter _ _ name "GError**" = - (Nothing, Nothing, + (Nothing, UnusedParam, \body -> ss "propagateGError $ \\". ss name. ss "Ptr ->". indent 1. body. indent 2. ss name. ss "Ptr") @@ -113,8 +132,8 @@ let classContext | leafClass typeName = Nothing | otherwise = Just $ shortTypeName ++ "Class " ++ name - argType = Just $ (if maybeNullParameter funcName name then "Maybe " else "") - ++ (if leafClass typeName then shortTypeName else name) + argType = (if maybeNullParameter funcName name then "Maybe " else "") + ++ (if leafClass typeName then shortTypeName else name) implementation | leafClass typeName && maybeNullParameter funcName name = ss "(fromMaybe (". ss shortTypeName. ss " nullForeignPtr) ". @@ -124,7 +143,7 @@ = ss "(maybe (". ss shortTypeName. ss " nullForeignPtr) to". ss shortTypeName. sc ' '. ss name. sc ')' | otherwise = ss "(to". ss shortTypeName. sc ' '. ss name. sc ')' - in (classContext, argType, + in (classContext, InParam argType, \body -> body. indent 2. implementation) where typeName = init typeName' @@ -135,7 +154,7 @@ genMarshalParameter knownSymbols _ name typeName | isUpper (head typeName) && symbolIsEnum typeKind = - (Nothing, Just shortTypeName, + (Nothing, InParam shortTypeName, \body -> body. indent 2. ss "((fromIntegral . fromEnum) ". ss name. ss ")") where shortTypeName = stripKnownPrefixes typeName @@ -145,34 +164,86 @@ genMarshalParameter knownSymbols _ name typeName | isUpper (head typeName) && symbolIsFlags typeKind = - (Nothing, Just ("[" ++ shortTypeName ++ "]"), + (Nothing, InParam ("[" ++ shortTypeName ++ "]"), \body -> body. indent 2. ss "((fromIntegral . fromFlags) ". ss name. ss ")") where shortTypeName = stripKnownPrefixes typeName typeKind = lookupFM knownSymbols typeName genMarshalParameter _ _ name textIter | textIter == "const-GtkTextIter*" - || textIter == "GtkTextIter*" = - (Nothing, Just "TextIter", + || textIter == "GtkTextIter*" = + (Nothing, InParam "TextIter", \body -> body. indent 2. ss name) genMarshalParameter _ _ name "GtkTreeIter*" = - (Nothing, Just "TreeIter", + (Nothing, InParam "TreeIter", \body -> body. indent 2. ss name) genMarshalParameter _ _ name "GtkTreePath*" = - (Nothing, Just "TreePath", + (Nothing, InParam "TreePath", \body -> ss "withTreePath ". ss name. ss " $ \\". ss name. ss " ->". indent 1. body. indent 2. ss name) +-- Out parameters ------------------------------- + +genMarshalParameter _ _ name "gboolean*" = + (Nothing, OutParam "Boolean", + \body -> body. + indent 2. ss name. ss "Ptr") + +genMarshalParameter _ _ name typeName + | typeName == "gint*" + || typeName == "guint*" = + (Nothing, OutParam "Int", + \body -> body. + indent 2. ss name. ss "Ptr") + +genMarshalParameter _ _ name "gfloat*" = + (Nothing, OutParam "Float", + \body -> body. + indent 2. ss name. ss "Ptr") + +genMarshalParameter _ _ name "gdouble*" = + (Nothing, OutParam "Double", + \body -> body. + indent 2. ss name. ss "Ptr") + +genMarshalParameter _ _ name "gchar**" = + (Nothing, OutParam "String", + \body -> body. + indent 2. ss name. ss "Ptr") + +-- Catch all case ------------------------------- genMarshalParameter _ _ name unknownType = - (Nothing, Just $ "{-" ++ unknownType ++ "-}", + (Nothing, InParam $ "{-" ++ unknownType ++ "-}", \body -> body. indent 2. ss "{-". ss name. ss "-}") +genMarshalOutParameter :: String -> String -> (ShowS, ShowS, ShowS) +genMarshalOutParameter "Boolean" name = (ss "alloca $ \\". ss name. ss "Ptr ->". indent 1 + ,indent 1. ss "peek ". ss name. ss "Ptr >>= \\". ss name. ss " ->" + ,ss "toBool ". ss name) + +genMarshalOutParameter "Int" name = (ss "alloca $ \\". ss name. ss "Ptr ->". indent 1 + ,indent 1. ss "peek ". ss name. ss "Ptr >>= \\". ss name. ss " ->" + ,ss "fromIntegral ". ss name) + +genMarshalOutParameter "Float" name = (ss "alloca $ \\". ss name. ss "Ptr ->". indent 1 + ,indent 1. ss "peek ". ss name. ss "Ptr >>= \\". ss name. ss " ->" + ,ss "realToFrac ". ss name) + +genMarshalOutParameter "Double" name = (ss "alloca $ \\". ss name. ss "Ptr ->". indent 1 + ,indent 1. ss "peek ". ss name. ss "Ptr >>= \\". ss name. ss " ->" + ,ss "realToFrac ". ss name) +genMarshalOutParameter "String" name = (ss "alloca $ \\". ss name. ss "Ptr ->". indent 1 + ,indent 1. ss "peek ". ss name. ss "Ptr >>= readUTFString >>= \\". ss name. ss " ->" + ,ss name) + +genMarshalOutParameter paramType name = (id, id, ss name) + -- Takes the type string and returns the Haskell Type and the marshaling code -- genMarshalResult :: @@ -185,6 +256,8 @@ genMarshalResult _ _ _ "gboolean" = ("Bool", \body -> ss "liftM toBool $". indent 1. body) genMarshalResult _ _ _ "gint" = ("Int", \body -> ss "liftM fromIntegral $". indent 1. body) genMarshalResult _ _ _ "guint" = ("Int", \body -> ss "liftM fromIntegral $". indent 1. body) +genMarshalResult _ _ _ "guint16" = ("Word16", \body -> ss "liftM fromIntegral $". indent 1. body) +genMarshalResult _ _ _ "guint32" = ("Word32", \body -> ss "liftM fromIntegral $". indent 1. body) genMarshalResult _ _ _ "gdouble" = ("Double", \body -> ss "liftM realToFrac $". indent 1. body) genMarshalResult _ _ _ "gfloat" = ("Float", \body -> ss "liftM realToFrac $". indent 1. body) genMarshalResult _ _ _ "gunichar" = ("Char", \body -> ss "liftM (chr . fromIntegral) $". indent 1. body) @@ -197,7 +270,9 @@ else ("String", \body -> body. indent 1. ss ">>= peekUTFString") -genMarshalResult _ funcName _ "gchar*" = +genMarshalResult _ funcName _ typeName + | typeName == "gchar*" + || typeName == "char*" = if maybeNullResult funcName then ("(Maybe String)", \body -> body. @@ -312,6 +387,7 @@ convertSignalType _ "gboolean" = ("BOOL", "Bool") convertSignalType _ "gint" = ("INT", "Int") convertSignalType _ "guint" = ("UINT", "Int") +convertSignalType _ "guint32" = ("UINT", "Int") convertSignalType _ "glong" = ("LONG", "Int") convertSignalType _ "gulong" = ("ULONG", "Int") convertSignalType _ "gfloat" = ("FLOAT", "Float") Index: CodeGen.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/CodeGen.hs,v retrieving revision 1.14 retrieving revision 1.15 diff -u -d -r1.14 -r1.15 --- CodeGen.hs 25 Mar 2005 19:14:55 -0000 1.14 +++ CodeGen.hs 31 Mar 2005 16:39:19 -0000 1.15 @@ -18,7 +18,7 @@ import Prelude hiding (Enum, lines) import List (groupBy, sortBy, isPrefixOf, isSuffixOf, partition, find) -import Maybe (isNothing, fromMaybe) +import Maybe (isNothing, fromMaybe, catMaybes) import Data.FiniteMap import Debug.Trace (trace) @@ -41,22 +41,39 @@ (c, ty, m) -> (c, (ty, parameter_name p), m) | p <- method_parameters method ] classConstraints = [ c | Just c <- classConstraints' ] - paramTypes = [ (paramType, lookup name paramDocMap) - | (Just paramType, name) <- paramTypes' ] - paramNames = [ changeIllegalNames (cParamNameToHsName (parameter_name p)) - | ((Just _, _), p) <- zip paramTypes' (method_parameters method) ] - formattedParamNames = cat (map (\name -> ss name.sc ' ') paramNames) + inParamTypes = [ (paramType, lookup name paramDocMap) + | (InParam paramType, name) <- paramTypes' ] + inParamNames = [ changeIllegalNames (cParamNameToHsName (parameter_name p)) + | ((InParam _, _), p) <- zip paramTypes' (method_parameters method) ] + outParamTypes = [ (paramType, lookup name paramDocMap) + | (OutParam paramType, name) <- paramTypes' ] + formattedParamNames = cat (map (\name -> ss name.sc ' ') inParamNames) (returnType', returnMarshaler) = genMarshalResult knownSymbols (method_cname method) isConstructor (method_return_type method) - returnType = ("IO " ++ returnType', lookup "Returns" paramDocMap) - functionType = (case classConstraints of + returnType | null outParamTypes = ("IO " ++ returnType', lookup "Returns" paramDocMap) + | otherwise = case unzip outParamTypes of + (types', docs') -> + let types | returnType' == "()" = types' + | otherwise = returnType' : types' + docs = mergeParamDocs (lookup "Returns" paramDocMap) docs' + in ("IO (" ++ sepBy ", " types "" ++ ")", docs) + (outParamMarshalersBefore, outParamMarshalersAfter, returnOutParamFragments) = + unzip3 [ genMarshalOutParameter outParamType (changeIllegalNames (cParamNameToHsName name)) + | (OutParam outParamType, name) <- paramTypes' ] + returnOutParams body | null outParamTypes = body + | otherwise = body + . indent 1. ss "return (". sepBy' ", " returnOutParamFragments. ss ")" + functionType = (case classConstraints of [] -> id [c] -> ss c. ss " => " cs -> sc '('. sepBy ", " classConstraints. ss ") => "). - formatParamTypes (paramTypes ++ [returnType]) + formatParamTypes (inParamTypes ++ [returnType]) body = foldl (\body marshaler -> marshaler body) - call (paramMarshalers++[returnMarshaler]) + call (paramMarshalers + ++ [ (\body -> frag. body) | frag <- reverse outParamMarshalersBefore ] + ++ [ (\body -> body. frag) | frag <- outParamMarshalersAfter ] + ++ [returnMarshaler,returnOutParams]) call = ss (genCall (maybe (method_cname method) methodinfo_shortcname info) safety) safety = case info of Nothing -> False @@ -104,6 +121,20 @@ . concatMap (haddocFormatSpan knownSymbols docNullsAllFixed) columnIndent = maximum [ length parmType | (parmType, _) <- paramTypes ] +mergeParamDocs :: Maybe [DocParaSpan] -> [Maybe [DocParaSpan]] -> Maybe [DocParaSpan] +mergeParamDocs doc docs = + case catMaybes (doc:docs) of + [] -> Nothing + [doc] -> Just doc + docs -> let (varNames, paramDocs) = + unzip [ case doc of + doc@(DocArg varName : _) -> (cParamNameToHsName varName, doc) + _ -> ("_", doc) + | doc <- docs ] + returnValName = DocLiteral ("(" ++ sepBy ", " varNames "" ++ ")") + fixmeMessage = DocText " {FIXME: merge return value docs} " + in Just $ returnValName : fixmeMessage : concat paramDocs + genModuleBody :: KnownSymbols -> Object -> ModuleDoc -> ModuleInfo -> ShowS genModuleBody knownSymbols object apiDoc modInfo = doVersionIfDefs (sepBy' "\n\n") $ @@ -183,7 +214,9 @@ } in method { method_name = object_name object ++ method_name method, - method_parameters = self : method_parameters method + method_parameters = if method_shared method + then method_parameters method + else self : method_parameters method } genConstructors :: KnownSymbols -> Object -> [FuncDoc] -> [MethodInfo] -> [(ShowS, (Since, Deprecated))] Index: Makefile =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/Makefile,v retrieving revision 1.12 retrieving revision 1.13 diff -u -d -r1.12 -r1.13 --- Makefile 27 Mar 2005 12:59:06 -0000 1.12 +++ Makefile 31 Mar 2005 16:39:19 -0000 1.13 @@ -28,20 +28,22 @@ # # source code # -GLIB_VERSION = 2.4.8 -PANGO_VERSION = 1.4.1 -ATK_VERSION = 1.6.1 -GTK_VERSION = 2.4.14 -GLADE_VERSION = 2.0.1 -CANVAS_VERSION = 2.4.0 +GLIB_VERSION = 2.6.3 +PANGO_VERSION = 1.8.1 +ATK_VERSION = 1.9.1 +GTK_VERSION = 2.6.4 +GLADE_VERSION = 2.5.1 +CANVAS_VERSION = 2.10.0 +GNOME_PLATFORM_URL = http://ftp.gnome.org/pub/gnome/platform/2.10/2.10.0/sources +GNOME_DESKTOP_URL = http://ftp.gnome.org/pub/gnome/desktop/2.10/2.10.0/sources DOWNLOADS = \ - ftp://ftp.gtk.org/pub/gtk/v2.4/glib-$(GLIB_VERSION).tar.bz2 \ - ftp://ftp.gtk.org/pub/gtk/v2.4/pango-$(PANGO_VERSION).tar.bz2 \ - ftp://ftp.gtk.org/pub/gtk/v2.4/atk-$(ATK_VERSION).tar.bz2 \ - ftp://ftp.gtk.org/pub/gtk/v2.4/gtk+-$(GTK_VERSION).tar.bz2 \ - http://ftp.gnome.org/pub/GNOME/desktop/2.4/2.4.2/sources/libglade-$(GLADE_VERSION).tar.bz2\ - http://ftp.gnome.org/pub/GNOME/desktop/2.4/2.4.2/sources/libgnomecanvas-$(CANVAS_VERSION).tar.bz2 + $(GNOME_PLATFORM_URL)/glib-$(GLIB_VERSION).tar.bz2 \ + $(GNOME_PLATFORM_URL)/pango-$(PANGO_VERSION).tar.bz2 \ + $(GNOME_PLATFORM_URL)/atk-$(ATK_VERSION).tar.bz2 \ + $(GNOME_PLATFORM_URL)/gtk+-$(GTK_VERSION).tar.bz2 \ + $(GNOME_PLATFORM_URL)/libglade-$(GLADE_VERSION).tar.bz2 \ + $(GNOME_PLATFORM_URL)/libgnomecanvas-$(CANVAS_VERSION).tar.bz2 get-source-code: for i in $(DOWNLOADS); do \ |
