From: Duncan C. <dun...@us...> - 2005-02-20 18:52:19
|
Update of /cvsroot/gtk2hs/gtk2hs/tools/apiGen In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv32237/tools/apiGen Modified Files: Api.hs CodeGen.hs FormatDocs.hs Marshal.hs Log Message: Various small improvements to the code generator: Api.hs: add support for misc symbols: structs, boxed, class, aliases and callbacks. tools/apiGen/FormatDocs.hs: Format constants correctly. Format object names as symbol hyperlinks rather than module hyperlinks. Format the class hierarchy better. Marshal.hs: Add misc types. Add a list of known misc types that do not need to generate FIXME's in the generated docs. Add a list of types that are 'leaf' classes where we do not need to generate code that allows for subclasses, eg GtkAdjustment. Add marshaling for some extra simple types gdouble, gfloat and some boxed types: TreeIter, TreePath and TextIter. Add a convertSignalType function which maps C type names to signal type specs, eg OBJECT etc. CodeGen.hs: Add section names in the generated code. Make generated constructors preserve 'unsafe' annotations. Do signal generation more fully; produce the full connect_* name. Add misc types to the symbols map. Index: Marshal.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/Marshal.hs,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- Marshal.hs 15 Feb 2005 19:03:27 -0000 1.3 +++ Marshal.hs 20 Feb 2005 18:52:09 -0000 1.4 @@ -4,9 +4,11 @@ ObjectKind(..), EnumKind(..), stripKnownPrefixes, + knownMiscType, genMarshalParameter, genMarshalResult, genMarshalProperty, + convertSignalType, genCall ) where @@ -20,6 +22,10 @@ | SymEnumType EnumKind | SymEnumValue | SymStructType + | SymBoxedType + | SymClassType + | SymTypeAlias + | SymCallbackType deriving Eq data ObjectKind = GObjectKind | GtkObjectKind @@ -42,6 +48,9 @@ symbolIsFlags (Just (SymEnumType FlagsKind)) = True symbolIsFlags _ = False +symbolIsBoxed (Just SymBoxedType) = True +symbolIsBoxed _ = False + stripKnownPrefixes :: String -> String stripKnownPrefixes ('A':'t':'k':remainder) = remainder stripKnownPrefixes ('G':'t':'k':remainder) = remainder @@ -50,6 +59,26 @@ stripKnownPrefixes ('G':'n':'o':'m':'e':remainder) = remainder stripKnownPrefixes other = other +-- These are ones we have bound and so we can make documentation references to +-- them. Otherwise we generate FIXME messages in the docs. +knownMiscType :: String -> Bool +knownMiscType "GtkTreePath" = True +knownMiscType "GtkTreeIter" = True +knownMiscType "GdkColor" = True +knownMiscType "GtkTextIter" = True +knownMiscType "GtkIconSet" = True +knownMiscType _ = False + +-- These are classes from which no other class derives or is ever likely to +-- derive. In this case we can use the actual type rather than the type class +-- For example: GtkAdjustment we say +-- > Adjustment -> ... +-- rather than +-- > AdjustmentClass adjustment => adjustment -> ... +leafClass :: String -> Bool +leafClass "GtkAdjustment" = True +leafClass _ = False + ------------------------------------------------------------------------------- -- Here's the interesting bit that generates the fragments of mashaling code ------------------------------------------------------------------------------- @@ -100,18 +129,24 @@ indent 1. body. indent 2. sc ' '. ss name. ss "Ptr") +-- Objects ----------------------------- genMarshalParameter knownSymbols name typeName' | isUpper (head typeName') && last typeName' == '*' && last typeName /= '*' && symbolIsObject typeKind = - (Just $ shortTypeName ++ "Class " ++ name, Just name, - \body -> body. - indent 2. ss " (to". ss shortTypeName. sc ' '. ss name. ss ")") + if leafClass typeName + then (Nothing, Just shortTypeName, + \body -> body. + indent 2. ss name) + else (Just $ shortTypeName ++ "Class " ++ name, Just name, + \body -> body. + indent 2. ss " (to". ss shortTypeName. sc ' '. ss name. ss ")") where typeName = init typeName' shortTypeName = stripKnownPrefixes typeName typeKind = lookupFM knownSymbols typeName +-- Enums ------------------------------- genMarshalParameter knownSymbols name typeName | isUpper (head typeName) && symbolIsEnum typeKind = @@ -121,6 +156,7 @@ where shortTypeName = stripKnownPrefixes typeName typeKind = lookupFM knownSymbols typeName +-- Flags ------------------------------- genMarshalParameter knownSymbols name typeName | isUpper (head typeName) && symbolIsFlags typeKind = @@ -130,6 +166,23 @@ where shortTypeName = stripKnownPrefixes typeName typeKind = lookupFM knownSymbols typeName +genMarshalParameter _ name textIter | textIter == "const-GtkTextIter*" + || textIter == "GtkTextIter*" = + (Nothing, Just "TextIter", + \body -> body. + indent 2. sc ' '. ss name) + +genMarshalParameter _ name "GtkTreeIter*" = + (Nothing, Just "TreeIter", + \body -> body. + indent 2. sc ' '. ss name) + +genMarshalParameter _ name "GtkTreePath*" = + (Nothing, Just "TreePath", + \body -> ss "withTreePath ". ss name. ss " $ \\". ss name. ss " ->". + indent 1. body. + indent 2. sc ' '. ss name) + genMarshalParameter _ name unknownType = (Nothing, Just $ "{-" ++ unknownType ++ "-}", \body -> body. @@ -141,6 +194,8 @@ genMarshalResult _ "gboolean" = ("IO Bool", \body -> ss "liftM toBool $". indent 1. body) genMarshalResult _ "gint" = ("IO Int", \body -> ss "liftM fromIntegral $". indent 1. body) genMarshalResult _ "guint" = ("IO Int", \body -> ss "liftM fromIntegral $". indent 1. body) +genMarshalResult _ "gdouble" = ("IO Double", \body -> ss "liftM realToFrac $". indent 1. body) +genMarshalResult _ "gfloat" = ("IO Float", \body -> ss "liftM realToFrac $". indent 1. body) genMarshalResult _ "void" = ("IO ()", id) genMarshalResult _ "const-gchar*" = ("IO String", \body -> body. indent 1. ss ">>= peekUTFString") @@ -196,6 +251,8 @@ genMarshalResult _ unknownType = ("{-" ++ unknownType ++ "-}", id) +-- Takes the type string and returns the Haskell Type and the GValue constructor +-- genMarshalProperty :: KnownSymbols -> String -> (String, String) genMarshalProperty _ "gint" = ("Int", "GVint") genMarshalProperty _ "guint" = ("Int", "GVuint") @@ -227,6 +284,32 @@ genMarshalProperty _ unknown = ("{-" ++ unknown ++ "-}", "{-" ++ unknown ++ "-}") +-- Takes the type string and returns the signal marshaing category +-- +convertSignalType :: KnownSymbols -> String -> String +convertSignalType _ "void" = "NONE" +convertSignalType _ "gchar" = "CHAR" +convertSignalType _ "guchar" = "UCHAR" +convertSignalType _ "gboolean" = "BOOLEAN" +convertSignalType _ "gint" = "INT" +convertSignalType _ "guint" = "UINT" +convertSignalType _ "glong" = "LONG" +convertSignalType _ "gulong" = "ULONG" +convertSignalType _ "gfloat" = "FLOAT" +convertSignalType _ "gdouble" = "DOUBLE" +convertSignalType _ "gchar*" = "STRING" +convertSignalType _ "const-gchar*" = "STRING" +convertSignalType knownSymbols typeName + | symbolIsEnum typeKind = "ENUM" + | symbolIsFlags typeKind = "FLAGS" + where typeKind = lookupFM knownSymbols typeName +convertSignalType knownSymbols typeName@(_:_) + | last typeName == '*' + && symbolIsBoxed typeKind = "BOXED" + | last typeName == '*' + && symbolIsObject typeKind = "OBJECT" + where typeKind = lookupFM knownSymbols (init typeName) +convertSignalType _ typeName = "{-" ++ typeName ++ "-}" ------------------------------------------------------------------------------- -- Now for some special cases, we can override the generation of {# call #}'s Index: CodeGen.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/CodeGen.hs,v retrieving revision 1.5 retrieving revision 1.6 diff -u -d -r1.5 -r1.6 --- CodeGen.hs 17 Feb 2005 13:51:34 -0000 1.5 +++ CodeGen.hs 20 Feb 2005 18:52:09 -0000 1.6 @@ -62,7 +62,7 @@ formattedDoc = case doc of Nothing -> ss "-- | \n-- \n" Just doc -> ss "-- | ". haddocFormatParas knownSymbols (funcdoc_paragraphs doc). nl. - comment. nl + ss "--\n" paramDocMap = case doc of Nothing -> [] Just doc -> [ (paramdoc_name paramdoc @@ -105,10 +105,16 @@ genModuleBody :: KnownSymbols -> Object -> ModuleDoc -> ModuleInfo -> ShowS genModuleBody knownSymbols object apiDoc modInfo = doVersionIfDefs (sepBy' "\n\n") $ - genConstructors knownSymbols object (moduledoc_functions apiDoc) - ++ genMethods knownSymbols object (moduledoc_functions apiDoc) (module_methods modInfo) - ++ genProperties knownSymbols object (moduledoc_properties apiDoc) - ++ genSignals knownSymbols object (moduledoc_signals apiDoc) + sectionHeader "Constructors" + (genConstructors knownSymbols object (moduledoc_functions apiDoc) (module_methods modInfo)) + ++ sectionHeader "Methods" + (genMethods knownSymbols object (moduledoc_functions apiDoc) (module_methods modInfo)) + ++ sectionHeader "Properties" + (genProperties knownSymbols object (moduledoc_properties apiDoc)) + ++ sectionHeader "Signals" + (genSignals knownSymbols object (moduledoc_signals apiDoc)) + where sectionHeader name [] = [] + sectionHeader name entries = (ss "--------------------\n-- ". ss name, ("", False)):entries -- fixup the names of the C functions we got from scaning the original modules -- we want the fully qualified "gtk_foo_bar" rather than "foo_bar" so that the @@ -169,17 +175,20 @@ method_parameters = self : method_parameters method } -genConstructors :: KnownSymbols -> Object -> [FuncDoc] -> [(ShowS, (Since, Deprecated))] -genConstructors knownSymbols object apiDoc = - [ (genFunction knownSymbols constructor doc Nothing, (maybe "" funcdoc_since doc, notDeprecated)) - | (constructor, doc) <- constructors object apiDoc ] +genConstructors :: KnownSymbols -> Object -> [FuncDoc] -> [MethodInfo] -> [(ShowS, (Since, Deprecated))] +genConstructors knownSymbols object apiDoc methodsInfo = + [ (genFunction knownSymbols constructor doc info, (maybe "" funcdoc_since doc, notDeprecated)) + | (constructor, doc, info) <- constructors object apiDoc methodsInfo ] -constructors :: Object -> [FuncDoc] -> [(Method, Maybe FuncDoc)] -constructors object docs = - [ (mungeConstructor object constructor, constructor_cname constructor `lookup` docmap) +constructors :: Object -> [FuncDoc] -> [MethodInfo] -> [(Method, Maybe FuncDoc, Maybe MethodInfo)] +constructors object docs methodsInfo = + [ (mungeConstructor object constructor + ,lookup (constructor_cname constructor) docmap + ,lookup (constructor_cname constructor) infomap) | constructor <- object_constructors object , null [ () | VarArgs <- constructor_parameters constructor] ] - where docmap = [ (funcdoc_name doc, doc) | doc <- docs ] + where docmap = [ (funcdoc_name doc, doc) | doc <- docs ] + infomap = [ (methodinfo_cname info, info) | info <- methodsInfo ] mungeConstructor :: Object -> Constructor -> Method mungeConstructor object constructor = @@ -221,17 +230,15 @@ formattedDoc = case doc of Nothing -> ss "-- | \n-- \n" Just doc -> ss "-- | ". haddocFormatParas knownSymbols (propdoc_paragraphs doc). nl. - comment. nl + ss "--\n" (propertyType, gvalueConstructor) = genMarshalProperty knownSymbols (property_type property) signals :: Object -> [SignalDoc] -> [(Signal, Maybe SignalDoc)] signals object docs = - [ (signal, map dashToUnderscore (signal_cname signal) `lookup` docmap) + [ (signal, canonicalSignalName (signal_cname signal) `lookup` docmap) | signal <- object_signals object ] - where docmap = [ (map dashToUnderscore (signaldoc_name doc), doc) + where docmap = [ (canonicalSignalName (signaldoc_name doc), doc) | doc <- docs ] - dashToUnderscore '-' = '_' - dashToUnderscore c = c genSignals :: KnownSymbols -> Object -> [SignalDoc] -> [(ShowS, (Since, Deprecated))] genSignals knownSymbols object apiDoc = @@ -239,19 +246,32 @@ | (signal, doc) <- signals object apiDoc ] genSignal :: KnownSymbols -> Object -> Signal -> Maybe SignalDoc -> ShowS -genSignal knownSymbols object property doc = +genSignal knownSymbols object signal doc = formattedDoc. ss "on". signalName. ss ", after". signalName. ss " :: ". nl. - ss "on". signalName. ss " = connect_{-type-}". connectType. sc ' '. signalCName. ss " False". nl. - ss "after". signalName. ss " = connect_{-type-}". connectType. sc ' '. signalCName. ss " True". nl + ss "on". signalName. ss " = connect_". connectType. sc ' '. signalCName. ss " False". nl. + ss "after". signalName. ss " = connect_". connectType. sc ' '. signalCName. ss " True". nl - where connectType = id - signalName = ss (upperCaseFirstChar (cFuncNameToHsName (signal_cname property))) - signalCName = sc '"'. ss (signal_cname property). sc '"' + where connectType = sepBy "_" paramTypes . ss "__" . ss returnType + -- strip off the object arg to the signal handler + params = case signal_parameters signal of + (param:params) | parameter_type param == object_cname object ++ "*" -> params + params -> params + paramTypes | null params = ["NONE"] + | otherwise = [ convertSignalType knownSymbols (parameter_type parameter) + | parameter <- params ] + returnType = convertSignalType knownSymbols (signal_return_type signal) + signalName = ss (toStudlyCaps . canonicalSignalName . signal_cname $ signal) + signalCName = sc '"'. ss (signal_cname signal). sc '"' formattedDoc = case doc of Nothing -> ss "-- | \n-- \n" Just doc -> ss "-- | ". haddocFormatParas knownSymbols (signaldoc_paragraphs doc). nl. - comment. nl + ss "--\n" + +canonicalSignalName :: String -> String +canonicalSignalName = map dashToUnderscore + where dashToUnderscore '-' = '_' + dashToUnderscore c = c makeKnownSymbolsMap :: API -> KnownSymbols makeKnownSymbolsMap api = @@ -269,6 +289,8 @@ ++ [ (member_cname member, SymEnumValue) | enum <- namespace_enums namespace , member <- enum_members enum ] + ++ [ (misc_cname misc, miscToCSymbol misc ) + | misc <- namespace_misc namespace ] | namespace <- api ] -- find if an object inherits via GtkObject or directly from GObject @@ -289,6 +311,11 @@ objectMap = [ (object_cname object, object) | namespace <- api , object <- namespace_objects namespace ] + miscToCSymbol (Struct _ _) = SymStructType + miscToCSymbol (Boxed _ _) = SymBoxedType + miscToCSymbol (Class _ _) = SymClassType + miscToCSymbol (Alias _ _) = SymTypeAlias + miscToCSymbol (Callback _ _) = SymCallbackType genExports :: Object -> ModuleDoc -> ModuleInfo -> ShowS genExports object docs modInfo = @@ -298,7 +325,7 @@ indent 1.ss "castTo".ss (object_name object).sc ','. (case [ (ss " ". ss (cFuncNameToHsName (method_cname constructor)). sc ',' ,(maybe "" funcdoc_since doc, notDeprecated)) - | (constructor, doc) <- constructors object (moduledoc_functions docs)] of + | (constructor, doc, _) <- constructors object (moduledoc_functions docs) []] of [] -> id cs -> nl.nl.comment.ss "* Constructors".nl. doVersionIfDefs lines cs). Index: Api.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/Api.hs,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- Api.hs 14 Feb 2005 02:10:48 -0000 1.2 +++ Api.hs 20 Feb 2005 18:52:09 -0000 1.3 @@ -10,6 +10,7 @@ Method(..), Property(..), Signal(..), + Misc(..), extractAPI ) where @@ -27,7 +28,8 @@ namespace_name :: String, namespace_library :: String, namespace_objects :: [Object], - namespace_enums :: [Enum] + namespace_enums :: [Enum], + namespace_misc :: [Misc] } deriving Show data Enum = Enum { @@ -97,6 +99,29 @@ signal_parameters :: [Parameter] } deriving Show +data Misc = + Struct { + misc_name :: String, + misc_cname :: String + } + | Boxed { + misc_name :: String, + misc_cname :: String + } + | Class { + misc_name :: String, + misc_cname :: String + } + | Alias { + misc_name :: String, + misc_cname :: String + } + | Callback { + misc_name :: String, + misc_cname :: String + } + deriving Show + ------------------------------------------------------------------------------- -- extract functions to convert the api xml file to the internal representation ------------------------------------------------------------------------------- @@ -112,7 +137,8 @@ namespace_name = Xml.verbatim name, namespace_library = Xml.verbatim lib, namespace_objects = catMaybes (map extractObject content), - namespace_enums = catMaybes (map extractEnum content) + namespace_enums = catMaybes (map extractEnum content), + namespace_misc = catMaybes (map extractMisc content) } extractNameSpace _ = Nothing @@ -229,6 +255,14 @@ parameter_isArray = False } extractParameter (Xml.CElem (Xml.Elem "parameter" + [("name", Xml.AttValue name), + ("type", Xml.AttValue type_)] [])) = + Parameter { + parameter_type = Xml.verbatim type_, + parameter_name = Xml.verbatim name, + parameter_isArray = False + } +extractParameter (Xml.CElem (Xml.Elem "parameter" [("type", Xml.AttValue type_), ("name", Xml.AttValue name), ("printf_format" ,_)] [])) = @@ -303,3 +337,32 @@ -> map extractParameter parameters } extractSignal _ = Nothing + +extractMisc :: Xml.Content -> Maybe Misc +extractMisc (Xml.CElem (Xml.Elem elem + (("name", Xml.AttValue name): + ("cname", Xml.AttValue cname):_) _)) + | elem == "struct" = Just Struct { + misc_name = Xml.verbatim name, + misc_cname = Xml.verbatim cname + } + | elem == "boxed" = Just Boxed { + misc_name = Xml.verbatim name, + misc_cname = Xml.verbatim cname + } + | elem == "class" = Just Class { + misc_name = Xml.verbatim name, + misc_cname = Xml.verbatim cname + } + | elem == "alias" = Just Alias { + misc_name = Xml.verbatim name, + misc_cname = Xml.verbatim cname + } + | elem == "callback" = Just Callback { + misc_name = Xml.verbatim name, + misc_cname = Xml.verbatim cname + } +extractMisc (Xml.CElem (Xml.Elem "object" _ _)) = Nothing +extractMisc (Xml.CElem (Xml.Elem "interface" _ _)) = Nothing +extractMisc (Xml.CElem (Xml.Elem "enum" _ _)) = Nothing +extractMisc other = error $ "extractMisc: " ++ Xml.verbatim other Index: FormatDocs.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/FormatDocs.hs,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- FormatDocs.hs 17 Feb 2005 13:51:35 -0000 1.3 +++ FormatDocs.hs 20 Feb 2005 18:52:09 -0000 1.4 @@ -10,6 +10,7 @@ genModuleDocumentation, cFuncNameToHsName, cParamNameToHsName, + toStudlyCaps, haddocFormatParas, haddocFormatSpans, haddocFormatSpan, @@ -20,7 +21,7 @@ import Api (NameSpace(namespace_name)) import Docs -import Marshal (stripKnownPrefixes, KnownSymbols, CSymbol(..)) +import Marshal (stripKnownPrefixes, knownMiscType, KnownSymbols, CSymbol(..)) import StringUtils import Maybe (isJust) @@ -53,9 +54,16 @@ haddocFormatHierarchy :: KnownSymbols -> [DocParaSpan] -> ShowS haddocFormatHierarchy knownSymbols = sepBy "\n-- |" + . map haddocTweakHierarchy . Prelude.lines . concatMap (haddocFormatSpan knownSymbols) +haddocTweakHierarchy :: String -> String +haddocTweakHierarchy ('+':'-':'-':'-':'-':cs@(c:_)) | c /= ''' = + case span isAlpha cs of (word, rest) -> "+----" ++ stripKnownPrefixes word ++ rest +haddocTweakHierarchy (c:cs) = c : haddocTweakHierarchy cs +haddocTweakHierarchy [] = [] + addVersionParagraphs :: NameSpace -> ModuleDoc -> ModuleDoc addVersionParagraphs namespace apiDoc = apiDoc { @@ -140,10 +148,16 @@ Nothing | text == "TRUE" -> "@True@" | text == "FALSE" -> "@False@" | otherwise -> "{" ++ text ++ ", FIXME: unknown type/value}" - Just (SymObjectType _) -> "\"" ++ stripKnownPrefixes text ++ "\"" + Just (SymObjectType _) -> "'" ++ stripKnownPrefixes text ++ "'" Just (SymEnumType _) -> "'" ++ stripKnownPrefixes text ++ "'" Just SymEnumValue -> "'" ++ cConstNameToHsName text ++ "'" - _ -> "{" ++ text ++ ", FIXME: unknown type/value}" --TODO fill in the other cases + Just SymStructType -> "{" ++ text ++ ", FIXME: struct type}" + Just SymBoxedType -> if knownMiscType text + then "'" ++ stripKnownPrefixes text ++ "'" + else "{" ++ text ++ ", FIXME: boxed type}" + Just SymClassType -> "{" ++ text ++ ", FIXME: class type}" + Just SymTypeAlias -> "{" ++ text ++ ", FIXME: type alias}" + Just SymCallbackType -> "{" ++ text ++ ", FIXME: callback type}" haddocFormatSpan _ (DocFuncXRef text) = "'" ++ cFuncNameToHsName text ++ "'" haddocFormatSpan _ (DocOtherXRef text) = "'{FIXME: gtk-doc cross reference to:" ++ text ++ "}'" haddocFormatSpan _ (DocEmphasis text) = "/" ++ text ++ "/" @@ -172,9 +186,8 @@ . toStudlyCaps cConstNameToHsName :: String -> String -cConstNameToHsName = --change "GTK_UPDATE_DISCONTINUOUS" to "updateDiscontinuous" - lowerCaseFirstChar - . stripKnownPrefixes +cConstNameToHsName = --change "GTK_UPDATE_DISCONTINUOUS" to "UpdateDiscontinuous" + stripKnownPrefixes . toStudlyCaps . map toLower @@ -208,9 +221,16 @@ | word' == "NULL" = "{@NULL@, FIXME: this should probably be converted to a Maybe data type}" ++ remainder | isJust e = case e of - Just (SymObjectType _) -> "\"" ++ stripKnownPrefixes word' ++ "\"" ++ remainder + Just (SymObjectType _) -> "'" ++ stripKnownPrefixes word' ++ "'" ++ remainder Just (SymEnumType _) -> "'" ++ stripKnownPrefixes word' ++ "'" ++ remainder Just SymEnumValue -> "'" ++ cConstNameToHsName word' ++ "'" ++ remainder + Just SymStructType -> "{" ++ word' ++ ", FIXME: struct type}" + Just SymBoxedType -> if knownMiscType word' + then "'" ++ stripKnownPrefixes word' ++ "'" + else "{" ++ word' ++ ", FIXME: boxed type}" + Just SymClassType -> "{" ++ word' ++ ", FIXME: class type}" + Just SymTypeAlias -> "{" ++ word' ++ ", FIXME: type alias}" + Just SymCallbackType -> "{" ++ word' ++ ", FIXME: callback type}" | otherwise = word where e = lookupFM knownSymbols word' (word', remainder) = span (\c -> isAlpha c || c == '_') word |