[hoc-cvs] [hoc commit] r313 - trunk/hoc/InterfaceGenerator2

[<cod...@go...>]

Author: wol...@gm...
Date: Sun Sep 28 09:37:57 2008
New Revision: 313

Modified:
    trunk/hoc/InterfaceGenerator2/BuildEntities.hs
    trunk/hoc/InterfaceGenerator2/Parser.hs
    trunk/hoc/InterfaceGenerator2/SyntaxTree.hs

Log:
Improve the parser:

  * parse ObjC 2.0 @property declarations (not handled in the other parts of  
ifgen yet)
  * more complete C type parsing, including function pointer types
  * various small fixes

Also, the parser is now good enough that it can parse all of
Foundation, QuartzCore, AppKit and CoreData without skipping any  
declarations;
from now on, declarations that we cannot parse will be reported as errors.


Modified: trunk/hoc/InterfaceGenerator2/BuildEntities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BuildEntities.hs	(original)
+++ trunk/hoc/InterfaceGenerator2/BuildEntities.hs	Sun Sep 28 09:37:57 2008
@@ -135,7 +135,7 @@
              = makeSelectorEntity True modName clsID clsName sel
          makeEntitiesForSelectorListItem modName _clsID _clsName (LocalDecl  
decl)
              = makeEntity modName decl >> return Nothing
-        makeEntitiesForSelectorListItem _modName _clsID _clsName  
PropertyDecl
+        makeEntitiesForSelectorListItem _modName _clsID _clsName  
(PropertyDecl _)
              = return Nothing
          makeEntitiesForSelectorListItem _modName _clsID _clsName (Required  
_)
              = return Nothing

Modified: trunk/hoc/InterfaceGenerator2/Parser.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Parser.hs	(original)
+++ trunk/hoc/InterfaceGenerator2/Parser.hs	Sun Sep 28 09:37:57 2008
@@ -1,8 +1,8 @@
-module Parser where
+module Parser( header, selector ) where

-import Data.Maybe(catMaybes, isJust)
+import Data.Maybe(catMaybes, isJust, fromJust)
  import Data.Char(ord, isUpper, isDigit)
-import Data.Bits(shiftL)
+import Data.Bits(shiftL, (.|.))
  import Control.Monad(guard)

  import Text.ParserCombinators.Parsec
@@ -23,20 +23,27 @@
      , identLetter    = alphaNum <|> char '_'
      , reservedNames  =  
["@class","@protocol","@interface","@implementation","@end","@property",
                          "const", "volatile", "struct", "union", "enum",
-                        "@required", "@optional"]
+                        "__attribute__", "__strong",
+                        "@required", "@optional", "@private", "@public" ]
      , caseSensitive  = True
      }

  objc :: TokenParser ()
  objc = makeTokenParser objcDef

+singleton x = [x]
+
+header :: Parser [Declaration]

-header = try (whiteSpace objc >> eof >> return []) <|> (
-                fmap catMaybes $ many (whiteSpace objc >>
-                                    (try interestingThing
-                                    <|> uninterestingThing))
-            )
+header = do
+    optional (whiteSpace objc)
+    fmap concat $ many $ do
+        -- thing <- try interestingThing <|> uninterestingThing -- lenient  
parsing
+        thing <- interestingThing   -- strict parsing
+        optional (whiteSpace objc)
+        return thing

+uninterestingThing :: Parser (Maybe Declaration)
  uninterestingThing = skipMany1 (satisfy (\x -> x /= '@' && x /= ';')) >>  
return Nothing

  interestingThing =
@@ -44,22 +51,23 @@
      <|> (try protocol_decl)
      <|> interface_decl
      <|> empty_decl
-    <|> (fmap Just type_declaration)
-    <|> (fmap Just extern_decl)
+    <|> type_declaration
+    <|> extern_decl
+    <|> (semi objc >> return [])

-empty_decl = semi objc >> return Nothing
+empty_decl = semi objc >> return []

  class_decl = do
      reserved objc "@class"
      classes <- commaSep1 objc (identifier objc)
      semi objc
-    return $ Just $ ForwardClass classes
+    return [ForwardClass classes]

  protocol_decl = do
      reserved objc "@protocol"
      protos <- commaSep1 objc (identifier objc)
      semi objc
