Thread: [Gtk2hs-commit] gtk2hs/tools/apiGen ModuleScan.hs,NONE,1.1 ApiGen.hs,1.12,1.13 Template.chs,1.5,1.6

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 422-6466

Update of /cvsroot/gtk2hs/gtk2hs/tools/apiGen
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv29496/tools/apiGen

Modified Files:
	ApiGen.hs Template.chs Makefile StringUtils.hs 
Added Files:
	ModuleScan.hs 
Log Message:
ModuleScan.hs: New module that scans the existing module source files to pick
out useful information so that we can use that information to improve the
generated modules. In particular it extracts module information like authors,
copyrights, dates, module imports and whether each C call is safe or unsafe.

ApiGen.hs: take advantage of the new ModuleScan information in the various
module headder fields. Add a new --scanmodules flag.

Template.chs: add author and copyright variable.

Makefile: use the new --scanmodules feature.

StringUtils.hs: add extra utility function.


Index: Template.chs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/Template.chs,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6

--- Template.chs	24 Jan 2005 01:39:28 -0000	1.5
+++ Template.chs	7 Feb 2005 00:38:02 -0000	1.6
@@ -1,11 +1,11 @@
 -- -*-haskell-*-
 --  GIMP Toolkit (GTK) Widget @OBJECT_NAME@
 --
---  Author : [Insert your full name here]
+--  Author : @AUTHORS@
 --
 --  Created: @DATE@
 --
---  Copyright (C) @YEAR@ [Insert your full name here]
+--  Copyright (C) @YEAR@ @COPYRIGHT@
 --
 --  This library is free software; you can redistribute it and/or
 --  modify it under the terms of the GNU Lesser General Public

Index: StringUtils.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/StringUtils.hs,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- StringUtils.hs	5 Feb 2005 02:57:40 -0000	1.1
+++ StringUtils.hs	7 Feb 2005 00:38:02 -0000	1.2
@@ -2,6 +2,7 @@
 
 import Prelude hiding (lines)
 import Char   (toLower, toUpper, isSpace, isAlpha, isAlphaNum, isUpper)
+import List   (unfoldr)
 
 -------------------------------------------------------------------------------
 -- Helper functions
@@ -66,3 +67,10 @@
         wrap col line (word:words) = wrap (col + length word + 1) (word:line) words
         wrap _ []   [] = []
         wrap _ line [] = [reverse line]
+
+splitOn :: Eq a => a -> [a] -> [[a]]
+splitOn sep = 
+  unfoldr (\s -> case break (sep==) s of
+                   ([],_) -> Nothing
+                   (w,_:r) -> Just (w,r)
+                   (w,[]) -> Just (w,[]))

Index: Makefile
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/Makefile,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- Makefile	5 Feb 2005 03:02:06 -0000	1.5
+++ Makefile	7 Feb 2005 00:38:02 -0000	1.6
@@ -76,8 +76,10 @@
 		gdk-api.xml pango-api.xml atk-api.xml
 	@mkdir -p $@
 	./ApiGen $< Template.chs --doc=gtk-docs.xml --outdir=$@ \
-	--includeapi=gdk-api.xml --includeapi=pango-api.xml --includeapi=atk-api.xml \
-	--modprefix=Graphics.UI.Gtk.{-Category-}
+	--includeapi=gdk-api.xml --includeapi=pango-api.xml \
+	--includeapi=atk-api.xml \
+	--modprefix=Graphics.UI.Gtk.{-Category-} \
+	--scanmodules=../../gtk/Graphics/UI/Gtk
 
 
 ###################
@@ -132,7 +134,7 @@
 #	tools
 #
 ApiGen : ApiGen.hs Api.hs Docs.hs FormatDocs.hs \
-	Marshal.hs CodeGen.hs StringUtils.hs 
+	Marshal.hs CodeGen.hs StringUtils.hs ModuleScan.hs
 	ghc --make $< -o $@
 
 gapi_format_xml : formatXml.c

