Menu
▾
▴
[hoc-cvs] [hoc commit] r317 - trunk/hoc/InterfaceGenerator2
|
From: <cod...@go...> - 2008-09-28 20:59:04
|
Author: wol...@gm...
Date: Sun Sep 28 13:58:13 2008
New Revision: 317
Modified:
trunk/hoc/InterfaceGenerator2/BindingScript.hs
trunk/hoc/InterfaceGenerator2/Headers.hs
trunk/hoc/InterfaceGenerator2/Messages.hs
trunk/hoc/InterfaceGenerator2/Parser.hs
trunk/hoc/InterfaceGenerator2/Preprocessor.hs
Log:
Further parser improvements:
* some bugfixes
* recognise & skip inline functions
* require parsec 3.0
* output warning messages for unhandled enum values
Modified: trunk/hoc/InterfaceGenerator2/BindingScript.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BindingScript.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BindingScript.hs Sun Sep 28 13:58:13 2008
@@ -13,6 +13,7 @@
Selector(..)
)
import qualified Parser(selector)
+import Parser(Parser)
import Control.Monad(when)
import qualified Data.Map as Map
@@ -20,9 +21,10 @@
import qualified Data.Set as Set hiding (Set)
import Data.List(intersperse)
-import Text.ParserCombinators.Parsec.Language(haskellStyle)
-import Text.ParserCombinators.Parsec.Token
-import Text.ParserCombinators.Parsec
+import Text.Parsec.Token
+import Text.Parsec
+
+import Messages
data BindingScript = BindingScript {
bsHiddenFromPrelude :: Set String,
@@ -80,10 +82,23 @@
where
top = bsTopLevelOptions bindingScript
-tokenParser :: TokenParser ()
-tokenParser = makeTokenParser $ haskellStyle { identStart = letter <|>
char '_' }
+tokenParser :: GenTokenParser String () Messages
+tokenParser = makeTokenParser $
+ LanguageDef
+ { commentStart = "{-"
+ , commentEnd = "-}"
+ , commentLine = "--"
+ , nestedComments = True
+ , identStart = letter <|> char '_'
+ , identLetter = alphaNum <|> oneOf "_'"
+ , opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"
+ , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
+ , reservedOpNames= []
+ , reservedNames = []
+ , caseSensitive = True
+ }
-selector, qualified :: TokenParser () -> Parser String
+selector, qualified :: GenTokenParser String () Messages -> Parser String
selector tp = lexeme tp $ do
c <- letter <|> char '_'
s <- many (alphaNum <|> oneOf "_:")
@@ -181,7 +196,8 @@
readBindingScript :: String -> IO BindingScript
readBindingScript fn = do
- either <- parseFromFile bindingScript fn
+ f <- readFile fn
+ let (either, messages) = runMessages (runParserT bindingScript () fn f)
case either 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 Sun Sep 28 13:58:13 2008
@@ -14,7 +14,8 @@
import Data.Maybe(mapMaybe)
import System.Directory(getDirectoryContents)
import System.Info(os)
-import Text.ParserCombinators.Parsec(parse)
+import Text.Parsec( runParserT )
+import Messages( runMessages )
import Data.ByteString.Char8(ByteString)
import qualified Data.ByteString.Char8 as BS
import Progress
@@ -71,7 +72,10 @@
let imports = findImports contents
preprocessed = preprocess headerFileName {-
stripPreprocessor -} contents
when dumpPreprocessed $ writeFile ("preprocessed-" ++
headerFileName) $ preprocessed
- result <- case parse header headerFileName preprocessed of
+
+ let (parseResult, parseMessages) = runMessages (runParserT
header () headerFileName preprocessed)
+ mapM_ print parseMessages
+ result <- case parseResult of
Left err -> error $ show err
Right decls -> do
when dumpParsed $ writeFile ("parsed-" ++
headerFileName) $ unlines $ map show decls
Modified: trunk/hoc/InterfaceGenerator2/Messages.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Messages.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Messages.hs Sun Sep 28 13:58:13 2008
@@ -24,7 +24,7 @@
-- mappend a EmptyBag = a more lazyness!
mappend a b = BagOfTwo a b
-type Messages a = Writer (Bag Doc) a
+type Messages = Writer (Bag Doc)
message d = tell (UnitBag d)
runMessages :: Messages a -> (a, [Doc])
Modified: trunk/hoc/InterfaceGenerator2/Parser.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Parser.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Parser.hs Sun Sep 28 13:58:13 2008
@@ -1,47 +1,66 @@
-module Parser( header, selector ) where
+{-# LANGUAGE TypeSynonymInstances #-}
+module Parser( Parser, header, selector ) where
import Data.Maybe(catMaybes, isJust, fromJust)
import Data.Char(ord, isUpper, isDigit)
import Data.Bits(shiftL, (.|.))
import Control.Monad(guard)
-import Text.ParserCombinators.Parsec
-import Text.ParserCombinators.Parsec.Token
-import Text.ParserCombinators.Parsec.Language(emptyDef)
-import Text.ParserCombinators.Parsec.Expr
+import Text.Parsec
+import Text.Parsec.Token
+import Text.Parsec.Language(emptyDef)
+import Text.Parsec.Expr
import SyntaxTree
import qualified Data.Map as Map
-objcDef = emptyDef
+import Control.Monad.Trans( lift )
+import Messages
+
+import qualified Text.PrettyPrint.HughesPJ as PP
+
+type Parser a = ParsecT String () Messages a
+
+objcDef = LanguageDef
{ commentStart = "/*"
, commentEnd = "*/"
, commentLine = "//"
, nestedComments = False
, identStart = letter <|> char '_'
, identLetter = alphaNum <|> char '_'
+ , opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"
+ , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
+ , reservedOpNames = []
, reservedNames =
["@class","@protocol","@interface","@implementation","@end","@property",
- "const", "volatile", "struct", "union", "enum",
+ "const", "volatile", "struct", "union", "enum", "typedef",
"__attribute__", "__strong",
"@required", "@optional", "@private", "@public" ]
, caseSensitive = True
}
-objc :: TokenParser ()
+objc :: GenTokenParser String () Messages
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
optional (whiteSpace objc)
- fmap concat $ many $ do
+ things <- fmap concat $ many $ do
-- thing <- try interestingThing <|> uninterestingThing -- lenient
parsing
thing <- interestingThing -- strict parsing
optional (whiteSpace objc)
return thing
+ eof
+ return things
uninterestingThing :: Parser (Maybe Declaration)
uninterestingThing = skipMany1 (satisfy (\x -> x /= '@' && x /= ';')) >>
return Nothing
@@ -52,6 +71,9 @@
<|> interface_decl
<|> empty_decl
<|> type_declaration
+ <|> (reserved objc "CF_EXTERN_C_BEGIN" >> return [])
+ <|> (reserved objc "CF_EXTERN_C_END" >> return [])
+ <|> inline_function
<|> extern_decl
<|> (semi objc >> return [])
@@ -225,12 +247,6 @@
(_, tf) <- declarator True (optional $ identifier
objc)
return $ Just $ tf t
-
-testdecl :: String -> IO ()
-testdecl s = case parse (declarator True (return ()){- (identifier
objc)-}) "" s of
- Right (n, t) -> print $ t (CTSimple "void")
- Left e -> print e
-
ctype = do
simple <- type_no_pointers
(_, f) <- declarator True (return ())
@@ -290,7 +306,8 @@
basic = suffixedInteger
<|> multiCharConstant
<|> (do name <- identifier objc
- Map.lookup name env)
+-- Map.lookup name env <?> (name ++ " undefined"))
+ Map.lookup name env <|> (parseWarning (name ++ "
undefined") >> fail ""))
<|> parens objc expr
optable = [ [Infix shiftLeft AssocLeft],
[Infix bitwiseOr AssocLeft] ]
@@ -322,6 +339,7 @@
>> option [] (enum_body env' (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)
return $ (id, TooComplicatedValue "") : xs
@@ -335,7 +353,7 @@
return $ key id body
where
struct_union_body = try (many member)
- <|> (skipBlockContents >> return [])
+ <|> (skipBlockContents >> parseWarning "problem parsing
struct" >> return [])
member = do
typ <- type_no_pointers
things <- commaSep objc $ do
@@ -343,6 +361,7 @@
bitfield <- option Nothing
(symbol objc ":" >> integer objc >>= return . Just)
return (name, typeModifiers)
+ availability
semi objc
return [ (modifier typ, name) | (name, modifier) <- things ]
@@ -381,7 +400,7 @@
extern_decl =
do
- extern_keyword
+ optional extern_keyword
t <- type_no_pointers
vars <- commaSep objc (one_var t)
availability
@@ -395,7 +414,8 @@
-> ExternFun (Selector n retval args varargs)
otherType
-> ExternVar otherType n
-
+
+availability :: Parser ()
availability = optional $
do reserved objc "__attribute__"
parens objc (skipParens)
@@ -410,7 +430,9 @@
<|> reserved objc "FOUNDATION_EXPORT" -- N.B. "Export" vs. "Extern".
<|> reserved objc "APPKIT_EXTERN"
<|> reserved objc "GS_EXPORT"
-
+ <|> reserved objc "CA_EXTERN"
+ <|> reserved objc "CF_EXPORT"
+
skipParens = parens objc (skipMany (
(satisfy (\x -> x /= '(' && x /= ')') >> return ())
<|> skipParens
@@ -423,3 +445,12 @@
skipBlock = braces objc skipBlockContents
skipEnumValue = skipMany1 (satisfy (\x -> x /= '}' && x /= ','))
+
+inline_function =
+ do
+ reserved objc "inline" <|> reserved objc "NS_INLINE"
+ <|> reserved objc "CF_INLINE"
+ t <- type_no_pointers
+ (n, tf) <- id_declarator
+ skipBlock
+ return []
Modified: trunk/hoc/InterfaceGenerator2/Preprocessor.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Preprocessor.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Preprocessor.hs Sun Sep 28 13:58:13 2008
@@ -1,9 +1,9 @@
module Preprocessor( preprocess ) where
-import Text.ParserCombinators.Parsec
-import Text.ParserCombinators.Parsec.Token
-import Text.ParserCombinators.Parsec.Language(emptyDef)
-import Text.ParserCombinators.Parsec.Expr
+import Text.Parsec
+import Text.Parsec.Token
+import Text.Parsec.Language(emptyDef)
+import Text.Parsec.Expr
import Control.Monad.State as StateM
@@ -54,7 +54,7 @@
expression = try (buildExpressionParser optable basic) <|> return (return
0)
where
- basic :: CharParser () Expr
+ basic :: Parsec String () Expr
basic = do i <- integer cpp
return (return i)
<|> do reserved cpp "defined"
@@ -145,7 +145,15 @@
parseDirectives = map (\l -> case parse line "" l of
Left e -> Text $ l ++ "// " ++ show (show
e)
- Right x -> x) . lines . unblockComments
+ Right x -> x) . handleBackslashes .
lines . unblockComments
+
+handleBackslashes [] = []
+handleBackslashes (l : ls)
+ | null l = [] : handleBackslashes ls
+ | last l == '\\' = case handleBackslashes ls of
+ (l2 : ls') -> (l ++ '\n' : l2) : ls'
+ ls' -> ls'
+ | otherwise = l : handleBackslashes ls
preprocess fn f = execute fn $ parseDirectives f
|