-    return $ Just $ ForwardProtocol protos
+    return [ForwardProtocol protos]

  interface_decl = do
      proto <- (reserved objc "@interface" >> return False)
@@ -79,9 +87,9 @@
              return $ Interface class_name super protos
          )
      instance_variables
-    selectors <- many selectorListItem
+    selectors <- fmap concat $ many selectorListItem
      reserved objc "@end"
-    return $ Just $ SelectorList what selectors
+    return [SelectorList what selectors]

  category_spec = parens objc (identifier objc)

@@ -98,11 +106,12 @@
  instance_variables = skipBlock <|> return ()

  selectorListItem
-    =   selector
-    <|> (fmap LocalDecl type_declaration)
-    <|> fmap LocalDecl extern_decl
-    <|> property
-    <|> requiredOrOptional
+    =   fmap singleton selector
+    <|> fmap (map LocalDecl) type_declaration
+    <|> fmap (map LocalDecl) extern_decl
+    <|> property_declaration
+    <|> fmap singleton requiredOrOptional
+    <|> (semi objc >> return [])

  requiredOrOptional
      =   (reserved objc "@required" >> return (Required True))
@@ -135,37 +144,103 @@
      semi objc
      return (classOrInstanceMethod $ Selector name rettype types vararg)

-property
+property_declaration
      = do
          reserved objc "@property"
-        optional (parens objc (identifier objc))
+        properties <- option [] (parens objc (commaSep objc $  
property_attribute))
          basetype <- type_no_pointers
-        args <- commaSep objc varname_with_stars
+        things <- commaSep objc id_declarator
+        availability
          semi objc
-        return PropertyDecl
+        return $ map (\ (name, typeModifiers) -> PropertyDecl $
+                        Property (typeModifiers $ basetype)
+                                 name properties ) things
+
+property_attribute =
+        (do reserved objc "getter"
+            symbol objc "="
+            name <- identifier objc
+            return $ Getter name)
+    <|> (do reserved objc "setter"
+            symbol objc "="
+            name <- identifier objc
+            symbol objc ":"
+            return $ Setter (name ++ ":"))
+    <|> (reserved objc "readonly" >> return ReadOnly)
+    <|> (reserved objc "readwrite" >> return ReadWrite)
+    <|> (reserved objc "assign" >> return Assign)
+    <|> (reserved objc "retain" >> return Retain)
+    <|> (reserved objc "copy" >> return Copy)

--- type_spec = parens objc ctype <|> return CTNoType
-    -- where
-    --  ctype = fmap (CType . unwords) $ many (identifier objc <|> symbol  
objc "*")

-type_spec = try (parens objc ctype) <|> (skipParens >> return CTUnknown) <| 
> return (CTIDType [])
+--type_spec = try (parens objc ctype) <|> (skipParens >> return CTUnknown)  
<|> return (CTIDType [])
+type_spec = parens objc ctype <|> return (CTIDType [])

  type_no_pointers = do  -- "const char" in "const char *foo[32]"
      many ignored_type_qualifier   -- ignore
