Menu
▾
▴
[Gtk2hs-commit] gtk2hs/tools/apiGen ApiGen.hs,1.19,1.20 ModuleScan.hs,1.4,1.5 CodeGen.hs,1.11,1.12 Marshal.hs,1.7,1.8
|
From: Duncan C. <dun...@us...> - 2005-03-04 22:22:01
|
Update of /cvsroot/gtk2hs/gtk2hs/tools/apiGen In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv3685/tools/apiGen Modified Files: ApiGen.hs ModuleScan.hs CodeGen.hs Marshal.hs Log Message: ApiGen.hs: remove pointless and verbose warnings. ModuleScan.hs: collect export list from existing modules. CodeGen.hs: generate signals and methods export lists in the same order as in the original modules. Also, improve the signal code generaton - though it's still not quite there yet for object types. Marshal.hs: For signals, produce the Haskell type as well as the signal handler tag. For object types this is not right yet because it uses the object type rather than the object class. Also change the marshaling of object parameter types to cover all four possibilities of: (leaf class/non-leaf class) x (ordinary/maybe type). Index: Marshal.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/Marshal.hs,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- Marshal.hs 27 Feb 2005 20:02:16 -0000 1.7 +++ Marshal.hs 4 Mar 2005 22:21:35 -0000 1.8 @@ -113,18 +113,23 @@ && last typeName' == '*' && last typeName /= '*' && symbolIsObject typeKind = - if leafClass typeName - 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 ")") + 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) + implementation + | leafClass typeName && maybeNullParameter funcName name + = ss "(fromMaybe (". ss shortTypeName. ss " nullForeignPtr) ". + ss name. ss ")" + | leafClass typeName = ss name + | maybeNullParameter funcName name + = 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, + \body -> body. + indent 2. implementation) where typeName = init typeName' shortTypeName = stripKnownPrefixes typeName typeKind = lookupFM knownSymbols typeName @@ -288,32 +293,33 @@ genMarshalProperty _ unknown = ("{-" ++ unknown ++ "-}", "{-" ++ unknown ++ "-}") --- Takes the type string and returns the signal marshaing category +-- Takes the type string and returns the signal marshaing category and the +-- Haskell type -- -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 -> String -> (String, String) +convertSignalType _ "void" = ("NONE", "()") +convertSignalType _ "gchar" = ("CHAR", "Char") +convertSignalType _ "guchar" = ("UCHAR", "Char") +convertSignalType _ "gboolean" = ("BOOL", "Bool") +convertSignalType _ "gint" = ("INT", "Int") +convertSignalType _ "guint" = ("UINT", "Int") +convertSignalType _ "glong" = ("LONG", "Int") +convertSignalType _ "gulong" = ("ULONG", "Int") +convertSignalType _ "gfloat" = ("FLOAT", "Float") +convertSignalType _ "gdouble" = ("DOUBLE", "Double") +convertSignalType _ "gchar*" = ("STRING", "String") +convertSignalType _ "const-gchar*" = ("STRING", "String") convertSignalType knownSymbols typeName - | symbolIsEnum typeKind = "ENUM" - | symbolIsFlags typeKind = "FLAGS" + | symbolIsEnum typeKind = ("ENUM", stripKnownPrefixes typeName) + | symbolIsFlags typeKind = ("FLAGS", stripKnownPrefixes typeName) where typeKind = lookupFM knownSymbols typeName convertSignalType knownSymbols typeName@(_:_) | last typeName == '*' - && symbolIsBoxed typeKind = "BOXED" + && symbolIsBoxed typeKind = ("BOXED", stripKnownPrefixes (init typeName)) | last typeName == '*' - && symbolIsObject typeKind = "OBJECT" + && symbolIsObject typeKind = ("OBJECT", stripKnownPrefixes (init typeName)) where typeKind = lookupFM knownSymbols (init typeName) -convertSignalType _ typeName = "{-" ++ typeName ++ "-}" +convertSignalType _ typeName = ("{-" ++ 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.11 retrieving revision 1.12 diff -u -d -r1.11 -r1.12 --- CodeGen.hs 1 Mar 2005 21:20:44 -0000 1.11 +++ CodeGen.hs 4 Mar 2005 22:21:35 -0000 1.12 @@ -17,7 +17,7 @@ import Prelude hiding (Enum, lines) import List (groupBy, sortBy, isPrefixOf, isSuffixOf, partition, find) -import Maybe (isNothing) +import Maybe (isNothing, fromMaybe) import Data.FiniteMap import Debug.Trace (trace) @@ -339,19 +339,24 @@ genSignal :: KnownSymbols -> Object -> Signal -> Maybe SignalDoc -> ShowS genSignal knownSymbols object signal doc = formattedDoc. - ss "on". signalName. ss ", after". signalName. ss " :: ". nl. - ss "on". signalName. ss " = connect_". connectType. sc ' '. signalCName. ss " False". nl. - ss "after". signalName. ss " = connect_". connectType. sc ' '. signalCName. ss " True". nl + ss "on". signalName. ss ", after". signalName. ss " :: ". signalType. + ss "on". signalName. ss " = connect_". connectCall. sc ' '. signalCName. ss " False". nl. + ss "after". signalName. ss " = connect_". connectCall. sc ' '. signalCName. ss " True" - where connectType = sepBy "_" paramTypes . ss "__" . ss returnType + where connectCall = let paramCategories' = if null paramCategories then ["NONE"] else paramCategories + in sepBy "_" paramCategories' . ss "__" . ss returnCategory -- 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) + (paramCategories, paramTypes) = unzip [ convertSignalType knownSymbols (parameter_type parameter) + | parameter <- params ] + (returnCategory, returnType) = convertSignalType knownSymbols (signal_return_type signal) + signalType = ss (object_name object). ss "Class self => self\n". + ss " -> ". (if null paramTypes + then ss "IO ". ss returnType + else sc '('. sepBy " -> " (paramTypes ++ ["IO " ++ returnType]). sc ')'). + ss "\n -> IO (ConnectId self)\n" signalName = ss (toStudlyCaps . canonicalSignalName . signal_cname $ signal) signalCName = sc '"'. ss (signal_cname signal). sc '"' formattedDoc = haddocFormatDeclaration knownSymbols False signaldoc_paragraphs doc @@ -416,9 +421,9 @@ genExports :: Object -> ModuleDoc -> ModuleInfo -> ShowS genExports object docs modInfo = - doVersionIfDefs lines $ - map adjustDeprecatedAndSinceVersion $ - [(ss "-- * Types", defaultAttrs) + doVersionIfDefs lines + . map adjustDeprecatedAndSinceVersion + $ [(ss "-- * Types", defaultAttrs) ,(ss " ".ss (object_name object).sc ',', defaultAttrs) ,(ss " ".ss (object_name object).ss "Class,", defaultAttrs) ,(ss " ".ss "castTo".ss (object_name object).sc ',', defaultAttrs)] @@ -426,20 +431,27 @@ [ (ss " ". ss (cFuncNameToHsName (method_cname constructor)). sc ',' ,(maybe "" funcdoc_since doc, notDeprecated)) | (constructor, doc, _) <- constructors object (moduledoc_functions docs) []] - ++ sectionHeader "Methods" - [ (ss " ". ss (cFuncNameToHsName (method_cname method)). sc ',' + ++ (sectionHeader "Methods" + . map fst + . sortBy (comparing snd)) + [ let functionName = cFuncNameToHsName (method_cname method) in + ((ss " ". ss functionName. sc ',' ,(maybe "" funcdoc_since doc, method_deprecated method)) + ,fromMaybe (maxBound::Int) (lookup functionName exportIndexMap)) | (method, doc, _) <- methods object (moduledoc_functions docs) (module_methods modInfo) False] ++ sectionHeader "Properties" [ (ss " ". ss (lowerCaseFirstChar (property_name property)). sc ',' ,(maybe "" propdoc_since doc, notDeprecated)) | (property, doc) <- properties object (moduledoc_properties docs)] - ++ sectionHeader "Signals" + ++ (sectionHeader "Signals" + . map fst + . sortBy (comparing snd)) [ let signalName = (toStudlyCaps . canonicalSignalName . signal_cname) signal in - (ss " on". ss signalName. sc ','.nl. + ((ss " on". ss signalName. sc ','.nl. ss " after". ss signalName. sc ',' ,(maybe "" signaldoc_since doc, notDeprecated)) + ,fromMaybe (maxBound::Int) (lookup ("on"++signalName) exportIndexMap)) | (signal, doc) <- signals object (moduledoc_signals docs)] where defaultAttrs = ("", notDeprecated) @@ -447,6 +459,7 @@ sectionHeader name entries = (id, defaultAttrs):(ss "-- * ". ss name, defaultAttrs):entries adjustDeprecatedAndSinceVersion (doc, (since, deprecated)) = (doc, (moduledoc_since docs `max` since, object_deprecated object || deprecated)) + exportIndexMap = zip (module_exports modInfo) [1..] genImports :: ModuleInfo -> ShowS genImports modInfo = Index: ApiGen.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/ApiGen.hs,v retrieving revision 1.19 retrieving revision 1.20 diff -u -d -r1.19 -r1.20 --- ApiGen.hs 1 Mar 2005 21:20:44 -0000 1.19 +++ ApiGen.hs 4 Mar 2005 22:21:35 -0000 1.20 @@ -140,9 +140,6 @@ Just moduleInfo -> do mkDirHier outdir (splitOn '.' (module_prefix moduleInfo)) return moduleInfo Nothing -> do - when (not (null moduleRoot) && not (object_deprecated object)) $ - putStrLn ("Warning: no existing module found for module " - ++ show (object_name object)) return ModuleInfo { module_name = object_name object, module_prefix = modPrefix, @@ -152,6 +149,7 @@ module_created = date, module_copyright_dates = Left year, module_copyright_holders = ["[Insert your full name here]"], + module_exports = [], module_imports = [], module_context_lib = if null lib then namespace_library namespace else lib, module_context_prefix = if null prefix then namespace_library namespace else prefix, Index: ModuleScan.hs =================================================================== RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/ModuleScan.hs,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- ModuleScan.hs 25 Feb 2005 01:32:11 -0000 1.4 +++ ModuleScan.hs 4 Mar 2005 22:21:35 -0000 1.5 @@ -25,6 +25,7 @@ module_copyright_dates :: Either String (String, String), -- eg "2004" or "2004-2005" module_copyright_holders :: [String], + module_exports :: [String], module_imports :: [(String, String)], -- mod name and the whole line module_context_lib :: String, module_context_prefix :: String, @@ -42,13 +43,23 @@ | Created String | Copyright (Either String (String, String)) [String] | Module String String + | Export String + | ExportEnd | Import String String | Context String String | CCall MethodInfo + deriving Show usefulLine None = False usefulLine _ = True +isModuleLine (Module _ _) = True +isModuleLine _ = False +isExportEndLine ExportEnd = True +isExportEndLine _ = False +isCCallLine (CCall _) = True +isCCallLine _ = False + main = do [path] <- getArgs modules <- findModules [] path @@ -101,20 +112,27 @@ scanModuleContent :: String -> String -> ModuleInfo scanModuleContent content filename = - let usefulLines = filter usefulLine [ scanLine line (tokenise line) | line <- lines content ] in - ModuleInfo { - module_name = head $ [ name | Module name prefix <- usefulLines ] ++ [missing], - module_prefix = head $ [ prefix | Module name prefix <- usefulLines ] ++ [missing], + let (headerLines, bodyLines) = + break isCCallLine + . filter usefulLine + $ [ scanLine line (tokenise line) | line <- lines content ] + in ModuleInfo { + module_name = head $ [ name | Module name prefix <- headerLines ] ++ [missing], + module_prefix = head $ [ prefix | Module name prefix <- headerLines ] ++ [missing], module_needspreproc = ".chs.pp" `isSuffixOf` filename, module_filename = "", - module_authors = head $ [ authors | Authors authors <- usefulLines ] ++ [[missing]], - module_created = head $ [ created | Created created <- usefulLines ] ++ [missing], - module_copyright_dates = head $ [ dates | Copyright dates _ <- usefulLines ] ++ [Left missing], - module_copyright_holders = head $ [ authors | Copyright _ authors <- usefulLines ] ++ [[missing]], - module_imports = [ (name, line) | Import name line <- usefulLines ], - module_context_lib = head $ [ lib | Context lib prefix <- usefulLines ] ++ [missing], - module_context_prefix = head $ [ prefix | Context lib prefix <- usefulLines ] ++ [missing], - module_methods = [ call | CCall call <- usefulLines ] + module_authors = head $ [ authors | Authors authors <- headerLines ] ++ [[missing]], + module_created = head $ [ created | Created created <- headerLines ] ++ [missing], + module_copyright_dates = head $ [ dates | Copyright dates _ <- headerLines ] ++ [Left missing], + module_copyright_holders = head $ [ authors | Copyright _ authors <- headerLines ] ++ [[missing]], + module_exports = let exportLines = takeWhile (not.isExportEndLine) + . dropWhile (not.isModuleLine) + $ headerLines + in [ name | Export name <- exportLines ], + module_imports = [ (name, line) | Import name line <- headerLines ], + module_context_lib = head $ [ lib | Context lib prefix <- headerLines ] ++ [missing], + module_context_prefix = head $ [ prefix | Context lib prefix <- headerLines ] ++ [missing], + module_methods = [ call | CCall call <- bodyLines ] } where missing = "{-missing-}" @@ -128,10 +146,15 @@ scanLine _ ("--":"Author":":":author) = scanAuthor author scanLine _ ("--":"Created:":created) = Created (unwords created) scanLine _ ("--":"Copyright":"(":c:")":copyright) = scanCopyright copyright +scanLine (' ':' ':_) ("module":moduleName) = Export (concat moduleName) scanLine _ ("module":moduleName) = scanModuleName moduleName +scanLine (' ':' ':_) (export:",":[]) = Export export +scanLine (' ':' ':_) (export:",":"--":_)= Export export +scanLine (' ':' ':_) (export:[]) = Export export +scanLine _ (")":"where":[]) = ExportEnd scanLine _ ("{#":"context":context) = scanContext context -scanLine line ("import":moduleName) = scanImport line moduleName -scanLine line ("{#":"import":moduleName) = scanImport line moduleName +scanLine line ("import":moduleName) = scanImport line moduleName +scanLine line ("{#":"import":moduleName)= scanImport line moduleName scanLine _ tokens | "{#" `elem` tokens = scanCCall tokens scanLine _ _ = None |