Index: ApiGen.hs
===================================================================
RCS file: /cvsroot/gtk2hs/gtk2hs/tools/apiGen/ApiGen.hs,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -d -r1.12 -r1.13
--- ApiGen.hs	5 Feb 2005 03:01:01 -0000	1.12
+++ ApiGen.hs	7 Feb 2005 00:38:02 -0000	1.13
@@ -11,11 +11,13 @@
 import Docs
 import FormatDocs
 import CodeGen
-import StringUtils (ss, templateSubstitute)
+import StringUtils (ss, templateSubstitute, splitOn)
+import ModuleScan
 
 import Monad  (when)
-import List   (isPrefixOf)
+import List   (isPrefixOf, intersperse)
 import System (getArgs, exitWith, ExitCode(..))
+import Directory (doesDirectoryExist, createDirectory)
 
 import qualified Text.XML.HaXml.Parse as Xml
 
@@ -44,11 +46,14 @@
                  (prefix:_) -> prefix
   let modPrefix = case map (drop 12) (filter ("--modprefix=" `isPrefixOf`)  rem) of
                     [] -> ""
-		    (modPrefix:_) -> modPrefix ++ "."
+		    (modPrefix:_) -> modPrefix
   let outdir = case map (drop 9) (filter ("--outdir=" `isPrefixOf`)  rem) of
                  [] -> ""
                  (outdir:_) -> if last outdir == '/' then outdir else outdir ++ "/"
   let includeApiFiles = map (drop 13) (filter ("--includeapi=" `isPrefixOf`)  rem)
+  let moduleRoot = case map (drop 14) (filter ("--scanmodules=" `isPrefixOf`)  rem) of
+                     [] -> ""
+                     (moduleRoot:_) -> moduleRoot
 
   -----------------------------------------------------------------------------
   -- Read in the input files
@@ -83,6 +88,15 @@
                ++ [ (moduledoc_altname moduleDoc, moduleDoc) | moduleDoc <- apiDoc ]
 
   -----------------------------------------------------------------------------
+  -- Scan the existing modules if their root path is supplied
+  --
+  modulesInfo <- if null moduleRoot
+                   then return []
+                   else scanModules moduleRoot
+  let moduleInfoMap = [ (module_name moduleInfo, moduleInfo)
+                      | moduleInfo <- modulesInfo ]
+
+  -----------------------------------------------------------------------------
   -- A few values that are used in the template
   --
   time <- System.Time.getClockTime
@@ -96,31 +110,58 @@
   -- Write the result file(s) by substituting values into the template file
   --
   mapM 