-    simple_type
-
-varname_with_stars = do
-    pointers_and_such <- many type_operator
-    name <- identifier objc
-    arrays <- many (symbol objc "[" >> symbol objc "]" >> return CTPointer)
-    return (name, \t -> foldl (flip ($)) t (pointers_and_such ++ arrays))
+    t <- simple_type
+    many ignored_type_qualifier
+    return t
+
+id_declarator = declarator False (identifier objc)
+
+declarator :: Bool -> Parser a -> Parser (a, CType -> CType)
+declarator emptyDeclaratorPossible thing = do
+        prefixes <- many prefix_operator
+        (name, typeFun) <- terminal
+        postfixes <- many postfix_operator
+        return (name, foldl (.) typeFun (postfixes ++ prefixes))
+    where
+        mbTry | emptyDeclaratorPossible = try
+              | otherwise = id
+        terminal =
+               mbTry (parens objc (declarator emptyDeclaratorPossible  
thing))
+               <|> (thing >>= \name -> return (name, id))
+        prefix_operator =
+            do
+                symbol objc "*"
+                many ignored_type_qualifier
+                return CTPointer
+
+        postfix_operator =
+            brackets objc (optional (integer objc) >> return CTPointer)
+            <|> do
+                (args, vararg) <- parens objc arguments
+                return (\retval -> CTFunction retval args vararg)
+
+        arguments =
+            do
+                args <- commaSep objc argument
+                case reverse args of
+                    (Nothing : moreArgs)
+                        | all isJust moreArgs ->
+                            return (map fromJust $ reverse moreArgs, True)
+                    _   | all isJust args -> return (map fromJust args,  
False)
+                        | otherwise -> fail "'...' in the middle of  
argument list"
+            where
+                argument =
+                    (symbol objc "..." >> return Nothing)
+                    <|> do
+                        t <- type_no_pointers
+                        (_, 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
-    pointers_and_such <- many type_operator
-    return $ foldl (flip ($)) simple pointers_and_such
+    (_, f) <- declarator True (return ())
+    return (f simple)

-simple_type = id_type <|> enum_type <|> struct_type <|> try builtin_type <| 
> fmap CTSimple (identifier objc)
+simple_type = id_type <|> enum_type <|> struct_type <|> try builtin_type
+    <|> do
+        n <- identifier objc
+        protos <- protocol_spec     -- TOOD: use these protocols
+        return $ CTSimple n

  builtin_type = do
      signedness <- (reserved objc "signed" >> return (Just True))
@@ -191,6 +266,7 @@
      protos <- protocol_spec
      return $ CTIDType protos

+
  multiCharConstant =
          lexeme objc (between (char '\'') (char '\'') multiChars)
      where
@@ -201,14 +277,26 @@
                  (iterate (*256) 1)


-const_int_expr env = buildExpressionParser optable basic
+suffixedInteger =
+    do
+        val <- integer objc
+        optional (reserved objc "U" <|> reserved objc "L"
+                    <|> reserved objc "UL") -- ### TODO: no space allowed  
before 'U'
+        return val
+
+const_int_expr env = expr
      where
-        basic = (integer objc) <|> multiCharConstant
+        expr = buildExpressionParser optable basic
+        basic = suffixedInteger
+            <|> multiCharConstant
              <|> (do name <- identifier objc
                      Map.lookup name env)
-        optable = [ [Infix shiftLeft AssocLeft] ]
+            <|> parens objc expr
+        optable = [ [Infix shiftLeft AssocLeft],
+                    [Infix bitwiseOr AssocLeft] ]

          shiftLeft = op "<<" (flip $ flip shiftL . fromIntegral)
+        bitwiseOr = op "|" (.|.)

          op str f = reservedOp objc str >> return f

@@ -216,34 +304,47 @@
      do
          key <- reserved objc "enum"
          id <- identifier objc <|> return ""
-        body <- braces objc (enum_body Map.empty (-1)) <|> return []
+        body <- braces objc (enum_body Map.empty (Just (-1))) <|> return []
          return $ CTEnum id body
      where
          enum_body env lastVal = do
              id <- identifier objc
-            val <- (do
+            mbVal <- (do
                      symbol objc "="
-                    const_int_expr env
-                ) <|> return (lastVal + 1)
+                    try (fmap Just $ const_int_expr env)
+                        <|> (skipEnumValue >> return Nothing)
+                ) <|> return (lastVal >>= Just . (+1))

-            let env' = Map.insert id val env
-            xs <- option [] $ comma objc >> option [] (enum_body env' val)
-            return $ (id, GivenValue val) : xs
+            case mbVal of
+                Just val -> do
+                    let env' = Map.insert id val env
+                    xs <- option [] $ comma objc
+                                    >> option [] (enum_body env' (Just  
val))
+                    return $ (id, GivenValue val) : xs
+                Nothing -> do
+                    xs <- option [] $ comma objc
+                                    >> option [] (enum_body env Nothing)
+                    return $ (id, TooComplicatedValue "") : xs

  struct_type =
      do
          key <- (reserved objc "struct" >> return CTStruct)
              <|> (reserved objc "union" >> return CTUnion)
          id <- identifier objc <|> return ""
-        body <- braces objc struct_union_body <|> return []
+        body <- fmap concat $ braces objc struct_union_body <|> return []
          return $ key id body
      where
-        struct_union_body = many member
+        struct_union_body = try (many member)
+            <|> (skipBlockContents >> return [])
          member = do
-            typ <- ctype
-            name <- identifier objc
+            typ <- type_no_pointers
+            things <- commaSep objc $ do
+                (name, typeModifiers) <- id_declarator
+                bitfield <- option Nothing
+                    (symbol objc ":" >> integer objc >>= return . Just)
+                return (name, typeModifiers)
              semi objc
-            return (typ, name)
+            return [ (modifier typ, name) | (name, modifier) <- things ]

  type_operator =
      (symbol objc "*" >> return CTPointer)
@@ -258,43 +359,52 @@
      <|> reserved objc "bycopy"
      <|> reserved objc "byref"
      <|> reserved objc "oneway"
+    <|> reserved objc "__strong"

  typedef = do
      reserved objc "typedef"
-    oldType <- ctype
-    newType <- identifier objc
-    semi objc
-    return $ Typedef oldType newType
+    baseType <- type_no_pointers

+    newTypes <- commaSep objc id_declarator
+    availability
+    semi objc
+    return $ [Typedef (typeFun baseType) name
+             | (name, typeFun) <- newTypes ]
+
  ctypeDecl = do
      typ <- enum_type <|> struct_type
+    availability
      semi objc
-    return $ CTypeDecl typ
+    return [CTypeDecl typ]

  type_declaration = typedef <|> ctypeDecl

  extern_decl =
-    extern_keyword >> ctype >>= \t -> identifier objc >>= \n ->
-        do
-            args <- parens objc (commaSep objc argument)
-            availability
-            semi objc
-            return $ ExternFun (Selector n t args False)
-    <|> do
-            availability
-            semi objc
-            return $ ExternVar t n
+    do
+        extern_keyword
+        t <- type_no_pointers
+        vars <- commaSep objc (one_var t)
+        availability
+        semi objc
+        return vars
      where
-        argument = do t <- ctype
-                      optional (identifier objc)
-                      arrays <- many (symbol objc "[" >> symbol objc "]"  
>> return CTPointer)
-                      return $ foldl (flip ($)) t arrays
-
+        one_var t = do
+            (n, typeOperators) <- id_declarator
+            return $ case typeOperators t of
+                CTFunction retval args varargs
+                    -> ExternFun (Selector n retval args varargs)
+                otherType
+                    -> ExternVar otherType n
+
  availability = optional $
+    do reserved objc "__attribute__"
+       parens objc (skipParens)
+       return ()
+    <|>
      do x <- identifier objc
         guard $ all (\c -> isUpper c || isDigit c || c == '_') x
         -- guard (any (`isPrefixOf` x) ["AVAILABLE_MAC_", "DEPRECATED_IN_"])
-
+
  extern_keyword =
          reserved objc "extern"
      <|> reserved objc "FOUNDATION_EXPORT" -- N.B. "Export" vs. "Extern".
@@ -306,8 +416,10 @@
      <|> skipParens
      ))

