Menu
▾
▴
[hoc-cvs] [hoc commit] r325 - trunk/hoc/InterfaceGenerator2
|
From: <cod...@go...> - 2008-10-01 21:54:52
|
Author: wol...@gm...
Date: Wed Oct 1 14:48:09 2008
New Revision: 325
Added:
trunk/hoc/InterfaceGenerator2/ParserBase.hs
Modified:
trunk/hoc/InterfaceGenerator2/BindingScript.hs
trunk/hoc/InterfaceGenerator2/Headers.hs
trunk/hoc/InterfaceGenerator2/Parser.hs
trunk/hoc/InterfaceGenerator2/SyntaxTree.hs
Log:
Introduce a parser state that is used for storing enum constant values;
now enum constants can be used to define other enum constants elsewhere
(in the same framework, for now).
Header.loadHeaders now topologically sorts the header files before
processing
them, so that we can see enum constants accross different header files.
Modified: trunk/hoc/InterfaceGenerator2/BindingScript.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BindingScript.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BindingScript.hs Wed Oct 1 14:48:09 2008
@@ -13,7 +13,8 @@
Selector(..)
)
import qualified Parser(selector)
-import Parser(Parser)
+import ParserBase
+
import Control.Monad(when)
import qualified Data.Map as Map
@@ -82,7 +83,7 @@
where
top = bsTopLevelOptions bindingScript
-tokenParser :: GenTokenParser String () Messages
+tokenParser :: HOCTokenParser
tokenParser = makeTokenParser $
LanguageDef
{ commentStart = "{-"
@@ -98,7 +99,7 @@
, caseSensitive = True
}
-selector, qualified :: GenTokenParser String () Messages -> Parser String
+selector, qualified :: GenTokenParser String ParseEnvironment Messages ->
Parser String
selector tp = lexeme tp $ do
c <- letter <|> char '_'
s <- many (alphaNum <|> oneOf "_:")
@@ -197,8 +198,7 @@
readBindingScript fn = do
f <- readFile fn
- let (either, _messages) = runMessages (runParserT bindingScript () fn
f)
- case either of
+ case runParserSimple bindingScript fn f of
Left err -> error (show err)
Right result -> return result
Modified: trunk/hoc/InterfaceGenerator2/Headers.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Headers.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Headers.hs Wed Oct 1 14:48:09 2008
@@ -5,6 +5,7 @@
loadHeaders ) where
import Parser(header)
+import ParserBase(emptyParseEnvironment)
import SyntaxTree(Declaration)
import Control.Exception(evaluate)
@@ -21,6 +22,9 @@
import Progress
import Preprocessor
import System.FilePath
+import Data.Graph.Inductive
+import Text.Parsec( getState )
+import qualified Data.Map as Map
type ModuleName = ByteString
data HeaderInfo = HeaderInfo ModuleName [ModuleName] [Declaration]
@@ -50,26 +54,50 @@
slashToDot '/' = '.'
slashToDot c = c
-loadHeaders (dumpPreprocessed, dumpParsed) progress headers =
- mapM (\(headerFileName, headerPathName, moduleName) -> do
- -- putStrLn $ "Parsing " ++ headerFileName
- contents <- readFile $ headerPathName
- evaluate (length contents)
- let imports = findImports contents
- preprocessed = preprocess headerFileName contents
+loadHeaders (dumpPreprocessed, dumpParsed) progress headers = do
+ loaded <- mapM (\(headerFileName, headerPathName, moduleName) -> do
+ contents <- readFile $ headerPathName
+ evaluate (length contents)
+ let imports = findImports contents
+
+ return (headerFileName, BS.pack moduleName, map (BS.pack .
translateObjCImport) imports, contents)
+ ) headers
+
+ let moduleNames = [ n | (_, n, _, _) <- loaded ]
+ namesToNums = Map.fromList (zip moduleNames [0..])
+ numsToHeaders = Map.fromList (zip [0..] loaded)
+ graph :: Gr () ()
+ graph = mkUGraph [ 0 .. length loaded - 1 ]
+ [ (to, from) | (_, name, includes, _) <- loaded,
+ from <- Map.lookup name
namesToNums,
+ include <- includes,
+ to <- Map.lookup include
namesToNums ]
+ sorted = map (numsToHeaders Map.!) $ topsort graph
+
+ process ( (headerFileName, moduleName, imports, contents) :
moreHeaders ) env accum
+ = do
+ let preprocessed = preprocess headerFileName contents
when dumpPreprocessed $ writeFile ("preprocessed-" ++
headerFileName) $ preprocessed
- let (parseResult, parseMessages) = runMessages (runParserT
header () headerFileName preprocessed)
+ let parser = do
+ decls <- header
+ env' <- getState
+ return (decls, env')
+ (parseResult, parseMessages) =
+ runMessages (runParserT parser env headerFileName
preprocessed)
mapM_ print parseMessages
- result <- case parseResult of
- Left err -> error $ show err
- Right decls -> do
+ case parseResult of
+ Left err -> fail $ show err
+ Right (decls, env') -> do
when dumpParsed $ writeFile ("parsed-" ++
headerFileName) $ unlines $ map show decls
- return $ HeaderInfo (BS.pack moduleName)
- (map (BS.pack .
translateObjCImport) imports) decls
- reportProgress progress nHeaders
- return result
- ) headers
+ reportProgress progress nHeaders
+ let result = HeaderInfo moduleName imports decls
+
+ process moreHeaders env' (result : accum)
+ process [] _ accum = return accum
+
+ process sorted emptyParseEnvironment [] >>= return . reverse
+
where
nHeaders = length headers
Modified: trunk/hoc/InterfaceGenerator2/Parser.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Parser.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Parser.hs Wed Oct 1 14:48:09 2008
@@ -15,15 +15,8 @@
import qualified Data.Map as Map
-import Control.Monad.Trans( lift )
-import Messages
-
-import qualified Text.PrettyPrint.HughesPJ as PP
-
-type Parser a = ParsecT String () Messages a
-
--- type Parser a = forall b. ParsecT String b Messages a
+import ParserBase
objcDef = LanguageDef
{ commentStart = "/*"
@@ -42,17 +35,11 @@
, caseSensitive = True
}
-objc :: GenTokenParser String () Messages
+objc :: HOCTokenParser
objc = makeTokenParser objcDef
singleton x = [x]
-parseWarning :: String -> Parser ()
-parseWarning msg
- = do
- pos <- getPosition
- lift (message $ PP.text (show pos ++ ": " ++ msg))
-
header :: Parser [Declaration]
header = do
@@ -105,8 +92,8 @@
empty_decl = semi objc >> return []
-const_int_expr :: Map.Map String Integer -> Parser Integer
-const_int_expr env = expr
+const_int_expr :: Parser Integer
+const_int_expr = expr
where
expr = buildExpressionParser optable basic
@@ -140,7 +127,7 @@
definedConstant =
do
name <- identifier objc
- Map.lookup name env <|> (parseWarning (name ++ "
undefined") >> fail "")
+ lookupIntegerConstant name <|> (parseWarning (name ++ "
undefined") >> fail "")
-- A ctype is a complete C type, as you'd write it in a cast expression.
-- Examples include "int", "const char*", and "void (*)(int, float[3])"
@@ -264,27 +251,27 @@
do
key <- reserved objc "enum"
id <- identifier objc <|> return ""
- body <- braces objc (enum_body Map.empty (Just (-1))) <|> return []
+ body <- braces objc (enum_body (Just (-1))) <|> return []
return $ CTEnum id body
where
- enum_body env lastVal = do
+ enum_body lastVal = do
id <- identifier objc
mbVal <- (do
symbol objc "="
- try (fmap Just $ const_int_expr env)
+ try (fmap Just $ const_int_expr)
<|> (skipEnumValue >> return Nothing)
) <|> return (lastVal >>= Just . (+1))
case mbVal of
Just val -> do
- let env' = Map.insert id val env
+ defineIntegerConstant id val
xs <- option [] $ comma objc
- >> option [] (enum_body env' (Just
val))
+ >> option [] (enum_body (Just val))
return $ (id, GivenValue val) : xs
Nothing -> do
parseWarning $ "Couldn't handle enum value for " ++ id
xs <- option [] $ comma objc
- >> option [] (enum_body env Nothing)
+ >> option [] (enum_body Nothing)
return $ (id, TooComplicatedValue "") : xs
struct_type =
@@ -475,8 +462,8 @@
things <- commaSep objc id_declarator
availability
semi objc
- return $ map (\ (name, typeModifiers) -> PropertyDecl $
- Property (typeModifiers $ basetype)
+ return $ map (\ (name, typeModifiers) ->
+ PropertyDecl (typeModifiers $ basetype)
name properties ) things
where
property_attribute =
Added: trunk/hoc/InterfaceGenerator2/ParserBase.hs
==============================================================================
--- (empty file)
+++ trunk/hoc/InterfaceGenerator2/ParserBase.hs Wed Oct 1 14:48:09 2008
@@ -0,0 +1,34 @@
+module ParserBase where
+
+import qualified Data.Map as Map
+import Text.Parsec
+import Text.Parsec.Token
+import Control.Monad.Trans( lift )
+import Messages
+import qualified Text.PrettyPrint.HughesPJ as PP
+
+
+type ParseEnvironment = Map.Map String Integer
+
+emptyParseEnvironment :: ParseEnvironment
+emptyParseEnvironment = Map.empty
+
+type Parser a = ParsecT String ParseEnvironment Messages a
+
+type HOCTokenParser = GenTokenParser String ParseEnvironment Messages
+
+runParserSimple parser fileName text
+ = fst $ runMessages $ runParserT parser emptyParseEnvironment fileName
text
+
+lookupIntegerConstant :: String -> Parser Integer
+lookupIntegerConstant name = getState >>= Map.lookup name
+
+defineIntegerConstant :: String -> Integer -> Parser ()
+defineIntegerConstant name value = modifyState (Map.insert name value)
+
+parseWarning :: String -> Parser ()
+parseWarning msg
+ = do
+ pos <- getPosition
+ lift (message $ PP.text (show pos ++ ": " ++ msg))
+
Modified: trunk/hoc/InterfaceGenerator2/SyntaxTree.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/SyntaxTree.hs (original)
+++ trunk/hoc/InterfaceGenerator2/SyntaxTree.hs Wed Oct 1 14:48:09 2008
@@ -23,7 +23,7 @@
InstanceMethod Selector
| ClassMethod Selector
| LocalDecl Declaration
- | PropertyDecl Property
+ | PropertyDecl CType String [PropertyAttribute]
| Required Bool
deriving (Show,Eq,Ord)
@@ -36,9 +36,6 @@
}
deriving (Read,Show,Eq,Ord,Typeable,Data)
-data Property = Property CType String [PropertyAttribute]
- deriving (Show, Eq, Ord)
-
data PropertyAttribute =
Getter String
| Setter String
|