-    (\(namespace, object, maybeModuleDoc) -> do
+    (\(namespace, object, maybeModuleDoc, maybeModuleInfo) -> do
       moduleDoc <- case maybeModuleDoc of
                      Nothing -> do when (not (null apiDoc)) $
 		                     putStrLn ("Warning: no documentation found for module "
 			                    ++ show (object_name object))
 			           return noModuleDoc
 		     Just moduleDoc -> return $ addVersionParagraphs namespace moduleDoc
-      writeFile (outdir ++ object_name object ++ ".chs") $
+      moduleInfo <-
+            case maybeModuleInfo of
+              Just moduleInfo -> do mkDirHier outdir (splitOn '.' (module_prefix moduleInfo))
+                                    return moduleInfo
+              Nothing -> do
+                when (not (null moduleRoot)) $
+                  putStrLn ("Warning: no existing module found for module "
+	                  ++ show (object_name object))
+                return ModuleInfo {
+                    module_name              = object_name object,
+                    module_prefix            = modPrefix,
+                    module_needspreproc      = False,
+                    module_filename          = object_name object ++ ".chs",
+                    module_authors           = ["[Insert your full name here]"],
+                    module_created           = date,
+                    module_copyright_dates   = Left year,
+                    module_copyright_holders = ["[Insert your full name here]"],
+                    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,
+                    module_methods           = []
+                  }
+      writeFile (outdir ++ module_filename moduleInfo) $
         templateSubstitute template (\var ->
           case var of
-	    "YEAR"           -> ss year
-	    "DATE"           -> ss date
-	    "OBJECT_NAME"    -> ss (object_name object)
-	    "DESCRIPTION"    -> ss (moduledoc_summary moduleDoc)
+	    "YEAR"           -> ss $ formatCopyrightDates year (module_copyright_dates moduleInfo)
+	    "DATE"           -> ss $ module_created moduleInfo
+	    "OBJECT_NAME"    -> ss $ module_name moduleInfo
+	    "AUTHORS"        -> ss $ concat $ intersperse ", " $ module_authors moduleInfo
+            "COPYRIGHT"      -> ss $ concat $ intersperse ", " $ module_copyright_holders moduleInfo
+            "DESCRIPTION"    -> ss (moduledoc_summary moduleDoc)
 	    "DOCUMENTATION"  -> genModuleDocumentation moduleDoc
 	    "TODO"           -> genTodoItems object
-	    "MODULE_NAME"    -> ss (modPrefix ++ object_name object)
+	    "MODULE_NAME"    -> ss $ module_prefix moduleInfo ++ "." ++ module_name moduleInfo
 	    "EXPORTS"        -> genExports object moduleDoc
 	    "IMPORTS"        -> ss $ "{#import Graphics.UI.Gtk.Types#}\n"
                                   ++ "-- CHECKME: extra imports may be required\n"
-	    "CONTEXT_LIB"    -> ss (if null lib then namespace_library namespace else lib)
-	    "CONTEXT_PREFIX" -> ss (if null prefix then namespace_library namespace else  prefix)
+	    "CONTEXT_LIB"    -> ss $ module_context_lib moduleInfo
+	    "CONTEXT_PREFIX" -> ss $ module_context_prefix  moduleInfo
 	    "MODULE_BODY"    -> genModuleBody knownTypes object moduleDoc
 	    _ -> ss "" ) ""
-    ) [ (namespace, object, lookup (object_cname object) apiDocMap)
+    ) [ (namespace
+        ,object
+        ,lookup (object_cname object) apiDocMap
+        ,lookup (object_name object) moduleInfoMap)
       | namespace <- api
       , object <- namespace_objects namespace ]
     
@@ -131,7 +172,7 @@
 	\ApiGen <apiFile> <templateFile>\n\
 	\         {--doc=<docFile>} {--lib=<lib>} {--prefix=<prefix>}\n\
 	\         {--outdir=<outDir>} {--modprefix=<modPrefix>}\n\
-	\         {--includeapi=<incApiFile>}\n\
+	\         {--includeapi=<incApiFile>} {--scanmodules=<modulesRoot>}\n\
 	\where\n\
 	\  <apiFile>       an xml api file produced by gapi_parser.pl\n\
 	\  <templateFile>  is the name and path of the output template file\n\
@@ -144,5 +185,20 @@
 	\  <modPrefix>     specify module name prefix, eg if using\n\
 	\                  hierarchical module names\n\
 	\  <incApiFile>    the api xml file for a parent api, for example Gtk\n\
-	\                  uses types defined by Gdk and Pango.\n"
+	\                  uses types defined by Gdk and Pango.\n\
+        \  <modulesRoot>   the path to the existing modules.\n"
   exitWith $ ExitFailure 1
+
+formatCopyrightDates :: String -> Either String (String, String) -> String
+formatCopyrightDates currentYear (Left year) | year == currentYear = year
+                                             | otherwise = year ++ "-" ++ currentYear
+formatCopyrightDates currentYear (Right (from, to)) = from ++ "-" ++ currentYear
+
+mkDirHier :: String -> [String] -> IO ()
+mkDirHier base [] = return ()
+mkDirHier base (dir:dirs) = do
+  let dirPath = base ++ "/" ++ dir
+  exists <- doesDirectoryExist dirPath
+  when (not exists) $
+    createDirectory dirPath
+  mkDirHier dirPath dirs

--- NEW FILE: ModuleScan.hs ---
{-# OPTIONS -fglasgow-exts #-}

module ModuleScan (
  ModuleInfo(..),
  ModuleMethodInfo(..),
  scanModules
  ) where

import StringUtils (splitOn)

import Char (isSpace, isAlpha)
import List (intersperse, partition, isSuffixOf, group, sort)
import Prelude hiding (unwords)

import System (getArgs)
import Directory (getDirectoryContents, doesDirectoryExist, doesFileExist)

data ModuleInfo = ModuleInfo {
    module_name              :: String,
    module_prefix            :: String,
    module_needspreproc      :: Bool,
    module_filename          :: String,
    module_authors           :: [String],
    module_created           :: String,
    module_copyright_dates   :: Either String (String, String),
                                -- eg "2004" or "2004-2005"
    module_copyright_holders :: [String],
    module_imports           :: [(String, String)], -- mod name and the whole line
    module_context_lib       :: String,
    module_context_prefix    :: String,
    module_methods           :: [ModuleMethodInfo]
  } deriving Show

data ModuleMethodInfo = ModuleMethodInfo {
    module_method_cname :: String,
    module_method_unsafe :: Bool
  } deriving Show

data Line = None
          | Authors [String]
          | Created String
          | Copyright (Either String (String, String)) [String]
          | Module String String
          | Import String String
          | Context String String
          | CCall ModuleMethodInfo

usefulLine None = False
usefulLine _    = True

main = do
  [path] <- getArgs
  modules <- findModules path
  modInfos <- mapM (\moduleName -> do ppExists <- doesFileExist (moduleName ++ ".chs.pp")
                                      if ppExists then scanModule (moduleName ++ ".chs.pp")
                                                  else scanModule (moduleName ++ ".chs")) modules
  print modInfos

scanModules :: FilePath -> IO [ModuleInfo]
scanModules path = do
  modules <- findModules path
  mapM (\moduleName -> do ppExists <- doesFileExist (moduleName ++ ".chs.pp")
                          if ppExists then scanModule (moduleName ++ ".chs.pp")
                                      else scanModule (moduleName ++ ".chs")) modules

findModules :: FilePath -> IO [FilePath]
findModules path = do
  files <- getDirectoryContents path
  let (chsFiles, maybeDirs) = partition (\file -> ".chs" `isSuffixOf` file
                                            || ".chs.pp" `isSuffixOf` file) files
      modules = map head
              . group
              . sort
              . map extractModule
              $ chsFiles
      extractModule [] = []
      extractModule ('.':'c':'h':'s':[]) = []
      extractModule ('.':'c':'h':'s':'.':'p':'p':[]) = []
      extractModule (c:cs) = c : extractModule cs
  dirs <- let filterDirs ds [] = return (reverse ds)
              filterDirs ds (md:mds) = do
                isDir <- doesDirectoryExist md
                if isDir then filterDirs (md:ds) mds
                         else filterDirs     ds  mds
           in filterDirs [] [ path ++ "/" ++ maybeDir
                            | maybeDir <- maybeDirs, maybeDir /= ".", maybeDir /= ".."]
  subDirModules <- mapM findModules dirs
  return $ map ((path++"/")++) modules ++ concat subDirModules

scanModule :: FilePath -> IO ModuleInfo
scanModule file = do
  content <- readFile file
  let moduleInfo = scanModuleContent content file
  return moduleInfo {
      module_filename = moduleNameToFileName (module_name moduleInfo)
                                             (module_prefix moduleInfo)
                                             (module_needspreproc moduleInfo)
    }

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],
    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 ]
  }
  where missing = "{-missing-}"