-skipBlock = braces objc (skipMany (
+skipBlockContents = (skipMany (
      (satisfy (\x -> x /= '{' && x /= '}') >> return ())
      <|> skipBlock
      ))
+skipBlock = braces objc skipBlockContents

+skipEnumValue = skipMany1 (satisfy (\x -> x /= '}' && x /= ','))

Modified: trunk/hoc/InterfaceGenerator2/SyntaxTree.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/SyntaxTree.hs	(original)
+++ trunk/hoc/InterfaceGenerator2/SyntaxTree.hs	Sun Sep 28 09:37:57 2008
@@ -23,7 +23,7 @@
          InstanceMethod Selector
      |   ClassMethod Selector
      |   LocalDecl Declaration
-    |   PropertyDecl
+    |   PropertyDecl Property
      |   Required Bool
      deriving (Show,Eq,Ord)

@@ -36,12 +36,27 @@
          }
      deriving (Read,Show,Eq,Ord,Typeable,Data)

+data Property = Property CType String [PropertyAttribute]
+    deriving (Show, Eq, Ord)
+
+data PropertyAttribute =
+        Getter String
+    |   Setter String
+    |   ReadOnly
+    |   ReadWrite
+    |   Assign
+    |   Retain
+    |   Copy
+    deriving (Show, Eq, Ord)
+
+
  data EnumValue = NextValue | GivenValue Integer | TooComplicatedValue  
String
      deriving (Read, Show, Eq, Ord,Typeable,Data)

  data CType = CTIDType [String {- protocols -}]
             | CTSimple String
             | CTPointer CType
+           | CTFunction CType [CType] Bool
             | CTUnknown
             | CTEnum String [(String, EnumValue)]
             | CTStruct String [(CType, String)]