Menu
▾
▴
[Gtk2hs-commit] gtk2hs/tools/apiGen ApiGen.hs,1.16,1.17 CodeGen.hs,1.6,1.7 FormatDocs.hs,1.4,1.5 Marshal.hs,1.4,1.5
|
From: Duncan C. <dun...@us...> - 2005-02-21 11:03:34
|
Update of /cvsroot/gtk2hs/gtk2hs/tools/apiGen In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv4199/tools/apiGen Modified Files: ApiGen.hs CodeGen.hs FormatDocs.hs Marshal.hs Log Message: More doc improvements and some code generator improvements: Marshal.hs: pass function name to parameter and return marshaling functions so that they can be used to lookup per-function fixup information. Add per-function fixup info maps; one to say that a function parameter can take a NULL pointer and one to say that the function return value can be NULL. Use this info to marshal these using Maybe types. Support Maybe for object parameters and returns and Maybe for string parameters and returns. FormatDocs.hs: add parameter to say if NULLs should be converted to Nothing or if they should generate FIXME messages. CodeGen.hs: include constructors in mapping of C function names from original modules so unsafe tags are preserved for constructors. Tell doc formatting functions when to ignore NULLs; do it when any of the function parameters or return are a Maybe type. Index: Marshal.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/Marshal.hs,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- Marshal.hs 20 Feb 2005 18:52:09 -0000 1.4 +++ Marshal.hs 21 Feb 2005 11:03:08 -0000 1.5 @@ -5,6 +5,8 @@ EnumKind(..), stripKnownPrefixes, knownMiscType, + maybeNullParameter, + maybeNullResult, genMarshalParameter, genMarshalResult, genMarshalProperty, @@ -77,26 +79,52 @@ -- > AdjustmentClass adjustment => adjustment -> ... leafClass :: String -> Bool leafClass "GtkAdjustment" = True +leafClass "GdkPixbuf" = True leafClass _ = False +-- This is a table of fixup information. It lists function parameters that +-- can be null and so should therefore be converted to use a Maybe type. +-- The perameters are identifed by C function name and parameter name. +-- +-- Note that if you set this to True for any parameter then the docs for this +-- function will use @Nothing@ in place of NULL rather than a FIXME message. So +-- make sure all possibly-null parameters have been fixed since all NULLs in +-- the function docs are suppressed (since there is no automatic way of working +-- out which function doc NULLs correspond to which parameters). +-- +maybeNullParameter :: String -> String -> Bool +maybeNullParameter "gtk_entry_completion_set_model" "model" = True +maybeNullParameter "gtk_label_new" "str" = True +maybeNullParameter _ _ = False + +-- similarly for method return values/types. +maybeNullResult :: String -> Bool +maybeNullResult "gtk_entry_completion_get_entry" = True +maybeNullResult "gtk_entry_completion_get_model" = True +maybeNullResult "gtk_accel_label_get_accel_widget" = True +maybeNullResult "gtk_progress_bar_get_text" = True +maybeNullResult "gtk_bin_get_child" = True +maybeNullResult _ = False + ------------------------------------------------------------------------------- -- Here's the interesting bit that generates the fragments of mashaling code ------------------------------------------------------------------------------- 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) ShowS -> ShowS) --marshaling code (\body -> ... body ...) -genMarshalParameter _ name "gboolean" = +genMarshalParameter _ _ name "gboolean" = (Nothing, Just "Bool", \body -> body. - indent 2. ss " (fromBool ". ss name. ss ")") + indent 2. ss "(fromBool ". ss name. ss ")") -genMarshalParameter _ name typeName +genMarshalParameter _ _ name typeName | typeName == "guint" --these two are unsigned types || typeName == "gint" || typeName == "int" @@ -104,33 +132,38 @@ || typeName == "gssize" = (Nothing, Just "Int", \body -> body. - indent 2. ss " (fromIntegral ". ss name. ss ")") + indent 2. ss "(fromIntegral ". ss name. ss ")") -genMarshalParameter _ name "gdouble" = +genMarshalParameter _ _ name "gdouble" = (Nothing, Just "Double", \body -> body. - indent 2. ss " (realToFrac ". ss name. ss ")") + indent 2. ss "(realToFrac ". ss name. ss ")") -genMarshalParameter _ name "gfloat" = +genMarshalParameter _ _ name "gfloat" = (Nothing, Just "Float", \body -> body. - indent 2. ss " (realToFrac ". ss name. ss ")") + indent 2. ss "(realToFrac ". ss name. ss ")") -genMarshalParameter _ name typeName | typeName == "const-gchar*" - || typeName == "const-char*" = - (Nothing, Just "String", - \body -> ss "withUTFString ". ss name. ss " $ \\". ss name. ss "Ptr ->". - indent 1. body. - indent 2. sc ' '. ss name. ss "Ptr") +genMarshalParameter _ funcName name typeName | typeName == "const-gchar*" + || typeName == "const-char*" = + if maybeNullParameter funcName name + then (Nothing, Just "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", + \body -> ss "withUTFString ". ss name. ss " $ \\". ss name. ss "Ptr ->". + indent 1. body. + indent 2. ss name. ss "Ptr") -genMarshalParameter _ name "GError**" = +genMarshalParameter _ _ name "GError**" = (Nothing, Nothing, \body -> ss "propagateGError $ \\". ss name. ss "Ptr ->". indent 1. body. - indent 2. sc ' '. ss name. ss "Ptr") + indent 2. ss name. ss "Ptr") -- Objects ----------------------------- -genMarshalParameter knownSymbols name typeName' +genMarshalParameter knownSymbols funcName name typeName' | isUpper (head typeName') && last typeName' == '*' && last typeName /= '*' @@ -139,99 +172,125 @@ then (Nothing, Just shortTypeName, \body -> body. indent 2. ss name) + else if maybeNullParameter funcName name + then (Just $ shortTypeName ++ "Class " ++ name, Just ("Maybe " ++ name), + \body -> body. + indent 2. ss "(maybe (". ss shortTypeName. ss " nullForeignPtr) to". + ss shortTypeName. sc ' '. ss name. ss ")") else (Just $ shortTypeName ++ "Class " ++ name, Just name, \body -> body. - indent 2. ss " (to". ss shortTypeName. sc ' '. ss name. ss ")") + 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 +genMarshalParameter knownSymbols _ name typeName | isUpper (head typeName) && symbolIsEnum typeKind = (Nothing, Just shortTypeName, \body -> body. - indent 2. ss " ((fromIntegral . fromEnum) ". ss name. ss ")") + indent 2. ss "((fromIntegral . fromEnum) ". ss name. ss ")") where shortTypeName = stripKnownPrefixes typeName typeKind = lookupFM knownSymbols typeName -- Flags ------------------------------- -genMarshalParameter knownSymbols name typeName +genMarshalParameter knownSymbols _ name typeName | isUpper (head typeName) && symbolIsFlags typeKind = (Nothing, Just shortTypeName, \body -> body. - indent 2. ss " ((fromIntegral . fromFlags) ". ss name. ss ")") + indent 2. ss "((fromIntegral . fromFlags) ". ss name. ss ")") where shortTypeName = stripKnownPrefixes typeName typeKind = lookupFM knownSymbols typeName -genMarshalParameter _ name textIter | textIter == "const-GtkTextIter*" +genMarshalParameter _ _ name textIter | textIter == "const-GtkTextIter*" || textIter == "GtkTextIter*" = (Nothing, Just "TextIter", \body -> body. - indent 2. sc ' '. ss name) + indent 2. ss name) -genMarshalParameter _ name "GtkTreeIter*" = +genMarshalParameter _ _ name "GtkTreeIter*" = (Nothing, Just "TreeIter", \body -> body. - indent 2. sc ' '. ss name) + indent 2. ss name) -genMarshalParameter _ name "GtkTreePath*" = +genMarshalParameter _ _ name "GtkTreePath*" = (Nothing, Just "TreePath", \body -> ss "withTreePath ". ss name. ss " $ \\". ss name. ss " ->". indent 1. body. - indent 2. sc ' '. ss name) + indent 2. ss name) -genMarshalParameter _ name unknownType = +genMarshalParameter _ _ name unknownType = (Nothing, Just $ "{-" ++ unknownType ++ "-}", \body -> body. - indent 2. ss " {-". ss name. ss "-}") + indent 2. ss "{-". ss name. ss "-}") -- Takes the type string and returns the Haskell Type and the marshaling code -- -genMarshalResult :: KnownSymbols -> String -> (String, ShowS -> ShowS) -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") -genMarshalResult _ "gchar*" = ("IO String", \body -> body. - indent 1. ss ">>= readUTFString") -genMarshalResult _ "const-GSList*" = +genMarshalResult :: + KnownSymbols -> --a collection of types we know to be objects or enums + String -> --function name (useful to lookup per-func fixup info) + String -> --C type decleration for the return value we will marshal + (String, --Haskell return type + ShowS -> ShowS) --marshaling code (\body -> ... body ...) +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 _ funcName "const-gchar*" = + if maybeNullResult funcName + then ("IO (Maybe String)", + \body -> body. + indent 1. ss ">>= maybePeek peekUTFString") + else ("IO String", + \body -> body. + indent 1. ss ">>= peekUTFString") +genMarshalResult _ funcName "gchar*" = + if maybeNullResult funcName + then ("IO (Maybe String)", + \body -> body. + indent 1. ss ">>= maybePeek readUTFString") + else ("IO String", + \body -> body. + indent 1. ss ">>= readUTFString") +genMarshalResult _ _ "const-GSList*" = ("[{- element type -}]", \body -> body. indent 1. ss ">>= readGSList". indent 1. ss ">>= mapM (\\elemPtr -> {-marshal elem-})") -genMarshalResult _ "GSList*" = +genMarshalResult _ _ "GSList*" = ("[{- element type -}]", \body -> body. indent 1. ss ">>= fromGSList". indent 1. ss ">>= mapM (\\elemPtr -> {-marshal elem-})") -genMarshalResult _ "GList*" = +genMarshalResult _ _ "GList*" = ("[{- element type -}]", \body -> body. indent 1. ss ">>= fromGList". indent 1. ss ">>= mapM (\\elemPtr -> {-marshal elem-})") -genMarshalResult knownSymbols typeName' +genMarshalResult knownSymbols funcName typeName' | isUpper (head typeName') && last typeName' == '*' && last typeName /= '*' && symbolIsObject typeKind = - ("IO " ++ shortTypeName, - \body -> ss constructor. ss " mk". ss shortTypeName. ss " $". - indent 1. body) + if maybeNullResult funcName + then ("IO (Maybe " ++ shortTypeName ++ ")", + \body -> ss "maybeNull (" .ss constructor. ss " mk". ss shortTypeName. ss ") $". + indent 1. body) + else ("IO " ++ shortTypeName, + \body -> ss constructor. ss " mk". ss shortTypeName. ss " $". + indent 1. body) where typeName = init typeName' shortTypeName = stripKnownPrefixes typeName typeKind = lookupFM knownSymbols typeName constructor | symbolIsGObject typeKind = "makeNewGObject" | symbolIsGtkObject typeKind = "makeNewObject" -genMarshalResult knownSymbols typeName +genMarshalResult knownSymbols _ typeName | isUpper (head typeName) && symbolIsEnum typeKind = ("IO " ++ shortTypeName, @@ -240,7 +299,7 @@ where shortTypeName = stripKnownPrefixes typeName typeKind = lookupFM knownSymbols typeName -genMarshalResult knownSymbols typeName +genMarshalResult knownSymbols _ typeName | isUpper (head typeName) && symbolIsFlags typeKind = ("IO " ++ shortTypeName, @@ -249,7 +308,7 @@ where shortTypeName = stripKnownPrefixes typeName typeKind = lookupFM knownSymbols typeName -genMarshalResult _ unknownType = ("{-" ++ unknownType ++ "-}", id) +genMarshalResult _ _ unknownType = ("{-" ++ unknownType ++ "-}", id) -- Takes the type string and returns the Haskell Type and the GValue constructor -- Index: CodeGen.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/CodeGen.hs,v retrieving revision 1.6 retrieving revision 1.7 diff -u -d -r1.6 -r1.7 --- CodeGen.hs 20 Feb 2005 18:52:09 -0000 1.6 +++ CodeGen.hs 21 Feb 2005 11:03:08 -0000 1.7 @@ -30,12 +30,12 @@ then ss "-- * Warning this function is deprecated\n--\n" else id). ss functionName. ss " :: ". functionType. nl. - ss functionName. sc ' '. sepBy " " paramNames. ss " =". + ss functionName. sc ' '. formattedParamNames. sc '='. indent 1. body where functionName = cFuncNameToHsName (method_cname method) (classConstraints', paramTypes', paramMarshalers) = - unzip3 [ case genMarshalParameter knownSymbols + unzip3 [ case genMarshalParameter knownSymbols (method_cname method) (changeIllegalNames (cParamNameToHsName (parameter_name p))) (parameter_type p) of (c, ty, m) -> (c, (ty, parameter_name p), m) @@ -45,8 +45,9 @@ | (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) (returnType', returnMarshaler) = - genMarshalResult knownSymbols (method_return_type method) + genMarshalResult knownSymbols (method_cname method) (method_return_type method) returnType = (returnType', lookup "Returns" paramDocMap) functionType = (case classConstraints of [] -> id @@ -61,8 +62,11 @@ Just info -> methodinfo_unsafe info formattedDoc = case doc of Nothing -> ss "-- | \n-- \n" - Just doc -> ss "-- | ". haddocFormatParas knownSymbols (funcdoc_paragraphs doc). nl. + Just doc -> ss "-- | ". haddocFormatParas knownSymbols docNullsAllFixed (funcdoc_paragraphs doc). nl. ss "--\n" + docNullsAllFixed = maybeNullResult (method_cname method) + || or [ maybeNullParameter (method_cname method) (parameter_name p) + | p <- method_parameters method ] paramDocMap = case doc of Nothing -> [] Just doc -> [ (paramdoc_name paramdoc @@ -97,9 +101,9 @@ sepBy' ("\n" ++ replicate (columnIndent+5) ' ' ++ "-- ") . map (sepBy " ") . wrapText 3 (80 - columnIndent - 8) - . map (mungeWord knownSymbols) + . map (mungeWord knownSymbols docNullsAllFixed) . words - . concatMap (haddocFormatSpan knownSymbols) + . concatMap (haddocFormatSpan knownSymbols docNullsAllFixed) columnIndent = maximum [ length parmType | (parmType, _) <- paramTypes ] genModuleBody :: KnownSymbols -> Object -> ModuleDoc -> ModuleInfo -> ShowS @@ -129,7 +133,10 @@ } else methodInfo) (module_methods modInfo) } - where shortMethodNames = map (stripPrefix . method_cname) (object_methods object) + where shortMethodNames = [ stripPrefix (constructor_cname constructor) + | constructor <- object_constructors object] + ++ [ stripPrefix (method_cname method) + | method <- object_methods object] stripPrefix cname | prefix `isPrefixOf` cname = drop (length prefix) cname | otherwise = cname prefix = module_context_prefix modInfo ++ "_" @@ -154,7 +161,6 @@ in (index,(mungeMethod object method, doc, info)) | method <- object_methods object , null [ () | VarArgs <- method_parameters method] --exclude VarArgs methods --- , not ("_get_type" `isSuffixOf` method_cname method && method_shared method) , not (method_deprecated method && isNothing (lookup (method_cname method) infomap)) ] where docmap = [ (funcdoc_name doc, (doc,index)) | (doc,index) <- zip docs [1..] ] @@ -229,7 +235,7 @@ setter = ss "(\\obj val -> objectSetProperty obj \"". ss (property_cname property). ss "\" (". ss gvalueConstructor. ss " val))" formattedDoc = case doc of Nothing -> ss "-- | \n-- \n" - Just doc -> ss "-- | ". haddocFormatParas knownSymbols (propdoc_paragraphs doc). nl. + Just doc -> ss "-- | ". haddocFormatParas knownSymbols False (propdoc_paragraphs doc). nl. ss "--\n" (propertyType, gvalueConstructor) = genMarshalProperty knownSymbols (property_type property) @@ -265,7 +271,7 @@ signalCName = sc '"'. ss (signal_cname signal). sc '"' formattedDoc = case doc of Nothing -> ss "-- | \n-- \n" - Just doc -> ss "-- | ". haddocFormatParas knownSymbols (signaldoc_paragraphs doc). nl. + Just doc -> ss "-- | ". haddocFormatParas knownSymbols False (signaldoc_paragraphs doc). nl. ss "--\n" canonicalSignalName :: String -> String Index: FormatDocs.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/FormatDocs.hs,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- FormatDocs.hs 20 Feb 2005 18:52:09 -0000 1.4 +++ FormatDocs.hs 21 Feb 2005 11:03:08 -0000 1.5 @@ -39,7 +39,7 @@ then id else comment.ss "* Description".nl. comment.nl. - comment.ss "| ".haddocFormatParas knownSymbols (moduledoc_description moduledoc).nl). + comment.ss "| ".haddocFormatParas knownSymbols False (moduledoc_description moduledoc).nl). (if null (moduledoc_sections moduledoc) then id else nl.comment.haddocFormatSections knownSymbols (moduledoc_sections moduledoc).nl.comment.nl). @@ -56,7 +56,7 @@ sepBy "\n-- |" . map haddocTweakHierarchy . Prelude.lines - . concatMap (haddocFormatSpan knownSymbols) + . concatMap (haddocFormatSpan knownSymbols False) haddocTweakHierarchy :: String -> String haddocTweakHierarchy ('+':'-':'-':'-':'-':cs@(c:_)) | c /= ''' = @@ -104,46 +104,46 @@ . map (\section -> ss "** ". ss (section_title section). nl. comment.nl. - comment.ss "| ".haddocFormatParas knownSymbols (section_paras section)) + comment.ss "| ".haddocFormatParas knownSymbols False (section_paras section)) -haddocFormatParas :: KnownSymbols -> [DocPara] -> ShowS -haddocFormatParas knownSymbols = +haddocFormatParas :: KnownSymbols -> Bool -> [DocPara] -> ShowS +haddocFormatParas knownSymbols handleNULLs = sepBy' "\n--\n-- " - . map (haddocFormatPara knownSymbols) + . map (haddocFormatPara knownSymbols handleNULLs) -haddocFormatPara :: KnownSymbols -> DocPara -> ShowS -haddocFormatPara knownSymbols (DocParaText spans) = haddocFormatSpans knownSymbols 3 spans -haddocFormatPara knownSymbols (DocParaProgram prog) = +haddocFormatPara :: KnownSymbols -> Bool -> DocPara -> ShowS +haddocFormatPara knownSymbols handleNULLs (DocParaText spans) = haddocFormatSpans knownSymbols handleNULLs 3 spans +haddocFormatPara knownSymbols _ (DocParaProgram prog) = ((ss "* FIXME: if the follwing is a C code example, port it to Haskell or remove it".nl. comment).) . sepBy "\n-- > " . List.lines $ prog -haddocFormatPara knownSymbols (DocParaTitle title) = +haddocFormatPara knownSymbols _ (DocParaTitle title) = ss "* ". ss title -haddocFormatPara knownSymbols (DocParaDefItem term spans) = - let def = (unwords . words . escape . concatMap (haddocFormatSpan knownSymbols)) term in +haddocFormatPara knownSymbols handleNULLs (DocParaDefItem term spans) = + let def = (unwords . words . escape . concatMap (haddocFormatSpan knownSymbols handleNULLs)) term in sc '['. ss def. ss "] ". - haddocFormatSpans knownSymbols (length def + 6) spans + haddocFormatSpans knownSymbols handleNULLs (length def + 6) spans where escape [] = [] escape (']':cs) = '\\': ']' : escape cs --we must escape ] in def terms escape (c:cs) = c : escape cs -haddocFormatPara knownSymbols (DocParaListItem spans) = +haddocFormatPara knownSymbols handleNULLs (DocParaListItem spans) = ss "* ". - haddocFormatSpans knownSymbols 5 spans + haddocFormatSpans knownSymbols handleNULLs 5 spans -haddocFormatSpans :: KnownSymbols -> Int -> [DocParaSpan] -> ShowS -haddocFormatSpans knownSymbols initialCol = +haddocFormatSpans :: KnownSymbols -> Bool -> Int -> [DocParaSpan] -> ShowS +haddocFormatSpans knownSymbols handleNULLs initialCol = sepBy' "\n-- " . map (sepBy " ") . wrapText initialCol 77 - . map (mungeWord knownSymbols) + . map (mungeWord knownSymbols handleNULLs) . words - . concatMap (haddocFormatSpan knownSymbols) + . concatMap (haddocFormatSpan knownSymbols handleNULLs) -haddocFormatSpan :: KnownSymbols -> DocParaSpan -> String -haddocFormatSpan _ (DocText text) = escapeHaddockSpecialChars text -haddocFormatSpan knownSymbols (DocTypeXRef text) = +haddocFormatSpan :: KnownSymbols -> Bool -> DocParaSpan -> String +haddocFormatSpan _ _ (DocText text) = escapeHaddockSpecialChars text +haddocFormatSpan knownSymbols handleNULLs (DocTypeXRef text) = case lookupFM knownSymbols text of Nothing | text == "TRUE" -> "@True@" | text == "FALSE" -> "@False@" @@ -158,20 +158,22 @@ 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 ++ "/" -haddocFormatSpan _ (DocLiteral "TRUE") = "@True@" -haddocFormatSpan _ (DocLiteral "FALSE") = "@False@" +haddocFormatSpan _ _ (DocFuncXRef text) = "'" ++ cFuncNameToHsName text ++ "'" +haddocFormatSpan _ _ (DocOtherXRef text) = "'{FIXME: gtk-doc cross reference to:" ++ text ++ "}'" +haddocFormatSpan _ _ (DocEmphasis text) = "/" ++ text ++ "/" +haddocFormatSpan _ _ (DocLiteral "TRUE") = "@True@" +haddocFormatSpan _ _ (DocLiteral "FALSE") = "@False@" --likely that something should be changed to a Maybe type if this is emitted: -haddocFormatSpan _ (DocLiteral "NULL") = "{@NULL@, FIXME: this should probably be converted" - ++ " to a Maybe data type}" -haddocFormatSpan knownSymbols (DocLiteral text) = +haddocFormatSpan _ handleNULLs (DocLiteral "NULL") = + if handleNULLs + then "@Nothing@" + else "{@NULL@, FIXME: this should probably be converted to a Maybe data type}" +haddocFormatSpan knownSymbols _ (DocLiteral text) = case lookupFM knownSymbols text of Nothing -> "@" ++ escapeHaddockSpecialChars text ++ "@" Just SymEnumValue -> "'" ++ cConstNameToHsName text ++ "'" _ -> "{" ++ text ++ ", FIXME: unknown literal value}" --TODO fill in the other cases -haddocFormatSpan _ (DocArg text) = "@" ++ cParamNameToHsName text ++ "@" +haddocFormatSpan _ _ (DocArg text) = "@" ++ cParamNameToHsName text ++ "@" cFuncNameToHsName :: String -> String cFuncNameToHsName = @@ -212,14 +214,17 @@ = '\\': c : escape cs escape (c:cs) = c : escape cs -mungeWord :: KnownSymbols -> String -> String -mungeWord knownSymbols ('G':'T':'K':[]) = "Gtk+" -mungeWord knownSymbols ('G':'T':'K':'+':remainder) = "Gtk+" ++ remainder -mungeWord knownSymbols word +mungeWord :: KnownSymbols -> Bool -> String -> String +mungeWord knownSymbols _ ('G':'T':'K':[]) = "Gtk+" +mungeWord knownSymbols _ ('G':'T':'K':'+':remainder) = "Gtk+" ++ remainder +mungeWord knownSymbols handleNULLs word | word' == "TRUE" = "@True@" ++ remainder | word' == "FALSE" = "@False@" ++ remainder - | word' == "NULL" = "{@NULL@, FIXME: this should probably be converted to a Maybe data type}" - ++ remainder + | word' == "NULL" = if handleNULLs + then "@Nothing@" ++ remainder + else "{@NULL@, FIXME: this should probably " + ++ "be converted to a Maybe data type}" ++ remainder + | word' == "G_MAXINT" = "@('maxBound' :: Int)@" ++ remainder | isJust e = case e of Just (SymObjectType _) -> "'" ++ stripKnownPrefixes word' ++ "'" ++ remainder Just (SymEnumType _) -> "'" ++ stripKnownPrefixes word' ++ "'" ++ remainder Index: ApiGen.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/ApiGen.hs,v retrieving revision 1.16 retrieving revision 1.17 diff -u -d -r1.16 -r1.17 --- ApiGen.hs 17 Feb 2005 13:51:34 -0000 1.16 +++ ApiGen.hs 21 Feb 2005 11:03:06 -0000 1.17 @@ -165,7 +165,7 @@ "OBJECT_NAME" -> ss $ module_name moduleInfo "AUTHORS" -> ss $ concat $ intersperse ", " $ module_authors moduleInfo "COPYRIGHT" -> ss $ concat $ intersperse ", " $ module_copyright_holders moduleInfo - "DESCRIPTION" -> haddocFormatSpans knownTypes 3 (moduledoc_summary moduleDoc) + "DESCRIPTION" -> haddocFormatSpans knownTypes False 3 (moduledoc_summary moduleDoc) "DOCUMENTATION" -> genModuleDocumentation knownTypes moduleDoc "TODO" -> genTodoItems object "MODULE_NAME" -> ss $ if null (module_prefix moduleInfo) |