moduleNameToFileName :: String -> String -> Bool -> String
moduleNameToFileName name prefix preproc  = map dotToSlash prefix ++ "/" ++ name
                                         ++ if preproc then ".chs.pp" else ".chs"
  where dotToSlash '.' = '/'
        dotToSlash  c  =  c

scanLine :: String -> [String] -> Line
scanLine _ ("--":"Author":":":author)   = scanAuthor author
scanLine _ ("--":"Created:":created)    = Created (unwords created)
scanLine _ ("--":"Copyright":"(":c:")":copyright) = scanCopyright copyright
scanLine _ ("module":moduleName)        = scanModuleName moduleName
scanLine _ ("{#":"context":context)     = scanContext context
scanLine line ("import":moduleName)      = scanImport line moduleName
scanLine line ("{#":"import":moduleName) = scanImport line moduleName
scanLine _ tokens | "{#" `elem` tokens  = scanCCall tokens

scanLine _ _ = None

scanAuthor :: [String] -> Line
scanAuthor = 
    Authors
  . map unwords
  . splitOn ","

scanCopyright :: [String] -> Line
scanCopyright (from:"..":to:name)         = Copyright (Right (from, to)) (map unwords $ splitOn "," name)
scanCopyright (from:"-":to:name)          = Copyright (Right (from, to)) (map unwords $ splitOn "," name)
scanCopyright ("[":from:"..":to:"]":name) = Copyright (Right (from, to)) (map unwords $ splitOn "," name)
scanCopyright (year:name)                 = Copyright (Left year)        (map unwords $ splitOn "," name)
scanCopyright line = error $ "scanCopyright: " ++ show line

scanModuleName :: [String] -> Line
scanModuleName line | ("(":moduleName:".":modulePrefix) <- reverse line =
  Module moduleName (concat (reverse modulePrefix))
scanModuleName line | ("where":")":_:"(":moduleName:".":modulePrefix) <- reverse line =
  Module moduleName (concat (reverse modulePrefix))
scanModuleName ("Graphics":".":"UI":".":"Gtk":".":"Gdk":".":"Enums":[]) = None
scanModuleName line = error $ "scanModuleName: " ++ show line

scanContext :: [String] -> Line
scanContext ("lib":"=\"":lib:"\"":"prefix":"=\"":prefix:"\"":"#}":[]) = Context lib prefix
scanContext ("lib":"=\"":lib:"\"":"prefix":"=\"":prefix:"\"#}":[])    = Context lib prefix
scanContext ("prefix":"=\"":prefix:"\"":"#}":[])                         = Context "" prefix
scanContext line = error $ "scanContext: " ++ show line

scanImport :: String -> [String] -> Line
scanImport line tokens = Import (concat $ takeWhile (\token -> isWord token || token == ".") tokens) line
  where isWord = all isAlpha

scanCCall :: [String] -> Line
scanCCall tokens =
  case takeWhile (\t -> t/="#}" && t/="#}."&& t/="#})") . tail . dropWhile (/="{#") $ tokens of
    ("call":"unsafe":cname:[]) -> CCall ModuleMethodInfo { module_method_cname = cname,
                                                           module_method_unsafe = True }
    ("call":         cname:[]) -> CCall ModuleMethodInfo { module_method_cname = cname,
                                                           module_method_unsafe = True }
    ("call":"fun":"unsafe":cname:[]) -> CCall ModuleMethodInfo { module_method_cname = cname,
                                                                 module_method_unsafe = True }
    ("fun":"pure":_)           -> None
    ("type":_)                 -> None
    ("pointer":_)              -> None
    ("pointer*":_)             -> None
    ("enum":_)                 -> None
    ("get":_)                  -> None
    ("sizeof":_)                  -> None
    tokens -> error $ "scanCCall: " ++ show tokens

tokenise :: String -> [String]
tokenise s = case dropWhile isSpace s of
               "" -> []
               s' -> case span isBoundary s' of
                       ("", s'') -> case break isSpaceOrBoundary s'' of
                                     (w,s''') -> w : tokenise s'''
                       (w, s'') -> w : tokenise s''
  where isBoundary c = c `elem` ".,[]{}#()-=\""
        isSpaceOrBoundary c = isSpace c || isBoundary c

unwords   :: [String] -> String
unwords []       =  ""
unwords [w]      = w
unwords (w:".":ws) = w ++ ". " ++ unwords ws
unwords (w:ws)   = w ++ ' ' : unwords ws





Thread: [Gtk2hs-commit] gtk2hs/tools/apiGen ModuleScan.hs,NONE,1.1 ApiGen.hs,1.12,1.13 Template.chs,1.5,1.6

gtk2hs-commit